diff --git a/.idea/vcs.xml b/.idea/vcs.xml new file mode 100644 index 0000000..35eb1dd --- /dev/null +++ b/.idea/vcs.xml @@ -0,0 +1,6 @@ + + + + + + \ No newline at end of file diff --git a/AMSS_NCKU_Program.py b/AMSS_NCKU_Program.py index 2d777cd..9c025dd 100755 --- a/AMSS_NCKU_Program.py +++ b/AMSS_NCKU_Program.py @@ -126,12 +126,7 @@ setup.generate_AMSSNCKU_input() #inputvalue = input() ## Wait for user input (press Enter) to proceed #print() -setup.print_puncture_information() - - -################################################################## - -## Generate AMSS-NCKU program input files based on the configured parameters +## Generate AMSS-NCKU program input files based on the configured parameters print( ) print( " Generating the AMSS-NCKU input parfile for the ABE executable. " ) @@ -312,7 +307,7 @@ if (input_data.Initial_Data_Method == "Ansorg-TwoPuncture" ): import generate_TwoPuncture_input - generate_TwoPuncture_input.generate_AMSSNCKU_TwoPuncture_input() + generate_TwoPuncture_input.generate_AMSSNCKU_TwoPuncture_input(numerical_grid.puncture_data) print( ) print( " The input parfile for the TwoPunctureABE executable has been generated. " ) @@ -354,7 +349,7 @@ if (input_data.Initial_Data_Method == "Ansorg-TwoPuncture" ): import renew_puncture_parameter -renew_puncture_parameter.append_AMSSNCKU_BSSN_input(File_directory, output_directory) +renew_puncture_parameter.append_AMSSNCKU_BSSN_input(File_directory, output_directory, numerical_grid.puncture_data) ## Generated AMSS-NCKU input filename diff --git a/AMSS_NCKU_source/BH_diagnostics.C b/AMSS_NCKU_source/AHF_Direct/BH_diagnostics.C similarity index 97% rename from AMSS_NCKU_source/BH_diagnostics.C rename to AMSS_NCKU_source/AHF_Direct/BH_diagnostics.C index c24adf7..09fe8cb 100644 --- a/AMSS_NCKU_source/BH_diagnostics.C +++ b/AMSS_NCKU_source/AHF_Direct/BH_diagnostics.C @@ -1,724 +1,724 @@ -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" -#include "myglobal.h" - -#include "horizon_sequence.h" -#include "BH_diagnostics.h" -#include "driver.h" - -namespace AHFinderDirect -{ - using jtutil::error_exit; - - BH_diagnostics::BH_diagnostics() - : centroid_x(0.0), centroid_y(0.0), centroid_z(0.0), - quadrupole_xx(0.0), quadrupole_xy(0.0), quadrupole_xz(0.0), - quadrupole_yy(0.0), quadrupole_yz(0.0), - quadrupole_zz(0.0), - min_radius(0.0), max_radius(0.0), - mean_radius(0.0), - min_x(0.0), max_x(0.0), - min_y(0.0), max_y(0.0), - min_z(0.0), max_z(0.0), - circumference_xy(0.0), circumference_xz(0.0), circumference_yz(0.0), - area(0.0), irreducible_mass(0.0), areal_radius(0.0) // no comma - { - } - - void BH_diagnostics::copy_to_buffer(double buffer[N_buffer]) - const - { - buffer[posn__centroid_x] = centroid_x; - buffer[posn__centroid_y] = centroid_y; - buffer[posn__centroid_z] = centroid_z; - - buffer[posn__quadrupole_xx] = quadrupole_xx; - buffer[posn__quadrupole_xy] = quadrupole_xy; - buffer[posn__quadrupole_xz] = quadrupole_xz; - buffer[posn__quadrupole_yy] = quadrupole_yy; - buffer[posn__quadrupole_xz] = quadrupole_yz; - buffer[posn__quadrupole_zz] = quadrupole_zz; - - buffer[posn__min_radius] = min_radius; - buffer[posn__max_radius] = max_radius; - buffer[posn__mean_radius] = mean_radius; - - buffer[posn__min_x] = min_x; - buffer[posn__max_x] = max_x; - buffer[posn__min_y] = min_y; - buffer[posn__max_y] = max_y; - buffer[posn__min_z] = min_z; - buffer[posn__max_z] = max_z; - - buffer[posn__circumference_xy] = circumference_xy; - buffer[posn__circumference_xz] = circumference_xz; - buffer[posn__circumference_yz] = circumference_yz; - - buffer[posn__area] = area; - buffer[posn__irreducible_mass] = irreducible_mass; - buffer[posn__areal_radius] = areal_radius; - } - - void BH_diagnostics::copy_from_buffer(const double buffer[N_buffer]) - { - centroid_x = buffer[posn__centroid_x]; - centroid_y = buffer[posn__centroid_y]; - centroid_z = buffer[posn__centroid_z]; - - quadrupole_xx = buffer[posn__quadrupole_xx]; - quadrupole_xy = buffer[posn__quadrupole_xy]; - quadrupole_xz = buffer[posn__quadrupole_xz]; - quadrupole_yy = buffer[posn__quadrupole_yy]; - quadrupole_yz = buffer[posn__quadrupole_yz]; - quadrupole_zz = buffer[posn__quadrupole_zz]; - - min_radius = buffer[posn__min_radius]; - max_radius = buffer[posn__max_radius]; - mean_radius = buffer[posn__mean_radius]; - - min_x = buffer[posn__min_x]; - max_x = buffer[posn__max_x]; - min_y = buffer[posn__min_y]; - max_y = buffer[posn__max_y]; - min_z = buffer[posn__min_z]; - max_z = buffer[posn__max_z]; - - circumference_xy = buffer[posn__circumference_xy]; - circumference_xz = buffer[posn__circumference_xz]; - circumference_yz = buffer[posn__circumference_yz]; - - area = buffer[posn__area]; - irreducible_mass = buffer[posn__irreducible_mass]; - areal_radius = buffer[posn__areal_radius]; - } - void BH_diagnostics::compute(patch_system &ps) - { - jtutil::norm h_norms; - ps.ghosted_gridfn_norms(gfns::gfn__h, h_norms); - min_radius = h_norms.min_abs_value(); - max_radius = h_norms.max_abs_value(); - - jtutil::norm x_norms; - jtutil::norm y_norms; - jtutil::norm z_norms; - - ps.gridfn_norms(gfns::gfn__global_x, x_norms); - ps.gridfn_norms(gfns::gfn__global_y, y_norms); - ps.gridfn_norms(gfns::gfn__global_z, z_norms); - - min_x = x_norms.min_value(); - max_x = x_norms.max_value(); - min_y = y_norms.min_value(); - max_y = y_norms.max_value(); - min_z = z_norms.min_value(); - max_z = z_norms.max_value(); - -// adjust the bounding box for the symmetries -#define REFLECT(origin_, max_) (origin_ - (max_ - origin_)) - switch (ps.type()) - { - case patch_system::patch_system__full_sphere: - break; - case patch_system::patch_system__plus_z_hemisphere: - min_z = REFLECT(ps.origin_z(), max_z); - break; - case patch_system::patch_system__plus_xy_quadrant_mirrored: - case patch_system::patch_system__plus_xy_quadrant_rotating: - min_x = REFLECT(ps.origin_x(), max_x); - min_y = REFLECT(ps.origin_y(), max_y); - break; - case patch_system::patch_system__plus_xz_quadrant_mirrored: - case patch_system::patch_system__plus_xz_quadrant_rotating: - min_x = REFLECT(ps.origin_x(), max_x); - min_z = REFLECT(ps.origin_z(), max_z); - break; - case patch_system::patch_system__plus_xyz_octant_mirrored: - case patch_system::patch_system__plus_xyz_octant_rotating: - min_x = REFLECT(ps.origin_x(), max_x); - min_y = REFLECT(ps.origin_y(), max_y); - min_z = REFLECT(ps.origin_z(), max_z); - break; - default: - error_exit(PANIC_EXIT, - "***** BH_diagnostics::compute(): unknown patch system type()=(int)%d!\n" - " (this should never happen!)\n", - int(ps.type())); /*NOTREACHED*/ - } - - // - // surface integrals - // - const fp integral_one = surface_integral(ps, - gfns::gfn__one, true, true, true, - patch::integration_method__automatic_choice); - const fp integral_h = surface_integral(ps, - gfns::gfn__h, true, true, true, - patch::integration_method__automatic_choice); - const fp integral_x = surface_integral(ps, - gfns::gfn__global_x, true, true, false, - patch::integration_method__automatic_choice); - const fp integral_y = surface_integral(ps, - gfns::gfn__global_y, true, false, true, - patch::integration_method__automatic_choice); - const fp integral_z = surface_integral(ps, - gfns::gfn__global_z, false, true, true, - patch::integration_method__automatic_choice); - const fp integral_xx = surface_integral(ps, - gfns::gfn__global_xx, true, true, true, - patch::integration_method__automatic_choice); - const fp integral_xy = surface_integral(ps, - gfns::gfn__global_xy, true, false, false, - patch::integration_method__automatic_choice); - const fp integral_xz = surface_integral(ps, - gfns::gfn__global_xz, false, true, false, - patch::integration_method__automatic_choice); - const fp integral_yy = surface_integral(ps, - gfns::gfn__global_yy, true, true, true, - patch::integration_method__automatic_choice); - const fp integral_yz = surface_integral(ps, - gfns::gfn__global_yz, false, false, true, - patch::integration_method__automatic_choice); - const fp integral_zz = surface_integral(ps, - gfns::gfn__global_zz, true, true, true, - patch::integration_method__automatic_choice); - - // - // centroids - // - centroid_x = integral_x / integral_one; - centroid_y = integral_y / integral_one; - centroid_z = integral_z / integral_one; - - // - // quadrupoles (taken about centroid position) - // - quadrupole_xx = integral_xx / integral_one - centroid_x * centroid_x; - quadrupole_xy = integral_xy / integral_one - centroid_x * centroid_y; - quadrupole_xz = integral_xz / integral_one - centroid_x * centroid_z; - quadrupole_yy = integral_yy / integral_one - centroid_y * centroid_y; - quadrupole_yz = integral_yz / integral_one - centroid_y * centroid_z; - quadrupole_zz = integral_zz / integral_one - centroid_z * centroid_z; - - // - // mean radius of horizon - // - mean_radius = integral_h / integral_one; - - // - // surface area and quantities derived from it - // - area = integral_one; - irreducible_mass = sqrt(area / (16.0 * PI)); - areal_radius = sqrt(area / (4.0 * PI)); - - // - // proper circumferences - // - circumference_xy = ps.circumference("xy", gfns::gfn__h, - gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, - gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, - gfns::gfn__g_dd_33, - patch::integration_method__automatic_choice); - circumference_xz = ps.circumference("xz", gfns::gfn__h, - gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, - gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, - gfns::gfn__g_dd_33, - patch::integration_method__automatic_choice); - circumference_yz = ps.circumference("yz", gfns::gfn__h, - gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, - gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, - gfns::gfn__g_dd_33, - patch::integration_method__automatic_choice); - - // prepare P^i,S^i in xx,xy,xz and yy,yz,zz - { - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - const fp g_xx = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); - const fp g_xy = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); - const fp g_xz = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); - const fp g_yy = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); - const fp g_yz = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); - const fp g_zz = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); - - const fp k_xx = p.gridfn(gfns::gfn__K_dd_11, irho, isigma); - const fp k_xy = p.gridfn(gfns::gfn__K_dd_12, irho, isigma); - const fp k_xz = p.gridfn(gfns::gfn__K_dd_13, irho, isigma); - const fp k_yy = p.gridfn(gfns::gfn__K_dd_22, irho, isigma); - const fp k_yz = p.gridfn(gfns::gfn__K_dd_23, irho, isigma); - const fp k_zz = p.gridfn(gfns::gfn__K_dd_33, irho, isigma); - const fp trk = p.gridfn(gfns::gfn__trK, irho, isigma); - - const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - fp xx, yy, zz; // local Cardesian coordinate - p.xyz_of_r_rho_sigma(r, rho, sigma, xx, yy, zz); - const fp X_ud_11 = p.partial_rho_wrt_x(xx, yy, zz); - const fp X_ud_12 = p.partial_rho_wrt_y(xx, yy, zz); - const fp X_ud_13 = p.partial_rho_wrt_z(xx, yy, zz); - const fp X_ud_21 = p.partial_sigma_wrt_x(xx, yy, zz); - const fp X_ud_22 = p.partial_sigma_wrt_y(xx, yy, zz); - const fp X_ud_23 = p.partial_sigma_wrt_z(xx, yy, zz); -#if 0 // for P^i and S^i - // F,i = x^i/r-X_ud_1i(dh/drho)-X_ud_2i(dh/dsigma) - double nx,ny,nz; - nx = xx/r-X_ud_11*p.partial_rho(gfns::gfn__h, irho,isigma)-X_ud_21*p.partial_sigma(gfns::gfn__h, irho,isigma); - ny = yy/r-X_ud_12*p.partial_rho(gfns::gfn__h, irho,isigma)-X_ud_22*p.partial_sigma(gfns::gfn__h, irho,isigma); - nz = zz/r-X_ud_13*p.partial_rho(gfns::gfn__h, irho,isigma)-X_ud_23*p.partial_sigma(gfns::gfn__h, irho,isigma); - double eps; // volume element - fp g_uu_11, g_uu_12, g_uu_13, g_uu_22, g_uu_23, g_uu_33; - double pxx,pxy,pxz,pyy,pyz,pzz; - { - fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; - fp t18, t21; - t1 = g_yy; - t2 = g_zz; - t4 = g_yz; - t5 = t4*t4; - t7 = g_xx; - t8 = t7*t1; - t11 = g_xy; - t12 = t11*t11; - t14 = g_xz; - t15 = t11*t14; - t18 = t14*t14; - eps = t8*t2-t7*t5-t12*t2+2.0*t15*t4-t18*t1; - t21 = 1/eps; - eps = sqrt(eps); - g_uu_11 = (t1*t2-t5)*t21; - g_uu_12 = -(t11*t2-t14*t4)*t21; - g_uu_13 = -(-t11*t4+t14*t1)*t21; - g_uu_22 = (t7*t2-t18)*t21; - g_uu_23 = -(t7*t4-t15)*t21; - g_uu_33 = (t8-t12)*t21; - - t5 = g_uu_11*nx*nx+g_uu_22*ny*ny+g_uu_33*nz*nz+2*(g_uu_12*nx*ny+g_uu_13*nx*nz+g_uu_23*ny*nz); - t5 = sqrt(t5); - nx = nx/t5; // lower index - ny = ny/t5; - nz = nz/t5; - - pxx= g_uu_11*(g_uu_11*k_xx+g_uu_12*k_xy+g_uu_13*k_xz) - +g_uu_12*(g_uu_11*k_xy+g_uu_12*k_yy+g_uu_13*k_yz) - +g_uu_13*(g_uu_11*k_xz+g_uu_12*k_yz+g_uu_13*k_zz); //k^xx - pxy= g_uu_11*(g_uu_12*k_xx+g_uu_22*k_xy+g_uu_23*k_xz) - +g_uu_12*(g_uu_12*k_xy+g_uu_22*k_yy+g_uu_23*k_yz) - +g_uu_13*(g_uu_12*k_xz+g_uu_22*k_yz+g_uu_23*k_zz); //k^xy - pxz= g_uu_11*(g_uu_13*k_xx+g_uu_23*k_xy+g_uu_33*k_xz) - +g_uu_12*(g_uu_13*k_xy+g_uu_23*k_yy+g_uu_33*k_yz) - +g_uu_13*(g_uu_13*k_xz+g_uu_23*k_yz+g_uu_33*k_zz); //k^xz - pyy= g_uu_12*(g_uu_12*k_xx+g_uu_22*k_xy+g_uu_23*k_xz) - +g_uu_22*(g_uu_12*k_xy+g_uu_22*k_yy+g_uu_23*k_yz) - +g_uu_23*(g_uu_12*k_xz+g_uu_22*k_yz+g_uu_23*k_zz); //k^yy - pyz= g_uu_12*(g_uu_13*k_xx+g_uu_23*k_xy+g_uu_33*k_xz) - +g_uu_22*(g_uu_13*k_xy+g_uu_23*k_yy+g_uu_33*k_yz) - +g_uu_23*(g_uu_13*k_xz+g_uu_23*k_yz+g_uu_33*k_zz); //k^yz - pzz= g_uu_13*(g_uu_13*k_xx+g_uu_23*k_xy+g_uu_33*k_xz) - +g_uu_23*(g_uu_13*k_xy+g_uu_23*k_yy+g_uu_33*k_yz) - +g_uu_33*(g_uu_13*k_xz+g_uu_23*k_yz+g_uu_33*k_zz); //k^zz - } - - pxx = pxx-g_uu_11*trk; // tracefree - pyy = pyy-g_uu_22*trk; - pzz = pzz-g_uu_33*trk; - double tx,ty,tz; - double sxx,sxy,sxz,syx,syy,syz,szx,szy,szz; - tx = nx*pxx + ny*pxy + nz*pxz; - ty = nx*pxy + ny*pyy + nz*pyz; - tz = nx*pxz + ny*pyz + nz*pzz; - sxx = xx*tx; - sxy = xx*ty; - sxz = xx*tz; - syx = yy*tx; - syy = yy*ty; - syz = yy*tz; - szx = zz*tx; - szy = zz*ty; - szz = zz*tz; - p.gridfn(gfns::gfn__global_xx, irho,isigma) = tx; //p^x - p.gridfn(gfns::gfn__global_xy, irho,isigma) = ty; //p^y - p.gridfn(gfns::gfn__global_xz, irho,isigma) = tz; //p^z - tx = eps*(syz-szy); //s_x - ty = eps*(szx-sxz); - tz = eps*(sxy-syx); - p.gridfn(gfns::gfn__global_yy, irho,isigma) = g_uu_11*tx+g_uu_12*ty+g_uu_13*tz; //s^x - p.gridfn(gfns::gfn__global_yz, irho,isigma) = g_uu_12*tx+g_uu_22*ty+g_uu_23*tz; //s^y - p.gridfn(gfns::gfn__global_zz, irho,isigma) = g_uu_13*tx+g_uu_23*ty+g_uu_33*tz; //s^z -#endif -#if 1 // for P_i and S_i - // F,i = x^i/r-X_ud_1i(dh/drho)-X_ud_2i(dh/dsigma) - double nx, ny, nz; - nx = xx / r - X_ud_11 * p.partial_rho(gfns::gfn__h, irho, isigma) - X_ud_21 * p.partial_sigma(gfns::gfn__h, irho, isigma); - ny = yy / r - X_ud_12 * p.partial_rho(gfns::gfn__h, irho, isigma) - X_ud_22 * p.partial_sigma(gfns::gfn__h, irho, isigma); - nz = zz / r - X_ud_13 * p.partial_rho(gfns::gfn__h, irho, isigma) - X_ud_23 * p.partial_sigma(gfns::gfn__h, irho, isigma); - { - fp g_uu_11, g_uu_12, g_uu_13, g_uu_22, g_uu_23, g_uu_33; - fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; - fp t18, t21; - t1 = g_yy; - t2 = g_zz; - t4 = g_yz; - t5 = t4 * t4; - t7 = g_xx; - t8 = t7 * t1; - t11 = g_xy; - t12 = t11 * t11; - t14 = g_xz; - t15 = t11 * t14; - t18 = t14 * t14; - t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); - g_uu_11 = (t1 * t2 - t5) * t21; - g_uu_12 = -(t11 * t2 - t14 * t4) * t21; - g_uu_13 = -(-t11 * t4 + t14 * t1) * t21; - g_uu_22 = (t7 * t2 - t18) * t21; - g_uu_23 = -(t7 * t4 - t15) * t21; - g_uu_33 = (t8 - t12) * t21; - - t1 = g_uu_11 * nx + g_uu_12 * ny + g_uu_13 * nz; - t2 = g_uu_12 * nx + g_uu_22 * ny + g_uu_23 * nz; - t4 = g_uu_13 * nx + g_uu_23 * ny + g_uu_33 * nz; - t5 = g_uu_11 * nx * nx + g_uu_22 * ny * ny + g_uu_33 * nz * nz + 2 * (g_uu_12 * nx * ny + g_uu_13 * nx * nz + g_uu_23 * ny * nz); - t5 = sqrt(t5); - nx = t1 / t5; // uper index - ny = t2 / t5; - nz = t4 / t5; - } - - double pxx, pxy, pxz, pyy, pyz, pzz; - double sxx, sxy, sxz, syx, syy, syz, szx, szy, szz; - // these tensor components are same for local Cardisean and global Cardisean - pxx = k_xx - g_xx * trk; // lower index - pxy = k_xy; - pxz = k_xz; - pyy = k_yy - g_yy * trk; - pyz = k_yz; - pzz = k_zz - g_zz * trk; - /* - sxx = yy*pxy - zz*pxz; - sxy = yy*pyy - zz*pyz; - sxz = yy*pyz - zz*pzz; - syx = zz*pxy - yy*pxz; - syy = zz*pyy - yy*pyz; - syz = zz*pyz - yy*pzz; - szx = xx*pxy - yy*pxx; - szy = xx*pyy - yy*pxy; - szz = xx*pyz - yy*pxz; - */ - // we need Cardisean coordinate whose original point coincide with centroid_x^i - xx = p.gridfn(gfns::gfn__global_x, irho, isigma) - centroid_x; - yy = p.gridfn(gfns::gfn__global_y, irho, isigma) - centroid_y; - zz = p.gridfn(gfns::gfn__global_z, irho, isigma) - centroid_z; - sxx = yy * pxz - zz * pxy; - sxy = zz * pxx - xx * pxz; - sxz = xx * pxy - yy * pxx; - syx = yy * pyz - zz * pyy; - syy = zz * pxy - xx * pyz; - syz = xx * pyy - yy * pxy; - szx = yy * pzz - zz * pyz; - szy = zz * pxz - xx * pzz; - szz = xx * pyz - yy * pxz; - - p.gridfn(gfns::gfn__global_xx, irho, isigma) = nx * pxx + ny * pxy + nz * pxz; // p_x - p.gridfn(gfns::gfn__global_xy, irho, isigma) = nx * pxy + ny * pyy + nz * pyz; // p_y - p.gridfn(gfns::gfn__global_xz, irho, isigma) = nx * pxz + ny * pyz + nz * pzz; // p_z - p.gridfn(gfns::gfn__global_yy, irho, isigma) = nx * sxx + ny * syx + nz * szx; // s_x - p.gridfn(gfns::gfn__global_yz, irho, isigma) = nx * sxy + ny * syy + nz * szy; // s_y - p.gridfn(gfns::gfn__global_zz, irho, isigma) = nx * sxz + ny * syz + nz * szz; // s_z -#endif - } - } - } - } - - Px = surface_integral(ps, - gfns::gfn__global_xx, true, true, false, // z,y,x direction, even or odd function - patch::integration_method__automatic_choice); - Py = surface_integral(ps, - gfns::gfn__global_xy, true, false, true, - patch::integration_method__automatic_choice); - Pz = surface_integral(ps, - gfns::gfn__global_xz, false, true, true, - patch::integration_method__automatic_choice); - Sx = surface_integral(ps, - gfns::gfn__global_yy, false, false, true, - patch::integration_method__automatic_choice); - Sy = surface_integral(ps, - gfns::gfn__global_yz, false, true, false, - patch::integration_method__automatic_choice); - Sz = surface_integral(ps, - gfns::gfn__global_zz, true, false, false, - patch::integration_method__automatic_choice); - const double F1o8pi = 1.0 / 8 / PI; - Px = Px * F1o8pi; - Py = Py * F1o8pi; - Pz = Pz * F1o8pi; - Sx = Sx * F1o8pi; - Sy = Sy * F1o8pi; - Sz = Sz * F1o8pi; - } - - //****************************************************************************** - - // - // This function computes the surface integral of a gridfn over the - // horizon. - // - fp BH_diagnostics::surface_integral(const patch_system &ps, - int src_gfn, bool src_gfn_is_even_across_xy_plane, - bool src_gfn_is_even_across_xz_plane, - bool src_gfn_is_even_across_yz_plane, - enum patch::integration_method method) - { - return ps.integrate_gridfn(src_gfn, src_gfn_is_even_across_xy_plane, - src_gfn_is_even_across_xz_plane, - src_gfn_is_even_across_yz_plane, - gfns::gfn__h, - gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, - gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, - gfns::gfn__g_dd_33, - method); - } - // with triad theta and phi - // since Thornburg uses vertex center, we will meet nan at pole points - void BH_diagnostics::compute_signature(patch_system &ps, const double dT) - { - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - for (int isigma = p.min_isigma(); isigma <= p.max_isigma(); ++isigma) - { - const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - fp xx, yy, zz; - p.xyz_of_r_rho_sigma(r, rho, sigma, xx, yy, zz); - - const fp sintheta = sqrt(1 - zz * zz / r / r); - - const fp X_ud_11 = xx * zz / r / r / sqrt(xx * xx + yy * yy); - const fp X_ud_12 = yy * zz / r / r / sqrt(xx * xx + yy * yy); - const fp X_ud_13 = -sqrt(xx * xx + yy * yy) / r / r; - const fp X_ud_21 = -yy / (xx * xx + yy * yy); - const fp X_ud_22 = xx / (xx * xx + yy * yy); - const fp X_ud_23 = 0; - - const fp g_dd_11 = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); - const fp g_dd_12 = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); - const fp g_dd_13 = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); - const fp g_dd_22 = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); - const fp g_dd_23 = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); - const fp g_dd_33 = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); - - const fp Lap = 1.0 + p.gridfn(gfns::gfn__global_xx, irho, isigma); - const fp Sfx = p.gridfn(gfns::gfn__global_xy, irho, isigma); - const fp Sfy = p.gridfn(gfns::gfn__global_xz, irho, isigma); - const fp Sfz = p.gridfn(gfns::gfn__global_yy, irho, isigma); - - const fp dfdt = (r - p.gridfn(gfns::gfn__oldh, irho, isigma)) / dT; - - double Br = Sfx * xx / r + Sfy * yy / r + Sfz * zz / r; - double Brho = Sfx * X_ud_11 + Sfy * X_ud_12 + Sfz * X_ud_13; - double Bsigma = Sfx * X_ud_21 + Sfy * X_ud_22 + Sfz * X_ud_23; - - double g_uu_11, g_uu_12, g_uu_13, g_uu_22, g_uu_23, g_uu_33; - double g11, g12, g13, g22, g23, g33; - { - // g^uu - fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; - fp t18, t21; - t1 = g_dd_22; - t2 = g_dd_33; - t4 = g_dd_23; - t5 = t4 * t4; - t7 = g_dd_11; - t8 = t7 * t1; - t11 = g_dd_12; - t12 = t11 * t11; - t14 = g_dd_13; - t15 = t11 * t14; - t18 = t14 * t14; - t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); - g11 = (t1 * t2 - t5) * t21; - g12 = -(t11 * t2 - t14 * t4) * t21; - g13 = -(-t11 * t4 + t14 * t1) * t21; - g22 = (t7 * t2 - t18) * t21; - g23 = -(t7 * t4 - t15) * t21; - g33 = (t8 - t12) * t21; - } - // 1 r;2 rho; 3 sigma - g_uu_22 = (g11 * X_ud_11 + g12 * X_ud_12 + g13 * X_ud_13) * X_ud_11 + (g12 * X_ud_11 + g22 * X_ud_12 + g23 * X_ud_13) * X_ud_12 + (g13 * X_ud_11 + g23 * X_ud_12 + g33 * X_ud_13) * X_ud_13; - g_uu_23 = (g11 * X_ud_11 + g12 * X_ud_12 + g13 * X_ud_13) * X_ud_21 + (g12 * X_ud_11 + g22 * X_ud_12 + g23 * X_ud_13) * X_ud_22 + (g13 * X_ud_11 + g23 * X_ud_12 + g33 * X_ud_13) * X_ud_23; - g_uu_12 = (g11 * X_ud_11 + g12 * X_ud_12 + g13 * X_ud_13) * xx / r + (g12 * X_ud_11 + g22 * X_ud_12 + g23 * X_ud_13) * yy / r + (g13 * X_ud_11 + g23 * X_ud_12 + g33 * X_ud_13) * zz / r; - g_uu_33 = (g11 * X_ud_21 + g12 * X_ud_22 + g13 * X_ud_23) * X_ud_21 + (g12 * X_ud_21 + g22 * X_ud_22 + g23 * X_ud_23) * X_ud_22 + (g13 * X_ud_21 + g23 * X_ud_22 + g33 * X_ud_23) * X_ud_23; - g_uu_13 = (g11 * X_ud_21 + g12 * X_ud_22 + g13 * X_ud_23) * xx / r + (g12 * X_ud_21 + g22 * X_ud_22 + g23 * X_ud_23) * yy / r + (g13 * X_ud_21 + g23 * X_ud_22 + g33 * X_ud_23) * zz / r; - g_uu_11 = (g11 * xx / r + g12 * yy / r + g13 * zz / r) * xx / r + (g12 * xx / r + g22 * yy / r + g23 * zz / r) * yy / r + (g13 * xx / r + g23 * yy / r + g33 * zz / r) * zz / r; - { - // g_uu - fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; - fp t18, t21; - t1 = g_uu_22; - t2 = g_uu_33; - t4 = g_uu_23; - t5 = t4 * t4; - t7 = g_uu_11; - t8 = t7 * t1; - t11 = g_uu_12; - t12 = t11 * t11; - t14 = g_uu_13; - t15 = t11 * t14; - t18 = t14 * t14; - t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); - g11 = (t1 * t2 - t5) * t21; - g12 = -(t11 * t2 - t14 * t4) * t21; - g13 = -(-t11 * t4 + t14 * t1) * t21; - g22 = (t7 * t2 - t18) * t21; - g23 = -(t7 * t4 - t15) * t21; - g33 = (t8 - t12) * t21; - } - - double q11 = g22, q12 = g23, q13 = Br + dfdt * g12; - double q22 = g33, q23 = Bsigma + dfdt * g13; - double q33 = (-Lap * Lap + g11 * Br * Br + g22 * Brho * Brho + g33 * Bsigma * Bsigma + - 2 * (g12 * Br * Brho + g13 * Br * Bsigma + g23 * Brho * Bsigma)) + - 2 * dfdt * Br + dfdt * dfdt * g11; - q12 = q12 / sintheta; - q22 = q22 / sintheta / sintheta; - q23 = q23 / sintheta; - // we use gfns::gfn__global_zz to store determinant - p.gridfn(gfns::gfn__global_zz, irho, isigma) = q11 * q22 * q33 + q12 * q23 * q13 + q13 * q12 * q23 - q13 * q22 * q13 - q12 * q12 * q33 - q11 * q23 * q23; - } // end for irho isigma - } - } - FILE *BH_diagnostics::setup_output_file(int N_horizons, int hn) - const - { - char file_name_buffer[50]; - sprintf(file_name_buffer, "infoah%02d.dat", hn); - const char *const file_open_mode = "w"; - - FILE *fileptr = fopen(file_name_buffer, file_open_mode); - if (fileptr == NULL) - printf("\n" - " BH_diagnostics::setup_output_file():\n" - " can't open BH-diagnostics output file\n" - " \"%s\"!", - file_name_buffer); - /* - fprintf(fileptr, "# apparent horizon %d/%d\n", hn, N_horizons); - fprintf(fileptr, "#\n"); - fprintf(fileptr, "# column 1 = cctk_time\n"); - fprintf(fileptr, "# column 2 = centroid_x\n"); - fprintf(fileptr, "# column 3 = centroid_y\n"); - fprintf(fileptr, "# column 4 = centroid_z\n"); - fprintf(fileptr, "# column 5 = min radius\n"); - fprintf(fileptr, "# column 6 = max radius\n"); - fprintf(fileptr, "# column 7 = mean radius\n"); - fprintf(fileptr, "# column 8 = quadrupole_xx\n"); - fprintf(fileptr, "# column 9 = quadrupole_xy\n"); - fprintf(fileptr, "# column 10 = quadrupole_xz\n"); - fprintf(fileptr, "# column 11 = quadrupole_yy\n"); - fprintf(fileptr, "# column 12 = quadrupole_yz\n"); - fprintf(fileptr, "# column 13 = quadrupole_zz\n"); - fprintf(fileptr, "# column 14 = min x\n"); - fprintf(fileptr, "# column 15 = max x\n"); - fprintf(fileptr, "# column 16 = min y\n"); - fprintf(fileptr, "# column 17 = max y\n"); - fprintf(fileptr, "# column 18 = min z\n"); - fprintf(fileptr, "# column 19 = max z\n"); - fprintf(fileptr, "# column 20 = xy-plane circumference\n"); - fprintf(fileptr, "# column 21 = xz-plane circumference\n"); - fprintf(fileptr, "# column 22 = yz-plane circumference\n"); - fprintf(fileptr, "# column 23 = ratio of xz/xy-plane circumferences\n"); - fprintf(fileptr, "# column 24 = ratio of yz/xy-plane circumferences\n"); - fprintf(fileptr, "# column 25 = area\n"); - fprintf(fileptr, "# column 26 = irreducible mass\n"); - fprintf(fileptr, "# column 27 = areal radius\n"); - */ - - fprintf(fileptr, "#time Mass x y z Px Py Pz Sx Sy Sz\n"); - fflush(fileptr); - - return fileptr; - } - void BH_diagnostics::output(FILE *fileptr, double time) - const - { - assert(fileptr != NULL); - /* - fprintf(fileptr, - "%f\t%f\t%f\t%f\t%#.10g\t%#.10g\t%#.10g\t", - double(time), - double(centroid_x), double(centroid_y), double(centroid_z), - double(min_radius), double(max_radius), double(mean_radius)); - - fprintf(fileptr, - "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t", - double(quadrupole_xx), double(quadrupole_xy), double(quadrupole_xz), - double(quadrupole_yy), double(quadrupole_yz), - double(quadrupole_zz)); - - fprintf(fileptr, - "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t", - double(min_x), double(max_x), - double(min_y), double(max_y), - double(min_z), double(max_z)); - - fprintf(fileptr, - "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t", - double(circumference_xy), - double(circumference_xz), - double(circumference_yz), - double(circumference_xz / circumference_xy), - double(circumference_yz / circumference_xy)); - - fprintf(fileptr, - "%#.10g\t%#.10g\t%#.10g\n", - double(area), double(irreducible_mass), double(areal_radius)); - */ - - fprintf(fileptr, - "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\n", - double(time), double(irreducible_mass), - double(centroid_x), double(centroid_y), double(centroid_z), - double(Px), double(Py), double(Pz), double(Sx), double(Sy), double(Sz)); - - fflush(fileptr); - } - -} // namespace AHFinderDirect +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" +#include "myglobal.h" + +#include "horizon_sequence.h" +#include "BH_diagnostics.h" +#include "driver.h" + +namespace AHFinderDirect +{ + using jtutil::error_exit; + + BH_diagnostics::BH_diagnostics() + : centroid_x(0.0), centroid_y(0.0), centroid_z(0.0), + quadrupole_xx(0.0), quadrupole_xy(0.0), quadrupole_xz(0.0), + quadrupole_yy(0.0), quadrupole_yz(0.0), + quadrupole_zz(0.0), + min_radius(0.0), max_radius(0.0), + mean_radius(0.0), + min_x(0.0), max_x(0.0), + min_y(0.0), max_y(0.0), + min_z(0.0), max_z(0.0), + circumference_xy(0.0), circumference_xz(0.0), circumference_yz(0.0), + area(0.0), irreducible_mass(0.0), areal_radius(0.0) // no comma + { + } + + void BH_diagnostics::copy_to_buffer(double buffer[N_buffer]) + const + { + buffer[posn__centroid_x] = centroid_x; + buffer[posn__centroid_y] = centroid_y; + buffer[posn__centroid_z] = centroid_z; + + buffer[posn__quadrupole_xx] = quadrupole_xx; + buffer[posn__quadrupole_xy] = quadrupole_xy; + buffer[posn__quadrupole_xz] = quadrupole_xz; + buffer[posn__quadrupole_yy] = quadrupole_yy; + buffer[posn__quadrupole_xz] = quadrupole_yz; + buffer[posn__quadrupole_zz] = quadrupole_zz; + + buffer[posn__min_radius] = min_radius; + buffer[posn__max_radius] = max_radius; + buffer[posn__mean_radius] = mean_radius; + + buffer[posn__min_x] = min_x; + buffer[posn__max_x] = max_x; + buffer[posn__min_y] = min_y; + buffer[posn__max_y] = max_y; + buffer[posn__min_z] = min_z; + buffer[posn__max_z] = max_z; + + buffer[posn__circumference_xy] = circumference_xy; + buffer[posn__circumference_xz] = circumference_xz; + buffer[posn__circumference_yz] = circumference_yz; + + buffer[posn__area] = area; + buffer[posn__irreducible_mass] = irreducible_mass; + buffer[posn__areal_radius] = areal_radius; + } + + void BH_diagnostics::copy_from_buffer(const double buffer[N_buffer]) + { + centroid_x = buffer[posn__centroid_x]; + centroid_y = buffer[posn__centroid_y]; + centroid_z = buffer[posn__centroid_z]; + + quadrupole_xx = buffer[posn__quadrupole_xx]; + quadrupole_xy = buffer[posn__quadrupole_xy]; + quadrupole_xz = buffer[posn__quadrupole_xz]; + quadrupole_yy = buffer[posn__quadrupole_yy]; + quadrupole_yz = buffer[posn__quadrupole_yz]; + quadrupole_zz = buffer[posn__quadrupole_zz]; + + min_radius = buffer[posn__min_radius]; + max_radius = buffer[posn__max_radius]; + mean_radius = buffer[posn__mean_radius]; + + min_x = buffer[posn__min_x]; + max_x = buffer[posn__max_x]; + min_y = buffer[posn__min_y]; + max_y = buffer[posn__max_y]; + min_z = buffer[posn__min_z]; + max_z = buffer[posn__max_z]; + + circumference_xy = buffer[posn__circumference_xy]; + circumference_xz = buffer[posn__circumference_xz]; + circumference_yz = buffer[posn__circumference_yz]; + + area = buffer[posn__area]; + irreducible_mass = buffer[posn__irreducible_mass]; + areal_radius = buffer[posn__areal_radius]; + } + void BH_diagnostics::compute(patch_system &ps) + { + jtutil::norm h_norms; + ps.ghosted_gridfn_norms(gfns::gfn__h, h_norms); + min_radius = h_norms.min_abs_value(); + max_radius = h_norms.max_abs_value(); + + jtutil::norm x_norms; + jtutil::norm y_norms; + jtutil::norm z_norms; + + ps.gridfn_norms(gfns::gfn__global_x, x_norms); + ps.gridfn_norms(gfns::gfn__global_y, y_norms); + ps.gridfn_norms(gfns::gfn__global_z, z_norms); + + min_x = x_norms.min_value(); + max_x = x_norms.max_value(); + min_y = y_norms.min_value(); + max_y = y_norms.max_value(); + min_z = z_norms.min_value(); + max_z = z_norms.max_value(); + +// adjust the bounding box for the symmetries +#define REFLECT(origin_, max_) (origin_ - (max_ - origin_)) + switch (ps.type()) + { + case patch_system::patch_system__full_sphere: + break; + case patch_system::patch_system__plus_z_hemisphere: + min_z = REFLECT(ps.origin_z(), max_z); + break; + case patch_system::patch_system__plus_xy_quadrant_mirrored: + case patch_system::patch_system__plus_xy_quadrant_rotating: + min_x = REFLECT(ps.origin_x(), max_x); + min_y = REFLECT(ps.origin_y(), max_y); + break; + case patch_system::patch_system__plus_xz_quadrant_mirrored: + case patch_system::patch_system__plus_xz_quadrant_rotating: + min_x = REFLECT(ps.origin_x(), max_x); + min_z = REFLECT(ps.origin_z(), max_z); + break; + case patch_system::patch_system__plus_xyz_octant_mirrored: + case patch_system::patch_system__plus_xyz_octant_rotating: + min_x = REFLECT(ps.origin_x(), max_x); + min_y = REFLECT(ps.origin_y(), max_y); + min_z = REFLECT(ps.origin_z(), max_z); + break; + default: + error_exit(PANIC_EXIT, + "***** BH_diagnostics::compute(): unknown patch system type()=(int)%d!\n" + " (this should never happen!)\n", + int(ps.type())); /*NOTREACHED*/ + } + + // + // surface integrals + // + const fp integral_one = surface_integral(ps, + gfns::gfn__one, true, true, true, + patch::integration_method__automatic_choice); + const fp integral_h = surface_integral(ps, + gfns::gfn__h, true, true, true, + patch::integration_method__automatic_choice); + const fp integral_x = surface_integral(ps, + gfns::gfn__global_x, true, true, false, + patch::integration_method__automatic_choice); + const fp integral_y = surface_integral(ps, + gfns::gfn__global_y, true, false, true, + patch::integration_method__automatic_choice); + const fp integral_z = surface_integral(ps, + gfns::gfn__global_z, false, true, true, + patch::integration_method__automatic_choice); + const fp integral_xx = surface_integral(ps, + gfns::gfn__global_xx, true, true, true, + patch::integration_method__automatic_choice); + const fp integral_xy = surface_integral(ps, + gfns::gfn__global_xy, true, false, false, + patch::integration_method__automatic_choice); + const fp integral_xz = surface_integral(ps, + gfns::gfn__global_xz, false, true, false, + patch::integration_method__automatic_choice); + const fp integral_yy = surface_integral(ps, + gfns::gfn__global_yy, true, true, true, + patch::integration_method__automatic_choice); + const fp integral_yz = surface_integral(ps, + gfns::gfn__global_yz, false, false, true, + patch::integration_method__automatic_choice); + const fp integral_zz = surface_integral(ps, + gfns::gfn__global_zz, true, true, true, + patch::integration_method__automatic_choice); + + // + // centroids + // + centroid_x = integral_x / integral_one; + centroid_y = integral_y / integral_one; + centroid_z = integral_z / integral_one; + + // + // quadrupoles (taken about centroid position) + // + quadrupole_xx = integral_xx / integral_one - centroid_x * centroid_x; + quadrupole_xy = integral_xy / integral_one - centroid_x * centroid_y; + quadrupole_xz = integral_xz / integral_one - centroid_x * centroid_z; + quadrupole_yy = integral_yy / integral_one - centroid_y * centroid_y; + quadrupole_yz = integral_yz / integral_one - centroid_y * centroid_z; + quadrupole_zz = integral_zz / integral_one - centroid_z * centroid_z; + + // + // mean radius of horizon + // + mean_radius = integral_h / integral_one; + + // + // surface area and quantities derived from it + // + area = integral_one; + irreducible_mass = sqrt(area / (16.0 * PI)); + areal_radius = sqrt(area / (4.0 * PI)); + + // + // proper circumferences + // + circumference_xy = ps.circumference("xy", gfns::gfn__h, + gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, + gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, + gfns::gfn__g_dd_33, + patch::integration_method__automatic_choice); + circumference_xz = ps.circumference("xz", gfns::gfn__h, + gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, + gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, + gfns::gfn__g_dd_33, + patch::integration_method__automatic_choice); + circumference_yz = ps.circumference("yz", gfns::gfn__h, + gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, + gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, + gfns::gfn__g_dd_33, + patch::integration_method__automatic_choice); + + // prepare P^i,S^i in xx,xy,xz and yy,yz,zz + { + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + const fp g_xx = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); + const fp g_xy = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); + const fp g_xz = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); + const fp g_yy = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); + const fp g_yz = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); + const fp g_zz = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); + + const fp k_xx = p.gridfn(gfns::gfn__K_dd_11, irho, isigma); + const fp k_xy = p.gridfn(gfns::gfn__K_dd_12, irho, isigma); + const fp k_xz = p.gridfn(gfns::gfn__K_dd_13, irho, isigma); + const fp k_yy = p.gridfn(gfns::gfn__K_dd_22, irho, isigma); + const fp k_yz = p.gridfn(gfns::gfn__K_dd_23, irho, isigma); + const fp k_zz = p.gridfn(gfns::gfn__K_dd_33, irho, isigma); + const fp trk = p.gridfn(gfns::gfn__trK, irho, isigma); + + const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + fp xx, yy, zz; // local Cardesian coordinate + p.xyz_of_r_rho_sigma(r, rho, sigma, xx, yy, zz); + const fp X_ud_11 = p.partial_rho_wrt_x(xx, yy, zz); + const fp X_ud_12 = p.partial_rho_wrt_y(xx, yy, zz); + const fp X_ud_13 = p.partial_rho_wrt_z(xx, yy, zz); + const fp X_ud_21 = p.partial_sigma_wrt_x(xx, yy, zz); + const fp X_ud_22 = p.partial_sigma_wrt_y(xx, yy, zz); + const fp X_ud_23 = p.partial_sigma_wrt_z(xx, yy, zz); +#if 0 // for P^i and S^i + // F,i = x^i/r-X_ud_1i(dh/drho)-X_ud_2i(dh/dsigma) + double nx,ny,nz; + nx = xx/r-X_ud_11*p.partial_rho(gfns::gfn__h, irho,isigma)-X_ud_21*p.partial_sigma(gfns::gfn__h, irho,isigma); + ny = yy/r-X_ud_12*p.partial_rho(gfns::gfn__h, irho,isigma)-X_ud_22*p.partial_sigma(gfns::gfn__h, irho,isigma); + nz = zz/r-X_ud_13*p.partial_rho(gfns::gfn__h, irho,isigma)-X_ud_23*p.partial_sigma(gfns::gfn__h, irho,isigma); + double eps; // volume element + fp g_uu_11, g_uu_12, g_uu_13, g_uu_22, g_uu_23, g_uu_33; + double pxx,pxy,pxz,pyy,pyz,pzz; + { + fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; + fp t18, t21; + t1 = g_yy; + t2 = g_zz; + t4 = g_yz; + t5 = t4*t4; + t7 = g_xx; + t8 = t7*t1; + t11 = g_xy; + t12 = t11*t11; + t14 = g_xz; + t15 = t11*t14; + t18 = t14*t14; + eps = t8*t2-t7*t5-t12*t2+2.0*t15*t4-t18*t1; + t21 = 1/eps; + eps = sqrt(eps); + g_uu_11 = (t1*t2-t5)*t21; + g_uu_12 = -(t11*t2-t14*t4)*t21; + g_uu_13 = -(-t11*t4+t14*t1)*t21; + g_uu_22 = (t7*t2-t18)*t21; + g_uu_23 = -(t7*t4-t15)*t21; + g_uu_33 = (t8-t12)*t21; + + t5 = g_uu_11*nx*nx+g_uu_22*ny*ny+g_uu_33*nz*nz+2*(g_uu_12*nx*ny+g_uu_13*nx*nz+g_uu_23*ny*nz); + t5 = sqrt(t5); + nx = nx/t5; // lower index + ny = ny/t5; + nz = nz/t5; + + pxx= g_uu_11*(g_uu_11*k_xx+g_uu_12*k_xy+g_uu_13*k_xz) + +g_uu_12*(g_uu_11*k_xy+g_uu_12*k_yy+g_uu_13*k_yz) + +g_uu_13*(g_uu_11*k_xz+g_uu_12*k_yz+g_uu_13*k_zz); //k^xx + pxy= g_uu_11*(g_uu_12*k_xx+g_uu_22*k_xy+g_uu_23*k_xz) + +g_uu_12*(g_uu_12*k_xy+g_uu_22*k_yy+g_uu_23*k_yz) + +g_uu_13*(g_uu_12*k_xz+g_uu_22*k_yz+g_uu_23*k_zz); //k^xy + pxz= g_uu_11*(g_uu_13*k_xx+g_uu_23*k_xy+g_uu_33*k_xz) + +g_uu_12*(g_uu_13*k_xy+g_uu_23*k_yy+g_uu_33*k_yz) + +g_uu_13*(g_uu_13*k_xz+g_uu_23*k_yz+g_uu_33*k_zz); //k^xz + pyy= g_uu_12*(g_uu_12*k_xx+g_uu_22*k_xy+g_uu_23*k_xz) + +g_uu_22*(g_uu_12*k_xy+g_uu_22*k_yy+g_uu_23*k_yz) + +g_uu_23*(g_uu_12*k_xz+g_uu_22*k_yz+g_uu_23*k_zz); //k^yy + pyz= g_uu_12*(g_uu_13*k_xx+g_uu_23*k_xy+g_uu_33*k_xz) + +g_uu_22*(g_uu_13*k_xy+g_uu_23*k_yy+g_uu_33*k_yz) + +g_uu_23*(g_uu_13*k_xz+g_uu_23*k_yz+g_uu_33*k_zz); //k^yz + pzz= g_uu_13*(g_uu_13*k_xx+g_uu_23*k_xy+g_uu_33*k_xz) + +g_uu_23*(g_uu_13*k_xy+g_uu_23*k_yy+g_uu_33*k_yz) + +g_uu_33*(g_uu_13*k_xz+g_uu_23*k_yz+g_uu_33*k_zz); //k^zz + } + + pxx = pxx-g_uu_11*trk; // tracefree + pyy = pyy-g_uu_22*trk; + pzz = pzz-g_uu_33*trk; + double tx,ty,tz; + double sxx,sxy,sxz,syx,syy,syz,szx,szy,szz; + tx = nx*pxx + ny*pxy + nz*pxz; + ty = nx*pxy + ny*pyy + nz*pyz; + tz = nx*pxz + ny*pyz + nz*pzz; + sxx = xx*tx; + sxy = xx*ty; + sxz = xx*tz; + syx = yy*tx; + syy = yy*ty; + syz = yy*tz; + szx = zz*tx; + szy = zz*ty; + szz = zz*tz; + p.gridfn(gfns::gfn__global_xx, irho,isigma) = tx; //p^x + p.gridfn(gfns::gfn__global_xy, irho,isigma) = ty; //p^y + p.gridfn(gfns::gfn__global_xz, irho,isigma) = tz; //p^z + tx = eps*(syz-szy); //s_x + ty = eps*(szx-sxz); + tz = eps*(sxy-syx); + p.gridfn(gfns::gfn__global_yy, irho,isigma) = g_uu_11*tx+g_uu_12*ty+g_uu_13*tz; //s^x + p.gridfn(gfns::gfn__global_yz, irho,isigma) = g_uu_12*tx+g_uu_22*ty+g_uu_23*tz; //s^y + p.gridfn(gfns::gfn__global_zz, irho,isigma) = g_uu_13*tx+g_uu_23*ty+g_uu_33*tz; //s^z +#endif +#if 1 // for P_i and S_i + // F,i = x^i/r-X_ud_1i(dh/drho)-X_ud_2i(dh/dsigma) + double nx, ny, nz; + nx = xx / r - X_ud_11 * p.partial_rho(gfns::gfn__h, irho, isigma) - X_ud_21 * p.partial_sigma(gfns::gfn__h, irho, isigma); + ny = yy / r - X_ud_12 * p.partial_rho(gfns::gfn__h, irho, isigma) - X_ud_22 * p.partial_sigma(gfns::gfn__h, irho, isigma); + nz = zz / r - X_ud_13 * p.partial_rho(gfns::gfn__h, irho, isigma) - X_ud_23 * p.partial_sigma(gfns::gfn__h, irho, isigma); + { + fp g_uu_11, g_uu_12, g_uu_13, g_uu_22, g_uu_23, g_uu_33; + fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; + fp t18, t21; + t1 = g_yy; + t2 = g_zz; + t4 = g_yz; + t5 = t4 * t4; + t7 = g_xx; + t8 = t7 * t1; + t11 = g_xy; + t12 = t11 * t11; + t14 = g_xz; + t15 = t11 * t14; + t18 = t14 * t14; + t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); + g_uu_11 = (t1 * t2 - t5) * t21; + g_uu_12 = -(t11 * t2 - t14 * t4) * t21; + g_uu_13 = -(-t11 * t4 + t14 * t1) * t21; + g_uu_22 = (t7 * t2 - t18) * t21; + g_uu_23 = -(t7 * t4 - t15) * t21; + g_uu_33 = (t8 - t12) * t21; + + t1 = g_uu_11 * nx + g_uu_12 * ny + g_uu_13 * nz; + t2 = g_uu_12 * nx + g_uu_22 * ny + g_uu_23 * nz; + t4 = g_uu_13 * nx + g_uu_23 * ny + g_uu_33 * nz; + t5 = g_uu_11 * nx * nx + g_uu_22 * ny * ny + g_uu_33 * nz * nz + 2 * (g_uu_12 * nx * ny + g_uu_13 * nx * nz + g_uu_23 * ny * nz); + t5 = sqrt(t5); + nx = t1 / t5; // uper index + ny = t2 / t5; + nz = t4 / t5; + } + + double pxx, pxy, pxz, pyy, pyz, pzz; + double sxx, sxy, sxz, syx, syy, syz, szx, szy, szz; + // these tensor components are same for local Cardisean and global Cardisean + pxx = k_xx - g_xx * trk; // lower index + pxy = k_xy; + pxz = k_xz; + pyy = k_yy - g_yy * trk; + pyz = k_yz; + pzz = k_zz - g_zz * trk; + /* + sxx = yy*pxy - zz*pxz; + sxy = yy*pyy - zz*pyz; + sxz = yy*pyz - zz*pzz; + syx = zz*pxy - yy*pxz; + syy = zz*pyy - yy*pyz; + syz = zz*pyz - yy*pzz; + szx = xx*pxy - yy*pxx; + szy = xx*pyy - yy*pxy; + szz = xx*pyz - yy*pxz; + */ + // we need Cardisean coordinate whose original point coincide with centroid_x^i + xx = p.gridfn(gfns::gfn__global_x, irho, isigma) - centroid_x; + yy = p.gridfn(gfns::gfn__global_y, irho, isigma) - centroid_y; + zz = p.gridfn(gfns::gfn__global_z, irho, isigma) - centroid_z; + sxx = yy * pxz - zz * pxy; + sxy = zz * pxx - xx * pxz; + sxz = xx * pxy - yy * pxx; + syx = yy * pyz - zz * pyy; + syy = zz * pxy - xx * pyz; + syz = xx * pyy - yy * pxy; + szx = yy * pzz - zz * pyz; + szy = zz * pxz - xx * pzz; + szz = xx * pyz - yy * pxz; + + p.gridfn(gfns::gfn__global_xx, irho, isigma) = nx * pxx + ny * pxy + nz * pxz; // p_x + p.gridfn(gfns::gfn__global_xy, irho, isigma) = nx * pxy + ny * pyy + nz * pyz; // p_y + p.gridfn(gfns::gfn__global_xz, irho, isigma) = nx * pxz + ny * pyz + nz * pzz; // p_z + p.gridfn(gfns::gfn__global_yy, irho, isigma) = nx * sxx + ny * syx + nz * szx; // s_x + p.gridfn(gfns::gfn__global_yz, irho, isigma) = nx * sxy + ny * syy + nz * szy; // s_y + p.gridfn(gfns::gfn__global_zz, irho, isigma) = nx * sxz + ny * syz + nz * szz; // s_z +#endif + } + } + } + } + + Px = surface_integral(ps, + gfns::gfn__global_xx, true, true, false, // z,y,x direction, even or odd function + patch::integration_method__automatic_choice); + Py = surface_integral(ps, + gfns::gfn__global_xy, true, false, true, + patch::integration_method__automatic_choice); + Pz = surface_integral(ps, + gfns::gfn__global_xz, false, true, true, + patch::integration_method__automatic_choice); + Sx = surface_integral(ps, + gfns::gfn__global_yy, false, false, true, + patch::integration_method__automatic_choice); + Sy = surface_integral(ps, + gfns::gfn__global_yz, false, true, false, + patch::integration_method__automatic_choice); + Sz = surface_integral(ps, + gfns::gfn__global_zz, true, false, false, + patch::integration_method__automatic_choice); + const double F1o8pi = 1.0 / 8 / PI; + Px = Px * F1o8pi; + Py = Py * F1o8pi; + Pz = Pz * F1o8pi; + Sx = Sx * F1o8pi; + Sy = Sy * F1o8pi; + Sz = Sz * F1o8pi; + } + + //****************************************************************************** + + // + // This function computes the surface integral of a gridfn over the + // horizon. + // + fp BH_diagnostics::surface_integral(const patch_system &ps, + int src_gfn, bool src_gfn_is_even_across_xy_plane, + bool src_gfn_is_even_across_xz_plane, + bool src_gfn_is_even_across_yz_plane, + enum patch::integration_method method) + { + return ps.integrate_gridfn(src_gfn, src_gfn_is_even_across_xy_plane, + src_gfn_is_even_across_xz_plane, + src_gfn_is_even_across_yz_plane, + gfns::gfn__h, + gfns::gfn__g_dd_11, gfns::gfn__g_dd_12, gfns::gfn__g_dd_13, + gfns::gfn__g_dd_22, gfns::gfn__g_dd_23, + gfns::gfn__g_dd_33, + method); + } + // with triad theta and phi + // since Thornburg uses vertex center, we will meet nan at pole points + void BH_diagnostics::compute_signature(patch_system &ps, const double dT) + { + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + for (int isigma = p.min_isigma(); isigma <= p.max_isigma(); ++isigma) + { + const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + fp xx, yy, zz; + p.xyz_of_r_rho_sigma(r, rho, sigma, xx, yy, zz); + + const fp sintheta = sqrt(1 - zz * zz / r / r); + + const fp X_ud_11 = xx * zz / r / r / sqrt(xx * xx + yy * yy); + const fp X_ud_12 = yy * zz / r / r / sqrt(xx * xx + yy * yy); + const fp X_ud_13 = -sqrt(xx * xx + yy * yy) / r / r; + const fp X_ud_21 = -yy / (xx * xx + yy * yy); + const fp X_ud_22 = xx / (xx * xx + yy * yy); + const fp X_ud_23 = 0; + + const fp g_dd_11 = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); + const fp g_dd_12 = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); + const fp g_dd_13 = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); + const fp g_dd_22 = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); + const fp g_dd_23 = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); + const fp g_dd_33 = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); + + const fp Lap = 1.0 + p.gridfn(gfns::gfn__global_xx, irho, isigma); + const fp Sfx = p.gridfn(gfns::gfn__global_xy, irho, isigma); + const fp Sfy = p.gridfn(gfns::gfn__global_xz, irho, isigma); + const fp Sfz = p.gridfn(gfns::gfn__global_yy, irho, isigma); + + const fp dfdt = (r - p.gridfn(gfns::gfn__oldh, irho, isigma)) / dT; + + double Br = Sfx * xx / r + Sfy * yy / r + Sfz * zz / r; + double Brho = Sfx * X_ud_11 + Sfy * X_ud_12 + Sfz * X_ud_13; + double Bsigma = Sfx * X_ud_21 + Sfy * X_ud_22 + Sfz * X_ud_23; + + double g_uu_11, g_uu_12, g_uu_13, g_uu_22, g_uu_23, g_uu_33; + double g11, g12, g13, g22, g23, g33; + { + // g^uu + fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; + fp t18, t21; + t1 = g_dd_22; + t2 = g_dd_33; + t4 = g_dd_23; + t5 = t4 * t4; + t7 = g_dd_11; + t8 = t7 * t1; + t11 = g_dd_12; + t12 = t11 * t11; + t14 = g_dd_13; + t15 = t11 * t14; + t18 = t14 * t14; + t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); + g11 = (t1 * t2 - t5) * t21; + g12 = -(t11 * t2 - t14 * t4) * t21; + g13 = -(-t11 * t4 + t14 * t1) * t21; + g22 = (t7 * t2 - t18) * t21; + g23 = -(t7 * t4 - t15) * t21; + g33 = (t8 - t12) * t21; + } + // 1 r;2 rho; 3 sigma + g_uu_22 = (g11 * X_ud_11 + g12 * X_ud_12 + g13 * X_ud_13) * X_ud_11 + (g12 * X_ud_11 + g22 * X_ud_12 + g23 * X_ud_13) * X_ud_12 + (g13 * X_ud_11 + g23 * X_ud_12 + g33 * X_ud_13) * X_ud_13; + g_uu_23 = (g11 * X_ud_11 + g12 * X_ud_12 + g13 * X_ud_13) * X_ud_21 + (g12 * X_ud_11 + g22 * X_ud_12 + g23 * X_ud_13) * X_ud_22 + (g13 * X_ud_11 + g23 * X_ud_12 + g33 * X_ud_13) * X_ud_23; + g_uu_12 = (g11 * X_ud_11 + g12 * X_ud_12 + g13 * X_ud_13) * xx / r + (g12 * X_ud_11 + g22 * X_ud_12 + g23 * X_ud_13) * yy / r + (g13 * X_ud_11 + g23 * X_ud_12 + g33 * X_ud_13) * zz / r; + g_uu_33 = (g11 * X_ud_21 + g12 * X_ud_22 + g13 * X_ud_23) * X_ud_21 + (g12 * X_ud_21 + g22 * X_ud_22 + g23 * X_ud_23) * X_ud_22 + (g13 * X_ud_21 + g23 * X_ud_22 + g33 * X_ud_23) * X_ud_23; + g_uu_13 = (g11 * X_ud_21 + g12 * X_ud_22 + g13 * X_ud_23) * xx / r + (g12 * X_ud_21 + g22 * X_ud_22 + g23 * X_ud_23) * yy / r + (g13 * X_ud_21 + g23 * X_ud_22 + g33 * X_ud_23) * zz / r; + g_uu_11 = (g11 * xx / r + g12 * yy / r + g13 * zz / r) * xx / r + (g12 * xx / r + g22 * yy / r + g23 * zz / r) * yy / r + (g13 * xx / r + g23 * yy / r + g33 * zz / r) * zz / r; + { + // g_uu + fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; + fp t18, t21; + t1 = g_uu_22; + t2 = g_uu_33; + t4 = g_uu_23; + t5 = t4 * t4; + t7 = g_uu_11; + t8 = t7 * t1; + t11 = g_uu_12; + t12 = t11 * t11; + t14 = g_uu_13; + t15 = t11 * t14; + t18 = t14 * t14; + t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); + g11 = (t1 * t2 - t5) * t21; + g12 = -(t11 * t2 - t14 * t4) * t21; + g13 = -(-t11 * t4 + t14 * t1) * t21; + g22 = (t7 * t2 - t18) * t21; + g23 = -(t7 * t4 - t15) * t21; + g33 = (t8 - t12) * t21; + } + + double q11 = g22, q12 = g23, q13 = Br + dfdt * g12; + double q22 = g33, q23 = Bsigma + dfdt * g13; + double q33 = (-Lap * Lap + g11 * Br * Br + g22 * Brho * Brho + g33 * Bsigma * Bsigma + + 2 * (g12 * Br * Brho + g13 * Br * Bsigma + g23 * Brho * Bsigma)) + + 2 * dfdt * Br + dfdt * dfdt * g11; + q12 = q12 / sintheta; + q22 = q22 / sintheta / sintheta; + q23 = q23 / sintheta; + // we use gfns::gfn__global_zz to store determinant + p.gridfn(gfns::gfn__global_zz, irho, isigma) = q11 * q22 * q33 + q12 * q23 * q13 + q13 * q12 * q23 - q13 * q22 * q13 - q12 * q12 * q33 - q11 * q23 * q23; + } // end for irho isigma + } + } + FILE *BH_diagnostics::setup_output_file(int N_horizons, int hn) + const + { + char file_name_buffer[50]; + sprintf(file_name_buffer, "infoah%02d.dat", hn); + const char *const file_open_mode = "w"; + + FILE *fileptr = fopen(file_name_buffer, file_open_mode); + if (fileptr == NULL) + printf("\n" + " BH_diagnostics::setup_output_file():\n" + " can't open BH-diagnostics output file\n" + " \"%s\"!", + file_name_buffer); + /* + fprintf(fileptr, "# apparent horizon %d/%d\n", hn, N_horizons); + fprintf(fileptr, "#\n"); + fprintf(fileptr, "# column 1 = cctk_time\n"); + fprintf(fileptr, "# column 2 = centroid_x\n"); + fprintf(fileptr, "# column 3 = centroid_y\n"); + fprintf(fileptr, "# column 4 = centroid_z\n"); + fprintf(fileptr, "# column 5 = min radius\n"); + fprintf(fileptr, "# column 6 = max radius\n"); + fprintf(fileptr, "# column 7 = mean radius\n"); + fprintf(fileptr, "# column 8 = quadrupole_xx\n"); + fprintf(fileptr, "# column 9 = quadrupole_xy\n"); + fprintf(fileptr, "# column 10 = quadrupole_xz\n"); + fprintf(fileptr, "# column 11 = quadrupole_yy\n"); + fprintf(fileptr, "# column 12 = quadrupole_yz\n"); + fprintf(fileptr, "# column 13 = quadrupole_zz\n"); + fprintf(fileptr, "# column 14 = min x\n"); + fprintf(fileptr, "# column 15 = max x\n"); + fprintf(fileptr, "# column 16 = min y\n"); + fprintf(fileptr, "# column 17 = max y\n"); + fprintf(fileptr, "# column 18 = min z\n"); + fprintf(fileptr, "# column 19 = max z\n"); + fprintf(fileptr, "# column 20 = xy-plane circumference\n"); + fprintf(fileptr, "# column 21 = xz-plane circumference\n"); + fprintf(fileptr, "# column 22 = yz-plane circumference\n"); + fprintf(fileptr, "# column 23 = ratio of xz/xy-plane circumferences\n"); + fprintf(fileptr, "# column 24 = ratio of yz/xy-plane circumferences\n"); + fprintf(fileptr, "# column 25 = area\n"); + fprintf(fileptr, "# column 26 = irreducible mass\n"); + fprintf(fileptr, "# column 27 = areal radius\n"); + */ + + fprintf(fileptr, "#time Mass x y z Px Py Pz Sx Sy Sz\n"); + fflush(fileptr); + + return fileptr; + } + void BH_diagnostics::output(FILE *fileptr, double time) + const + { + assert(fileptr != NULL); + /* + fprintf(fileptr, + "%f\t%f\t%f\t%f\t%#.10g\t%#.10g\t%#.10g\t", + double(time), + double(centroid_x), double(centroid_y), double(centroid_z), + double(min_radius), double(max_radius), double(mean_radius)); + + fprintf(fileptr, + "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t", + double(quadrupole_xx), double(quadrupole_xy), double(quadrupole_xz), + double(quadrupole_yy), double(quadrupole_yz), + double(quadrupole_zz)); + + fprintf(fileptr, + "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t", + double(min_x), double(max_x), + double(min_y), double(max_y), + double(min_z), double(max_z)); + + fprintf(fileptr, + "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t", + double(circumference_xy), + double(circumference_xz), + double(circumference_yz), + double(circumference_xz / circumference_xy), + double(circumference_yz / circumference_xy)); + + fprintf(fileptr, + "%#.10g\t%#.10g\t%#.10g\n", + double(area), double(irreducible_mass), double(areal_radius)); + */ + + fprintf(fileptr, + "%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\t%#.10g\n", + double(time), double(irreducible_mass), + double(centroid_x), double(centroid_y), double(centroid_z), + double(Px), double(Py), double(Pz), double(Sx), double(Sy), double(Sz)); + + fflush(fileptr); + } + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/BH_diagnostics.h b/AMSS_NCKU_source/AHF_Direct/BH_diagnostics.h similarity index 95% rename from AMSS_NCKU_source/BH_diagnostics.h rename to AMSS_NCKU_source/AHF_Direct/BH_diagnostics.h index d2d3cd4..eefd3ec 100644 --- a/AMSS_NCKU_source/BH_diagnostics.h +++ b/AMSS_NCKU_source/AHF_Direct/BH_diagnostics.h @@ -1,101 +1,101 @@ -#ifndef BH_DIAGNOSTICS_H -#define BH_DIAGNOSTICS_H -namespace AHFinderDirect -{ - - struct BH_diagnostics - { - public: - // mean x,y,z - fp centroid_x, centroid_y, centroid_z; - - // these are quadrupole moments about the centroid, i.e. - // mean(xi*xj) - centroid_i*centroid_j - fp quadrupole_xx, quadrupole_xy, quadrupole_xz, - quadrupole_yy, quadrupole_yz, - quadrupole_zz; - - // min,max,mean surface radius about local coordinate origin - fp min_radius, max_radius, mean_radius; - - // xyz bounding box - fp min_x, max_x, - min_y, max_y, - min_z, max_z; - - // proper circumference - // (computed using induced metric along these local-coordinate planes) - fp circumference_xy, - circumference_xz, - circumference_yz; - - // surface area (computed using induced metric) - // and quantities derived from it - fp area, irreducible_mass, areal_radius; - - double Px, Py, Pz, Sx, Sy, Sz; - - public: - // position of diagnostics in buffer and number of diagnostics - enum - { - posn__centroid_x = 0, - posn__centroid_y, - posn__centroid_z, - posn__quadrupole_xx, - posn__quadrupole_xy, - posn__quadrupole_xz, - posn__quadrupole_yy, - posn__quadrupole_yz, - posn__quadrupole_zz, - posn__min_radius, - posn__max_radius, - posn__mean_radius, - - posn__min_x, - posn__max_x, - posn__min_y, - posn__max_y, - posn__min_z, - posn__max_z, - - posn__circumference_xy, - posn__circumference_xz, - posn__circumference_yz, - - posn__area, - posn__irreducible_mass, - posn__areal_radius, - - N_buffer // no comma // size of buffer - }; - - // copy diagnostics to/from buffer - void copy_to_buffer(double buffer[N_buffer]) const; - void copy_from_buffer(const double buffer[N_buffer]); - - public: - void compute(patch_system &ps); - - void compute_signature(patch_system &ps, const double dT); - - FILE *setup_output_file(int N_horizons, int hn) - const; - - void output(FILE *fileptr, double time) - const; - - BH_diagnostics(); - - private: - static double surface_integral(const patch_system &ps, - int src_gfn, bool src_gfn_is_even_across_xy_plane, - bool src_gfn_is_even_across_xz_plane, - bool src_gfn_is_even_across_yz_plane, - enum patch::integration_method method); - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* BH_DIAGNOSTICS_H */ +#ifndef BH_DIAGNOSTICS_H +#define BH_DIAGNOSTICS_H +namespace AHFinderDirect +{ + + struct BH_diagnostics + { + public: + // mean x,y,z + fp centroid_x, centroid_y, centroid_z; + + // these are quadrupole moments about the centroid, i.e. + // mean(xi*xj) - centroid_i*centroid_j + fp quadrupole_xx, quadrupole_xy, quadrupole_xz, + quadrupole_yy, quadrupole_yz, + quadrupole_zz; + + // min,max,mean surface radius about local coordinate origin + fp min_radius, max_radius, mean_radius; + + // xyz bounding box + fp min_x, max_x, + min_y, max_y, + min_z, max_z; + + // proper circumference + // (computed using induced metric along these local-coordinate planes) + fp circumference_xy, + circumference_xz, + circumference_yz; + + // surface area (computed using induced metric) + // and quantities derived from it + fp area, irreducible_mass, areal_radius; + + double Px, Py, Pz, Sx, Sy, Sz; + + public: + // position of diagnostics in buffer and number of diagnostics + enum + { + posn__centroid_x = 0, + posn__centroid_y, + posn__centroid_z, + posn__quadrupole_xx, + posn__quadrupole_xy, + posn__quadrupole_xz, + posn__quadrupole_yy, + posn__quadrupole_yz, + posn__quadrupole_zz, + posn__min_radius, + posn__max_radius, + posn__mean_radius, + + posn__min_x, + posn__max_x, + posn__min_y, + posn__max_y, + posn__min_z, + posn__max_z, + + posn__circumference_xy, + posn__circumference_xz, + posn__circumference_yz, + + posn__area, + posn__irreducible_mass, + posn__areal_radius, + + N_buffer // no comma // size of buffer + }; + + // copy diagnostics to/from buffer + void copy_to_buffer(double buffer[N_buffer]) const; + void copy_from_buffer(const double buffer[N_buffer]); + + public: + void compute(patch_system &ps); + + void compute_signature(patch_system &ps, const double dT); + + FILE *setup_output_file(int N_horizons, int hn) + const; + + void output(FILE *fileptr, double time) + const; + + BH_diagnostics(); + + private: + static double surface_integral(const patch_system &ps, + int src_gfn, bool src_gfn_is_even_across_xy_plane, + bool src_gfn_is_even_across_xz_plane, + bool src_gfn_is_even_across_yz_plane, + enum patch::integration_method method); + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* BH_DIAGNOSTICS_H */ diff --git a/AMSS_NCKU_source/FFT.f90 b/AMSS_NCKU_source/AHF_Direct/FFT.f90 similarity index 95% rename from AMSS_NCKU_source/FFT.f90 rename to AMSS_NCKU_source/AHF_Direct/FFT.f90 index 7dfe727..eb37d8c 100644 --- a/AMSS_NCKU_source/FFT.f90 +++ b/AMSS_NCKU_source/AHF_Direct/FFT.f90 @@ -1,87 +1,87 @@ - - -#if 0 -program checkFFT -use dfport -implicit none -double precision::x -integer,parameter::N=256 -double precision,dimension(N*2)::p -double precision,dimension(N/2)::s -integer::ncount,j,idum -character(len=8)::tt -tt=clock() -idum=iachar(tt(8:8))-48 -p=0.0 -open(77,file='prime.dat',status='unknown') -loop1:do ncount=1,N - x=ran(idum) - p(2*ncount-1)=x - write(77,'(f15.3)')x -enddo loop1 -close(77) -call four1(p,N,1) -do j=1,N/2 - s(j)=p(2*j)*p(2*j)+p(2*j-1)*p(2*j-1) -enddo -x=0.0 -do j=1,N/2 - x=x+s(j) -enddo -s=s/x -open(77,file='power.dat',status='unknown') -do j=1,N/2 - write(77,'(2(1x,f15.3))')dble(j-1)/dble(N),s(j) -enddo -close(77) -end program checkFFT -#endif - -!------------- -! Optimized FFT using Intel oneMKL DFTI -! Mathematical equivalence: Standard DFT definition -! Forward (isign=1): X[k] = sum_{n=0}^{N-1} x[n] * exp(-2*pi*i*k*n/N) -! Backward (isign=-1): X[k] = sum_{n=0}^{N-1} x[n] * exp(+2*pi*i*k*n/N) -! Input/Output: dataa is interleaved complex array [Re(0),Im(0),Re(1),Im(1),...] -!------------- -SUBROUTINE four1(dataa,nn,isign) -use MKL_DFTI -implicit none -INTEGER, intent(in) :: isign, nn -DOUBLE PRECISION, dimension(2*nn), intent(inout) :: dataa - -type(DFTI_DESCRIPTOR), pointer :: desc -integer :: status - -! Create DFTI descriptor for 1D complex-to-complex transform -status = DftiCreateDescriptor(desc, DFTI_DOUBLE, DFTI_COMPLEX, 1, nn) -if (status /= 0) return - -! Set input/output storage as interleaved complex (default) -status = DftiSetValue(desc, DFTI_PLACEMENT, DFTI_INPLACE) -if (status /= 0) then - status = DftiFreeDescriptor(desc) - return -endif - -! Commit the descriptor -status = DftiCommitDescriptor(desc) -if (status /= 0) then - status = DftiFreeDescriptor(desc) - return -endif - -! Execute FFT based on direction -if (isign == 1) then - ! Forward FFT: exp(-2*pi*i*k*n/N) - status = DftiComputeForward(desc, dataa) -else - ! Backward FFT: exp(+2*pi*i*k*n/N) - status = DftiComputeBackward(desc, dataa) -endif - -! Free descriptor -status = DftiFreeDescriptor(desc) - -return -END SUBROUTINE four1 + + +#if 0 +program checkFFT +use dfport +implicit none +double precision::x +integer,parameter::N=256 +double precision,dimension(N*2)::p +double precision,dimension(N/2)::s +integer::ncount,j,idum +character(len=8)::tt +tt=clock() +idum=iachar(tt(8:8))-48 +p=0.0 +open(77,file='prime.dat',status='unknown') +loop1:do ncount=1,N + x=ran(idum) + p(2*ncount-1)=x + write(77,'(f15.3)')x +enddo loop1 +close(77) +call four1(p,N,1) +do j=1,N/2 + s(j)=p(2*j)*p(2*j)+p(2*j-1)*p(2*j-1) +enddo +x=0.0 +do j=1,N/2 + x=x+s(j) +enddo +s=s/x +open(77,file='power.dat',status='unknown') +do j=1,N/2 + write(77,'(2(1x,f15.3))')dble(j-1)/dble(N),s(j) +enddo +close(77) +end program checkFFT +#endif + +!------------- +! Optimized FFT using Intel oneMKL DFTI +! Mathematical equivalence: Standard DFT definition +! Forward (isign=1): X[k] = sum_{n=0}^{N-1} x[n] * exp(-2*pi*i*k*n/N) +! Backward (isign=-1): X[k] = sum_{n=0}^{N-1} x[n] * exp(+2*pi*i*k*n/N) +! Input/Output: dataa is interleaved complex array [Re(0),Im(0),Re(1),Im(1),...] +!------------- +SUBROUTINE four1(dataa,nn,isign) +use MKL_DFTI +implicit none +INTEGER, intent(in) :: isign, nn +DOUBLE PRECISION, dimension(2*nn), intent(inout) :: dataa + +type(DFTI_DESCRIPTOR), pointer :: desc +integer :: status + +! Create DFTI descriptor for 1D complex-to-complex transform +status = DftiCreateDescriptor(desc, DFTI_DOUBLE, DFTI_COMPLEX, 1, nn) +if (status /= 0) return + +! Set input/output storage as interleaved complex (default) +status = DftiSetValue(desc, DFTI_PLACEMENT, DFTI_INPLACE) +if (status /= 0) then + status = DftiFreeDescriptor(desc) + return +endif + +! Commit the descriptor +status = DftiCommitDescriptor(desc) +if (status /= 0) then + status = DftiFreeDescriptor(desc) + return +endif + +! Execute FFT based on direction +if (isign == 1) then + ! Forward FFT: exp(-2*pi*i*k*n/N) + status = DftiComputeForward(desc, dataa) +else + ! Backward FFT: exp(+2*pi*i*k*n/N) + status = DftiComputeBackward(desc, dataa) +endif + +! Free descriptor +status = DftiFreeDescriptor(desc) + +return +END SUBROUTINE four1 diff --git a/AMSS_NCKU_source/IntPnts.C b/AMSS_NCKU_source/AHF_Direct/IntPnts.C similarity index 96% rename from AMSS_NCKU_source/IntPnts.C rename to AMSS_NCKU_source/AHF_Direct/IntPnts.C index d8739c9..aac52a8 100644 --- a/AMSS_NCKU_source/IntPnts.C +++ b/AMSS_NCKU_source/AHF_Direct/IntPnts.C @@ -1,97 +1,97 @@ -//$Id: IntPnts.C,v 1.1 2012/04/03 10:49:42 zjcao Exp $ - -#include "macrodef.h" -#ifdef With_AHF - -#include -#include - -#include -using namespace std; - -#include "myglobal.h" - -namespace AHFinderDirect -{ - extern struct state state; - int globalInterpGFL(double *X, double *Y, double *Z, int Ns, - double *Data) - { - if (Ns == 0) - return 0; - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[Ns]; - for (n = 0; n < Ns; n++) - { - pox[0][n] = X[n]; - pox[1][n] = Y[n]; - pox[2][n] = Z[n]; - } - - const int InList = 35; - - double *datap; - datap = new double[Ns * InList]; - if (!(state.ADM->AH_Interp_Points(state.AHList, Ns, pox, datap, state.Symmetry))) - return 0; - // reform data - for (int pnt = 0; pnt < Ns; pnt++) - for (int ii = 0; ii < InList; ii++) - { - if (ii == 0 || ii == 12 || ii == 20) - Data[pnt + ii * Ns] = datap[ii + pnt * InList] + 1; - else if (ii == 24) // from chi-1 to psi - Data[pnt + ii * Ns] = pow(datap[ii + pnt * InList] + 1, -0.25); - else if (ii == 25 || ii == 26 || ii == 27) // from chi,i to psi,i - Data[pnt + ii * Ns] = -pow(datap[24 + pnt * InList] + 1, -1.25) / 4 * datap[ii + pnt * InList]; - else - Data[pnt + ii * Ns] = datap[ii + pnt * InList]; - } - delete[] datap; - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - - return 1; - } - // inerpolate lapse and shift - int globalInterpGFLlash(double *X, double *Y, double *Z, int Ns, - double *Data) - { - if (Ns == 0) - return 0; - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[Ns]; - for (n = 0; n < Ns; n++) - { - pox[0][n] = X[n]; - pox[1][n] = Y[n]; - pox[2][n] = Z[n]; - } - - double SYM = 1.0, ANT = -1.0; - const int InList = 4; - - double *datap; - datap = new double[Ns * InList]; - state.ADM->AH_Interp_Points(state.GaugeList, Ns, pox, datap, state.Symmetry); - // reform data - for (int pnt = 0; pnt < Ns; pnt++) - for (int ii = 0; ii < InList; ii++) - Data[pnt + ii * Ns] = datap[ii + pnt * InList]; - - delete[] datap; - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - - return 1; - } - -} // namespace AHFinderDirect -#endif +//$Id: IntPnts.C,v 1.1 2012/04/03 10:49:42 zjcao Exp $ + +#include "macrodef.h" +#ifdef With_AHF + +#include +#include + +#include +using namespace std; + +#include "myglobal.h" + +namespace AHFinderDirect +{ + extern struct state state; + int globalInterpGFL(double *X, double *Y, double *Z, int Ns, + double *Data) + { + if (Ns == 0) + return 0; + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[Ns]; + for (n = 0; n < Ns; n++) + { + pox[0][n] = X[n]; + pox[1][n] = Y[n]; + pox[2][n] = Z[n]; + } + + const int InList = 35; + + double *datap; + datap = new double[Ns * InList]; + if (!(state.ADM->AH_Interp_Points(state.AHList, Ns, pox, datap, state.Symmetry))) + return 0; + // reform data + for (int pnt = 0; pnt < Ns; pnt++) + for (int ii = 0; ii < InList; ii++) + { + if (ii == 0 || ii == 12 || ii == 20) + Data[pnt + ii * Ns] = datap[ii + pnt * InList] + 1; + else if (ii == 24) // from chi-1 to psi + Data[pnt + ii * Ns] = pow(datap[ii + pnt * InList] + 1, -0.25); + else if (ii == 25 || ii == 26 || ii == 27) // from chi,i to psi,i + Data[pnt + ii * Ns] = -pow(datap[24 + pnt * InList] + 1, -1.25) / 4 * datap[ii + pnt * InList]; + else + Data[pnt + ii * Ns] = datap[ii + pnt * InList]; + } + delete[] datap; + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + + return 1; + } + // inerpolate lapse and shift + int globalInterpGFLlash(double *X, double *Y, double *Z, int Ns, + double *Data) + { + if (Ns == 0) + return 0; + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[Ns]; + for (n = 0; n < Ns; n++) + { + pox[0][n] = X[n]; + pox[1][n] = Y[n]; + pox[2][n] = Z[n]; + } + + double SYM = 1.0, ANT = -1.0; + const int InList = 4; + + double *datap; + datap = new double[Ns * InList]; + state.ADM->AH_Interp_Points(state.GaugeList, Ns, pox, datap, state.Symmetry); + // reform data + for (int pnt = 0; pnt < Ns; pnt++) + for (int ii = 0; ii < InList; ii++) + Data[pnt + ii * Ns] = datap[ii + pnt * InList]; + + delete[] datap; + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + + return 1; + } + +} // namespace AHFinderDirect +#endif diff --git a/AMSS_NCKU_source/IntPnts0.C b/AMSS_NCKU_source/AHF_Direct/IntPnts0.C similarity index 95% rename from AMSS_NCKU_source/IntPnts0.C rename to AMSS_NCKU_source/AHF_Direct/IntPnts0.C index fb176d8..1942ba7 100644 --- a/AMSS_NCKU_source/IntPnts0.C +++ b/AMSS_NCKU_source/AHF_Direct/IntPnts0.C @@ -1,43 +1,43 @@ - -#include -#include -#include -#include - -#include - -#include "myglobal.h" - -int CCTK_VInfo(const char *thorn, const char *format, ...) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD,&myrank); - if (myrank !=0) return 0; - - va_list ap; - va_start (ap, format); - fprintf (stdout, "INFO (%s): ", thorn); - vfprintf (stdout, format, ap); - fprintf (stdout, "\n"); - va_end (ap); - return 0; -} -int CCTK_VWarn (int level, - int line, - const char *file, - const char *thorn, - const char *format, - ...) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD,&myrank); - if (myrank !=0) return 0; - - va_list ap; - va_start (ap, format); - fprintf (stdout, "WARN (%s): ", thorn); - vfprintf (stdout, format, ap); - fprintf (stdout, "\n"); - va_end (ap); - return 0; -} + +#include +#include +#include +#include + +#include + +#include "myglobal.h" + +int CCTK_VInfo(const char *thorn, const char *format, ...) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD,&myrank); + if (myrank !=0) return 0; + + va_list ap; + va_start (ap, format); + fprintf (stdout, "INFO (%s): ", thorn); + vfprintf (stdout, format, ap); + fprintf (stdout, "\n"); + va_end (ap); + return 0; +} +int CCTK_VWarn (int level, + int line, + const char *file, + const char *thorn, + const char *format, + ...) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD,&myrank); + if (myrank !=0) return 0; + + va_list ap; + va_start (ap, format); + fprintf (stdout, "WARN (%s): ", thorn); + vfprintf (stdout, format, ap); + fprintf (stdout, "\n"); + va_end (ap); + return 0; +} diff --git a/AMSS_NCKU_source/Jacobian.C b/AMSS_NCKU_source/AHF_Direct/Jacobian.C similarity index 95% rename from AMSS_NCKU_source/Jacobian.C rename to AMSS_NCKU_source/AHF_Direct/Jacobian.C index c8de8f2..d5a859b 100644 --- a/AMSS_NCKU_source/Jacobian.C +++ b/AMSS_NCKU_source/AHF_Direct/Jacobian.C @@ -1,270 +1,270 @@ -#include -#include -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" - -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" -#include "ilucg.h" -// all the code in this file is inside this namespace -namespace AHFinderDirect -{ - // this represents a single element stored in the matrix for - // sort_row_into_column_order() and sort_row_into_column_order__cmp() - struct matrix_element - { - int JA; - fp A; - }; - - Jacobian::Jacobian(patch_system &ps) - : ps_(ps), - N_rows_(ps.N_grid_points()), - N_nonzeros_(0), current_N_rows_(0), N_nonzeros_allocated_(0), - IA_(new integer[N_rows_ + 1]), JA_(NULL), A_(NULL), - itemp_(NULL), rtemp_(NULL) - { - IO_ = 1; - zero_matrix(); - } - - Jacobian::~Jacobian() - { - if (A_) - delete[] A_; - if (JA_) - delete[] JA_; - if (IA_) - delete[] IA_; - if (rtemp_) - delete[] rtemp_; - if (itemp_) - delete[] itemp_; - } - - double Jacobian::element(int II, int JJ) - const - { - const int posn = find_element(II, JJ); - return (posn >= 0) ? A_[posn] : 0.0; - } - - void Jacobian::zero_matrix() - { - - N_nonzeros_ = 0; - current_N_rows_ = 0; - IA_[0] = IO_; - } - - void Jacobian::set_element(int II, int JJ, fp value) - { - const int posn = find_element(II, JJ); - if (posn >= 0) - then A_[posn] = value; - else - insert_element(II, JJ, value); - } - - void Jacobian::sum_into_element(int II, int JJ, fp value) - { - const int posn = find_element(II, JJ); - if (posn >= 0) - then A_[posn] += value; - else - insert_element(II, JJ, value); - } - - int Jacobian::find_element(int II, int JJ) - const - { - if (II >= current_N_rows_) - then return -1; // this row not defined yet - - const int start = IA_[II] - IO_; - const int stop = IA_[II + 1] - IO_; - for (int posn = start; posn < stop; ++posn) - { - if (JA_[posn] - IO_ == JJ) - then return posn; // found - } - - return -1; // not found - } - - int Jacobian::insert_element(int II, int JJ, double value) - { - if (!((II == current_N_rows_ - 1) || (II == current_N_rows_))) - { - printf( - "***** row_sparse_Jacobian::insert_element(II=%d, JJ=%d, value=%g):\n" - " attempt to insert element elsewhere than {last row, last row+1}!\n" - " N_rows_=%d current_N_rows_=%d IO_=%d\n" - " N_nonzeros_=%d N_nonzeros_allocated_=%d\n", - II, JJ, double(value), - N_rows_, current_N_rows_, IO_, - N_nonzeros_, N_nonzeros_allocated_); - abort(); - } - - // start a new row if necessary - if (II == current_N_rows_) - then - { - assert(current_N_rows_ < N_rows_); - IA_[current_N_rows_ + 1] = IA_[current_N_rows_]; - ++current_N_rows_; - } - - // insert into current row - assert(II == current_N_rows_ - 1); - if (IA_[II + 1] - IO_ >= N_nonzeros_allocated_) - then grow_arrays(); - const int posn = IA_[II + 1] - IO_; - assert(posn < N_nonzeros_allocated_); - JA_[posn] = JJ + IO_; - A_[posn] = value; - ++IA_[II + 1]; - ++N_nonzeros_; - - return posn; - } - - void Jacobian::grow_arrays() - { - N_nonzeros_allocated_ += base_growth_amount + (N_nonzeros_allocated_ >> 1); - - int *const new_JA = new int[N_nonzeros_allocated_]; - double *const new_A = new double[N_nonzeros_allocated_]; - for (int posn = 0; posn < N_nonzeros_; ++posn) - { - new_JA[posn] = JA_[posn]; - new_A[posn] = A_[posn]; - } - delete[] A_; - delete[] JA_; - JA_ = new_JA; - A_ = new_A; - } - - int compare_matrix_elements(const void *x, const void *y) - { - const struct matrix_element *const px = static_cast(x); - const struct matrix_element *const py = static_cast(y); - - return px->JA - py->JA; - } - - void Jacobian::sort_each_row_into_column_order() - { - // buffer must be big enough to hold the largest row - int max_N_in_row = 0; - { - for (int II = 0; II < N_rows_; ++II) - { - max_N_in_row = max(max_N_in_row, IA_[II + 1] - IA_[II]); - } - } - - // contiguous buffer for sorting - struct matrix_element *const buffer = new struct matrix_element[max_N_in_row]; - - { - for (int II = 0; II < N_rows_; ++II) - { - const int N_in_row = IA_[II + 1] - IA_[II]; - - // copy this row's JA_[] and A_[] values to the buffer - const int start = IA_[II] - IO_; - for (int p = 0; p < N_in_row; ++p) - { - const int posn = start + p; - buffer[p].JA = JA_[posn]; - buffer[p].A = A_[posn]; - } - - // sort the buffer - qsort(static_cast(buffer), N_in_row, sizeof(buffer[0]), - &compare_matrix_elements); - - // copy the buffer values back to this row's JA_[] and A_[] - for (int p = 0; p < N_in_row; ++p) - { - const int posn = start + p; - JA_[posn] = buffer[p].JA; - A_[posn] = buffer[p].A; - } - } - } - - delete[] buffer; - } - - double Jacobian::solve_linear_system(int rhs_gfn, int x_gfn, bool print_msg_flag) - { - assert(IO_ == Fortran_index_origin); - assert(current_N_rows_ == N_rows_); - - if (itemp_ == NULL) - then - { - itemp_ = new int[3 * N_rows_ + 3 * N_nonzeros_ + 2]; - rtemp_ = new double[4 * N_rows_ + N_nonzeros_]; - } - - // initial guess = all zeros - double *x = ps_.gridfn_data(x_gfn); - for (int II = 0; II < N_rows_; ++II) - { - x[II] = 0.0; - } - - const int N = N_rows_; - const double *rhs = ps_.gridfn_data(rhs_gfn); - const double eps = 1e-10; - const int max_iterations = N_rows_; - int istatus; - - // the actual linear solution - f_ilucg(N, - IA_, JA_, A_, - rhs, x, - itemp_, rtemp_, - eps, max_iterations, - istatus); - - if (istatus < 0) - { - printf( - "***** row_sparse_Jacobian__ILUCG::solve_linear_system(rhs_gfn=%d, x_gfn=%d):\n" - " error return from [sd]ilucg() routine!\n" - " istatus=%d < 0 ==> bad matrix structure, eg. zero diagonal element!\n", - rhs_gfn, x_gfn, - int(istatus)); - abort(); - } - - return -1.0; - } - -} // namespace AHFinderDirect +#include +#include +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" + +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" +#include "ilucg.h" +// all the code in this file is inside this namespace +namespace AHFinderDirect +{ + // this represents a single element stored in the matrix for + // sort_row_into_column_order() and sort_row_into_column_order__cmp() + struct matrix_element + { + int JA; + fp A; + }; + + Jacobian::Jacobian(patch_system &ps) + : ps_(ps), + N_rows_(ps.N_grid_points()), + N_nonzeros_(0), current_N_rows_(0), N_nonzeros_allocated_(0), + IA_(new integer[N_rows_ + 1]), JA_(NULL), A_(NULL), + itemp_(NULL), rtemp_(NULL) + { + IO_ = 1; + zero_matrix(); + } + + Jacobian::~Jacobian() + { + if (A_) + delete[] A_; + if (JA_) + delete[] JA_; + if (IA_) + delete[] IA_; + if (rtemp_) + delete[] rtemp_; + if (itemp_) + delete[] itemp_; + } + + double Jacobian::element(int II, int JJ) + const + { + const int posn = find_element(II, JJ); + return (posn >= 0) ? A_[posn] : 0.0; + } + + void Jacobian::zero_matrix() + { + + N_nonzeros_ = 0; + current_N_rows_ = 0; + IA_[0] = IO_; + } + + void Jacobian::set_element(int II, int JJ, fp value) + { + const int posn = find_element(II, JJ); + if (posn >= 0) + then A_[posn] = value; + else + insert_element(II, JJ, value); + } + + void Jacobian::sum_into_element(int II, int JJ, fp value) + { + const int posn = find_element(II, JJ); + if (posn >= 0) + then A_[posn] += value; + else + insert_element(II, JJ, value); + } + + int Jacobian::find_element(int II, int JJ) + const + { + if (II >= current_N_rows_) + then return -1; // this row not defined yet + + const int start = IA_[II] - IO_; + const int stop = IA_[II + 1] - IO_; + for (int posn = start; posn < stop; ++posn) + { + if (JA_[posn] - IO_ == JJ) + then return posn; // found + } + + return -1; // not found + } + + int Jacobian::insert_element(int II, int JJ, double value) + { + if (!((II == current_N_rows_ - 1) || (II == current_N_rows_))) + { + printf( + "***** row_sparse_Jacobian::insert_element(II=%d, JJ=%d, value=%g):\n" + " attempt to insert element elsewhere than {last row, last row+1}!\n" + " N_rows_=%d current_N_rows_=%d IO_=%d\n" + " N_nonzeros_=%d N_nonzeros_allocated_=%d\n", + II, JJ, double(value), + N_rows_, current_N_rows_, IO_, + N_nonzeros_, N_nonzeros_allocated_); + abort(); + } + + // start a new row if necessary + if (II == current_N_rows_) + then + { + assert(current_N_rows_ < N_rows_); + IA_[current_N_rows_ + 1] = IA_[current_N_rows_]; + ++current_N_rows_; + } + + // insert into current row + assert(II == current_N_rows_ - 1); + if (IA_[II + 1] - IO_ >= N_nonzeros_allocated_) + then grow_arrays(); + const int posn = IA_[II + 1] - IO_; + assert(posn < N_nonzeros_allocated_); + JA_[posn] = JJ + IO_; + A_[posn] = value; + ++IA_[II + 1]; + ++N_nonzeros_; + + return posn; + } + + void Jacobian::grow_arrays() + { + N_nonzeros_allocated_ += base_growth_amount + (N_nonzeros_allocated_ >> 1); + + int *const new_JA = new int[N_nonzeros_allocated_]; + double *const new_A = new double[N_nonzeros_allocated_]; + for (int posn = 0; posn < N_nonzeros_; ++posn) + { + new_JA[posn] = JA_[posn]; + new_A[posn] = A_[posn]; + } + delete[] A_; + delete[] JA_; + JA_ = new_JA; + A_ = new_A; + } + + int compare_matrix_elements(const void *x, const void *y) + { + const struct matrix_element *const px = static_cast(x); + const struct matrix_element *const py = static_cast(y); + + return px->JA - py->JA; + } + + void Jacobian::sort_each_row_into_column_order() + { + // buffer must be big enough to hold the largest row + int max_N_in_row = 0; + { + for (int II = 0; II < N_rows_; ++II) + { + max_N_in_row = max(max_N_in_row, IA_[II + 1] - IA_[II]); + } + } + + // contiguous buffer for sorting + struct matrix_element *const buffer = new struct matrix_element[max_N_in_row]; + + { + for (int II = 0; II < N_rows_; ++II) + { + const int N_in_row = IA_[II + 1] - IA_[II]; + + // copy this row's JA_[] and A_[] values to the buffer + const int start = IA_[II] - IO_; + for (int p = 0; p < N_in_row; ++p) + { + const int posn = start + p; + buffer[p].JA = JA_[posn]; + buffer[p].A = A_[posn]; + } + + // sort the buffer + qsort(static_cast(buffer), N_in_row, sizeof(buffer[0]), + &compare_matrix_elements); + + // copy the buffer values back to this row's JA_[] and A_[] + for (int p = 0; p < N_in_row; ++p) + { + const int posn = start + p; + JA_[posn] = buffer[p].JA; + A_[posn] = buffer[p].A; + } + } + } + + delete[] buffer; + } + + double Jacobian::solve_linear_system(int rhs_gfn, int x_gfn, bool print_msg_flag) + { + assert(IO_ == Fortran_index_origin); + assert(current_N_rows_ == N_rows_); + + if (itemp_ == NULL) + then + { + itemp_ = new int[3 * N_rows_ + 3 * N_nonzeros_ + 2]; + rtemp_ = new double[4 * N_rows_ + N_nonzeros_]; + } + + // initial guess = all zeros + double *x = ps_.gridfn_data(x_gfn); + for (int II = 0; II < N_rows_; ++II) + { + x[II] = 0.0; + } + + const int N = N_rows_; + const double *rhs = ps_.gridfn_data(rhs_gfn); + const double eps = 1e-10; + const int max_iterations = N_rows_; + int istatus; + + // the actual linear solution + f_ilucg(N, + IA_, JA_, A_, + rhs, x, + itemp_, rtemp_, + eps, max_iterations, + istatus); + + if (istatus < 0) + { + printf( + "***** row_sparse_Jacobian__ILUCG::solve_linear_system(rhs_gfn=%d, x_gfn=%d):\n" + " error return from [sd]ilucg() routine!\n" + " istatus=%d < 0 ==> bad matrix structure, eg. zero diagonal element!\n", + rhs_gfn, x_gfn, + int(istatus)); + abort(); + } + + return -1.0; + } + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/Jacobian.h b/AMSS_NCKU_source/AHF_Direct/Jacobian.h similarity index 95% rename from AMSS_NCKU_source/Jacobian.h rename to AMSS_NCKU_source/AHF_Direct/Jacobian.h index b9c4490..44e864a 100644 --- a/AMSS_NCKU_source/Jacobian.h +++ b/AMSS_NCKU_source/AHF_Direct/Jacobian.h @@ -1,90 +1,90 @@ -#ifndef AHFINDERDIRECT__JACOBIAN_HH -#define AHFINDERDIRECT__JACOBIAN_HH - -namespace AHFinderDirect -{ - class Jacobian - { - public: - // basic meta-info - patch_system &my_patch_system() const { return ps_; } - int N_rows() const { return N_rows_; } - - // convert (patch,irho,isigma) <--> row/column index - int II_of_patch_irho_isigma(const patch &p, int irho, int isigma) - const - { - return ps_.gpn_of_patch_irho_isigma(p, irho, isigma); - } - const patch &patch_irho_isigma_of_II(int II, int &irho, int &isigma) - const - { - return ps_.patch_irho_isigma_of_gpn(II, irho, isigma); - } - - double element(int II, int JJ) const; - - // is the matrix element (II,JJ) stored explicitly? - bool is_explicitly_stored(int II, int JJ) const - { - return find_element(II, JJ) > 0; - } - - int IO() const { return IO_; } - enum - { - C_index_origin = 0, - Fortran_index_origin = 1 - }; - - void zero_matrix(); - - void set_element(int II, int JJ, fp value); - - void sum_into_element(int II, int JJ, fp value); - - int find_element(int II, int JJ) const; - - int insert_element(int II, int JJ, fp value); - - void grow_arrays(); - - enum - { - base_growth_amount = 1000 - }; - - void sort_each_row_into_column_order(); - - double solve_linear_system(int rhs_gfn, int x_gfn, - bool print_msg_flag); - - public: - Jacobian(patch_system &ps); - ~Jacobian(); - - protected: - patch_system &ps_; - int N_rows_; - - int IO_; - - int N_nonzeros_; - int current_N_rows_; - - int N_nonzeros_allocated_; - - int *IA_; - - int *JA_; - - double *A_; - - int *itemp_; - double *rtemp_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* AHFINDERDIRECT__JACOBIAN_HH */ +#ifndef AHFINDERDIRECT__JACOBIAN_HH +#define AHFINDERDIRECT__JACOBIAN_HH + +namespace AHFinderDirect +{ + class Jacobian + { + public: + // basic meta-info + patch_system &my_patch_system() const { return ps_; } + int N_rows() const { return N_rows_; } + + // convert (patch,irho,isigma) <--> row/column index + int II_of_patch_irho_isigma(const patch &p, int irho, int isigma) + const + { + return ps_.gpn_of_patch_irho_isigma(p, irho, isigma); + } + const patch &patch_irho_isigma_of_II(int II, int &irho, int &isigma) + const + { + return ps_.patch_irho_isigma_of_gpn(II, irho, isigma); + } + + double element(int II, int JJ) const; + + // is the matrix element (II,JJ) stored explicitly? + bool is_explicitly_stored(int II, int JJ) const + { + return find_element(II, JJ) > 0; + } + + int IO() const { return IO_; } + enum + { + C_index_origin = 0, + Fortran_index_origin = 1 + }; + + void zero_matrix(); + + void set_element(int II, int JJ, fp value); + + void sum_into_element(int II, int JJ, fp value); + + int find_element(int II, int JJ) const; + + int insert_element(int II, int JJ, fp value); + + void grow_arrays(); + + enum + { + base_growth_amount = 1000 + }; + + void sort_each_row_into_column_order(); + + double solve_linear_system(int rhs_gfn, int x_gfn, + bool print_msg_flag); + + public: + Jacobian(patch_system &ps); + ~Jacobian(); + + protected: + patch_system &ps_; + int N_rows_; + + int IO_; + + int N_nonzeros_; + int current_N_rows_; + + int N_nonzeros_allocated_; + + int *IA_; + + int *JA_; + + double *A_; + + int *itemp_; + double *rtemp_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* AHFINDERDIRECT__JACOBIAN_HH */ diff --git a/AMSS_NCKU_source/Newton.C b/AMSS_NCKU_source/AHF_Direct/Newton.C similarity index 97% rename from AMSS_NCKU_source/Newton.C rename to AMSS_NCKU_source/AHF_Direct/Newton.C index 5e93014..2418ef7 100644 --- a/AMSS_NCKU_source/Newton.C +++ b/AMSS_NCKU_source/AHF_Direct/Newton.C @@ -1,555 +1,555 @@ -//$Id: Newton.C,v 1.1 2012/04/03 10:49:44 zjcao Exp $ - -#include "macrodef.h" -#ifdef With_AHF - -#include -#include -#include -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -#include "horizon_sequence.h" -#include "BH_diagnostics.h" -#include "driver.h" -#include "myglobal.h" - -namespace AHFinderDirect -{ - extern struct state state; - using jtutil::error_exit; - - void recentering(patch_system &ps, double max_x, double max_y, double max_z, - double min_x, double min_y, double min_z, - double centroid_x, double centroid_y, double centroid_z) - { - fp ox = ps.origin_x(); - fp oy = ps.origin_y(); - fp oz = ps.origin_z(); - - const fp CTR_TOLERENCE = .45; - bool center = (abs(max_x + min_x - 2.0 * ox) < CTR_TOLERENCE * (max_x - min_x)) && - (abs(max_y + min_y - 2.0 * oy) < CTR_TOLERENCE * (max_y - min_y)) && - (abs(max_z + min_z - 2.0 * oz) < CTR_TOLERENCE * (max_z - min_z)); - - if (!center) - { - - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - for (int isigma = p.min_isigma(); isigma <= p.max_isigma(); ++isigma) - { - - p.ghosted_gridfn(gfns::gfn__h, irho, isigma) = - sqrt(jtutil::pow2(p.gridfn(gfns::gfn__global_x, irho, isigma) - centroid_x) + - jtutil::pow2(p.gridfn(gfns::gfn__global_y, irho, isigma) - centroid_y) + - jtutil::pow2(p.gridfn(gfns::gfn__global_z, irho, isigma) - centroid_z)); - } - } - - ps.recentering(centroid_x, centroid_y, centroid_z); - } - } - - namespace - { - bool broadcast_status(int N_procs, int N_active_procs, - int my_proc, bool my_active_flag, - int hn, int iteration, - enum expansion_status expansion_status, - fp mean_horizon_radius, fp infinity_norm, - bool found_this_horizon, bool I_need_more_iterations, - struct iteration_status_buffers &isb); - - void Newton_step(patch_system &ps, - fp mean_horizon_radius, fp max_allowable_Delta_h_over_h); - - void save_oldh(patch_system &ps); - - int interpolate_alsh(patch_system *ps_ptr) - { - int status = 1; - -#define CAST_PTR_OR_NULL(type_, ptr_) \ - (ps_ptr == NULL) ? NULL : static_cast(ptr_) - - // - // ***** interpolation points ***** - // - const int N_interp_points = (ps_ptr == NULL) ? 0 : ps_ptr->N_grid_points(); - double *interp_coords[3] = { - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_x)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_y)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_z)), - }; - - double *const output_arrays[] = { - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_xx)), // Lapse-1 - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_xy)), // Sfx - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_xz)), // Sfy - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_yy)), // Sfz - }; - - const int N_output_arrays_dim = sizeof(output_arrays) / sizeof(output_arrays[0]); - const int N_output_arrays_use = N_output_arrays_dim; - - double *Data, *oX, *oY, *oZ; - - int s; - int Npts = 0; - for (int ncpu = 0; ncpu < state.N_procs; ncpu++) - { - - if (state.my_proc == ncpu) - Npts = N_interp_points; - - MPI_Bcast(&Npts, 1, MPI_INT, ncpu, MPI_COMM_WORLD); - - if (Npts != 0) - { - Data = new double[Npts * N_output_arrays_use]; - - oX = new double[Npts]; - oY = new double[Npts]; - oZ = new double[Npts]; - if (state.my_proc == ncpu) - { - memcpy(oX, interp_coords[0], Npts * sizeof(double)); - memcpy(oY, interp_coords[1], Npts * sizeof(double)); - memcpy(oZ, interp_coords[2], Npts * sizeof(double)); - } - MPI_Bcast(oX, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); - MPI_Bcast(oY, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); - MPI_Bcast(oZ, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); - - // each cpu calls interpolator - s = globalInterpGFLlash( - oX, oY, oZ, Npts, - Data); // 1 succuss; 0 fail - - if (state.my_proc == ncpu) - { - status = s; - - if (status == 1) - { - for (int ngf = 0; ngf < N_output_arrays_use; ngf++) - { - memcpy(output_arrays[ngf], Data + ngf * N_interp_points, - sizeof(double) * N_interp_points); - } - } - } - - delete[] oX; - delete[] oY; - delete[] oZ; - delete[] Data; - } - } - - return status; - } - - } - - //****************************************************************************** - void Newton(int N_procs, int N_active_procs, int my_proc, - horizon_sequence &hs, struct AH_data *const AH_data_array[], - struct iteration_status_buffers &isb, int *dumpid, double *dT) - { - const bool my_active_flag = hs.has_genuine_horizons(); - const int N_horizons = hs.N_horizons(); - - for (int hn = hs.init_hn();; hn = hs.next_hn()) // hn always =0 for cpu who has no patch_system - { - bool horizon_is_genuine = hs.is_genuine(); - const bool there_is_another_genuine_horizon = hs.is_next_genuine(); - - struct AH_data *AH_data_ptr = horizon_is_genuine ? AH_data_array[hn] : NULL; - - horizon_is_genuine = horizon_is_genuine && AH_data_ptr->find_trigger && !AH_data_ptr->stop_finding; - if (horizon_is_genuine) - cout << "being finding horizon #" << hn << endl; - patch_system *const ps_ptr = horizon_is_genuine ? AH_data_ptr->ps_ptr : NULL; - Jacobian *const Jac_ptr = horizon_is_genuine ? AH_data_ptr->Jac_ptr : NULL; - const double add_to_expansion = horizon_is_genuine ? -AH_data_ptr->surface_expansion : 0.0; - const int max_iterations = horizon_is_genuine - ? (AH_data_ptr->initial_find_flag ? 80 : 20) - : INT_MAX; - - if (horizon_is_genuine) - save_oldh(*ps_ptr); - - for (int iteration = 1;; ++iteration) - { - if (horizon_is_genuine && iteration == max_iterations) - cout << "AHfinder: fail to find horizon #" << hn - << " with Newton iteration " << iteration << " steps!!!" << endl; - jtutil::norm Theta_norms; - - const enum expansion_status raw_expansion_status = expansion(ps_ptr, add_to_expansion, - (iteration == 1), true, &Theta_norms); - - const bool Theta_is_ok = (raw_expansion_status == expansion_success); - const bool norms_are_ok = horizon_is_genuine && Theta_is_ok; - - // - // have we found this horizon? - // if so, compute and output BH diagnostics - // - const bool found_this_horizon = norms_are_ok && (Theta_norms.infinity_norm() <= 1e-11); - - if (horizon_is_genuine) - AH_data_ptr->found_flag = found_this_horizon; - - if (horizon_is_genuine && found_this_horizon) - cout << "found horizon #" << hn << " with " << iteration << " steps!!!" << endl; - // - // see if the expansion is too big - // (if so, we'll give up on this horizon) - // - const bool expansion_is_too_large = norms_are_ok && (Theta_norms.infinity_norm() > 1e10); - - // - // compute the mean horizon radius, and if it's too large, - // then pretend expansion() returned a "surface too large" error status - // - jtutil::norm h_norms; - if (horizon_is_genuine) - then ps_ptr->ghosted_gridfn_norms(gfns::gfn__h, h_norms); - const fp mean_horizon_radius = horizon_is_genuine ? h_norms.mean() - : 0.0; - const bool horizon_is_too_large = (mean_horizon_radius > 1e10); - - const enum expansion_status effective_expansion_status = horizon_is_too_large ? expansion_failure__surface_too_large - : raw_expansion_status; - - // - // see if we need more iterations (either on this or another horizon) - // - - // does *this* horizon need more iterations? - // i.e. has this horizon's Newton iteration not yet converged? - const bool this_horizon_needs_more_iterations = horizon_is_genuine && Theta_is_ok && !found_this_horizon && !expansion_is_too_large && !horizon_is_too_large && (iteration < max_iterations); - - // do I (this processor) need to do more iterations - // on this or a following horizon? - const bool I_need_more_iterations = this_horizon_needs_more_iterations || there_is_another_genuine_horizon; - - // - // broadcast iteration status from each active processor - // to all processors, and inclusive-or the "we need more iterations" - // flags to see if *any* (active) processor needs more iterations - // - const bool any_proc_needs_more_iterations = broadcast_status(N_procs, N_active_procs, - my_proc, my_active_flag, - hn, iteration, effective_expansion_status, - mean_horizon_radius, - (norms_are_ok ? Theta_norms.infinity_norm() : 0.0), - found_this_horizon, I_need_more_iterations, - isb); - // set found-this-horizon flags - // for all active processors' non-dummy horizons - for (int found_proc = 0; found_proc < N_active_procs; ++found_proc) - { - const int found_hn = isb.hn_buffer[found_proc]; - if (found_hn > 0) - AH_data_array[found_hn]->found_flag = isb.found_horizon_buffer[found_proc]; - } - - // - // prepare lapse and shift - { - int ff = 0, fft = 0; - if (found_this_horizon && dumpid[hn - 1] > 0 && dT[hn - 1] > 0) - fft = 1; - MPI_Allreduce(&fft, &ff, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - - if (ff) - { - if ((interpolate_alsh(ps_ptr) == 0) && (state.my_proc == 0)) - cout << "interpolation of lapse and shift for AH failed." << endl; - } - } - - if (found_this_horizon) - { - struct BH_diagnostics &BH_diagnostics = AH_data_ptr->BH_diagnostics; - // output data - if (dumpid[hn - 1] > 0) - { - char filename[100]; - sprintf(filename, "ah%02d_%05d.dat", hn, dumpid[hn - 1]); - if (dT[hn - 1] > 0) - { - // gridfunction xx,xy,xz,yy,yz,zz will be used as temp storage - BH_diagnostics.compute_signature(*ps_ptr, dT[hn - 1]); - ps_ptr->print_gridfn_with_xyz(gfns::gfn__global_zz, true, gfns::gfn__h, filename); - } - else - ps_ptr->print_ghosted_gridfn_with_xyz(gfns::gfn__h, true, gfns::gfn__h, filename, false); - } - - BH_diagnostics.compute(*ps_ptr); // gridfunction xx,xy,xz,yy,yz,zz changed - - if (AH_data_ptr->BH_diagnostics_fileptr == NULL) - AH_data_ptr->BH_diagnostics_fileptr = BH_diagnostics.setup_output_file(N_horizons, hn); - BH_diagnostics.output(AH_data_ptr->BH_diagnostics_fileptr, (*state.PhysTime)); - - // recentering - recentering(*ps_ptr, (AH_data_ptr->BH_diagnostics).max_x, (AH_data_ptr->BH_diagnostics).max_y, (AH_data_ptr->BH_diagnostics).max_z, - (AH_data_ptr->BH_diagnostics).min_x, (AH_data_ptr->BH_diagnostics).min_y, (AH_data_ptr->BH_diagnostics).min_z, - (AH_data_ptr->BH_diagnostics).centroid_x, (AH_data_ptr->BH_diagnostics).centroid_y, (AH_data_ptr->BH_diagnostics).centroid_z); - AH_data_ptr->recentering_flag = true; - } - - // - // are all processors done with all their genuine horizons? - // or if this is a single-processor run, are we done with this horizon? - // - if (!any_proc_needs_more_iterations) - return; // *** NORMAL RETURN *** - - // - // compute the Jacobian matrix - // *** this is a synchronous operation across all processors *** - // - - const enum expansion_status - Jacobian_status = expansion_Jacobian(this_horizon_needs_more_iterations ? ps_ptr : NULL, - this_horizon_needs_more_iterations ? Jac_ptr : NULL, - add_to_expansion, - (iteration == 1), - false); - const bool Jacobian_is_ok = (Jacobian_status == expansion_success); - - // - // skip to the next horizon unless - // this is a genuine Jacobian computation, and it went ok - // - if (!(this_horizon_needs_more_iterations && Jacobian_is_ok)) - break; // *** LOOP EXIT *** - - // - // compute the Newton step - // - Jac_ptr->solve_linear_system(gfns::gfn__Theta, gfns::gfn__Delta_h, false); - - Newton_step(*ps_ptr, mean_horizon_radius, 0.1); - - // end of this Newton iteration - } - - // end of this horizon - } - - // we should never get to here - assert(false); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - namespace - { - bool broadcast_status(int N_procs, int N_active_procs, - int my_proc, bool my_active_flag, - int hn, int iteration, - enum expansion_status effective_expansion_status, - fp mean_horizon_radius, fp infinity_norm, - bool found_this_horizon, bool I_need_more_iterations, - struct iteration_status_buffers &isb) - { - assert(my_proc >= 0); - assert(my_proc < N_procs); - - enum - { - buffer_var__hn = 0, // also encodes found_this_horizon flag - // in sign: +=true, -=false - buffer_var__iteration, // also encodes I_need_more_iterations flag - // in sign: +=true, -=false - buffer_var__expansion_status, - buffer_var__mean_horizon_radius, - buffer_var__Theta_infinity_norm, - N_buffer_vars // no comma - }; - - // - // allocate buffers if this is the first use - // - if (isb.hn_buffer == NULL) - then - { - isb.hn_buffer = new int[N_active_procs]; - isb.iteration_buffer = new int[N_active_procs]; - isb.expansion_status_buffer = new enum expansion_status[N_active_procs]; - isb.mean_horizon_radius_buffer = new fp[N_active_procs]; - isb.Theta_infinity_norm_buffer = new fp[N_active_procs]; - isb.found_horizon_buffer = new bool[N_active_procs]; - - isb.send_buffer_ptr = new jtutil::array2d(0, N_active_procs - 1, - 0, N_buffer_vars - 1); - isb.receive_buffer_ptr = new jtutil::array2d(0, N_active_procs - 1, - 0, N_buffer_vars - 1); - } - jtutil::array2d &send_buffer = *isb.send_buffer_ptr; - jtutil::array2d &receive_buffer = *isb.receive_buffer_ptr; - - // - // pack this processor's values into the reduction buffer - // - jtutil::zero_C_array(send_buffer.N_array(), send_buffer.data_array()); - if (my_active_flag) - then - { - assert(send_buffer.is_valid_i(my_proc)); - assert(hn >= 0); // encoding scheme assumes this - assert(iteration > 0); // encoding scheme assumes this - send_buffer(my_proc, buffer_var__hn) = found_this_horizon ? +hn : -hn; - send_buffer(my_proc, buffer_var__iteration) = I_need_more_iterations ? +iteration : -iteration; - send_buffer(my_proc, buffer_var__expansion_status) = int(effective_expansion_status); - send_buffer(my_proc, buffer_var__mean_horizon_radius) = mean_horizon_radius; - send_buffer(my_proc, buffer_var__Theta_infinity_norm) = infinity_norm; - } - - const int reduction_status = MPI_Allreduce(static_cast(send_buffer.data_array()), - static_cast(receive_buffer.data_array()), - send_buffer.N_array(), - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD); - - // if (reduction_status < 0) - if (reduction_status != MPI_SUCCESS) - then CCTK_VWarn(0, __LINE__, __FILE__, CCTK_THORNSTRING, - "broadcast_status(): error status %d from reduction!", - reduction_status); /*NOTREACHED*/ - - // - // unpack the reduction buffer back to the high-level result buffers and - // compute the inclusive-or of the broadcast I_need_more_iterations flags - // - bool any_proc_needs_more_iterations = false; - for (int proc = 0; proc < N_active_procs; ++proc) - { - const int hn_temp = static_cast( - receive_buffer(proc, buffer_var__hn)); - isb.hn_buffer[proc] = jtutil::abs(hn_temp); - isb.found_horizon_buffer[proc] = (hn_temp > 0); - - const int iteration_temp = static_cast( - receive_buffer(proc, buffer_var__iteration)); - isb.iteration_buffer[proc] = jtutil::abs(iteration_temp); - const bool proc_needs_more_iterations = (iteration_temp > 0); - any_proc_needs_more_iterations |= proc_needs_more_iterations; - - isb.expansion_status_buffer[proc] = static_cast( - static_cast( - receive_buffer(proc, buffer_var__expansion_status))); - - isb.mean_horizon_radius_buffer[proc] = receive_buffer(proc, buffer_var__mean_horizon_radius); - isb.Theta_infinity_norm_buffer[proc] = receive_buffer(proc, buffer_var__Theta_infinity_norm); - } - - return any_proc_needs_more_iterations; - } - } - // - // This function takes the Newton step, scaling it down if it's too large. - // - // Arguments: - // ps = The patch system containing the gridfns h and Delta_h. - // mean_horizon_radius = ||h||_mean - // max_allowable_Delta_h_over_h = The maximum allowable - // ||Delta_h||_infinity / ||h||_mean - // Any step over this is internally clamped - // (scaled down) to this size. - // - namespace - { - void Newton_step(patch_system &ps, - fp mean_horizon_radius, fp max_allowable_Delta_h_over_h) - { - // - // compute scale factor (1 for small steps, <1 for large steps) - // - - const fp max_allowable_Delta_h = max_allowable_Delta_h_over_h * mean_horizon_radius; - - jtutil::norm Delta_h_norms; - ps.gridfn_norms(gfns::gfn__Delta_h, Delta_h_norms); - const fp max_Delta_h = Delta_h_norms.infinity_norm(); - - const fp scale = (max_Delta_h <= max_allowable_Delta_h) - ? 1.0 - : max_allowable_Delta_h / max_Delta_h; - - // - // take the Newton step (scaled if necessary) - // - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - p.ghosted_gridfn(gfns::gfn__h, irho, isigma) -= scale * p.gridfn(gfns::gfn__Delta_h, irho, isigma); - } - } - } - } - void save_oldh(patch_system &ps) - { - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - p.gridfn(gfns::gfn__oldh, irho, isigma) = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - } - } - } - } - } - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif +//$Id: Newton.C,v 1.1 2012/04/03 10:49:44 zjcao Exp $ + +#include "macrodef.h" +#ifdef With_AHF + +#include +#include +#include +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +#include "horizon_sequence.h" +#include "BH_diagnostics.h" +#include "driver.h" +#include "myglobal.h" + +namespace AHFinderDirect +{ + extern struct state state; + using jtutil::error_exit; + + void recentering(patch_system &ps, double max_x, double max_y, double max_z, + double min_x, double min_y, double min_z, + double centroid_x, double centroid_y, double centroid_z) + { + fp ox = ps.origin_x(); + fp oy = ps.origin_y(); + fp oz = ps.origin_z(); + + const fp CTR_TOLERENCE = .45; + bool center = (abs(max_x + min_x - 2.0 * ox) < CTR_TOLERENCE * (max_x - min_x)) && + (abs(max_y + min_y - 2.0 * oy) < CTR_TOLERENCE * (max_y - min_y)) && + (abs(max_z + min_z - 2.0 * oz) < CTR_TOLERENCE * (max_z - min_z)); + + if (!center) + { + + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + for (int isigma = p.min_isigma(); isigma <= p.max_isigma(); ++isigma) + { + + p.ghosted_gridfn(gfns::gfn__h, irho, isigma) = + sqrt(jtutil::pow2(p.gridfn(gfns::gfn__global_x, irho, isigma) - centroid_x) + + jtutil::pow2(p.gridfn(gfns::gfn__global_y, irho, isigma) - centroid_y) + + jtutil::pow2(p.gridfn(gfns::gfn__global_z, irho, isigma) - centroid_z)); + } + } + + ps.recentering(centroid_x, centroid_y, centroid_z); + } + } + + namespace + { + bool broadcast_status(int N_procs, int N_active_procs, + int my_proc, bool my_active_flag, + int hn, int iteration, + enum expansion_status expansion_status, + fp mean_horizon_radius, fp infinity_norm, + bool found_this_horizon, bool I_need_more_iterations, + struct iteration_status_buffers &isb); + + void Newton_step(patch_system &ps, + fp mean_horizon_radius, fp max_allowable_Delta_h_over_h); + + void save_oldh(patch_system &ps); + + int interpolate_alsh(patch_system *ps_ptr) + { + int status = 1; + +#define CAST_PTR_OR_NULL(type_, ptr_) \ + (ps_ptr == NULL) ? NULL : static_cast(ptr_) + + // + // ***** interpolation points ***** + // + const int N_interp_points = (ps_ptr == NULL) ? 0 : ps_ptr->N_grid_points(); + double *interp_coords[3] = { + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_x)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_y)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_z)), + }; + + double *const output_arrays[] = { + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_xx)), // Lapse-1 + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_xy)), // Sfx + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_xz)), // Sfy + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_yy)), // Sfz + }; + + const int N_output_arrays_dim = sizeof(output_arrays) / sizeof(output_arrays[0]); + const int N_output_arrays_use = N_output_arrays_dim; + + double *Data, *oX, *oY, *oZ; + + int s; + int Npts = 0; + for (int ncpu = 0; ncpu < state.N_procs; ncpu++) + { + + if (state.my_proc == ncpu) + Npts = N_interp_points; + + MPI_Bcast(&Npts, 1, MPI_INT, ncpu, MPI_COMM_WORLD); + + if (Npts != 0) + { + Data = new double[Npts * N_output_arrays_use]; + + oX = new double[Npts]; + oY = new double[Npts]; + oZ = new double[Npts]; + if (state.my_proc == ncpu) + { + memcpy(oX, interp_coords[0], Npts * sizeof(double)); + memcpy(oY, interp_coords[1], Npts * sizeof(double)); + memcpy(oZ, interp_coords[2], Npts * sizeof(double)); + } + MPI_Bcast(oX, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); + MPI_Bcast(oY, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); + MPI_Bcast(oZ, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); + + // each cpu calls interpolator + s = globalInterpGFLlash( + oX, oY, oZ, Npts, + Data); // 1 succuss; 0 fail + + if (state.my_proc == ncpu) + { + status = s; + + if (status == 1) + { + for (int ngf = 0; ngf < N_output_arrays_use; ngf++) + { + memcpy(output_arrays[ngf], Data + ngf * N_interp_points, + sizeof(double) * N_interp_points); + } + } + } + + delete[] oX; + delete[] oY; + delete[] oZ; + delete[] Data; + } + } + + return status; + } + + } + + //****************************************************************************** + void Newton(int N_procs, int N_active_procs, int my_proc, + horizon_sequence &hs, struct AH_data *const AH_data_array[], + struct iteration_status_buffers &isb, int *dumpid, double *dT) + { + const bool my_active_flag = hs.has_genuine_horizons(); + const int N_horizons = hs.N_horizons(); + + for (int hn = hs.init_hn();; hn = hs.next_hn()) // hn always =0 for cpu who has no patch_system + { + bool horizon_is_genuine = hs.is_genuine(); + const bool there_is_another_genuine_horizon = hs.is_next_genuine(); + + struct AH_data *AH_data_ptr = horizon_is_genuine ? AH_data_array[hn] : NULL; + + horizon_is_genuine = horizon_is_genuine && AH_data_ptr->find_trigger && !AH_data_ptr->stop_finding; + if (horizon_is_genuine) + cout << "being finding horizon #" << hn << endl; + patch_system *const ps_ptr = horizon_is_genuine ? AH_data_ptr->ps_ptr : NULL; + Jacobian *const Jac_ptr = horizon_is_genuine ? AH_data_ptr->Jac_ptr : NULL; + const double add_to_expansion = horizon_is_genuine ? -AH_data_ptr->surface_expansion : 0.0; + const int max_iterations = horizon_is_genuine + ? (AH_data_ptr->initial_find_flag ? 80 : 20) + : INT_MAX; + + if (horizon_is_genuine) + save_oldh(*ps_ptr); + + for (int iteration = 1;; ++iteration) + { + if (horizon_is_genuine && iteration == max_iterations) + cout << "AHfinder: fail to find horizon #" << hn + << " with Newton iteration " << iteration << " steps!!!" << endl; + jtutil::norm Theta_norms; + + const enum expansion_status raw_expansion_status = expansion(ps_ptr, add_to_expansion, + (iteration == 1), true, &Theta_norms); + + const bool Theta_is_ok = (raw_expansion_status == expansion_success); + const bool norms_are_ok = horizon_is_genuine && Theta_is_ok; + + // + // have we found this horizon? + // if so, compute and output BH diagnostics + // + const bool found_this_horizon = norms_are_ok && (Theta_norms.infinity_norm() <= 1e-11); + + if (horizon_is_genuine) + AH_data_ptr->found_flag = found_this_horizon; + + if (horizon_is_genuine && found_this_horizon) + cout << "found horizon #" << hn << " with " << iteration << " steps!!!" << endl; + // + // see if the expansion is too big + // (if so, we'll give up on this horizon) + // + const bool expansion_is_too_large = norms_are_ok && (Theta_norms.infinity_norm() > 1e10); + + // + // compute the mean horizon radius, and if it's too large, + // then pretend expansion() returned a "surface too large" error status + // + jtutil::norm h_norms; + if (horizon_is_genuine) + then ps_ptr->ghosted_gridfn_norms(gfns::gfn__h, h_norms); + const fp mean_horizon_radius = horizon_is_genuine ? h_norms.mean() + : 0.0; + const bool horizon_is_too_large = (mean_horizon_radius > 1e10); + + const enum expansion_status effective_expansion_status = horizon_is_too_large ? expansion_failure__surface_too_large + : raw_expansion_status; + + // + // see if we need more iterations (either on this or another horizon) + // + + // does *this* horizon need more iterations? + // i.e. has this horizon's Newton iteration not yet converged? + const bool this_horizon_needs_more_iterations = horizon_is_genuine && Theta_is_ok && !found_this_horizon && !expansion_is_too_large && !horizon_is_too_large && (iteration < max_iterations); + + // do I (this processor) need to do more iterations + // on this or a following horizon? + const bool I_need_more_iterations = this_horizon_needs_more_iterations || there_is_another_genuine_horizon; + + // + // broadcast iteration status from each active processor + // to all processors, and inclusive-or the "we need more iterations" + // flags to see if *any* (active) processor needs more iterations + // + const bool any_proc_needs_more_iterations = broadcast_status(N_procs, N_active_procs, + my_proc, my_active_flag, + hn, iteration, effective_expansion_status, + mean_horizon_radius, + (norms_are_ok ? Theta_norms.infinity_norm() : 0.0), + found_this_horizon, I_need_more_iterations, + isb); + // set found-this-horizon flags + // for all active processors' non-dummy horizons + for (int found_proc = 0; found_proc < N_active_procs; ++found_proc) + { + const int found_hn = isb.hn_buffer[found_proc]; + if (found_hn > 0) + AH_data_array[found_hn]->found_flag = isb.found_horizon_buffer[found_proc]; + } + + // + // prepare lapse and shift + { + int ff = 0, fft = 0; + if (found_this_horizon && dumpid[hn - 1] > 0 && dT[hn - 1] > 0) + fft = 1; + MPI_Allreduce(&fft, &ff, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + + if (ff) + { + if ((interpolate_alsh(ps_ptr) == 0) && (state.my_proc == 0)) + cout << "interpolation of lapse and shift for AH failed." << endl; + } + } + + if (found_this_horizon) + { + struct BH_diagnostics &BH_diagnostics = AH_data_ptr->BH_diagnostics; + // output data + if (dumpid[hn - 1] > 0) + { + char filename[100]; + sprintf(filename, "ah%02d_%05d.dat", hn, dumpid[hn - 1]); + if (dT[hn - 1] > 0) + { + // gridfunction xx,xy,xz,yy,yz,zz will be used as temp storage + BH_diagnostics.compute_signature(*ps_ptr, dT[hn - 1]); + ps_ptr->print_gridfn_with_xyz(gfns::gfn__global_zz, true, gfns::gfn__h, filename); + } + else + ps_ptr->print_ghosted_gridfn_with_xyz(gfns::gfn__h, true, gfns::gfn__h, filename, false); + } + + BH_diagnostics.compute(*ps_ptr); // gridfunction xx,xy,xz,yy,yz,zz changed + + if (AH_data_ptr->BH_diagnostics_fileptr == NULL) + AH_data_ptr->BH_diagnostics_fileptr = BH_diagnostics.setup_output_file(N_horizons, hn); + BH_diagnostics.output(AH_data_ptr->BH_diagnostics_fileptr, (*state.PhysTime)); + + // recentering + recentering(*ps_ptr, (AH_data_ptr->BH_diagnostics).max_x, (AH_data_ptr->BH_diagnostics).max_y, (AH_data_ptr->BH_diagnostics).max_z, + (AH_data_ptr->BH_diagnostics).min_x, (AH_data_ptr->BH_diagnostics).min_y, (AH_data_ptr->BH_diagnostics).min_z, + (AH_data_ptr->BH_diagnostics).centroid_x, (AH_data_ptr->BH_diagnostics).centroid_y, (AH_data_ptr->BH_diagnostics).centroid_z); + AH_data_ptr->recentering_flag = true; + } + + // + // are all processors done with all their genuine horizons? + // or if this is a single-processor run, are we done with this horizon? + // + if (!any_proc_needs_more_iterations) + return; // *** NORMAL RETURN *** + + // + // compute the Jacobian matrix + // *** this is a synchronous operation across all processors *** + // + + const enum expansion_status + Jacobian_status = expansion_Jacobian(this_horizon_needs_more_iterations ? ps_ptr : NULL, + this_horizon_needs_more_iterations ? Jac_ptr : NULL, + add_to_expansion, + (iteration == 1), + false); + const bool Jacobian_is_ok = (Jacobian_status == expansion_success); + + // + // skip to the next horizon unless + // this is a genuine Jacobian computation, and it went ok + // + if (!(this_horizon_needs_more_iterations && Jacobian_is_ok)) + break; // *** LOOP EXIT *** + + // + // compute the Newton step + // + Jac_ptr->solve_linear_system(gfns::gfn__Theta, gfns::gfn__Delta_h, false); + + Newton_step(*ps_ptr, mean_horizon_radius, 0.1); + + // end of this Newton iteration + } + + // end of this horizon + } + + // we should never get to here + assert(false); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + namespace + { + bool broadcast_status(int N_procs, int N_active_procs, + int my_proc, bool my_active_flag, + int hn, int iteration, + enum expansion_status effective_expansion_status, + fp mean_horizon_radius, fp infinity_norm, + bool found_this_horizon, bool I_need_more_iterations, + struct iteration_status_buffers &isb) + { + assert(my_proc >= 0); + assert(my_proc < N_procs); + + enum + { + buffer_var__hn = 0, // also encodes found_this_horizon flag + // in sign: +=true, -=false + buffer_var__iteration, // also encodes I_need_more_iterations flag + // in sign: +=true, -=false + buffer_var__expansion_status, + buffer_var__mean_horizon_radius, + buffer_var__Theta_infinity_norm, + N_buffer_vars // no comma + }; + + // + // allocate buffers if this is the first use + // + if (isb.hn_buffer == NULL) + then + { + isb.hn_buffer = new int[N_active_procs]; + isb.iteration_buffer = new int[N_active_procs]; + isb.expansion_status_buffer = new enum expansion_status[N_active_procs]; + isb.mean_horizon_radius_buffer = new fp[N_active_procs]; + isb.Theta_infinity_norm_buffer = new fp[N_active_procs]; + isb.found_horizon_buffer = new bool[N_active_procs]; + + isb.send_buffer_ptr = new jtutil::array2d(0, N_active_procs - 1, + 0, N_buffer_vars - 1); + isb.receive_buffer_ptr = new jtutil::array2d(0, N_active_procs - 1, + 0, N_buffer_vars - 1); + } + jtutil::array2d &send_buffer = *isb.send_buffer_ptr; + jtutil::array2d &receive_buffer = *isb.receive_buffer_ptr; + + // + // pack this processor's values into the reduction buffer + // + jtutil::zero_C_array(send_buffer.N_array(), send_buffer.data_array()); + if (my_active_flag) + then + { + assert(send_buffer.is_valid_i(my_proc)); + assert(hn >= 0); // encoding scheme assumes this + assert(iteration > 0); // encoding scheme assumes this + send_buffer(my_proc, buffer_var__hn) = found_this_horizon ? +hn : -hn; + send_buffer(my_proc, buffer_var__iteration) = I_need_more_iterations ? +iteration : -iteration; + send_buffer(my_proc, buffer_var__expansion_status) = int(effective_expansion_status); + send_buffer(my_proc, buffer_var__mean_horizon_radius) = mean_horizon_radius; + send_buffer(my_proc, buffer_var__Theta_infinity_norm) = infinity_norm; + } + + const int reduction_status = MPI_Allreduce(static_cast(send_buffer.data_array()), + static_cast(receive_buffer.data_array()), + send_buffer.N_array(), + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD); + + // if (reduction_status < 0) + if (reduction_status != MPI_SUCCESS) + then CCTK_VWarn(0, __LINE__, __FILE__, CCTK_THORNSTRING, + "broadcast_status(): error status %d from reduction!", + reduction_status); /*NOTREACHED*/ + + // + // unpack the reduction buffer back to the high-level result buffers and + // compute the inclusive-or of the broadcast I_need_more_iterations flags + // + bool any_proc_needs_more_iterations = false; + for (int proc = 0; proc < N_active_procs; ++proc) + { + const int hn_temp = static_cast( + receive_buffer(proc, buffer_var__hn)); + isb.hn_buffer[proc] = jtutil::abs(hn_temp); + isb.found_horizon_buffer[proc] = (hn_temp > 0); + + const int iteration_temp = static_cast( + receive_buffer(proc, buffer_var__iteration)); + isb.iteration_buffer[proc] = jtutil::abs(iteration_temp); + const bool proc_needs_more_iterations = (iteration_temp > 0); + any_proc_needs_more_iterations |= proc_needs_more_iterations; + + isb.expansion_status_buffer[proc] = static_cast( + static_cast( + receive_buffer(proc, buffer_var__expansion_status))); + + isb.mean_horizon_radius_buffer[proc] = receive_buffer(proc, buffer_var__mean_horizon_radius); + isb.Theta_infinity_norm_buffer[proc] = receive_buffer(proc, buffer_var__Theta_infinity_norm); + } + + return any_proc_needs_more_iterations; + } + } + // + // This function takes the Newton step, scaling it down if it's too large. + // + // Arguments: + // ps = The patch system containing the gridfns h and Delta_h. + // mean_horizon_radius = ||h||_mean + // max_allowable_Delta_h_over_h = The maximum allowable + // ||Delta_h||_infinity / ||h||_mean + // Any step over this is internally clamped + // (scaled down) to this size. + // + namespace + { + void Newton_step(patch_system &ps, + fp mean_horizon_radius, fp max_allowable_Delta_h_over_h) + { + // + // compute scale factor (1 for small steps, <1 for large steps) + // + + const fp max_allowable_Delta_h = max_allowable_Delta_h_over_h * mean_horizon_radius; + + jtutil::norm Delta_h_norms; + ps.gridfn_norms(gfns::gfn__Delta_h, Delta_h_norms); + const fp max_Delta_h = Delta_h_norms.infinity_norm(); + + const fp scale = (max_Delta_h <= max_allowable_Delta_h) + ? 1.0 + : max_allowable_Delta_h / max_Delta_h; + + // + // take the Newton step (scaled if necessary) + // + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + p.ghosted_gridfn(gfns::gfn__h, irho, isigma) -= scale * p.gridfn(gfns::gfn__Delta_h, irho, isigma); + } + } + } + } + void save_oldh(patch_system &ps) + { + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + p.gridfn(gfns::gfn__oldh, irho, isigma) = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + } + } + } + } + } + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif diff --git a/AMSS_NCKU_source/array.C b/AMSS_NCKU_source/AHF_Direct/array.C similarity index 96% rename from AMSS_NCKU_source/array.C rename to AMSS_NCKU_source/AHF_Direct/array.C index 830c2ce..7a1ee4a 100644 --- a/AMSS_NCKU_source/array.C +++ b/AMSS_NCKU_source/AHF_Direct/array.C @@ -1,186 +1,186 @@ -#include -#include // NULL -#include // size_t - -#include "cctk.h" - -#include "stdc.h" -#include "util.h" -#include "array.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - - template - array1d::array1d(int min_i_in, int max_i_in, - T *array_in /* = NULL */, - int stride_i_in /* = 0 */) - : array_(array_in), - offset_(0), // temp value, changed below - stride_i_(stride_i_in), - min_i_(min_i_in), max_i_(max_i_in), - we_own_array_(array_in == NULL) - { - if (stride_i_ == 0) - then stride_i_ = 1; - - // must use unchecked subscripting here since setup isn't done yet - offset_ = -subscript_unchecked(min_i_); // RHS uses offset_ = 0 - assert(subscript_unchecked(min_i_) == 0); - max_subscript_ = subscript_unchecked(max_i_); - - if (we_own_array_) - then - { - // allocate it - const int N_allocate = N_i(); - array_ = new T[N_allocate]; - } - - // explicitly initialize array (new[] *doesn't* do this automagically) - for (int i = min_i(); i <= max_i(); ++i) - { - operator()(i) = T(0); - } - } - - // - // This function destroys an array1d object. - // - template - array1d::~array1d() - { - if (we_own_array_) - then delete[] array_; - } - - // - // This function constructs an array2d object. - // - template - array2d::array2d(int min_i_in, int max_i_in, - int min_j_in, int max_j_in, - T *array_in /* = NULL */, - int stride_i_in /* = 0 */, int stride_j_in /* = 0 */) - : array_(array_in), - offset_(0), // temp value, changed below - stride_i_(stride_i_in), stride_j_(stride_j_in), - min_i_(min_i_in), max_i_(max_i_in), - min_j_(min_j_in), max_j_(max_j_in), - we_own_array_(array_in == NULL) - { - if (stride_j_ == 0) - then stride_j_ = 1; - if (stride_i_ == 0) - then stride_i_ = N_j(); - - // must use unchecked subscripting here since setup isn't done yet - offset_ = -subscript_unchecked(min_i_, min_j_); // RHS uses offset_ = 0 - assert(subscript_unchecked(min_i_, min_j_) == 0); - max_subscript_ = subscript_unchecked(max_i_, max_j_); - - if (we_own_array_) - then - { - // allocate it - const int N_allocate = N_i() * N_j(); - array_ = new T[N_allocate]; - } - - // explicitly initialize array (new[] *doesn't* do this automagically) - for (int i = min_i(); i <= max_i(); ++i) - { - for (int j = min_j(); j <= max_j(); ++j) - { - operator()(i, j) = T(0); - } - } - } - - // - // This function destroys an array2d object. - // - template - array2d::~array2d() - { - if (we_own_array_) - then delete[] array_; - } - - // - // This function constructs an array3d object. - // - template - array3d::array3d(int min_i_in, int max_i_in, - int min_j_in, int max_j_in, - int min_k_in, int max_k_in, - T *array_in /* = NULL */, - int stride_i_in /* = 0 */, int stride_j_in /* = 0 */, - int stride_k_in /* = 0 */) - : array_(array_in), - offset_(0), // temp value, changed below - stride_i_(stride_i_in), stride_j_(stride_j_in), - stride_k_(stride_k_in), - min_i_(min_i_in), max_i_(max_i_in), - min_j_(min_j_in), max_j_(max_j_in), - min_k_(min_k_in), max_k_(max_k_in), - we_own_array_(array_in == NULL) - { - if (stride_k_ == 0) - then stride_k_ = 1; - if (stride_j_ == 0) - then stride_j_ = N_k(); - if (stride_i_ == 0) - then stride_i_ = N_j() * N_k(); - - // must use unchecked subscripting here since setup isn't done yet - offset_ = -subscript_unchecked(min_i_, min_j_, min_k_); // RHS uses offset_ = 0 - assert(subscript_unchecked(min_i_, min_j_, min_k_) == 0); - max_subscript_ = subscript_unchecked(max_i_, max_j_, max_k_); - - if (we_own_array_) - then - { - // allocate it - const int N_allocate = N_i() * N_j() * N_k(); - array_ = new T[N_allocate]; - } - - // explicitly initialize array (new[] *doesn't* do this automagically) - for (int i = min_i(); i <= max_i(); ++i) - { - for (int j = min_j(); j <= max_j(); ++j) - { - for (int k = min_k(); k <= max_k(); ++k) - { - operator()(i, j, k) = T(0); - } - } - } - } - // - // This function destroys an array3d object. - // - template - array3d::~array3d() - { - if (we_own_array_) - then delete[] array_; - } - - template class array1d; - - // FIXME: we shouldn't have to instantiate these both, the const one - // is actually trivially derivable from the non-const one. :( - template class array1d; - template class array1d; - - template class array1d; - template class array2d; - template class array2d; - template class array3d; - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include // NULL +#include // size_t + +#include "cctk.h" + +#include "stdc.h" +#include "util.h" +#include "array.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + + template + array1d::array1d(int min_i_in, int max_i_in, + T *array_in /* = NULL */, + int stride_i_in /* = 0 */) + : array_(array_in), + offset_(0), // temp value, changed below + stride_i_(stride_i_in), + min_i_(min_i_in), max_i_(max_i_in), + we_own_array_(array_in == NULL) + { + if (stride_i_ == 0) + then stride_i_ = 1; + + // must use unchecked subscripting here since setup isn't done yet + offset_ = -subscript_unchecked(min_i_); // RHS uses offset_ = 0 + assert(subscript_unchecked(min_i_) == 0); + max_subscript_ = subscript_unchecked(max_i_); + + if (we_own_array_) + then + { + // allocate it + const int N_allocate = N_i(); + array_ = new T[N_allocate]; + } + + // explicitly initialize array (new[] *doesn't* do this automagically) + for (int i = min_i(); i <= max_i(); ++i) + { + operator()(i) = T(0); + } + } + + // + // This function destroys an array1d object. + // + template + array1d::~array1d() + { + if (we_own_array_) + then delete[] array_; + } + + // + // This function constructs an array2d object. + // + template + array2d::array2d(int min_i_in, int max_i_in, + int min_j_in, int max_j_in, + T *array_in /* = NULL */, + int stride_i_in /* = 0 */, int stride_j_in /* = 0 */) + : array_(array_in), + offset_(0), // temp value, changed below + stride_i_(stride_i_in), stride_j_(stride_j_in), + min_i_(min_i_in), max_i_(max_i_in), + min_j_(min_j_in), max_j_(max_j_in), + we_own_array_(array_in == NULL) + { + if (stride_j_ == 0) + then stride_j_ = 1; + if (stride_i_ == 0) + then stride_i_ = N_j(); + + // must use unchecked subscripting here since setup isn't done yet + offset_ = -subscript_unchecked(min_i_, min_j_); // RHS uses offset_ = 0 + assert(subscript_unchecked(min_i_, min_j_) == 0); + max_subscript_ = subscript_unchecked(max_i_, max_j_); + + if (we_own_array_) + then + { + // allocate it + const int N_allocate = N_i() * N_j(); + array_ = new T[N_allocate]; + } + + // explicitly initialize array (new[] *doesn't* do this automagically) + for (int i = min_i(); i <= max_i(); ++i) + { + for (int j = min_j(); j <= max_j(); ++j) + { + operator()(i, j) = T(0); + } + } + } + + // + // This function destroys an array2d object. + // + template + array2d::~array2d() + { + if (we_own_array_) + then delete[] array_; + } + + // + // This function constructs an array3d object. + // + template + array3d::array3d(int min_i_in, int max_i_in, + int min_j_in, int max_j_in, + int min_k_in, int max_k_in, + T *array_in /* = NULL */, + int stride_i_in /* = 0 */, int stride_j_in /* = 0 */, + int stride_k_in /* = 0 */) + : array_(array_in), + offset_(0), // temp value, changed below + stride_i_(stride_i_in), stride_j_(stride_j_in), + stride_k_(stride_k_in), + min_i_(min_i_in), max_i_(max_i_in), + min_j_(min_j_in), max_j_(max_j_in), + min_k_(min_k_in), max_k_(max_k_in), + we_own_array_(array_in == NULL) + { + if (stride_k_ == 0) + then stride_k_ = 1; + if (stride_j_ == 0) + then stride_j_ = N_k(); + if (stride_i_ == 0) + then stride_i_ = N_j() * N_k(); + + // must use unchecked subscripting here since setup isn't done yet + offset_ = -subscript_unchecked(min_i_, min_j_, min_k_); // RHS uses offset_ = 0 + assert(subscript_unchecked(min_i_, min_j_, min_k_) == 0); + max_subscript_ = subscript_unchecked(max_i_, max_j_, max_k_); + + if (we_own_array_) + then + { + // allocate it + const int N_allocate = N_i() * N_j() * N_k(); + array_ = new T[N_allocate]; + } + + // explicitly initialize array (new[] *doesn't* do this automagically) + for (int i = min_i(); i <= max_i(); ++i) + { + for (int j = min_j(); j <= max_j(); ++j) + { + for (int k = min_k(); k <= max_k(); ++k) + { + operator()(i, j, k) = T(0); + } + } + } + } + // + // This function destroys an array3d object. + // + template + array3d::~array3d() + { + if (we_own_array_) + then delete[] array_; + } + + template class array1d; + + // FIXME: we shouldn't have to instantiate these both, the const one + // is actually trivially derivable from the non-const one. :( + template class array1d; + template class array1d; + + template class array1d; + template class array2d; + template class array2d; + template class array3d; + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/array.h b/AMSS_NCKU_source/AHF_Direct/array.h similarity index 97% rename from AMSS_NCKU_source/array.h rename to AMSS_NCKU_source/AHF_Direct/array.h index 463fc5f..c8ea8c1 100644 --- a/AMSS_NCKU_source/array.h +++ b/AMSS_NCKU_source/AHF_Direct/array.h @@ -1,292 +1,292 @@ -#ifndef AHFINDERDIRECT__ARRAY_HH -#define AHFINDERDIRECT__ARRAY_HH - -namespace AHFinderDirect -{ - namespace jtutil - { - - //****************************************************************************** - - template - class array1d - { - public: - int min_i() const { return min_i_; } - int max_i() const { return max_i_; } - int N_i() const { return jtutil::how_many_in_range(min_i_, max_i_); } - bool is_valid_i(int i) const { return (i >= min_i_) && (i <= max_i_); } - - int subscript_unchecked(int i) const - { - return offset_ + stride_i_ * i; - } - int subscript(int i) const - { - assert(is_valid_i(i)); - const int posn = subscript_unchecked(i); - assert(posn >= 0); - assert(posn <= max_subscript_); - return posn; - } - int subscript_offset() const { return offset_; } - int subscript_stride_i() const { return stride_i_; } - - // normal-use access functions - // ... rvalue - const T &operator()(int i) const { return array_[subscript(i)]; } - // ... lvalue - T &operator()(int i) { return array_[subscript(i)]; } - - // get access to internal 0-origin 1D storage array - // (low-level, dangerous, use with caution!) - // ... semantics of N_array() may not be what you want - // if strides specify noncontiguous storage - int N_array() const { return max_subscript_ + stride_i_; } - const T *data_array() const { return const_cast(array_); } - T *data_array() { return array_; } - - // constructor, destructor - // ... constructor initializes all array elements to T(0.0) - // ... omitted strides default to C storage order - array1d(int min_i_in, int max_i_in, - T *array_in = NULL, // caller-provided storage array - // if non-NULL - int stride_i_in = 0); - ~array1d(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - array1d(const array1d &rhs); - array1d &operator=(const array1d &rhs); - - private: - // n.b. we declare the array pointer first in the class - // ==> it's probably at 0 offset - // ==> we may get slightly faster array access - T *array_; // --> new-allocated 1D storage array - - // subscripting info - // n.b. put this next in class so it should be in the same - // cpu cache line as array_ ==> faster array access - int offset_, stride_i_; - - // min/max array bounds - const int min_i_, max_i_; - int max_subscript_; - - // n.b. put this at end of class since performance doesn't matter - bool we_own_array_; // true ==> array_ --> new[] array which we own - // false ==> array_ --> client-owned storage - }; - - //****************************************************************************** - - template - class array2d - { - public: - // array info - int min_i() const { return min_i_; } - int max_i() const { return max_i_; } - int min_j() const { return min_j_; } - int max_j() const { return max_j_; } - int N_i() const { return jtutil::how_many_in_range(min_i_, max_i_); } - int N_j() const { return jtutil::how_many_in_range(min_j_, max_j_); } - bool is_valid_i(int i) const { return (i >= min_i_) && (i <= max_i_); } - bool is_valid_j(int j) const { return (j >= min_j_) && (j <= max_j_); } - bool is_valid_ij(int i, int j) const - { - return is_valid_i(i) && is_valid_j(j); - } - - int subscript_unchecked(int i, int j) const - { - return offset_ + stride_i_ * i + stride_j_ * j; - } - int subscript(int i, int j) const - { - // n.b. we want each assert() here to be on a separate - // source line, so an assert() failure message can - // pinpoint *which* index is bad - assert(is_valid_i(i)); - assert(is_valid_j(j)); - const int posn = subscript_unchecked(i, j); - assert(posn >= 0); - assert(posn <= max_subscript_); - return posn; - } - int subscript_offset() const { return offset_; } - int subscript_stride_i() const { return stride_i_; } - int subscript_stride_j() const { return stride_j_; } - - // normal-use access functions - // ... rvalue - const T &operator()(int i, int j) const - { - return array_[subscript(i, j)]; - } - // ... lvalue - T &operator()(int i, int j) - { - return array_[subscript(i, j)]; - } - - // get access to internal 0-origin 1D storage array - // (low-level, dangerous, use with caution!) - // ... semantics of N_array() may not be what you want - // if strides specify noncontiguous storage - int N_array() const { return max_subscript_ + stride_j_; } - const T *data_array() const { return const_cast(array_); } - T *data_array() { return array_; } - - // constructor, destructor - // ... constructor initializes all array elements to T(0.0) - // ... omitted strides default to C storage order - array2d(int min_i_in, int max_i_in, - int min_j_in, int max_j_in, - T *array_in = NULL, // caller-provided storage array - // if non-NULL - int stride_i_in = 0, int stride_j_in = 0); - ~array2d(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - array2d(const array2d &rhs); - array2d &operator=(const array2d &rhs); - - private: - // n.b. we declare the array pointer first in the class - // ==> it's probably at 0 offset - // ==> we may get slightly faster array access - T *array_; // --> new-allocated 1D storage array - - // subscripting info - // n.b. put this next in class so it should be in the same - // cpu cache line as array_ ==> faster array access - int offset_, stride_i_, stride_j_; - - // min/max array bounds - const int min_i_, max_i_; - const int min_j_, max_j_; - int max_subscript_; - - // n.b. put this at end of class since performance doesn't matter - bool we_own_array_; // true ==> array_ --> new[] array which we own - // false ==> array_ --> client-owned storage - }; - - //****************************************************************************** - - template - class array3d - { - public: - // array info - int min_i() const { return min_i_; } - int max_i() const { return max_i_; } - int min_j() const { return min_j_; } - int max_j() const { return max_j_; } - int min_k() const { return min_k_; } - int max_k() const { return max_k_; } - int N_i() const { return jtutil::how_many_in_range(min_i_, max_i_); } - int N_j() const { return jtutil::how_many_in_range(min_j_, max_j_); } - int N_k() const { return jtutil::how_many_in_range(min_k_, max_k_); } - bool is_valid_i(int i) const { return (i >= min_i_) && (i <= max_i_); } - bool is_valid_j(int j) const { return (j >= min_j_) && (j <= max_j_); } - bool is_valid_k(int k) const { return (k >= min_k_) && (k <= max_k_); } - bool is_valid_ijk(int i, int j, int k) const - { - return is_valid_i(i) && is_valid_j(j) && is_valid_k(k); - } - - int subscript_unchecked(int i, int j, int k) const - { - return offset_ + stride_i_ * i + stride_j_ * j + stride_k_ * k; - } - int subscript(int i, int j, int k) const - { - // n.b. we want each assert() here to be on a separate - // source line, so an assert() failure message can - // pinpoint *which* index is bad - assert(is_valid_i(i)); - assert(is_valid_j(j)); - assert(is_valid_k(k)); - const int posn = subscript_unchecked(i, j, k); - assert(posn >= 0); - assert(posn <= max_subscript_); - return posn; - } - int subscript_offset() const { return offset_; } - int subscript_stride_i() const { return stride_i_; } - int subscript_stride_j() const { return stride_j_; } - int subscript_stride_k() const { return stride_k_; } - - // normal-use access functions - // ... rvalue - const T &operator()(int i, int j, int k) const - { - return array_[subscript(i, j, k)]; - } - // ... lvalue - T &operator()(int i, int j, int k) - { - return array_[subscript(i, j, k)]; - } - - // get access to internal 0-origin 1D storage array - // (low-level, dangerous, use with caution!) - // ... semantics of N_array() may not be what you want - // if strides specify noncontiguous storage - int N_array() const { return max_subscript_ + stride_k_; } - const T *data_array() const { return const_cast(array_); } - T *data_array() { return array_; } - - // constructor, destructor - // ... constructor initializes all array elements to T(0.0) - // ... omitted strides default to C storage order - array3d(int min_i_in, int max_i_in, - int min_j_in, int max_j_in, - int min_k_in, int max_k_in, - T *array_in = NULL, // caller-provided storage array - // if non-NULL - int stride_i_in = 0, int stride_j_in = 0, int stride_k_in = 0); - ~array3d(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - array3d(const array3d &rhs); - array3d &operator=(const array3d &rhs); - - private: - // n.b. we declare the array pointer first in the class - // ==> it's probably at 0 offset - // ==> we may get slightly faster array access - T *array_; // --> new-allocated 1D storage array - - // subscripting info - // n.b. put this next in class so it should be in the same - // cpu cache line as array_ ==> faster array access - int offset_, stride_i_, stride_j_, stride_k_; - - // min/max array bounds - const int min_i_, max_i_; - const int min_j_, max_j_; - const int min_k_, max_k_; - int max_subscript_; - - // n.b. put this at end of class since performance doesn't matter - bool we_own_array_; // true ==> array_ --> new[] array which we own - // false ==> array_ --> client-owned storage - }; - - } // namespace jtutil -} // namespace AHFinderDirect - -#endif /* AHFINDERDIRECT__ARRAY_HH */ +#ifndef AHFINDERDIRECT__ARRAY_HH +#define AHFINDERDIRECT__ARRAY_HH + +namespace AHFinderDirect +{ + namespace jtutil + { + + //****************************************************************************** + + template + class array1d + { + public: + int min_i() const { return min_i_; } + int max_i() const { return max_i_; } + int N_i() const { return jtutil::how_many_in_range(min_i_, max_i_); } + bool is_valid_i(int i) const { return (i >= min_i_) && (i <= max_i_); } + + int subscript_unchecked(int i) const + { + return offset_ + stride_i_ * i; + } + int subscript(int i) const + { + assert(is_valid_i(i)); + const int posn = subscript_unchecked(i); + assert(posn >= 0); + assert(posn <= max_subscript_); + return posn; + } + int subscript_offset() const { return offset_; } + int subscript_stride_i() const { return stride_i_; } + + // normal-use access functions + // ... rvalue + const T &operator()(int i) const { return array_[subscript(i)]; } + // ... lvalue + T &operator()(int i) { return array_[subscript(i)]; } + + // get access to internal 0-origin 1D storage array + // (low-level, dangerous, use with caution!) + // ... semantics of N_array() may not be what you want + // if strides specify noncontiguous storage + int N_array() const { return max_subscript_ + stride_i_; } + const T *data_array() const { return const_cast(array_); } + T *data_array() { return array_; } + + // constructor, destructor + // ... constructor initializes all array elements to T(0.0) + // ... omitted strides default to C storage order + array1d(int min_i_in, int max_i_in, + T *array_in = NULL, // caller-provided storage array + // if non-NULL + int stride_i_in = 0); + ~array1d(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + array1d(const array1d &rhs); + array1d &operator=(const array1d &rhs); + + private: + // n.b. we declare the array pointer first in the class + // ==> it's probably at 0 offset + // ==> we may get slightly faster array access + T *array_; // --> new-allocated 1D storage array + + // subscripting info + // n.b. put this next in class so it should be in the same + // cpu cache line as array_ ==> faster array access + int offset_, stride_i_; + + // min/max array bounds + const int min_i_, max_i_; + int max_subscript_; + + // n.b. put this at end of class since performance doesn't matter + bool we_own_array_; // true ==> array_ --> new[] array which we own + // false ==> array_ --> client-owned storage + }; + + //****************************************************************************** + + template + class array2d + { + public: + // array info + int min_i() const { return min_i_; } + int max_i() const { return max_i_; } + int min_j() const { return min_j_; } + int max_j() const { return max_j_; } + int N_i() const { return jtutil::how_many_in_range(min_i_, max_i_); } + int N_j() const { return jtutil::how_many_in_range(min_j_, max_j_); } + bool is_valid_i(int i) const { return (i >= min_i_) && (i <= max_i_); } + bool is_valid_j(int j) const { return (j >= min_j_) && (j <= max_j_); } + bool is_valid_ij(int i, int j) const + { + return is_valid_i(i) && is_valid_j(j); + } + + int subscript_unchecked(int i, int j) const + { + return offset_ + stride_i_ * i + stride_j_ * j; + } + int subscript(int i, int j) const + { + // n.b. we want each assert() here to be on a separate + // source line, so an assert() failure message can + // pinpoint *which* index is bad + assert(is_valid_i(i)); + assert(is_valid_j(j)); + const int posn = subscript_unchecked(i, j); + assert(posn >= 0); + assert(posn <= max_subscript_); + return posn; + } + int subscript_offset() const { return offset_; } + int subscript_stride_i() const { return stride_i_; } + int subscript_stride_j() const { return stride_j_; } + + // normal-use access functions + // ... rvalue + const T &operator()(int i, int j) const + { + return array_[subscript(i, j)]; + } + // ... lvalue + T &operator()(int i, int j) + { + return array_[subscript(i, j)]; + } + + // get access to internal 0-origin 1D storage array + // (low-level, dangerous, use with caution!) + // ... semantics of N_array() may not be what you want + // if strides specify noncontiguous storage + int N_array() const { return max_subscript_ + stride_j_; } + const T *data_array() const { return const_cast(array_); } + T *data_array() { return array_; } + + // constructor, destructor + // ... constructor initializes all array elements to T(0.0) + // ... omitted strides default to C storage order + array2d(int min_i_in, int max_i_in, + int min_j_in, int max_j_in, + T *array_in = NULL, // caller-provided storage array + // if non-NULL + int stride_i_in = 0, int stride_j_in = 0); + ~array2d(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + array2d(const array2d &rhs); + array2d &operator=(const array2d &rhs); + + private: + // n.b. we declare the array pointer first in the class + // ==> it's probably at 0 offset + // ==> we may get slightly faster array access + T *array_; // --> new-allocated 1D storage array + + // subscripting info + // n.b. put this next in class so it should be in the same + // cpu cache line as array_ ==> faster array access + int offset_, stride_i_, stride_j_; + + // min/max array bounds + const int min_i_, max_i_; + const int min_j_, max_j_; + int max_subscript_; + + // n.b. put this at end of class since performance doesn't matter + bool we_own_array_; // true ==> array_ --> new[] array which we own + // false ==> array_ --> client-owned storage + }; + + //****************************************************************************** + + template + class array3d + { + public: + // array info + int min_i() const { return min_i_; } + int max_i() const { return max_i_; } + int min_j() const { return min_j_; } + int max_j() const { return max_j_; } + int min_k() const { return min_k_; } + int max_k() const { return max_k_; } + int N_i() const { return jtutil::how_many_in_range(min_i_, max_i_); } + int N_j() const { return jtutil::how_many_in_range(min_j_, max_j_); } + int N_k() const { return jtutil::how_many_in_range(min_k_, max_k_); } + bool is_valid_i(int i) const { return (i >= min_i_) && (i <= max_i_); } + bool is_valid_j(int j) const { return (j >= min_j_) && (j <= max_j_); } + bool is_valid_k(int k) const { return (k >= min_k_) && (k <= max_k_); } + bool is_valid_ijk(int i, int j, int k) const + { + return is_valid_i(i) && is_valid_j(j) && is_valid_k(k); + } + + int subscript_unchecked(int i, int j, int k) const + { + return offset_ + stride_i_ * i + stride_j_ * j + stride_k_ * k; + } + int subscript(int i, int j, int k) const + { + // n.b. we want each assert() here to be on a separate + // source line, so an assert() failure message can + // pinpoint *which* index is bad + assert(is_valid_i(i)); + assert(is_valid_j(j)); + assert(is_valid_k(k)); + const int posn = subscript_unchecked(i, j, k); + assert(posn >= 0); + assert(posn <= max_subscript_); + return posn; + } + int subscript_offset() const { return offset_; } + int subscript_stride_i() const { return stride_i_; } + int subscript_stride_j() const { return stride_j_; } + int subscript_stride_k() const { return stride_k_; } + + // normal-use access functions + // ... rvalue + const T &operator()(int i, int j, int k) const + { + return array_[subscript(i, j, k)]; + } + // ... lvalue + T &operator()(int i, int j, int k) + { + return array_[subscript(i, j, k)]; + } + + // get access to internal 0-origin 1D storage array + // (low-level, dangerous, use with caution!) + // ... semantics of N_array() may not be what you want + // if strides specify noncontiguous storage + int N_array() const { return max_subscript_ + stride_k_; } + const T *data_array() const { return const_cast(array_); } + T *data_array() { return array_; } + + // constructor, destructor + // ... constructor initializes all array elements to T(0.0) + // ... omitted strides default to C storage order + array3d(int min_i_in, int max_i_in, + int min_j_in, int max_j_in, + int min_k_in, int max_k_in, + T *array_in = NULL, // caller-provided storage array + // if non-NULL + int stride_i_in = 0, int stride_j_in = 0, int stride_k_in = 0); + ~array3d(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + array3d(const array3d &rhs); + array3d &operator=(const array3d &rhs); + + private: + // n.b. we declare the array pointer first in the class + // ==> it's probably at 0 offset + // ==> we may get slightly faster array access + T *array_; // --> new-allocated 1D storage array + + // subscripting info + // n.b. put this next in class so it should be in the same + // cpu cache line as array_ ==> faster array access + int offset_, stride_i_, stride_j_, stride_k_; + + // min/max array bounds + const int min_i_, max_i_; + const int min_j_, max_j_; + const int min_k_, max_k_; + int max_subscript_; + + // n.b. put this at end of class since performance doesn't matter + bool we_own_array_; // true ==> array_ --> new[] array which we own + // false ==> array_ --> client-owned storage + }; + + } // namespace jtutil +} // namespace AHFinderDirect + +#endif /* AHFINDERDIRECT__ARRAY_HH */ diff --git a/AMSS_NCKU_source/cctk.h b/AMSS_NCKU_source/AHF_Direct/cctk.h similarity index 96% rename from AMSS_NCKU_source/cctk.h rename to AMSS_NCKU_source/AHF_Direct/cctk.h index 094e388..193704d 100644 --- a/AMSS_NCKU_source/cctk.h +++ b/AMSS_NCKU_source/AHF_Direct/cctk.h @@ -1,58 +1,58 @@ -#ifndef _CCTK_H_ -#define _CCTK_H_ 1 - -/* Grab the main configuration info. */ -#include "cctk_Config.h" - -#define CCTK_THORNSTRING "AHFinderDirect" - -/* Include the constants */ -#include "cctk_Constants.h" - -/* get the definition of ptrdiff_t */ -#include -int CCTK_VInfo(const char *thorn, const char *format, ...); -int CCTK_VWarn(int level, - int line, - const char *file, - const char *thorn, - const char *format, - ...); -#define CCTK_ERROR_INTERP_GHOST_SIZE_TOO_SMALL (-1001) -#ifdef __cplusplus -#define HAVE_INLINE -#else -#ifndef inline -#define HAVE_INLINE -#endif -#endif - -#define CCTK_PRINTSEPARATOR \ - printf("--------------------------------------------------------------------------------\n"); - -#define _DECLARE_CCTK_ARGUMENTS _DECLARE_CCTK_CARGUMENTS -#define _DECLARE_CCTK_CARGUMENTS \ - ptrdiff_t cctki_dummy_int; \ - CCTK_REAL cctk_time = cctkGH->PhysTime; \ - int cctk_iteration = 1; \ - int cctk_dim = 3; - -#define CCTK_EQUALS(a, b) (CCTK_Equals((a), (b))) - -#define CCTK_PASS_CTOC cctkGH - -#define CCTK_ORIGIN_SPACE(x) (cctk_origin_space[x] + cctk_delta_space[x] / cctk_levfac[x] * cctk_levoff[x] / cctk_levoffdenom[x]) -#define CCTK_DELTA_SPACE(x) (cctk_delta_space[x] / cctk_levfac[x]) -#define CCTK_DELTA_TIME (cctk_delta_time / cctk_timefac) -#define CCTK_LSSH(stag, dim) cctk_lssh[(stag) + CCTK_NSTAGGER * (dim)] -#define CCTK_LSSH_IDX(stag, dim) ((stag) + CCTK_NSTAGGER * (dim)) - -#define CCTK_WARN(a, b) CCTK_Warn(a, __LINE__, __FILE__, CCTK_THORNSTRING, b) - -#define CCTK_MALLOC(s) CCTKi_Malloc(s, __LINE__, __FILE__) -#define CCTK_FREE(p) CCTKi_Free(p) - -#define CCTK_INFO(a) CCTK_Info(CCTK_THORNSTRING, (a)) -#define CCTK_PARAMWARN(a) CCTK_ParamWarn(CCTK_THORNSTRING, (a)) - -#endif +#ifndef _CCTK_H_ +#define _CCTK_H_ 1 + +/* Grab the main configuration info. */ +#include "cctk_Config.h" + +#define CCTK_THORNSTRING "AHFinderDirect" + +/* Include the constants */ +#include "cctk_Constants.h" + +/* get the definition of ptrdiff_t */ +#include +int CCTK_VInfo(const char *thorn, const char *format, ...); +int CCTK_VWarn(int level, + int line, + const char *file, + const char *thorn, + const char *format, + ...); +#define CCTK_ERROR_INTERP_GHOST_SIZE_TOO_SMALL (-1001) +#ifdef __cplusplus +#define HAVE_INLINE +#else +#ifndef inline +#define HAVE_INLINE +#endif +#endif + +#define CCTK_PRINTSEPARATOR \ + printf("--------------------------------------------------------------------------------\n"); + +#define _DECLARE_CCTK_ARGUMENTS _DECLARE_CCTK_CARGUMENTS +#define _DECLARE_CCTK_CARGUMENTS \ + ptrdiff_t cctki_dummy_int; \ + CCTK_REAL cctk_time = cctkGH->PhysTime; \ + int cctk_iteration = 1; \ + int cctk_dim = 3; + +#define CCTK_EQUALS(a, b) (CCTK_Equals((a), (b))) + +#define CCTK_PASS_CTOC cctkGH + +#define CCTK_ORIGIN_SPACE(x) (cctk_origin_space[x] + cctk_delta_space[x] / cctk_levfac[x] * cctk_levoff[x] / cctk_levoffdenom[x]) +#define CCTK_DELTA_SPACE(x) (cctk_delta_space[x] / cctk_levfac[x]) +#define CCTK_DELTA_TIME (cctk_delta_time / cctk_timefac) +#define CCTK_LSSH(stag, dim) cctk_lssh[(stag) + CCTK_NSTAGGER * (dim)] +#define CCTK_LSSH_IDX(stag, dim) ((stag) + CCTK_NSTAGGER * (dim)) + +#define CCTK_WARN(a, b) CCTK_Warn(a, __LINE__, __FILE__, CCTK_THORNSTRING, b) + +#define CCTK_MALLOC(s) CCTKi_Malloc(s, __LINE__, __FILE__) +#define CCTK_FREE(p) CCTKi_Free(p) + +#define CCTK_INFO(a) CCTK_Info(CCTK_THORNSTRING, (a)) +#define CCTK_PARAMWARN(a) CCTK_ParamWarn(CCTK_THORNSTRING, (a)) + +#endif diff --git a/AMSS_NCKU_source/cctk_Config.h b/AMSS_NCKU_source/AHF_Direct/cctk_Config.h similarity index 95% rename from AMSS_NCKU_source/cctk_Config.h rename to AMSS_NCKU_source/AHF_Direct/cctk_Config.h index ca00555..04b310e 100644 --- a/AMSS_NCKU_source/cctk_Config.h +++ b/AMSS_NCKU_source/AHF_Direct/cctk_Config.h @@ -1,168 +1,168 @@ -#ifndef _CCTK_CONFIG_H_ -#define _CCTK_CONFIG_H_ - -#define STDC_HEADERS 1 - -#define CCTK_FCALL - -#define HAVE_GETHOSTBYNAME 1 -#define HAVE_GETOPT_LONG_ONLY 1 -#define HAVE_CRYPT 1 -#define HAVE_FINITE 1 -#define HAVE_ISNAN 1 -#define HAVE_ISINF 1 -#define HAVE_MKSTEMP 1 -#define HAVE_VA_COPY 1 - -/* Do we have mode_t ? */ -#define HAVE_MODE_T 1 - -#define HAVE_SOCKLEN_T 1 -#ifdef HAVE_SOCKLEN_T -# define CCTK_SOCKLEN_T socklen_t -#else -# define CCTK_SOCKLEN_T int -#endif - -#define HAVE_TIME_H 1 -#define HAVE_SYS_IOCTL_H 1 -#define HAVE_SYS_SOCKET_H 1 -#define HAVE_SYS_TIME_H 1 -#define HAVE_SYS_TYPES_H 1 -#define HAVE_UNISTD_H 1 -#define HAVE_STRING_H 1 -#define HAVE_ASSERT_H 1 -#define HAVE_TGMATH_H 1 -#define HAVE_SYS_STAT_H 1 -#define HAVE_GETOPT_H 1 -#define HAVE_REGEX_H 1 -#define HAVE_NETINET_IN_H 1 -#define HAVE_NETDB_H 1 -#define HAVE_ARPA_INET_H 1 -#define HAVE_CRYPT_H 1 -#define HAVE_DIRENT_H 1 -#define HAVE_SIGNAL_H 1 -#define HAVE_MALLOC_H 1 -#define HAVE_MALLINFO 1 -#define HAVE_MALLOPT 1 -#define HAVE_M_MMAP_THRESHOLD_VALUE 1 - -#define TIME_WITH_SYS_TIME 1 - -#define HAVE_VECTOR 1 -#define HAVE_VECTOR_H 1 - -#define GETTIMEOFDAY_NEEDS_TIMEZONE 1 - -#define CCTK_CACHELINE_BYTES 64 -#define CCTK_CACHE_SIZE 1024*1024 - -#define NULL_DEVICE "/dev/null" - -#define CCTK_BUILD_OS "linux-gnu" -#define CCTK_BUILD_CPU "x86_64" -#define CCTK_BUILD_VENDOR "unknown" - -#define SIZEOF_SHORT_INT 2 -#define SIZEOF_INT 4 -#define SIZEOF_LONG_INT 8 -#define SIZEOF_LONG_LONG 8 -#define SIZEOF_LONG_DOUBLE 16 -#define SIZEOF_DOUBLE 8 -#define SIZEOF_FLOAT 4 -#define SIZEOF_CHAR_P 8 - -#define CCTK_REAL_PRECISION_8 1 - -#define CCTK_INTEGER_PRECISION_4 1 - -#define HAVE_CCTK_INT8 1 -#define HAVE_CCTK_INT4 1 -#define HAVE_CCTK_INT2 1 -#define HAVE_CCTK_INT1 1 - -#define HAVE_CCTK_REAL16 1 -#define HAVE_CCTK_REAL8 1 -#define HAVE_CCTK_REAL4 1 - -#define CCTK_INT8 long int -#define CCTK_INT4 int -#define CCTK_INT2 short int -#define CCTK_INT1 signed char - -#define CCTK_REAL16 long double -#define CCTK_REAL8 double -#define CCTK_REAL4 float - -#ifndef __cplusplus - -#ifdef CCTK_C_RESTRICT -#define restrict CCTK_C_RESTRICT -#endif - -/* Allow the use of CCTK_RESTRICT as a qualifier always. */ -#ifdef CCTK_C_RESTRICT -#define CCTK_RESTRICT CCTK_C_RESTRICT -#else -#define CCTK_RESTRICT restrict -#endif - -#ifdef HAVE_CCTK_C_BOOL -#define CCTK_HAVE_C_BOOL -#endif - -#endif /* ! defined __cplusplus */ -/****************************************************************************/ - -/****************************************************************************/ -/* C++ specific stuff */ -/****************************************************************************/ -#ifdef __cplusplus - -/* Some C++ compilers don't have bool ! */ -#define HAVE_CCTK_CXX_BOOL 1 - -#ifndef HAVE_CCTK_CXX_BOOL -typedef enum {false, true} bool; -#else -/* deprecated in beta15 */ -#define CCTK_HAVE_CXX_BOOL -#endif - -/* Some C++ compilers recognise the restrict keyword */ -#define CCTK_CXX_RESTRICT __restrict__ - -/* Since this is non-standard leave commented out for the moment */ -#if 0 -/* Define to empty if the keyword does not work. */ -#ifdef CCTK_CXX_RESTRICT -#define restrict CCTK_CXX_RESTRICT -#endif -#endif - -/* Allow the use of CCTK_RESTRICT as a qualifier always. */ -#ifdef CCTK_CXX_RESTRICT -#define CCTK_RESTRICT CCTK_CXX_RESTRICT -#else -#define CCTK_RESTRICT restrict -#endif - -#endif /* __cplusplus */ -/****************************************************************************/ - -#ifdef FCODE - -#define HAVE_CCTK_FORTRAN_REAL4 1 -#define HAVE_CCTK_FORTRAN_REAL8 1 -#define HAVE_CCTK_FORTRAN_REAL16 1 - -#define HAVE_CCTK_FORTRAN_COMPLEX8 1 -#define HAVE_CCTK_FORTRAN_COMPLEX16 1 -#define HAVE_CCTK_FORTRAN_COMPLEX32 1 - -#endif /* FCODE */ - -/* Now include the code to pick an appropriate precison for reals and ints */ -#include "cctk_Types.h" - -#endif /* _CCTK_CONFIG_H_ */ +#ifndef _CCTK_CONFIG_H_ +#define _CCTK_CONFIG_H_ + +#define STDC_HEADERS 1 + +#define CCTK_FCALL + +#define HAVE_GETHOSTBYNAME 1 +#define HAVE_GETOPT_LONG_ONLY 1 +#define HAVE_CRYPT 1 +#define HAVE_FINITE 1 +#define HAVE_ISNAN 1 +#define HAVE_ISINF 1 +#define HAVE_MKSTEMP 1 +#define HAVE_VA_COPY 1 + +/* Do we have mode_t ? */ +#define HAVE_MODE_T 1 + +#define HAVE_SOCKLEN_T 1 +#ifdef HAVE_SOCKLEN_T +# define CCTK_SOCKLEN_T socklen_t +#else +# define CCTK_SOCKLEN_T int +#endif + +#define HAVE_TIME_H 1 +#define HAVE_SYS_IOCTL_H 1 +#define HAVE_SYS_SOCKET_H 1 +#define HAVE_SYS_TIME_H 1 +#define HAVE_SYS_TYPES_H 1 +#define HAVE_UNISTD_H 1 +#define HAVE_STRING_H 1 +#define HAVE_ASSERT_H 1 +#define HAVE_TGMATH_H 1 +#define HAVE_SYS_STAT_H 1 +#define HAVE_GETOPT_H 1 +#define HAVE_REGEX_H 1 +#define HAVE_NETINET_IN_H 1 +#define HAVE_NETDB_H 1 +#define HAVE_ARPA_INET_H 1 +#define HAVE_CRYPT_H 1 +#define HAVE_DIRENT_H 1 +#define HAVE_SIGNAL_H 1 +#define HAVE_MALLOC_H 1 +#define HAVE_MALLINFO 1 +#define HAVE_MALLOPT 1 +#define HAVE_M_MMAP_THRESHOLD_VALUE 1 + +#define TIME_WITH_SYS_TIME 1 + +#define HAVE_VECTOR 1 +#define HAVE_VECTOR_H 1 + +#define GETTIMEOFDAY_NEEDS_TIMEZONE 1 + +#define CCTK_CACHELINE_BYTES 64 +#define CCTK_CACHE_SIZE 1024*1024 + +#define NULL_DEVICE "/dev/null" + +#define CCTK_BUILD_OS "linux-gnu" +#define CCTK_BUILD_CPU "x86_64" +#define CCTK_BUILD_VENDOR "unknown" + +#define SIZEOF_SHORT_INT 2 +#define SIZEOF_INT 4 +#define SIZEOF_LONG_INT 8 +#define SIZEOF_LONG_LONG 8 +#define SIZEOF_LONG_DOUBLE 16 +#define SIZEOF_DOUBLE 8 +#define SIZEOF_FLOAT 4 +#define SIZEOF_CHAR_P 8 + +#define CCTK_REAL_PRECISION_8 1 + +#define CCTK_INTEGER_PRECISION_4 1 + +#define HAVE_CCTK_INT8 1 +#define HAVE_CCTK_INT4 1 +#define HAVE_CCTK_INT2 1 +#define HAVE_CCTK_INT1 1 + +#define HAVE_CCTK_REAL16 1 +#define HAVE_CCTK_REAL8 1 +#define HAVE_CCTK_REAL4 1 + +#define CCTK_INT8 long int +#define CCTK_INT4 int +#define CCTK_INT2 short int +#define CCTK_INT1 signed char + +#define CCTK_REAL16 long double +#define CCTK_REAL8 double +#define CCTK_REAL4 float + +#ifndef __cplusplus + +#ifdef CCTK_C_RESTRICT +#define restrict CCTK_C_RESTRICT +#endif + +/* Allow the use of CCTK_RESTRICT as a qualifier always. */ +#ifdef CCTK_C_RESTRICT +#define CCTK_RESTRICT CCTK_C_RESTRICT +#else +#define CCTK_RESTRICT restrict +#endif + +#ifdef HAVE_CCTK_C_BOOL +#define CCTK_HAVE_C_BOOL +#endif + +#endif /* ! defined __cplusplus */ +/****************************************************************************/ + +/****************************************************************************/ +/* C++ specific stuff */ +/****************************************************************************/ +#ifdef __cplusplus + +/* Some C++ compilers don't have bool ! */ +#define HAVE_CCTK_CXX_BOOL 1 + +#ifndef HAVE_CCTK_CXX_BOOL +typedef enum {false, true} bool; +#else +/* deprecated in beta15 */ +#define CCTK_HAVE_CXX_BOOL +#endif + +/* Some C++ compilers recognise the restrict keyword */ +#define CCTK_CXX_RESTRICT __restrict__ + +/* Since this is non-standard leave commented out for the moment */ +#if 0 +/* Define to empty if the keyword does not work. */ +#ifdef CCTK_CXX_RESTRICT +#define restrict CCTK_CXX_RESTRICT +#endif +#endif + +/* Allow the use of CCTK_RESTRICT as a qualifier always. */ +#ifdef CCTK_CXX_RESTRICT +#define CCTK_RESTRICT CCTK_CXX_RESTRICT +#else +#define CCTK_RESTRICT restrict +#endif + +#endif /* __cplusplus */ +/****************************************************************************/ + +#ifdef FCODE + +#define HAVE_CCTK_FORTRAN_REAL4 1 +#define HAVE_CCTK_FORTRAN_REAL8 1 +#define HAVE_CCTK_FORTRAN_REAL16 1 + +#define HAVE_CCTK_FORTRAN_COMPLEX8 1 +#define HAVE_CCTK_FORTRAN_COMPLEX16 1 +#define HAVE_CCTK_FORTRAN_COMPLEX32 1 + +#endif /* FCODE */ + +/* Now include the code to pick an appropriate precison for reals and ints */ +#include "cctk_Types.h" + +#endif /* _CCTK_CONFIG_H_ */ diff --git a/AMSS_NCKU_source/cctk_Constants.h b/AMSS_NCKU_source/AHF_Direct/cctk_Constants.h similarity index 96% rename from AMSS_NCKU_source/cctk_Constants.h rename to AMSS_NCKU_source/AHF_Direct/cctk_Constants.h index 238f25e..876fc3d 100644 --- a/AMSS_NCKU_source/cctk_Constants.h +++ b/AMSS_NCKU_source/AHF_Direct/cctk_Constants.h @@ -1,57 +1,57 @@ -#ifndef _CCTK_CONSTANTS_H_ -#define _CCTK_CONSTANTS_H_ - -#define CCTK_VARIABLE_VOID 100 -#define CCTK_VARIABLE_BYTE 101 -#define CCTK_VARIABLE_INT 102 -#define CCTK_VARIABLE_INT1 103 -#define CCTK_VARIABLE_INT2 104 -#define CCTK_VARIABLE_INT4 105 -#define CCTK_VARIABLE_INT8 106 -#define CCTK_VARIABLE_REAL 107 -#define CCTK_VARIABLE_REAL4 108 -#define CCTK_VARIABLE_REAL8 109 -#define CCTK_VARIABLE_REAL16 110 -#define CCTK_VARIABLE_COMPLEX 111 -#define CCTK_VARIABLE_COMPLEX8 112 -#define CCTK_VARIABLE_COMPLEX16 113 -#define CCTK_VARIABLE_COMPLEX32 114 -#define CCTK_VARIABLE_CHAR 115 -#define CCTK_VARIABLE_STRING 116 -#define CCTK_VARIABLE_POINTER 117 -#define CCTK_VARIABLE_POINTER_TO_CONST 118 -#define CCTK_VARIABLE_FPOINTER 119 - -/* DEPRECATED IN BETA 12 */ -#define CCTK_VARIABLE_FN_POINTER CCTK_VARIABLE_FPOINTER - -/* steerable status of parameters */ -#define CCTK_STEERABLE_NEVER 200 -#define CCTK_STEERABLE_ALWAYS 201 -#define CCTK_STEERABLE_RECOVER 202 - -/* number of staggerings */ -#define CCTK_NSTAGGER 3 - -/* group distributions */ -#define CCTK_DISTRIB_CONSTANT 301 -#define CCTK_DISTRIB_DEFAULT 302 - -/* group types */ -#define CCTK_SCALAR 401 -#define CCTK_GF 402 -#define CCTK_ARRAY 403 - -/* group scopes */ -#define CCTK_PRIVATE 501 -#define CCTK_PROTECTED 502 -#define CCTK_PUBLIC 503 - -/* constants for CCTK_TraverseString() */ -#define CCTK_VAR 601 -#define CCTK_GROUP 602 -#define CCTK_GROUP_OR_VAR 603 - - -#endif /* _CCTK_CONSTANTS_ */ - +#ifndef _CCTK_CONSTANTS_H_ +#define _CCTK_CONSTANTS_H_ + +#define CCTK_VARIABLE_VOID 100 +#define CCTK_VARIABLE_BYTE 101 +#define CCTK_VARIABLE_INT 102 +#define CCTK_VARIABLE_INT1 103 +#define CCTK_VARIABLE_INT2 104 +#define CCTK_VARIABLE_INT4 105 +#define CCTK_VARIABLE_INT8 106 +#define CCTK_VARIABLE_REAL 107 +#define CCTK_VARIABLE_REAL4 108 +#define CCTK_VARIABLE_REAL8 109 +#define CCTK_VARIABLE_REAL16 110 +#define CCTK_VARIABLE_COMPLEX 111 +#define CCTK_VARIABLE_COMPLEX8 112 +#define CCTK_VARIABLE_COMPLEX16 113 +#define CCTK_VARIABLE_COMPLEX32 114 +#define CCTK_VARIABLE_CHAR 115 +#define CCTK_VARIABLE_STRING 116 +#define CCTK_VARIABLE_POINTER 117 +#define CCTK_VARIABLE_POINTER_TO_CONST 118 +#define CCTK_VARIABLE_FPOINTER 119 + +/* DEPRECATED IN BETA 12 */ +#define CCTK_VARIABLE_FN_POINTER CCTK_VARIABLE_FPOINTER + +/* steerable status of parameters */ +#define CCTK_STEERABLE_NEVER 200 +#define CCTK_STEERABLE_ALWAYS 201 +#define CCTK_STEERABLE_RECOVER 202 + +/* number of staggerings */ +#define CCTK_NSTAGGER 3 + +/* group distributions */ +#define CCTK_DISTRIB_CONSTANT 301 +#define CCTK_DISTRIB_DEFAULT 302 + +/* group types */ +#define CCTK_SCALAR 401 +#define CCTK_GF 402 +#define CCTK_ARRAY 403 + +/* group scopes */ +#define CCTK_PRIVATE 501 +#define CCTK_PROTECTED 502 +#define CCTK_PUBLIC 503 + +/* constants for CCTK_TraverseString() */ +#define CCTK_VAR 601 +#define CCTK_GROUP 602 +#define CCTK_GROUP_OR_VAR 603 + + +#endif /* _CCTK_CONSTANTS_ */ + diff --git a/AMSS_NCKU_source/cctk_Types.h b/AMSS_NCKU_source/AHF_Direct/cctk_Types.h similarity index 95% rename from AMSS_NCKU_source/cctk_Types.h rename to AMSS_NCKU_source/AHF_Direct/cctk_Types.h index aa5f536..9648598 100644 --- a/AMSS_NCKU_source/cctk_Types.h +++ b/AMSS_NCKU_source/AHF_Direct/cctk_Types.h @@ -1,180 +1,180 @@ -#ifndef _CCTK_TYPES_H_ -#define _CCTK_TYPES_H_ - -#ifndef _CCTK_CONFIG_H_ -#include "cctk_Config.h" -#endif - -typedef void *CCTK_POINTER; -typedef const void *CCTK_POINTER_TO_CONST; -typedef void (*CCTK_FPOINTER)(void); -#define HAVE_CCTK_POINTER 1 -#define HAVE_CCTK_POINTER_TO_CONST 1 -#define HAVE_CCTK_FPOINTER 1 - -/* Character types */ -typedef char CCTK_CHAR; -typedef const char * CCTK_STRING; -#define HAVE_CCTK_CHAR 1 -#define HAVE_CCTK_STRING 1 - -/* Structures for complex types */ - -#ifdef HAVE_CCTK_REAL16 -#define HAVE_CCTK_COMPLEX32 1 -typedef struct CCTK_COMPLEX32 -{ - CCTK_REAL16 Re; - CCTK_REAL16 Im; -#ifdef __cplusplus - CCTK_REAL16 real() const { return Re; } - CCTK_REAL16 imag() const { return Im; } -#endif -} CCTK_COMPLEX32; -#endif - -#ifdef HAVE_CCTK_REAL8 -#define HAVE_CCTK_COMPLEX16 1 -typedef struct CCTK_COMPLEX16 -{ - CCTK_REAL8 Re; - CCTK_REAL8 Im; -#ifdef __cplusplus - CCTK_REAL8 real() const { return Re; } - CCTK_REAL8 imag() const { return Im; } -#endif -} CCTK_COMPLEX16; -#endif - -#ifdef HAVE_CCTK_REAL4 -#define HAVE_CCTK_COMPLEX8 1 -typedef struct CCTK_COMPLEX8 -{ - CCTK_REAL4 Re; - CCTK_REAL4 Im; -#ifdef __cplusplus - CCTK_REAL4 real() const { return Re; } - CCTK_REAL4 imag() const { return Im; } -#endif -} CCTK_COMPLEX8; -#endif - -/* Small positive integer type */ -typedef unsigned char CCTK_BYTE; -#define HAVE_CCTK_BYTE 1 - -/* Define stuff for fortran. */ -#ifdef FCODE - -#define CCTK_POINTER integer*SIZEOF_CHAR_P -#define CCTK_POINTER_TO_CONST integer*SIZEOF_CHAR_P -/* TODO: add autoconf for determining the size of function pointers */ -#define CCTK_FPOINTER integer*SIZEOF_CHAR_P -#define HAVE_CCTK_POINTER 1 -#define HAVE_CCTK_POINTER_TO_CONST 1 -#define HAVE_CCTK_FPOINTER 1 - -/* Character types */ -/* A single character does not exist in Fortran; in Fortran, all - character types are strings. Hence we do not define CCTK_CHAR. */ -/* #define CCTK_CHAR CHARACTER */ -/* #define HAVE_CCTK_CHAR 1 */ -/* This is a C-string, i.e., only a pointer */ -#define CCTK_STRING CCTK_POINTER_TO_CONST -#define HAVE_CCTK_STRING 1 - -#ifdef HAVE_CCTK_INT8 -#define CCTK_INT8 INTEGER*8 -#endif -#ifdef HAVE_CCTK_INT4 -#define CCTK_INT4 INTEGER*4 -#endif -#ifdef HAVE_CCTK_INT2 -#define CCTK_INT2 INTEGER*2 -#endif -#ifdef HAVE_CCTK_INT1 -#define CCTK_INT1 INTEGER*1 -#endif - -#ifdef HAVE_CCTK_REAL16 -#define CCTK_REAL16 REAL*16 -#define HAVE_CCTK_COMPLEX32 1 -#define CCTK_COMPLEX32 COMPLEX*32 -#endif - -#ifdef HAVE_CCTK_REAL8 -#define CCTK_REAL8 REAL*8 -#define HAVE_CCTK_COMPLEX16 1 -#define CCTK_COMPLEX16 COMPLEX*16 -#endif - -#ifdef HAVE_CCTK_REAL4 -#define CCTK_REAL4 REAL*4 -#define HAVE_CCTK_COMPLEX8 1 -#define CCTK_COMPLEX8 COMPLEX*8 -#endif - -/* Should be unsigned, but Fortran doesn't have that */ -#define CCTK_BYTE INTEGER*1 -#define HAVE_CCTK_BYTE 1 - -#endif /*FCODE */ - -/* Now pick the types based upon the precision variable. */ - -/* Floating point precision */ -#ifdef CCTK_REAL_PRECISION_16 -#define CCTK_REAL_PRECISION 16 -#define CCTK_REAL CCTK_REAL16 -#endif - -#ifdef CCTK_REAL_PRECISION_8 -#define CCTK_REAL_PRECISION 8 -#define CCTK_REAL CCTK_REAL8 -#endif - -#ifdef CCTK_REAL_PRECISION_4 -#define CCTK_REAL_PRECISION 4 -#define CCTK_REAL CCTK_REAL4 -#endif - -/* Integer precision */ - -#ifdef CCTK_INTEGER_PRECISION_8 -#define CCTK_INTEGER_PRECISION 8 -#define CCTK_INT CCTK_INT8 -#endif - -#ifdef CCTK_INTEGER_PRECISION_4 -#define CCTK_INTEGER_PRECISION 4 -#define CCTK_INT CCTK_INT4 -#endif - -#ifdef CCTK_INTEGER_PRECISION_2 -#define CCTK_INTEGER_PRECISION 2 -#define CCTK_INT CCTK_INT2 -#endif - -#ifdef CCTK_INTEGER_PRECISION_1 -#define CCTK_INTEGER_PRECISION 1 -#define CCTK_INT CCTK_INT1 -#endif - -/* Complex precision */ -#ifdef CCTK_REAL_PRECISION_16 -#define CCTK_COMPLEX_PRECISION 32 -#define CCTK_COMPLEX CCTK_COMPLEX32 -#endif - -#ifdef CCTK_REAL_PRECISION_8 -#define CCTK_COMPLEX_PRECISION 16 -#define CCTK_COMPLEX CCTK_COMPLEX16 -#endif - -#ifdef CCTK_REAL_PRECISION_4 -#define CCTK_COMPLEX_PRECISION 8 -#define CCTK_COMPLEX CCTK_COMPLEX8 -#endif - -#endif /*_CCTK_TYPES_H_ */ - +#ifndef _CCTK_TYPES_H_ +#define _CCTK_TYPES_H_ + +#ifndef _CCTK_CONFIG_H_ +#include "cctk_Config.h" +#endif + +typedef void *CCTK_POINTER; +typedef const void *CCTK_POINTER_TO_CONST; +typedef void (*CCTK_FPOINTER)(void); +#define HAVE_CCTK_POINTER 1 +#define HAVE_CCTK_POINTER_TO_CONST 1 +#define HAVE_CCTK_FPOINTER 1 + +/* Character types */ +typedef char CCTK_CHAR; +typedef const char * CCTK_STRING; +#define HAVE_CCTK_CHAR 1 +#define HAVE_CCTK_STRING 1 + +/* Structures for complex types */ + +#ifdef HAVE_CCTK_REAL16 +#define HAVE_CCTK_COMPLEX32 1 +typedef struct CCTK_COMPLEX32 +{ + CCTK_REAL16 Re; + CCTK_REAL16 Im; +#ifdef __cplusplus + CCTK_REAL16 real() const { return Re; } + CCTK_REAL16 imag() const { return Im; } +#endif +} CCTK_COMPLEX32; +#endif + +#ifdef HAVE_CCTK_REAL8 +#define HAVE_CCTK_COMPLEX16 1 +typedef struct CCTK_COMPLEX16 +{ + CCTK_REAL8 Re; + CCTK_REAL8 Im; +#ifdef __cplusplus + CCTK_REAL8 real() const { return Re; } + CCTK_REAL8 imag() const { return Im; } +#endif +} CCTK_COMPLEX16; +#endif + +#ifdef HAVE_CCTK_REAL4 +#define HAVE_CCTK_COMPLEX8 1 +typedef struct CCTK_COMPLEX8 +{ + CCTK_REAL4 Re; + CCTK_REAL4 Im; +#ifdef __cplusplus + CCTK_REAL4 real() const { return Re; } + CCTK_REAL4 imag() const { return Im; } +#endif +} CCTK_COMPLEX8; +#endif + +/* Small positive integer type */ +typedef unsigned char CCTK_BYTE; +#define HAVE_CCTK_BYTE 1 + +/* Define stuff for fortran. */ +#ifdef FCODE + +#define CCTK_POINTER integer*SIZEOF_CHAR_P +#define CCTK_POINTER_TO_CONST integer*SIZEOF_CHAR_P +/* TODO: add autoconf for determining the size of function pointers */ +#define CCTK_FPOINTER integer*SIZEOF_CHAR_P +#define HAVE_CCTK_POINTER 1 +#define HAVE_CCTK_POINTER_TO_CONST 1 +#define HAVE_CCTK_FPOINTER 1 + +/* Character types */ +/* A single character does not exist in Fortran; in Fortran, all + character types are strings. Hence we do not define CCTK_CHAR. */ +/* #define CCTK_CHAR CHARACTER */ +/* #define HAVE_CCTK_CHAR 1 */ +/* This is a C-string, i.e., only a pointer */ +#define CCTK_STRING CCTK_POINTER_TO_CONST +#define HAVE_CCTK_STRING 1 + +#ifdef HAVE_CCTK_INT8 +#define CCTK_INT8 INTEGER*8 +#endif +#ifdef HAVE_CCTK_INT4 +#define CCTK_INT4 INTEGER*4 +#endif +#ifdef HAVE_CCTK_INT2 +#define CCTK_INT2 INTEGER*2 +#endif +#ifdef HAVE_CCTK_INT1 +#define CCTK_INT1 INTEGER*1 +#endif + +#ifdef HAVE_CCTK_REAL16 +#define CCTK_REAL16 REAL*16 +#define HAVE_CCTK_COMPLEX32 1 +#define CCTK_COMPLEX32 COMPLEX*32 +#endif + +#ifdef HAVE_CCTK_REAL8 +#define CCTK_REAL8 REAL*8 +#define HAVE_CCTK_COMPLEX16 1 +#define CCTK_COMPLEX16 COMPLEX*16 +#endif + +#ifdef HAVE_CCTK_REAL4 +#define CCTK_REAL4 REAL*4 +#define HAVE_CCTK_COMPLEX8 1 +#define CCTK_COMPLEX8 COMPLEX*8 +#endif + +/* Should be unsigned, but Fortran doesn't have that */ +#define CCTK_BYTE INTEGER*1 +#define HAVE_CCTK_BYTE 1 + +#endif /*FCODE */ + +/* Now pick the types based upon the precision variable. */ + +/* Floating point precision */ +#ifdef CCTK_REAL_PRECISION_16 +#define CCTK_REAL_PRECISION 16 +#define CCTK_REAL CCTK_REAL16 +#endif + +#ifdef CCTK_REAL_PRECISION_8 +#define CCTK_REAL_PRECISION 8 +#define CCTK_REAL CCTK_REAL8 +#endif + +#ifdef CCTK_REAL_PRECISION_4 +#define CCTK_REAL_PRECISION 4 +#define CCTK_REAL CCTK_REAL4 +#endif + +/* Integer precision */ + +#ifdef CCTK_INTEGER_PRECISION_8 +#define CCTK_INTEGER_PRECISION 8 +#define CCTK_INT CCTK_INT8 +#endif + +#ifdef CCTK_INTEGER_PRECISION_4 +#define CCTK_INTEGER_PRECISION 4 +#define CCTK_INT CCTK_INT4 +#endif + +#ifdef CCTK_INTEGER_PRECISION_2 +#define CCTK_INTEGER_PRECISION 2 +#define CCTK_INT CCTK_INT2 +#endif + +#ifdef CCTK_INTEGER_PRECISION_1 +#define CCTK_INTEGER_PRECISION 1 +#define CCTK_INT CCTK_INT1 +#endif + +/* Complex precision */ +#ifdef CCTK_REAL_PRECISION_16 +#define CCTK_COMPLEX_PRECISION 32 +#define CCTK_COMPLEX CCTK_COMPLEX32 +#endif + +#ifdef CCTK_REAL_PRECISION_8 +#define CCTK_COMPLEX_PRECISION 16 +#define CCTK_COMPLEX CCTK_COMPLEX16 +#endif + +#ifdef CCTK_REAL_PRECISION_4 +#define CCTK_COMPLEX_PRECISION 8 +#define CCTK_COMPLEX CCTK_COMPLEX8 +#endif + +#endif /*_CCTK_TYPES_H_ */ + diff --git a/AMSS_NCKU_source/config.h b/AMSS_NCKU_source/AHF_Direct/config.h similarity index 95% rename from AMSS_NCKU_source/config.h rename to AMSS_NCKU_source/AHF_Direct/config.h index 5cd90fe..0f1ba8d 100644 --- a/AMSS_NCKU_source/config.h +++ b/AMSS_NCKU_source/AHF_Direct/config.h @@ -1,16 +1,16 @@ -#ifndef AHFINDERDIRECT__CONFIG_H -#define AHFINDERDIRECT__CONFIG_H - -#include -#include -#include -#include - -size_t Util_Strlcat(char* dst, const char* src, size_t dst_size); -size_t Util_Strlcpy(char* dst, const char* src, size_t dst_size); - -typedef CCTK_REAL fp; - -typedef CCTK_INT integer; - -#endif /* AHFINDERDIRECT__CONFIG_H */ +#ifndef AHFINDERDIRECT__CONFIG_H +#define AHFINDERDIRECT__CONFIG_H + +#include +#include +#include +#include + +size_t Util_Strlcat(char* dst, const char* src, size_t dst_size); +size_t Util_Strlcpy(char* dst, const char* src, size_t dst_size); + +typedef CCTK_REAL fp; + +typedef CCTK_INT integer; + +#endif /* AHFINDERDIRECT__CONFIG_H */ diff --git a/AMSS_NCKU_source/coords.C b/AMSS_NCKU_source/AHF_Direct/coords.C similarity index 96% rename from AMSS_NCKU_source/coords.C rename to AMSS_NCKU_source/AHF_Direct/coords.C index 2058d94..98d30c2 100644 --- a/AMSS_NCKU_source/coords.C +++ b/AMSS_NCKU_source/AHF_Direct/coords.C @@ -1,533 +1,533 @@ -#include -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" - -#include "coords.h" - -namespace AHFinderDirect -{ - using jtutil::arctan_xy; - using jtutil::error_exit; - using jtutil::hypot3; - using jtutil::pow2; - using jtutil::signum; - - namespace local_coords - { - - bool fuzzy_EQ_ang(fp ang1, fp ang2) - { - return jtutil::fuzzy::is_integer((ang2 - ang1) / (2.0 * PI)); - } - - bool fuzzy_EQ_dang(fp dang1, fp dang2) - { - return jtutil::fuzzy::is_integer((dang2 - dang1) / 360.0); - } - - } - - namespace local_coords - { - - fp modulo_reduce_ang(fp ang, fp min_ang, fp max_ang) - { - return jtutil::modulo_reduce(ang, 2.0 * PI, min_ang, max_ang); - } - - fp modulo_reduce_dang(fp dang, fp min_dang, fp max_dang) - { - return jtutil::modulo_reduce(dang, 360.0, min_dang, max_dang); - } - - } - - namespace local_coords - { - void xyz_of_r_mu_nu(fp r, fp mu, fp nu, fp &x, fp &y, fp &z) - { - const fp sign_y = signum(sin(mu)); - const fp sign_z_via_mu = signum(cos(mu)); - assert(jtutil::fuzzy::NE(cos(mu), 0.0)); - const fp y_over_z = tan(mu); - - const fp sign_x = signum(sin(nu)); - const fp sign_z_via_nu = signum(cos(nu)); - assert(jtutil::fuzzy::NE(cos(nu), 0.0)); - const fp x_over_z = tan(nu); - - // failure of next assert() ==> inconsistent input (mu,nu) - assert(sign_z_via_mu == sign_z_via_nu); - const fp sign_z = sign_z_via_mu; - - const fp temp = 1.0 / sqrt(1.0 + pow2(y_over_z) + pow2(x_over_z)); - - z = sign_z * r * temp; - x = x_over_z * z; - y = y_over_z * z; - } - } - - namespace local_coords - { - void xyz_of_r_mu_phi(fp r, fp mu, fp phi, fp &x, fp &y, fp &z) - { - const fp mu_bar = 0.5 * PI - mu; - const fp phi_bar = 0.5 * PI - phi; - - const fp sign_z = signum(sin(mu_bar)); - const fp sign_y_via_mu_bar = signum(cos(mu_bar)); - assert(jtutil::fuzzy::NE(cos(mu_bar), 0.0)); - const fp z_over_y = tan(mu_bar); - - const fp sign_x = signum(sin(phi_bar)); - const fp sign_y_via_phi_bar = signum(cos(phi_bar)); - assert(jtutil::fuzzy::NE(cos(phi_bar), 0.0)); - const fp x_over_y = tan(phi_bar); - - // failure of next assert() ==> inconsistent input (mu,phi) - assert(sign_y_via_mu_bar == sign_y_via_phi_bar); - const fp sign_y = sign_y_via_mu_bar; - - const fp temp = 1.0 / sqrt(1.0 + pow2(z_over_y) + pow2(x_over_y)); - - y = sign_y * r * temp; - z = z_over_y * y; - x = x_over_y * y; - } - } - namespace local_coords - { - void xyz_of_r_nu_phi(fp r, fp nu, fp phi, fp &x, fp &y, fp &z) - { - const fp nu_bar = 0.5 * PI - nu; - - const fp sign_z = signum(sin(nu_bar)); - const fp sign_x_via_nu_bar = signum(cos(nu_bar)); - assert(jtutil::fuzzy::NE(cos(nu_bar), 0.0)); - const fp z_over_x = tan(nu_bar); - - const fp sign_y = signum(sin(phi)); - const fp sign_x_via_phi = signum(cos(phi)); - assert(jtutil::fuzzy::NE(cos(phi), 0.0)); - const fp y_over_x = tan(phi); - - // failure of next assert() ==> inconsistent input (nu,phi) - assert(sign_x_via_nu_bar == sign_x_via_phi); - const fp sign_x = sign_x_via_nu_bar; - - const fp temp = 1.0 / sqrt(1.0 + pow2(z_over_x) + pow2(y_over_x)); - - x = sign_x * r * temp; - z = z_over_x * x; - y = y_over_x * x; - } - } - namespace local_coords - { - fp phi_of_mu_nu(fp mu, fp nu) - { - fp x, y, z; - xyz_of_r_mu_nu(1.0, mu, nu, x, y, z); - return phi_of_xy(x, y); - } - } - - namespace local_coords - { - fp nu_of_mu_phi(fp mu, fp phi) - { - fp x, y, z; - xyz_of_r_mu_phi(1.0, mu, phi, x, y, z); - return nu_of_xz(x, z); - } - } - - //************************************** - - // ill-conditioned near x axis - // not valid in yz plane (sin(nu) == 0 || cos(phi) == 0) - namespace local_coords - { - fp mu_of_nu_phi(fp nu, fp phi) - { - fp x, y, z; - xyz_of_r_nu_phi(1.0, nu, phi, x, y, z); - return mu_of_yz(y, z); - } - } - - //****************************************************************************** - - namespace local_coords - { - fp r_of_xyz(fp x, fp y, fp z) { return hypot3(x, y, z); } - fp mu_of_yz(fp y, fp z) { return arctan_xy(z, y); } - fp nu_of_xz(fp x, fp z) { return arctan_xy(z, x); } - fp phi_of_xy(fp x, fp y) { return arctan_xy(x, y); } - } - - namespace local_coords - { - void partial_xyz_wrt_r_mu_nu(fp r, fp mu, fp nu, - fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_nu, - fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_nu, - fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_nu) - { - const fp tan_mu = tan(mu); - const fp tan_nu = tan(nu); - const fp tan2_mu = pow2(tan_mu); - const fp tan2_nu = pow2(tan_nu); - - fp x, y, z; - xyz_of_r_mu_nu(r, mu, nu, x, y, z); - - assert(jtutil::fuzzy::NE(r, 0.0)); - const fp rinv = 1.0 / r; - partial_x_wrt_r = x * rinv; - partial_y_wrt_r = y * rinv; - partial_z_wrt_r = z * rinv; - - const fp t = 1 + tan2_mu + tan2_nu; // = $r^2/z^2$ - const fp partial_t_wrt_mu = 2.0 * tan_mu * (1.0 + tan2_mu); - const fp partial_t_wrt_nu = 2.0 * tan_nu * (1.0 + tan2_nu); - - const fp r2_over_zt2 = (r * r) / (z * t * t); - partial_z_wrt_mu = -0.5 * r2_over_zt2 * partial_t_wrt_mu; - partial_z_wrt_nu = -0.5 * r2_over_zt2 * partial_t_wrt_nu; - - partial_x_wrt_mu = tan_nu * partial_z_wrt_mu; - partial_x_wrt_nu = tan_nu * partial_z_wrt_nu + z * (1.0 + tan2_nu); - partial_y_wrt_mu = tan_mu * partial_z_wrt_mu + z * (1.0 + tan2_mu); - partial_y_wrt_nu = tan_mu * partial_z_wrt_nu; - } - } - - //************************************** - - namespace local_coords - { - void partial_xyz_wrt_r_mu_phi(fp r, fp mu, fp phi, - fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_phi, - fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_phi, - fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_phi) - { - const fp mu_bar = 0.5 * PI - mu; - const fp phi_bar = 0.5 * PI - phi; - - const fp tan_mu_bar = tan(mu_bar); - const fp tan_phi_bar = tan(phi_bar); - const fp tan2_mu_bar = pow2(tan_mu_bar); - const fp tan2_phi_bar = pow2(tan_phi_bar); - - fp x, y, z; - xyz_of_r_mu_phi(r, mu, phi, x, y, z); - - assert(jtutil::fuzzy::NE(r, 0.0)); - const fp rinv = 1.0 / r; - partial_x_wrt_r = x * rinv; - partial_y_wrt_r = y * rinv; - partial_z_wrt_r = z * rinv; - - const fp t = 1 + tan2_mu_bar + tan2_phi_bar; // = $r^2/y^2$ - const fp partial_t_wrt_mu_bar = 2.0 * tan_mu_bar * (1.0 + tan2_mu_bar); - const fp partial_t_wrt_phi_bar = 2.0 * tan_phi_bar * (1.0 + tan2_phi_bar); - - const fp r2_over_yt2 = (r * r) / (y * t * t); - partial_y_wrt_mu = 0.5 * r2_over_yt2 * partial_t_wrt_mu_bar; - partial_y_wrt_phi = 0.5 * r2_over_yt2 * partial_t_wrt_phi_bar; - - partial_x_wrt_mu = tan_phi_bar * partial_y_wrt_mu; - partial_x_wrt_phi = tan_phi_bar * partial_y_wrt_phi - y * (1.0 + tan2_phi_bar); - partial_z_wrt_mu = tan_mu_bar * partial_y_wrt_mu - y * (1.0 + tan2_mu_bar); - partial_z_wrt_phi = tan_mu_bar * partial_y_wrt_phi; - } - } - - //************************************** - - namespace local_coords - { - void partial_xyz_wrt_r_nu_phi(fp r, fp nu, fp phi, - fp &partial_x_wrt_r, fp &partial_x_wrt_nu, fp &partial_x_wrt_phi, - fp &partial_y_wrt_r, fp &partial_y_wrt_nu, fp &partial_y_wrt_phi, - fp &partial_z_wrt_r, fp &partial_z_wrt_nu, fp &partial_z_wrt_phi) - { - const fp nu_bar = 0.5 * PI - nu; - - const fp tan_nu_bar = tan(nu_bar); - const fp tan_phi = tan(phi); - const fp tan2_nu_bar = pow2(tan_nu_bar); - const fp tan2_phi = pow2(tan_phi); - - fp x, y, z; - xyz_of_r_nu_phi(r, nu, phi, x, y, z); - - assert(jtutil::fuzzy::NE(r, 0.0)); - const fp rinv = 1.0 / r; - partial_x_wrt_r = x * rinv; - partial_y_wrt_r = y * rinv; - partial_z_wrt_r = z * rinv; - - const fp t = 1 + tan2_nu_bar + tan2_phi; // = $r^2/x^2$ - const fp partial_t_wrt_nu_bar = 2.0 * tan_nu_bar * (1.0 + tan2_nu_bar); - const fp partial_t_wrt_phi = 2.0 * tan_phi * (1.0 + tan2_phi); - - const fp r2_over_xt2 = (r * r) / (x * t * t); - partial_x_wrt_nu = 0.5 * r2_over_xt2 * partial_t_wrt_nu_bar; - partial_x_wrt_phi = -0.5 * r2_over_xt2 * partial_t_wrt_phi; - - partial_y_wrt_nu = tan_phi * partial_x_wrt_nu; - partial_y_wrt_phi = tan_phi * partial_x_wrt_phi + x * (1.0 + tan2_phi); - partial_z_wrt_nu = tan_nu_bar * partial_x_wrt_nu - x * (1.0 + tan2_nu_bar); - partial_z_wrt_phi = tan_nu_bar * partial_x_wrt_phi; - } - } - - //****************************************************************************** - - // - // these functions compute the partial derivatives - // partial {mu,nu,phi} / partial {x,y,z} - // as computed by the maple file "coord_derivs.{maple,out}" in this directory - // - namespace local_coords - { - fp partial_mu_wrt_y(fp y, fp z) { return z / (y * y + z * z); } - fp partial_mu_wrt_z(fp y, fp z) { return -y / (y * y + z * z); } - - fp partial_nu_wrt_x(fp x, fp z) { return z / (x * x + z * z); } - fp partial_nu_wrt_z(fp x, fp z) { return -x / (x * x + z * z); } - - fp partial_phi_wrt_x(fp x, fp y) { return -y / (x * x + y * y); } - fp partial_phi_wrt_y(fp x, fp y) { return x / (x * x + y * y); } - } - - //****************************************************************************** - - // - // these functions compute the 2nd partial derivatives - // partial {mu,nu,phi} / partial {xx,xy,xz,yy,yz,zz} - // as computed by the maple file "coord_derivs.{maple,out}" in this directory - // - namespace local_coords - { - fp partial2_mu_wrt_yy(fp y, fp z) { return -2.0 * y * z / pow2(y * y + z * z); } - fp partial2_mu_wrt_yz(fp y, fp z) { return (y * y - z * z) / pow2(y * y + z * z); } - fp partial2_mu_wrt_zz(fp y, fp z) { return 2.0 * y * z / pow2(y * y + z * z); } - - fp partial2_nu_wrt_xx(fp x, fp z) { return -2.0 * x * z / pow2(x * x + z * z); } - fp partial2_nu_wrt_xz(fp x, fp z) { return (x * x - z * z) / pow2(x * x + z * z); } - fp partial2_nu_wrt_zz(fp x, fp z) { return 2.0 * x * z / pow2(x * x + z * z); } - - fp partial2_phi_wrt_xx(fp x, fp y) { return 2.0 * x * y / pow2(x * x + y * y); } - fp partial2_phi_wrt_xy(fp x, fp y) { return (y * y - x * x) / pow2(x * x + y * y); } - fp partial2_phi_wrt_yy(fp x, fp y) { return -2.0 * x * y / pow2(x * x + y * y); } - } - - namespace local_coords - { - void xyz_of_r_theta_phi(fp r, fp theta, fp phi, fp &x, fp &y, fp &z) - { - z = r * cos(theta); - x = r * sin(theta) * cos(phi); - y = r * sin(theta) * sin(phi); - } - } - - //************************************** - - namespace local_coords - { - void r_theta_phi_of_xyz(fp x, fp y, fp z, fp &r, fp &theta, fp &phi) - { - r = r_of_xyz(x, y, z); - theta = theta_of_xyz(x, y, z); - phi = phi_of_xy(x, y); - } - } - - //************************************** - - namespace local_coords - { - fp theta_of_xyz(fp x, fp y, fp z) - { - return arctan_xy(z, hypot(x, y)); - } - } - - //****************************************************************************** - - // - // these functions convert ((mu,nu,phi)) <--> usual polar spherical (theta,phi) - // ... note phi is the same coordinate in both systems - // - - namespace local_coords - { - void theta_phi_of_mu_nu(fp mu, fp nu, fp &ps_theta, fp &ps_phi) - { - fp x, y, z; - xyz_of_r_mu_nu(1.0, mu, nu, x, y, z); - - ps_theta = theta_of_xyz(x, y, z); - ps_phi = phi_of_xy(x, y); - } - } - - //************************************** - - // Bugs: computes ps_phi via trig, even though it's trivially == phi - namespace local_coords - { - void theta_phi_of_mu_phi(fp mu, fp phi, fp &ps_theta, fp &ps_phi) - { - fp x, y, z; - xyz_of_r_mu_phi(1.0, mu, phi, x, y, z); - - ps_theta = theta_of_xyz(x, y, z); - ps_phi = phi_of_xy(x, y); - assert(fuzzy_EQ_ang(ps_phi, phi)); - } - } - - //************************************** - - // Bugs: computes ps_phi via trig, even though it's trivially == phi - namespace local_coords - { - void theta_phi_of_nu_phi(fp nu, fp phi, fp &ps_theta, fp &ps_phi) - { - fp x, y, z; - xyz_of_r_nu_phi(1.0, nu, phi, x, y, z); - - ps_theta = theta_of_xyz(x, y, z); - ps_phi = phi_of_xy(x, y); - assert(fuzzy_EQ_ang(ps_phi, phi)); - } - } - - //****************************************************************************** - - namespace local_coords - { - void mu_nu_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &nu) - { - fp x, y, z; - xyz_of_r_theta_phi(1.0, ps_theta, ps_phi, x, y, z); - - mu = mu_of_yz(y, z); - nu = nu_of_xz(x, z); - } - } - - //************************************** - - // Bugs: computes phi via trig, even though it's trivially == ps_phi - namespace local_coords - { - void mu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &phi) - { - fp x, y, z; - xyz_of_r_theta_phi(1.0, ps_theta, ps_phi, x, y, z); - - mu = mu_of_yz(y, z); - phi = phi_of_xy(x, y); - assert(fuzzy_EQ_ang(phi, ps_phi)); - } - } - - //************************************** - - // Bugs: computes phi via trig, even though it's trivially == ps_phi - namespace local_coords - { - void nu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &nu, fp &phi) - { - fp x, y, z; - xyz_of_r_theta_phi(1.0, ps_theta, ps_phi, x, y, z); - - nu = nu_of_xz(x, z); - phi = phi_of_xy(x, y); - assert(fuzzy_EQ_ang(phi, ps_phi)); - } - } - - //****************************************************************************** - - // - // these functions convert ((mu,nu,phi)) to the direction cosines - // (xcos,ycos,zcos) - // - - namespace local_coords - { - void xyzcos_of_mu_nu(fp mu, fp nu, fp &xcos, fp &ycos, fp &zcos) - { - xyz_of_r_mu_nu(1.0, mu, nu, xcos, ycos, zcos); - } - } - - namespace local_coords - { - void xyzcos_of_mu_phi(fp mu, fp phi, fp &xcos, fp &ycos, fp &zcos) - { - xyz_of_r_mu_phi(1.0, mu, phi, xcos, ycos, zcos); - } - } - - namespace local_coords - { - void xyzcos_of_nu_phi(fp nu, fp phi, fp &xcos, fp &ycos, fp &zcos) - { - xyz_of_r_nu_phi(1.0, nu, phi, xcos, ycos, zcos); - } - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function computes a human-readable name from a (mu,nu,phi) - // coordinates set. - // - const char *local_coords::name_of_coords_set(coords_set S) - { - // - // we have to use an if-else chain because the local_coords::set_* - // constants aren't compile-time constants and hence aren't eligible - // to be switch case labels - // - if (S == coords_set_empty) - then return "{}"; - else if (S == coords_set_mu) - then return "mu"; - else if (S == coords_set_nu) - then return "nu"; - else if (S == coords_set_phi) - then return "phi"; - else if (S == coords_set_mu | coords_set_nu) - then return "{mu,nu}"; - else if (S == coords_set_mu | coords_set_phi) - then return "{mu,phi}"; - else if (S == coords_set_nu | coords_set_phi) - then return "{nu,phi}"; - else if (S == coords_set_mu | coords_set_nu | coords_set_phi) - then return "{mu,nu,phi}"; - else - error_exit(PANIC_EXIT, - "***** local_coords::mu_nu_phi::name_of_coords_set:\n" - " S=0x%x isn't a valid coords_set bit vector!\n", - int(S)); /*NOTREACHED*/ - } - -} // namespace AHFinderDirect +#include +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" + +#include "coords.h" + +namespace AHFinderDirect +{ + using jtutil::arctan_xy; + using jtutil::error_exit; + using jtutil::hypot3; + using jtutil::pow2; + using jtutil::signum; + + namespace local_coords + { + + bool fuzzy_EQ_ang(fp ang1, fp ang2) + { + return jtutil::fuzzy::is_integer((ang2 - ang1) / (2.0 * PI)); + } + + bool fuzzy_EQ_dang(fp dang1, fp dang2) + { + return jtutil::fuzzy::is_integer((dang2 - dang1) / 360.0); + } + + } + + namespace local_coords + { + + fp modulo_reduce_ang(fp ang, fp min_ang, fp max_ang) + { + return jtutil::modulo_reduce(ang, 2.0 * PI, min_ang, max_ang); + } + + fp modulo_reduce_dang(fp dang, fp min_dang, fp max_dang) + { + return jtutil::modulo_reduce(dang, 360.0, min_dang, max_dang); + } + + } + + namespace local_coords + { + void xyz_of_r_mu_nu(fp r, fp mu, fp nu, fp &x, fp &y, fp &z) + { + const fp sign_y = signum(sin(mu)); + const fp sign_z_via_mu = signum(cos(mu)); + assert(jtutil::fuzzy::NE(cos(mu), 0.0)); + const fp y_over_z = tan(mu); + + const fp sign_x = signum(sin(nu)); + const fp sign_z_via_nu = signum(cos(nu)); + assert(jtutil::fuzzy::NE(cos(nu), 0.0)); + const fp x_over_z = tan(nu); + + // failure of next assert() ==> inconsistent input (mu,nu) + assert(sign_z_via_mu == sign_z_via_nu); + const fp sign_z = sign_z_via_mu; + + const fp temp = 1.0 / sqrt(1.0 + pow2(y_over_z) + pow2(x_over_z)); + + z = sign_z * r * temp; + x = x_over_z * z; + y = y_over_z * z; + } + } + + namespace local_coords + { + void xyz_of_r_mu_phi(fp r, fp mu, fp phi, fp &x, fp &y, fp &z) + { + const fp mu_bar = 0.5 * PI - mu; + const fp phi_bar = 0.5 * PI - phi; + + const fp sign_z = signum(sin(mu_bar)); + const fp sign_y_via_mu_bar = signum(cos(mu_bar)); + assert(jtutil::fuzzy::NE(cos(mu_bar), 0.0)); + const fp z_over_y = tan(mu_bar); + + const fp sign_x = signum(sin(phi_bar)); + const fp sign_y_via_phi_bar = signum(cos(phi_bar)); + assert(jtutil::fuzzy::NE(cos(phi_bar), 0.0)); + const fp x_over_y = tan(phi_bar); + + // failure of next assert() ==> inconsistent input (mu,phi) + assert(sign_y_via_mu_bar == sign_y_via_phi_bar); + const fp sign_y = sign_y_via_mu_bar; + + const fp temp = 1.0 / sqrt(1.0 + pow2(z_over_y) + pow2(x_over_y)); + + y = sign_y * r * temp; + z = z_over_y * y; + x = x_over_y * y; + } + } + namespace local_coords + { + void xyz_of_r_nu_phi(fp r, fp nu, fp phi, fp &x, fp &y, fp &z) + { + const fp nu_bar = 0.5 * PI - nu; + + const fp sign_z = signum(sin(nu_bar)); + const fp sign_x_via_nu_bar = signum(cos(nu_bar)); + assert(jtutil::fuzzy::NE(cos(nu_bar), 0.0)); + const fp z_over_x = tan(nu_bar); + + const fp sign_y = signum(sin(phi)); + const fp sign_x_via_phi = signum(cos(phi)); + assert(jtutil::fuzzy::NE(cos(phi), 0.0)); + const fp y_over_x = tan(phi); + + // failure of next assert() ==> inconsistent input (nu,phi) + assert(sign_x_via_nu_bar == sign_x_via_phi); + const fp sign_x = sign_x_via_nu_bar; + + const fp temp = 1.0 / sqrt(1.0 + pow2(z_over_x) + pow2(y_over_x)); + + x = sign_x * r * temp; + z = z_over_x * x; + y = y_over_x * x; + } + } + namespace local_coords + { + fp phi_of_mu_nu(fp mu, fp nu) + { + fp x, y, z; + xyz_of_r_mu_nu(1.0, mu, nu, x, y, z); + return phi_of_xy(x, y); + } + } + + namespace local_coords + { + fp nu_of_mu_phi(fp mu, fp phi) + { + fp x, y, z; + xyz_of_r_mu_phi(1.0, mu, phi, x, y, z); + return nu_of_xz(x, z); + } + } + + //************************************** + + // ill-conditioned near x axis + // not valid in yz plane (sin(nu) == 0 || cos(phi) == 0) + namespace local_coords + { + fp mu_of_nu_phi(fp nu, fp phi) + { + fp x, y, z; + xyz_of_r_nu_phi(1.0, nu, phi, x, y, z); + return mu_of_yz(y, z); + } + } + + //****************************************************************************** + + namespace local_coords + { + fp r_of_xyz(fp x, fp y, fp z) { return hypot3(x, y, z); } + fp mu_of_yz(fp y, fp z) { return arctan_xy(z, y); } + fp nu_of_xz(fp x, fp z) { return arctan_xy(z, x); } + fp phi_of_xy(fp x, fp y) { return arctan_xy(x, y); } + } + + namespace local_coords + { + void partial_xyz_wrt_r_mu_nu(fp r, fp mu, fp nu, + fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_nu, + fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_nu, + fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_nu) + { + const fp tan_mu = tan(mu); + const fp tan_nu = tan(nu); + const fp tan2_mu = pow2(tan_mu); + const fp tan2_nu = pow2(tan_nu); + + fp x, y, z; + xyz_of_r_mu_nu(r, mu, nu, x, y, z); + + assert(jtutil::fuzzy::NE(r, 0.0)); + const fp rinv = 1.0 / r; + partial_x_wrt_r = x * rinv; + partial_y_wrt_r = y * rinv; + partial_z_wrt_r = z * rinv; + + const fp t = 1 + tan2_mu + tan2_nu; // = $r^2/z^2$ + const fp partial_t_wrt_mu = 2.0 * tan_mu * (1.0 + tan2_mu); + const fp partial_t_wrt_nu = 2.0 * tan_nu * (1.0 + tan2_nu); + + const fp r2_over_zt2 = (r * r) / (z * t * t); + partial_z_wrt_mu = -0.5 * r2_over_zt2 * partial_t_wrt_mu; + partial_z_wrt_nu = -0.5 * r2_over_zt2 * partial_t_wrt_nu; + + partial_x_wrt_mu = tan_nu * partial_z_wrt_mu; + partial_x_wrt_nu = tan_nu * partial_z_wrt_nu + z * (1.0 + tan2_nu); + partial_y_wrt_mu = tan_mu * partial_z_wrt_mu + z * (1.0 + tan2_mu); + partial_y_wrt_nu = tan_mu * partial_z_wrt_nu; + } + } + + //************************************** + + namespace local_coords + { + void partial_xyz_wrt_r_mu_phi(fp r, fp mu, fp phi, + fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_phi, + fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_phi, + fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_phi) + { + const fp mu_bar = 0.5 * PI - mu; + const fp phi_bar = 0.5 * PI - phi; + + const fp tan_mu_bar = tan(mu_bar); + const fp tan_phi_bar = tan(phi_bar); + const fp tan2_mu_bar = pow2(tan_mu_bar); + const fp tan2_phi_bar = pow2(tan_phi_bar); + + fp x, y, z; + xyz_of_r_mu_phi(r, mu, phi, x, y, z); + + assert(jtutil::fuzzy::NE(r, 0.0)); + const fp rinv = 1.0 / r; + partial_x_wrt_r = x * rinv; + partial_y_wrt_r = y * rinv; + partial_z_wrt_r = z * rinv; + + const fp t = 1 + tan2_mu_bar + tan2_phi_bar; // = $r^2/y^2$ + const fp partial_t_wrt_mu_bar = 2.0 * tan_mu_bar * (1.0 + tan2_mu_bar); + const fp partial_t_wrt_phi_bar = 2.0 * tan_phi_bar * (1.0 + tan2_phi_bar); + + const fp r2_over_yt2 = (r * r) / (y * t * t); + partial_y_wrt_mu = 0.5 * r2_over_yt2 * partial_t_wrt_mu_bar; + partial_y_wrt_phi = 0.5 * r2_over_yt2 * partial_t_wrt_phi_bar; + + partial_x_wrt_mu = tan_phi_bar * partial_y_wrt_mu; + partial_x_wrt_phi = tan_phi_bar * partial_y_wrt_phi - y * (1.0 + tan2_phi_bar); + partial_z_wrt_mu = tan_mu_bar * partial_y_wrt_mu - y * (1.0 + tan2_mu_bar); + partial_z_wrt_phi = tan_mu_bar * partial_y_wrt_phi; + } + } + + //************************************** + + namespace local_coords + { + void partial_xyz_wrt_r_nu_phi(fp r, fp nu, fp phi, + fp &partial_x_wrt_r, fp &partial_x_wrt_nu, fp &partial_x_wrt_phi, + fp &partial_y_wrt_r, fp &partial_y_wrt_nu, fp &partial_y_wrt_phi, + fp &partial_z_wrt_r, fp &partial_z_wrt_nu, fp &partial_z_wrt_phi) + { + const fp nu_bar = 0.5 * PI - nu; + + const fp tan_nu_bar = tan(nu_bar); + const fp tan_phi = tan(phi); + const fp tan2_nu_bar = pow2(tan_nu_bar); + const fp tan2_phi = pow2(tan_phi); + + fp x, y, z; + xyz_of_r_nu_phi(r, nu, phi, x, y, z); + + assert(jtutil::fuzzy::NE(r, 0.0)); + const fp rinv = 1.0 / r; + partial_x_wrt_r = x * rinv; + partial_y_wrt_r = y * rinv; + partial_z_wrt_r = z * rinv; + + const fp t = 1 + tan2_nu_bar + tan2_phi; // = $r^2/x^2$ + const fp partial_t_wrt_nu_bar = 2.0 * tan_nu_bar * (1.0 + tan2_nu_bar); + const fp partial_t_wrt_phi = 2.0 * tan_phi * (1.0 + tan2_phi); + + const fp r2_over_xt2 = (r * r) / (x * t * t); + partial_x_wrt_nu = 0.5 * r2_over_xt2 * partial_t_wrt_nu_bar; + partial_x_wrt_phi = -0.5 * r2_over_xt2 * partial_t_wrt_phi; + + partial_y_wrt_nu = tan_phi * partial_x_wrt_nu; + partial_y_wrt_phi = tan_phi * partial_x_wrt_phi + x * (1.0 + tan2_phi); + partial_z_wrt_nu = tan_nu_bar * partial_x_wrt_nu - x * (1.0 + tan2_nu_bar); + partial_z_wrt_phi = tan_nu_bar * partial_x_wrt_phi; + } + } + + //****************************************************************************** + + // + // these functions compute the partial derivatives + // partial {mu,nu,phi} / partial {x,y,z} + // as computed by the maple file "coord_derivs.{maple,out}" in this directory + // + namespace local_coords + { + fp partial_mu_wrt_y(fp y, fp z) { return z / (y * y + z * z); } + fp partial_mu_wrt_z(fp y, fp z) { return -y / (y * y + z * z); } + + fp partial_nu_wrt_x(fp x, fp z) { return z / (x * x + z * z); } + fp partial_nu_wrt_z(fp x, fp z) { return -x / (x * x + z * z); } + + fp partial_phi_wrt_x(fp x, fp y) { return -y / (x * x + y * y); } + fp partial_phi_wrt_y(fp x, fp y) { return x / (x * x + y * y); } + } + + //****************************************************************************** + + // + // these functions compute the 2nd partial derivatives + // partial {mu,nu,phi} / partial {xx,xy,xz,yy,yz,zz} + // as computed by the maple file "coord_derivs.{maple,out}" in this directory + // + namespace local_coords + { + fp partial2_mu_wrt_yy(fp y, fp z) { return -2.0 * y * z / pow2(y * y + z * z); } + fp partial2_mu_wrt_yz(fp y, fp z) { return (y * y - z * z) / pow2(y * y + z * z); } + fp partial2_mu_wrt_zz(fp y, fp z) { return 2.0 * y * z / pow2(y * y + z * z); } + + fp partial2_nu_wrt_xx(fp x, fp z) { return -2.0 * x * z / pow2(x * x + z * z); } + fp partial2_nu_wrt_xz(fp x, fp z) { return (x * x - z * z) / pow2(x * x + z * z); } + fp partial2_nu_wrt_zz(fp x, fp z) { return 2.0 * x * z / pow2(x * x + z * z); } + + fp partial2_phi_wrt_xx(fp x, fp y) { return 2.0 * x * y / pow2(x * x + y * y); } + fp partial2_phi_wrt_xy(fp x, fp y) { return (y * y - x * x) / pow2(x * x + y * y); } + fp partial2_phi_wrt_yy(fp x, fp y) { return -2.0 * x * y / pow2(x * x + y * y); } + } + + namespace local_coords + { + void xyz_of_r_theta_phi(fp r, fp theta, fp phi, fp &x, fp &y, fp &z) + { + z = r * cos(theta); + x = r * sin(theta) * cos(phi); + y = r * sin(theta) * sin(phi); + } + } + + //************************************** + + namespace local_coords + { + void r_theta_phi_of_xyz(fp x, fp y, fp z, fp &r, fp &theta, fp &phi) + { + r = r_of_xyz(x, y, z); + theta = theta_of_xyz(x, y, z); + phi = phi_of_xy(x, y); + } + } + + //************************************** + + namespace local_coords + { + fp theta_of_xyz(fp x, fp y, fp z) + { + return arctan_xy(z, hypot(x, y)); + } + } + + //****************************************************************************** + + // + // these functions convert ((mu,nu,phi)) <--> usual polar spherical (theta,phi) + // ... note phi is the same coordinate in both systems + // + + namespace local_coords + { + void theta_phi_of_mu_nu(fp mu, fp nu, fp &ps_theta, fp &ps_phi) + { + fp x, y, z; + xyz_of_r_mu_nu(1.0, mu, nu, x, y, z); + + ps_theta = theta_of_xyz(x, y, z); + ps_phi = phi_of_xy(x, y); + } + } + + //************************************** + + // Bugs: computes ps_phi via trig, even though it's trivially == phi + namespace local_coords + { + void theta_phi_of_mu_phi(fp mu, fp phi, fp &ps_theta, fp &ps_phi) + { + fp x, y, z; + xyz_of_r_mu_phi(1.0, mu, phi, x, y, z); + + ps_theta = theta_of_xyz(x, y, z); + ps_phi = phi_of_xy(x, y); + assert(fuzzy_EQ_ang(ps_phi, phi)); + } + } + + //************************************** + + // Bugs: computes ps_phi via trig, even though it's trivially == phi + namespace local_coords + { + void theta_phi_of_nu_phi(fp nu, fp phi, fp &ps_theta, fp &ps_phi) + { + fp x, y, z; + xyz_of_r_nu_phi(1.0, nu, phi, x, y, z); + + ps_theta = theta_of_xyz(x, y, z); + ps_phi = phi_of_xy(x, y); + assert(fuzzy_EQ_ang(ps_phi, phi)); + } + } + + //****************************************************************************** + + namespace local_coords + { + void mu_nu_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &nu) + { + fp x, y, z; + xyz_of_r_theta_phi(1.0, ps_theta, ps_phi, x, y, z); + + mu = mu_of_yz(y, z); + nu = nu_of_xz(x, z); + } + } + + //************************************** + + // Bugs: computes phi via trig, even though it's trivially == ps_phi + namespace local_coords + { + void mu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &phi) + { + fp x, y, z; + xyz_of_r_theta_phi(1.0, ps_theta, ps_phi, x, y, z); + + mu = mu_of_yz(y, z); + phi = phi_of_xy(x, y); + assert(fuzzy_EQ_ang(phi, ps_phi)); + } + } + + //************************************** + + // Bugs: computes phi via trig, even though it's trivially == ps_phi + namespace local_coords + { + void nu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &nu, fp &phi) + { + fp x, y, z; + xyz_of_r_theta_phi(1.0, ps_theta, ps_phi, x, y, z); + + nu = nu_of_xz(x, z); + phi = phi_of_xy(x, y); + assert(fuzzy_EQ_ang(phi, ps_phi)); + } + } + + //****************************************************************************** + + // + // these functions convert ((mu,nu,phi)) to the direction cosines + // (xcos,ycos,zcos) + // + + namespace local_coords + { + void xyzcos_of_mu_nu(fp mu, fp nu, fp &xcos, fp &ycos, fp &zcos) + { + xyz_of_r_mu_nu(1.0, mu, nu, xcos, ycos, zcos); + } + } + + namespace local_coords + { + void xyzcos_of_mu_phi(fp mu, fp phi, fp &xcos, fp &ycos, fp &zcos) + { + xyz_of_r_mu_phi(1.0, mu, phi, xcos, ycos, zcos); + } + } + + namespace local_coords + { + void xyzcos_of_nu_phi(fp nu, fp phi, fp &xcos, fp &ycos, fp &zcos) + { + xyz_of_r_nu_phi(1.0, nu, phi, xcos, ycos, zcos); + } + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function computes a human-readable name from a (mu,nu,phi) + // coordinates set. + // + const char *local_coords::name_of_coords_set(coords_set S) + { + // + // we have to use an if-else chain because the local_coords::set_* + // constants aren't compile-time constants and hence aren't eligible + // to be switch case labels + // + if (S == coords_set_empty) + then return "{}"; + else if (S == coords_set_mu) + then return "mu"; + else if (S == coords_set_nu) + then return "nu"; + else if (S == coords_set_phi) + then return "phi"; + else if (S == coords_set_mu | coords_set_nu) + then return "{mu,nu}"; + else if (S == coords_set_mu | coords_set_phi) + then return "{mu,phi}"; + else if (S == coords_set_nu | coords_set_phi) + then return "{nu,phi}"; + else if (S == coords_set_mu | coords_set_nu | coords_set_phi) + then return "{mu,nu,phi}"; + else + error_exit(PANIC_EXIT, + "***** local_coords::mu_nu_phi::name_of_coords_set:\n" + " S=0x%x isn't a valid coords_set bit vector!\n", + int(S)); /*NOTREACHED*/ + } + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/coords.h b/AMSS_NCKU_source/AHF_Direct/coords.h similarity index 97% rename from AMSS_NCKU_source/coords.h rename to AMSS_NCKU_source/AHF_Direct/coords.h index c93ddab..8c3c630 100644 --- a/AMSS_NCKU_source/coords.h +++ b/AMSS_NCKU_source/AHF_Direct/coords.h @@ -1,173 +1,173 @@ -#ifndef COORDS_H -#define COORDS_H -namespace AHFinderDirect -{ - namespace local_coords - { - - // compare if two angles are fuzzily equal mod 2*pi radians (360 degrees) - bool fuzzy_EQ_ang(fp ang1, fp ang2); // radians - bool fuzzy_EQ_dang(fp dang1, fp dang2); // degrees - - // modulo-reduce {ang,dang} to be (fuzzily) within the range - // [min,max]_{ang,dang}, or error_exit() if no such value exists - fp modulo_reduce_ang(fp ang, fp min_ang, fp max_ang); - fp modulo_reduce_dang(fp dang, fp min_dang, fp max_dang); - - } // close namespace local_coords:: - - namespace local_coords - { - // (r,(mu,nu,phi)) <--> (x,y,z) - void xyz_of_r_mu_nu(fp r, fp mu, fp nu, fp &x, fp &y, fp &z); - void xyz_of_r_mu_phi(fp r, fp mu, fp phi, fp &x, fp &y, fp &z); - void xyz_of_r_nu_phi(fp r, fp nu, fp phi, fp &x, fp &y, fp &z); - fp r_of_xyz(fp x, fp y, fp z); - fp mu_of_yz(fp y, fp z); - fp nu_of_xz(fp x, fp z); - fp phi_of_xy(fp x, fp y); - - // ((mu,nu,phi)) --> the 3rd - fp phi_of_mu_nu(fp mu, fp nu); - fp nu_of_mu_phi(fp mu, fp phi); - fp mu_of_nu_phi(fp nu, fp phi); - - // partial {x,y,z} / partial {mu,nu,phi} - void partial_xyz_wrt_r_mu_nu(fp r, fp mu, fp nu, - fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_nu, - fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_nu, - fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_nu); - void partial_xyz_wrt_r_mu_phi(fp r, fp mu, fp phi, - fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_phi, - fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_phi, - fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_phi); - void partial_xyz_wrt_r_nu_phi(fp r, fp nu, fp phi, - fp &partial_x_wrt_r, fp &partial_x_wrt_nu, fp &partial_x_wrt_phi, - fp &partial_y_wrt_r, fp &partial_y_wrt_nu, fp &partial_y_wrt_phi, - fp &partial_z_wrt_r, fp &partial_z_wrt_nu, fp &partial_z_wrt_phi); - - // partial {mu,nu,phi} / partial {x,y,z} - fp partial_mu_wrt_y(fp y, fp z); - fp partial_mu_wrt_z(fp y, fp z); - fp partial_nu_wrt_x(fp x, fp z); - fp partial_nu_wrt_z(fp x, fp z); - fp partial_phi_wrt_x(fp x, fp y); - fp partial_phi_wrt_y(fp x, fp y); - - // partial^2 {mu,nu,phi} / partial {x,y,z}{x,y,z} - fp partial2_mu_wrt_yy(fp y, fp z); - fp partial2_mu_wrt_yz(fp y, fp z); - fp partial2_mu_wrt_zz(fp y, fp z); - fp partial2_nu_wrt_xx(fp x, fp z); - fp partial2_nu_wrt_xz(fp x, fp z); - fp partial2_nu_wrt_zz(fp x, fp z); - fp partial2_phi_wrt_xx(fp x, fp y); - fp partial2_phi_wrt_xy(fp x, fp y); - fp partial2_phi_wrt_yy(fp x, fp y); - - // usual polar spherical (r,theta,phi) <--> (x,y,z) - void xyz_of_r_theta_phi(fp r, fp theta, fp phi, fp &x, fp &y, fp &z); - void r_theta_phi_of_xyz(fp x, fp y, fp z, fp &r, fp &theta, fp &phi); - // ... already have r_of_xyz() - // ... already have phi_of_xy() - fp theta_of_xyz(fp x, fp y, fp z); - - // ((mu,nu,phi)) <--> usual polar spherical (theta,phi) - // ... note phi is the same coordinate in both systems - void theta_phi_of_mu_nu(fp mu, fp nu, fp &ps_theta, fp &ps_phi); - void theta_phi_of_mu_phi(fp mu, fp phi, fp &ps_theta, fp &ps_phi); - void theta_phi_of_nu_phi(fp nu, fp phi, fp &ps_theta, fp &ps_phi); - void mu_nu_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &nu); - void mu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &phi); - void nu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &nu, fp &phi); - - // ((mu,nu,phi)) --> direction cosines (xcos,ycos,zcos) - void xyzcos_of_mu_nu(fp mu, fp nu, fp &xcos, fp &ycos, fp &zcos); - void xyzcos_of_mu_phi(fp mu, fp phi, fp &xcos, fp &ycos, fp &zcos); - void xyzcos_of_nu_phi(fp nu, fp phi, fp &xcos, fp &ycos, fp &zcos); - } // close namespace local_coords:: - - //***************************************************************************** - - // - // ***** bit masks for coordinates **** - // - - // - // We need to manipulate coordinates to do calculations like "which - // coordinate do these two patches have in common". We do these by - // Boolean operations on integers using the following bit masks: - // - - namespace local_coords - { - - typedef int coords_set; - - enum - { - coords_set_mu = 0x1, - coords_set_nu = 0x2, - coords_set_phi = 0x4, - - coords_set_empty = 0x0, - coords_set_all = coords_set_mu | coords_set_nu | coords_set_phi // no comma - }; - - // human-readable coordinate names for debugging etc - const char *name_of_coords_set(coords_set S); - - // set complement of coordinates - inline coords_set coords_set_not(coords_set S) - { - return coords_set_all & ~S; - } - - } // close namespace local_coords:: - - //****************************************************************************** - - // - // This class stores the origin point of our local coordinates, and - // provides conversions between local and global coordinates. - // - class global_coords - { - public: - // get global (x,y,z) coordinates of local origin point - fp origin_x() const { return origin_x_; } - fp origin_y() const { return origin_y_; } - fp origin_z() const { return origin_z_; } - - // constructor: specify global (x,y,z) coordinates of local origin point - global_coords(fp origin_x_in, fp origin_y_in, fp origin_z_in) - : origin_x_(origin_x_in), - origin_y_(origin_y_in), - origin_z_(origin_z_in) - { - } - // destructor: compiler-generated no-op is ok - - void recentering(fp x, fp y, fp z) - { - origin_x_ = x; - origin_y_ = y; - origin_z_ = z; - } - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - global_coords(const global_coords &rhs); - global_coords &operator=(const global_coords &rhs); - - private: - // global (x,y,z) coordinates of local origin point - fp origin_x_, origin_y_, origin_z_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* COORDS_H */ +#ifndef COORDS_H +#define COORDS_H +namespace AHFinderDirect +{ + namespace local_coords + { + + // compare if two angles are fuzzily equal mod 2*pi radians (360 degrees) + bool fuzzy_EQ_ang(fp ang1, fp ang2); // radians + bool fuzzy_EQ_dang(fp dang1, fp dang2); // degrees + + // modulo-reduce {ang,dang} to be (fuzzily) within the range + // [min,max]_{ang,dang}, or error_exit() if no such value exists + fp modulo_reduce_ang(fp ang, fp min_ang, fp max_ang); + fp modulo_reduce_dang(fp dang, fp min_dang, fp max_dang); + + } // close namespace local_coords:: + + namespace local_coords + { + // (r,(mu,nu,phi)) <--> (x,y,z) + void xyz_of_r_mu_nu(fp r, fp mu, fp nu, fp &x, fp &y, fp &z); + void xyz_of_r_mu_phi(fp r, fp mu, fp phi, fp &x, fp &y, fp &z); + void xyz_of_r_nu_phi(fp r, fp nu, fp phi, fp &x, fp &y, fp &z); + fp r_of_xyz(fp x, fp y, fp z); + fp mu_of_yz(fp y, fp z); + fp nu_of_xz(fp x, fp z); + fp phi_of_xy(fp x, fp y); + + // ((mu,nu,phi)) --> the 3rd + fp phi_of_mu_nu(fp mu, fp nu); + fp nu_of_mu_phi(fp mu, fp phi); + fp mu_of_nu_phi(fp nu, fp phi); + + // partial {x,y,z} / partial {mu,nu,phi} + void partial_xyz_wrt_r_mu_nu(fp r, fp mu, fp nu, + fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_nu, + fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_nu, + fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_nu); + void partial_xyz_wrt_r_mu_phi(fp r, fp mu, fp phi, + fp &partial_x_wrt_r, fp &partial_x_wrt_mu, fp &partial_x_wrt_phi, + fp &partial_y_wrt_r, fp &partial_y_wrt_mu, fp &partial_y_wrt_phi, + fp &partial_z_wrt_r, fp &partial_z_wrt_mu, fp &partial_z_wrt_phi); + void partial_xyz_wrt_r_nu_phi(fp r, fp nu, fp phi, + fp &partial_x_wrt_r, fp &partial_x_wrt_nu, fp &partial_x_wrt_phi, + fp &partial_y_wrt_r, fp &partial_y_wrt_nu, fp &partial_y_wrt_phi, + fp &partial_z_wrt_r, fp &partial_z_wrt_nu, fp &partial_z_wrt_phi); + + // partial {mu,nu,phi} / partial {x,y,z} + fp partial_mu_wrt_y(fp y, fp z); + fp partial_mu_wrt_z(fp y, fp z); + fp partial_nu_wrt_x(fp x, fp z); + fp partial_nu_wrt_z(fp x, fp z); + fp partial_phi_wrt_x(fp x, fp y); + fp partial_phi_wrt_y(fp x, fp y); + + // partial^2 {mu,nu,phi} / partial {x,y,z}{x,y,z} + fp partial2_mu_wrt_yy(fp y, fp z); + fp partial2_mu_wrt_yz(fp y, fp z); + fp partial2_mu_wrt_zz(fp y, fp z); + fp partial2_nu_wrt_xx(fp x, fp z); + fp partial2_nu_wrt_xz(fp x, fp z); + fp partial2_nu_wrt_zz(fp x, fp z); + fp partial2_phi_wrt_xx(fp x, fp y); + fp partial2_phi_wrt_xy(fp x, fp y); + fp partial2_phi_wrt_yy(fp x, fp y); + + // usual polar spherical (r,theta,phi) <--> (x,y,z) + void xyz_of_r_theta_phi(fp r, fp theta, fp phi, fp &x, fp &y, fp &z); + void r_theta_phi_of_xyz(fp x, fp y, fp z, fp &r, fp &theta, fp &phi); + // ... already have r_of_xyz() + // ... already have phi_of_xy() + fp theta_of_xyz(fp x, fp y, fp z); + + // ((mu,nu,phi)) <--> usual polar spherical (theta,phi) + // ... note phi is the same coordinate in both systems + void theta_phi_of_mu_nu(fp mu, fp nu, fp &ps_theta, fp &ps_phi); + void theta_phi_of_mu_phi(fp mu, fp phi, fp &ps_theta, fp &ps_phi); + void theta_phi_of_nu_phi(fp nu, fp phi, fp &ps_theta, fp &ps_phi); + void mu_nu_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &nu); + void mu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &mu, fp &phi); + void nu_phi_of_theta_phi(fp ps_theta, fp ps_phi, fp &nu, fp &phi); + + // ((mu,nu,phi)) --> direction cosines (xcos,ycos,zcos) + void xyzcos_of_mu_nu(fp mu, fp nu, fp &xcos, fp &ycos, fp &zcos); + void xyzcos_of_mu_phi(fp mu, fp phi, fp &xcos, fp &ycos, fp &zcos); + void xyzcos_of_nu_phi(fp nu, fp phi, fp &xcos, fp &ycos, fp &zcos); + } // close namespace local_coords:: + + //***************************************************************************** + + // + // ***** bit masks for coordinates **** + // + + // + // We need to manipulate coordinates to do calculations like "which + // coordinate do these two patches have in common". We do these by + // Boolean operations on integers using the following bit masks: + // + + namespace local_coords + { + + typedef int coords_set; + + enum + { + coords_set_mu = 0x1, + coords_set_nu = 0x2, + coords_set_phi = 0x4, + + coords_set_empty = 0x0, + coords_set_all = coords_set_mu | coords_set_nu | coords_set_phi // no comma + }; + + // human-readable coordinate names for debugging etc + const char *name_of_coords_set(coords_set S); + + // set complement of coordinates + inline coords_set coords_set_not(coords_set S) + { + return coords_set_all & ~S; + } + + } // close namespace local_coords:: + + //****************************************************************************** + + // + // This class stores the origin point of our local coordinates, and + // provides conversions between local and global coordinates. + // + class global_coords + { + public: + // get global (x,y,z) coordinates of local origin point + fp origin_x() const { return origin_x_; } + fp origin_y() const { return origin_y_; } + fp origin_z() const { return origin_z_; } + + // constructor: specify global (x,y,z) coordinates of local origin point + global_coords(fp origin_x_in, fp origin_y_in, fp origin_z_in) + : origin_x_(origin_x_in), + origin_y_(origin_y_in), + origin_z_(origin_z_in) + { + } + // destructor: compiler-generated no-op is ok + + void recentering(fp x, fp y, fp z) + { + origin_x_ = x; + origin_y_ = y; + origin_z_ = z; + } + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + global_coords(const global_coords &rhs); + global_coords &operator=(const global_coords &rhs); + + private: + // global (x,y,z) coordinates of local origin point + fp origin_x_, origin_y_, origin_z_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* COORDS_H */ diff --git a/AMSS_NCKU_source/cpm_map.C b/AMSS_NCKU_source/AHF_Direct/cpm_map.C similarity index 97% rename from AMSS_NCKU_source/cpm_map.C rename to AMSS_NCKU_source/AHF_Direct/cpm_map.C index be80f8a..847ae1d 100644 --- a/AMSS_NCKU_source/cpm_map.C +++ b/AMSS_NCKU_source/AHF_Direct/cpm_map.C @@ -1,93 +1,93 @@ -#include -#include - -#include "stdc.h" -#include "util.h" -#include "cpm_map.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - - template - cpm_map::cpm_map(int min_i_in, int max_i_in, - fp_t fixed_point) - : min_i_(min_i_in), max_i_(max_i_in), - map_is_plus_(false) - { - const fp_t d_offset = 2.0 * fixed_point; - if (!fuzzy::is_integer(d_offset)) - then error_exit(ERROR_EXIT, - "***** cpm_map::cpm_map (mirror):\n" - " fixed_point=%g isn't (fuzzily) integral or half-integral!\n", - double(fixed_point)); /*NOTREACHED*/ - - offset_ = round::to_integer(d_offset); - - assert( - map_unchecked(fuzzy::floor(fixed_point)) == - fuzzy::ceiling(fixed_point)); - } - - //****************************************************************************** - - // - // This function constructs a generic cpm_map object, with the mapping - // specified by a sample point sample_i --> sample_j and by sign. - // The sample point need not be in the map's domain/range. - // - template - cpm_map::cpm_map(int min_i_in, int max_i_in, - int sample_i, int sample_j, - bool map_is_plus_in) - : min_i_(min_i_in), max_i_(max_i_in), - offset_(map_is_plus_in ? sample_j - sample_i - : sample_j + sample_i), - map_is_plus_(map_is_plus_in) - { - assert(map_unchecked(sample_i) == sample_j); - } - - //****************************************************************************** - - // - // This function constructs a generic cpm_map object, with the mapping - // specified by a *fp* sample point sample_i --> sample_j (which - // must specify an integer --> integer mapping, i.e. 4.2 --> 4.2 is - // ok for a + map, and 4.5 --> 4.5 is ok for a minus map, but 4.2 --> 4.7 - // is never ok) and by sign. The sample point need not be in the map's - // domain/range. - // - template - cpm_map::cpm_map(int min_i_in, int max_i_in, - fp_t sample_i, fp_t sample_j, - bool map_is_plus_in) - : min_i_(min_i_in), max_i_(max_i_in), - map_is_plus_(map_is_plus_in) - { - const fp_t fp_offset = map_is_plus_in ? sample_j - sample_i - : sample_j + sample_i; - if (!fuzzy::is_integer(fp_offset)) - then error_exit(ERROR_EXIT, - "***** cpm_map::cpm_map (generic via fp sample point):\n" - " fp_offset=%g isn't fuzzily integral!\n" - " ==> sample_i=%g --> sample_j=%g\n" - " doesn't fuzzily specify an integer --> integer mapping!\n", - double(fp_offset), - double(sample_i), double(sample_j)); /*NOTREACHED*/ - - offset_ = round::to_integer(fp_offset); - - // verify that we have setup correct - assert( - map_unchecked(fuzzy::floor(sample_i)) == - (map_is_plus_in ? fuzzy::floor(sample_j) - : fuzzy::ceiling(sample_j))); - } - - template class cpm_map; - template class cpm_map; - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include + +#include "stdc.h" +#include "util.h" +#include "cpm_map.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + + template + cpm_map::cpm_map(int min_i_in, int max_i_in, + fp_t fixed_point) + : min_i_(min_i_in), max_i_(max_i_in), + map_is_plus_(false) + { + const fp_t d_offset = 2.0 * fixed_point; + if (!fuzzy::is_integer(d_offset)) + then error_exit(ERROR_EXIT, + "***** cpm_map::cpm_map (mirror):\n" + " fixed_point=%g isn't (fuzzily) integral or half-integral!\n", + double(fixed_point)); /*NOTREACHED*/ + + offset_ = round::to_integer(d_offset); + + assert( + map_unchecked(fuzzy::floor(fixed_point)) == + fuzzy::ceiling(fixed_point)); + } + + //****************************************************************************** + + // + // This function constructs a generic cpm_map object, with the mapping + // specified by a sample point sample_i --> sample_j and by sign. + // The sample point need not be in the map's domain/range. + // + template + cpm_map::cpm_map(int min_i_in, int max_i_in, + int sample_i, int sample_j, + bool map_is_plus_in) + : min_i_(min_i_in), max_i_(max_i_in), + offset_(map_is_plus_in ? sample_j - sample_i + : sample_j + sample_i), + map_is_plus_(map_is_plus_in) + { + assert(map_unchecked(sample_i) == sample_j); + } + + //****************************************************************************** + + // + // This function constructs a generic cpm_map object, with the mapping + // specified by a *fp* sample point sample_i --> sample_j (which + // must specify an integer --> integer mapping, i.e. 4.2 --> 4.2 is + // ok for a + map, and 4.5 --> 4.5 is ok for a minus map, but 4.2 --> 4.7 + // is never ok) and by sign. The sample point need not be in the map's + // domain/range. + // + template + cpm_map::cpm_map(int min_i_in, int max_i_in, + fp_t sample_i, fp_t sample_j, + bool map_is_plus_in) + : min_i_(min_i_in), max_i_(max_i_in), + map_is_plus_(map_is_plus_in) + { + const fp_t fp_offset = map_is_plus_in ? sample_j - sample_i + : sample_j + sample_i; + if (!fuzzy::is_integer(fp_offset)) + then error_exit(ERROR_EXIT, + "***** cpm_map::cpm_map (generic via fp sample point):\n" + " fp_offset=%g isn't fuzzily integral!\n" + " ==> sample_i=%g --> sample_j=%g\n" + " doesn't fuzzily specify an integer --> integer mapping!\n", + double(fp_offset), + double(sample_i), double(sample_j)); /*NOTREACHED*/ + + offset_ = round::to_integer(fp_offset); + + // verify that we have setup correct + assert( + map_unchecked(fuzzy::floor(sample_i)) == + (map_is_plus_in ? fuzzy::floor(sample_j) + : fuzzy::ceiling(sample_j))); + } + + template class cpm_map; + template class cpm_map; + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/cpm_map.h b/AMSS_NCKU_source/AHF_Direct/cpm_map.h similarity index 96% rename from AMSS_NCKU_source/cpm_map.h rename to AMSS_NCKU_source/AHF_Direct/cpm_map.h index 92e0596..2f8d759 100644 --- a/AMSS_NCKU_source/cpm_map.h +++ b/AMSS_NCKU_source/AHF_Direct/cpm_map.h @@ -1,120 +1,120 @@ -#ifndef AHFINDERDIRECT__CPM_MAP_HH -#define AHFINDERDIRECT__CPM_MAP_HH -namespace AHFinderDirect -{ - namespace jtutil - { - - template - class cpm_map - { - public: - // bounds info -- domain - int min_i() const { return min_i_; } - int max_i() const { return max_i_; } - int N_points() const - { - return jtutil::how_many_in_range(min_i_, max_i_); - } - bool in_domain(int i) const { return (i >= min_i_) && (i <= max_i_); } - - // is the mapping + or - ? - bool is_plus() const { return map_is_plus_; } - bool is_minus() const { return !map_is_plus_; } - int sign() const { return map_is_plus_ ? +1 : -1; } - fp_t fp_sign() const { return map_is_plus_ ? +1.0 : -1.0; } - - // the mapping itself - int map_unchecked(int i) const - { - return map_is_plus_ ? offset_ + i - : offset_ - i; - } - int inv_map_unchecked(int j) const - { - return map_is_plus_ ? j - offset_ - : offset_ - j; - } - int map(int i) const - { - assert(in_domain(i)); - return map_unchecked(i); - } - int inv_map(int j) const - { - int i = inv_map_unchecked(j); - assert(in_domain(i)); - return i; - } - - // bounds info -- range - // ... we use the unchecked map here in case the domain is empty - int min_j() const - { - return map_is_plus_ ? map_unchecked(min_i_) - : map_unchecked(max_i_); - } - int max_j() const - { - return map_is_plus_ ? map_unchecked(max_i_) - : map_unchecked(min_i_); - } - bool in_range(int j) const { return in_domain(inv_map_unchecked(j)); } - - // - // constructors - // - - // "mirror" map: i --> const - i - // ... map specified by fixed point (must be integer or half-integer) - // ... fixed point need not be in domain/range - cpm_map(int min_i_in, int max_i_in, - fp_t fixed_point); - - // "shift" map: i --> const + i - // ... map specified by shift amount - // ... default is identity map - cpm_map(int min_i_in, int max_i_in, - int shift_amount = 0) - : min_i_(min_i_in), max_i_(max_i_in), - offset_(shift_amount), map_is_plus_(true) - { - } - - // generic map: i --> const +/- i - // ... map specified by sample point sample_i --> sample_j - // and by sign (one of {plus,minus}_map ) - // ... sample point need not be in domain/range - cpm_map(int min_i_in, int max_i_in, - int sample_i, int sample_j, - bool map_is_plus_in); - - // generic map: i --> const +/- i - // ... map specified by *fp* sample point sample_i --> sample_j - // (must specify an integer --> integer mapping) - // and by sign (one of {plus,minus}_map ) - // ... hence if sign is -1, then sample_i and sample_j - // must both be half-integral - // ... sample point need *not* be in domain/range - cpm_map(int min_i_in, int max_i_in, - fp_t sample_i, fp_t sample_j, - bool map_is_plus_in); - - // no need for explicit destructor, compiler-generated no-op is ok - // ditto for copy constructor and assignment operator - - private: - // bounds (inclusive) - int min_i_, max_i_; - - // these define the actual mapping - int offset_; - bool map_is_plus_; - }; - - //****************************************************************************** - - } // namespace jtutil -} // namespace AHFinderDirect - -#endif /* AHFINDERDIRECT__CPM_MAP_HH */ +#ifndef AHFINDERDIRECT__CPM_MAP_HH +#define AHFINDERDIRECT__CPM_MAP_HH +namespace AHFinderDirect +{ + namespace jtutil + { + + template + class cpm_map + { + public: + // bounds info -- domain + int min_i() const { return min_i_; } + int max_i() const { return max_i_; } + int N_points() const + { + return jtutil::how_many_in_range(min_i_, max_i_); + } + bool in_domain(int i) const { return (i >= min_i_) && (i <= max_i_); } + + // is the mapping + or - ? + bool is_plus() const { return map_is_plus_; } + bool is_minus() const { return !map_is_plus_; } + int sign() const { return map_is_plus_ ? +1 : -1; } + fp_t fp_sign() const { return map_is_plus_ ? +1.0 : -1.0; } + + // the mapping itself + int map_unchecked(int i) const + { + return map_is_plus_ ? offset_ + i + : offset_ - i; + } + int inv_map_unchecked(int j) const + { + return map_is_plus_ ? j - offset_ + : offset_ - j; + } + int map(int i) const + { + assert(in_domain(i)); + return map_unchecked(i); + } + int inv_map(int j) const + { + int i = inv_map_unchecked(j); + assert(in_domain(i)); + return i; + } + + // bounds info -- range + // ... we use the unchecked map here in case the domain is empty + int min_j() const + { + return map_is_plus_ ? map_unchecked(min_i_) + : map_unchecked(max_i_); + } + int max_j() const + { + return map_is_plus_ ? map_unchecked(max_i_) + : map_unchecked(min_i_); + } + bool in_range(int j) const { return in_domain(inv_map_unchecked(j)); } + + // + // constructors + // + + // "mirror" map: i --> const - i + // ... map specified by fixed point (must be integer or half-integer) + // ... fixed point need not be in domain/range + cpm_map(int min_i_in, int max_i_in, + fp_t fixed_point); + + // "shift" map: i --> const + i + // ... map specified by shift amount + // ... default is identity map + cpm_map(int min_i_in, int max_i_in, + int shift_amount = 0) + : min_i_(min_i_in), max_i_(max_i_in), + offset_(shift_amount), map_is_plus_(true) + { + } + + // generic map: i --> const +/- i + // ... map specified by sample point sample_i --> sample_j + // and by sign (one of {plus,minus}_map ) + // ... sample point need not be in domain/range + cpm_map(int min_i_in, int max_i_in, + int sample_i, int sample_j, + bool map_is_plus_in); + + // generic map: i --> const +/- i + // ... map specified by *fp* sample point sample_i --> sample_j + // (must specify an integer --> integer mapping) + // and by sign (one of {plus,minus}_map ) + // ... hence if sign is -1, then sample_i and sample_j + // must both be half-integral + // ... sample point need *not* be in domain/range + cpm_map(int min_i_in, int max_i_in, + fp_t sample_i, fp_t sample_j, + bool map_is_plus_in); + + // no need for explicit destructor, compiler-generated no-op is ok + // ditto for copy constructor and assignment operator + + private: + // bounds (inclusive) + int min_i_, max_i_; + + // these define the actual mapping + int offset_; + bool map_is_plus_; + }; + + //****************************************************************************** + + } // namespace jtutil +} // namespace AHFinderDirect + +#endif /* AHFINDERDIRECT__CPM_MAP_HH */ diff --git a/AMSS_NCKU_source/driver.h b/AMSS_NCKU_source/AHF_Direct/driver.h similarity index 95% rename from AMSS_NCKU_source/driver.h rename to AMSS_NCKU_source/AHF_Direct/driver.h index 39c6053..e90f8c0 100644 --- a/AMSS_NCKU_source/driver.h +++ b/AMSS_NCKU_source/AHF_Direct/driver.h @@ -1,108 +1,108 @@ -#ifndef DRIVER_H -#define DRIVER_H -#include -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -#include "horizon_sequence.h" -#include "BH_diagnostics.h" - -namespace AHFinderDirect -{ - struct iteration_status_buffers - { - int *hn_buffer; - int *iteration_buffer; - enum expansion_status *expansion_status_buffer; - fp *mean_horizon_radius_buffer; - fp *Theta_infinity_norm_buffer; - bool *found_horizon_buffer; - - jtutil::array2d *send_buffer_ptr; - jtutil::array2d *receive_buffer_ptr; - - iteration_status_buffers() - : hn_buffer(NULL), iteration_buffer(NULL), - expansion_status_buffer(NULL), - mean_horizon_radius_buffer(NULL), - Theta_infinity_norm_buffer(NULL), - found_horizon_buffer(NULL), - send_buffer_ptr(NULL), receive_buffer_ptr(NULL) - { - } - }; - - // - // This struct holds interprocessor-communication buffers for broadcasting - // the BH diagnostics and horizon shape from the processor which finds a - // given horizon, to all processors. - // - struct horizon_buffers - { - int N_buffer; - double *send_buffer; - double *receive_buffer; - - horizon_buffers() - : N_buffer(0), - send_buffer(NULL), - receive_buffer(NULL) - { - } - }; - // - struct AH_data - { - patch_system *ps_ptr; - Jacobian *Jac_ptr; - double surface_expansion; - - bool initial_find_flag; - bool recentering_flag, stop_finding, find_trigger; - - bool found_flag; // did we find this horizon (successfully) - - struct BH_diagnostics BH_diagnostics; - FILE *BH_diagnostics_fileptr; - - // interprocessor-communication buffers - // for this horizon's BH diagnostics and (optionally) horizon shape - struct horizon_buffers horizon_buffers; - }; - - // initial_guess.cc - void setup_initial_guess(patch_system &ps, - fp x_center, fp y_center, fp z_center, - fp x_radius, fp y_radius, fp z_radius); - - // Newton.cc - void Newton(int N_procs, int N_active_procs, int my_proc, - horizon_sequence &hs, struct AH_data *const AH_data_array[], - struct iteration_status_buffers &isb, int *dumpid, double *); - -} // namespace AHFinderDirect -#endif /* DRIVER_H */ +#ifndef DRIVER_H +#define DRIVER_H +#include +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +#include "horizon_sequence.h" +#include "BH_diagnostics.h" + +namespace AHFinderDirect +{ + struct iteration_status_buffers + { + int *hn_buffer; + int *iteration_buffer; + enum expansion_status *expansion_status_buffer; + fp *mean_horizon_radius_buffer; + fp *Theta_infinity_norm_buffer; + bool *found_horizon_buffer; + + jtutil::array2d *send_buffer_ptr; + jtutil::array2d *receive_buffer_ptr; + + iteration_status_buffers() + : hn_buffer(NULL), iteration_buffer(NULL), + expansion_status_buffer(NULL), + mean_horizon_radius_buffer(NULL), + Theta_infinity_norm_buffer(NULL), + found_horizon_buffer(NULL), + send_buffer_ptr(NULL), receive_buffer_ptr(NULL) + { + } + }; + + // + // This struct holds interprocessor-communication buffers for broadcasting + // the BH diagnostics and horizon shape from the processor which finds a + // given horizon, to all processors. + // + struct horizon_buffers + { + int N_buffer; + double *send_buffer; + double *receive_buffer; + + horizon_buffers() + : N_buffer(0), + send_buffer(NULL), + receive_buffer(NULL) + { + } + }; + // + struct AH_data + { + patch_system *ps_ptr; + Jacobian *Jac_ptr; + double surface_expansion; + + bool initial_find_flag; + bool recentering_flag, stop_finding, find_trigger; + + bool found_flag; // did we find this horizon (successfully) + + struct BH_diagnostics BH_diagnostics; + FILE *BH_diagnostics_fileptr; + + // interprocessor-communication buffers + // for this horizon's BH diagnostics and (optionally) horizon shape + struct horizon_buffers horizon_buffers; + }; + + // initial_guess.cc + void setup_initial_guess(patch_system &ps, + fp x_center, fp y_center, fp z_center, + fp x_radius, fp y_radius, fp z_radius); + + // Newton.cc + void Newton(int N_procs, int N_active_procs, int my_proc, + horizon_sequence &hs, struct AH_data *const AH_data_array[], + struct iteration_status_buffers &isb, int *dumpid, double *); + +} // namespace AHFinderDirect +#endif /* DRIVER_H */ diff --git a/AMSS_NCKU_source/error_exit.C b/AMSS_NCKU_source/AHF_Direct/error_exit.C similarity index 95% rename from AMSS_NCKU_source/error_exit.C rename to AMSS_NCKU_source/AHF_Direct/error_exit.C index b0eae77..b51295d 100644 --- a/AMSS_NCKU_source/error_exit.C +++ b/AMSS_NCKU_source/AHF_Direct/error_exit.C @@ -1,38 +1,38 @@ -#include -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - int error_exit(int msg_level, const char *format, ...) - { - const int N_buffer = 2000; - char buffer[N_buffer]; - - va_list ap; - va_start(ap, format); - vsnprintf(buffer, N_buffer, format, ap); - va_end(ap); - - const int len = strlen(buffer); - if ((len > 0) && (buffer[len - 1] == '\n')) - then buffer[len - 1] = '\0'; - - CCTK_VWarn(msg_level, __LINE__, __FILE__, CCTK_THORNSTRING, "%s", buffer); - - // if we got here, evidently msg_level wasn't drastic enough - abort(); /*NOTREACHED*/ - } - - //****************************************************************************** - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + int error_exit(int msg_level, const char *format, ...) + { + const int N_buffer = 2000; + char buffer[N_buffer]; + + va_list ap; + va_start(ap, format); + vsnprintf(buffer, N_buffer, format, ap); + va_end(ap); + + const int len = strlen(buffer); + if ((len > 0) && (buffer[len - 1] == '\n')) + then buffer[len - 1] = '\0'; + + CCTK_VWarn(msg_level, __LINE__, __FILE__, CCTK_THORNSTRING, "%s", buffer); + + // if we got here, evidently msg_level wasn't drastic enough + abort(); /*NOTREACHED*/ + } + + //****************************************************************************** + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/expansion.C b/AMSS_NCKU_source/AHF_Direct/expansion.C similarity index 98% rename from AMSS_NCKU_source/expansion.C rename to AMSS_NCKU_source/AHF_Direct/expansion.C index 44c5f3c..49ded1f 100644 --- a/AMSS_NCKU_source/expansion.C +++ b/AMSS_NCKU_source/AHF_Direct/expansion.C @@ -1,1682 +1,1682 @@ - - -#include "macrodef.h" -#ifdef With_AHF - -#include -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "myglobal.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -// all the code in this file is inside this namespace -namespace AHFinderDirect -{ - using jtutil::error_exit; - using jtutil::pow2; - using jtutil::pow4; - - namespace - { - - void setup_xyz_posns(patch_system &ps, bool print_msg_flag); - enum expansion_status - interpolate_geometry(patch_system *ps_ptr, - bool initial_flag, - bool print_msg_flag); - void convert_conformal_to_physical(patch_system &ps, - bool print_msg_flag); - - bool h_is_finite(patch_system &ps, bool initial_flag, - bool print_msg_flag); - bool geometry_is_finite(patch_system &ps, bool initial_flag, - bool print_msg_flag); - - bool compute_Theta(patch_system &ps, fp add_to_expansion, - bool Jacobian_flag, jtutil::norm *Theta_norms_ptr, - bool initial_flag, - bool print_msg_flag); - } - - extern struct state state; - //****************************************************************************** - enum expansion_status - expansion(patch_system *ps_ptr, fp add_to_expansion, - bool initial_flag, - bool Jacobian_flag /* = false */, - jtutil::norm *Theta_norms_ptr /* = NULL */) - { - const bool active_flag = (ps_ptr != NULL); - - if (active_flag) - then - { - // - // normal computation - // - - // fill in values of all ghosted gridfns in ghost zones - ps_ptr->synchronize(); - - if (!h_is_finite(*ps_ptr, initial_flag, false)) - then return expansion_failure__surface_nonfinite; - - // set up xyz positions of grid points - setup_xyz_posns(*ps_ptr, false); - } - - { - // this is the only function we call unconditionally; it looks at - // ps_ptr (non-NULL vs NULL) to choose a normal vs dummy computation - const enum expansion_status status = interpolate_geometry(ps_ptr, - initial_flag, - false); - - if (status != expansion_success) - then return status; // *** ERROR RETURN *** - if (active_flag) - convert_conformal_to_physical(*ps_ptr, false); - } - - if (active_flag) - then - { - if (!geometry_is_finite(*ps_ptr, initial_flag, false)) - then return expansion_failure__geometry_nonfinite; - - // compute remaining gridfns --> $\Theta$ - // and optionally also the Jacobian coefficients - // by algebraic ops and angular finite differencing - if (!compute_Theta(*ps_ptr, add_to_expansion, - Jacobian_flag, Theta_norms_ptr, - initial_flag, - false)) - then return expansion_failure__gij_not_positive_definite; - // *** ERROR RETURN *** - } - - return expansion_success; // *** NORMAL RETURN *** - } - - //****************************************************************************** - namespace - { - void setup_xyz_posns(patch_system &ps, bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " xyz positions and derivative coefficients"); - - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - - fp local_x, local_y, local_z; - p.xyz_of_r_rho_sigma(r, rho, sigma, local_x, local_y, local_z); - - const fp global_x = ps.origin_x() + local_x; - const fp global_y = ps.origin_y() + local_y; - const fp global_z = ps.origin_z() + local_z; - - p.gridfn(gfns::gfn__global_x, irho, isigma) = global_x; - p.gridfn(gfns::gfn__global_y, irho, isigma) = global_y; - p.gridfn(gfns::gfn__global_z, irho, isigma) = global_z; - - const fp global_xx = global_x * global_x; - const fp global_xy = global_x * global_y; - const fp global_xz = global_x * global_z; - const fp global_yy = global_y * global_y; - const fp global_yz = global_y * global_z; - const fp global_zz = global_z * global_z; - - p.gridfn(gfns::gfn__global_xx, irho, isigma) = global_xx; - p.gridfn(gfns::gfn__global_xy, irho, isigma) = global_xy; - p.gridfn(gfns::gfn__global_xz, irho, isigma) = global_xz; - p.gridfn(gfns::gfn__global_yy, irho, isigma) = global_yy; - p.gridfn(gfns::gfn__global_yz, irho, isigma) = global_yz; - p.gridfn(gfns::gfn__global_zz, irho, isigma) = global_zz; - } - } - } - } - } - - //****************************************************************************** - namespace - { - enum expansion_status - interpolate_geometry(patch_system *ps_ptr, - bool initial_flag, - bool print_msg_flag) - { - int status = 1; - -#define CAST_PTR_OR_NULL(type_, ptr_) \ - (ps_ptr == NULL) ? NULL : static_cast(ptr_) - - // - // ***** interpolation points ***** - // - const int N_interp_points = (ps_ptr == NULL) ? 0 : ps_ptr->N_grid_points(); - double *interp_coords[3] = { - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_x)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_y)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_z)), - }; - - double *const output_arrays[] = { - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_11)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_111)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_211)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_311)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_12)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_112)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_212)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_312)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_13)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_113)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_213)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_313)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_22)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_122)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_222)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_322)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_23)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_123)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_223)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_323)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_33)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_133)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_233)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_333)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__psi)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_psi_1)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_psi_2)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_psi_3)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_11)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_12)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_13)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_22)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_23)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_33)), - CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__trK)), - }; - - const int N_output_arrays_dim = sizeof(output_arrays) / sizeof(output_arrays[0]); - const int N_output_arrays_use = N_output_arrays_dim; - - int s; - int Npts = 0; - for (int ncpu = 0; ncpu < state.N_procs; ncpu++) - { - - if (state.my_proc == ncpu) - Npts = N_interp_points; - - MPI_Bcast(&Npts, 1, MPI_INT, ncpu, MPI_COMM_WORLD); - - if (Npts != 0) - { - if (state.my_proc == ncpu) - { - memcpy(state.oX, interp_coords[0], Npts * sizeof(double)); - memcpy(state.oY, interp_coords[1], Npts * sizeof(double)); - memcpy(state.oZ, interp_coords[2], Npts * sizeof(double)); - } - MPI_Bcast(state.oX, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); - MPI_Bcast(state.oY, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); - MPI_Bcast(state.oZ, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); - - // each cpu calls interpolator - s = globalInterpGFL(state.oX, state.oY, state.oZ, Npts, state.Data); // 1 succuss; 0 fail - - if (state.my_proc == ncpu) - { - status = s; - - if (status == 1) - { - for (int ngf = 0; ngf < N_output_arrays_use; ngf++) - { - memcpy(output_arrays[ngf], state.Data + ngf * N_interp_points, - sizeof(double) * N_interp_points); - } - } - else - { - char filename[100]; - sprintf(filename, "check%05d.dat", state.my_proc); - if (ps_ptr) - ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_11, true, gfns::gfn__h, filename); - // MPI_Abort(MPI_COMM_WORLD,1); - return expansion_failure__surface_outside_grid; - } - } - } - } - -#if 0 - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_11,true,gfns::gfn__h,"check.dat"); - char filename[100]; - sprintf(filename,"g311%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_311,true,gfns::gfn__h,filename); - sprintf(filename,"g12%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_12,true,gfns::gfn__h,filename); - sprintf(filename,"g112%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_112,true,gfns::gfn__h,filename); - sprintf(filename,"g212%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_212,true,gfns::gfn__h,filename); - sprintf(filename,"g312%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_312,true,gfns::gfn__h,filename); - sprintf(filename,"g13%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_13,true,gfns::gfn__h,filename); - sprintf(filename,"g113%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_113,true,gfns::gfn__h,filename); - sprintf(filename,"g213%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_213,true,gfns::gfn__h,filename); - sprintf(filename,"g313%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_313,true,gfns::gfn__h,filename); - sprintf(filename,"g22%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_22,true,gfns::gfn__h,filename); - sprintf(filename,"g122%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_122,true,gfns::gfn__h,filename); - sprintf(filename,"g222%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_222,true,gfns::gfn__h,filename); - sprintf(filename,"g322%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_322,true,gfns::gfn__h,filename); - sprintf(filename,"g23%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_23,true,gfns::gfn__h,filename); - sprintf(filename,"g123%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_123,true,gfns::gfn__h,filename); - sprintf(filename,"g223%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_223,true,gfns::gfn__h,filename); - sprintf(filename,"g323%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_323,true,gfns::gfn__h,filename); - sprintf(filename,"g33%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_33,true,gfns::gfn__h,filename); - sprintf(filename,"g133%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_133,true,gfns::gfn__h,filename); - sprintf(filename,"g233%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_233,true,gfns::gfn__h,filename); - sprintf(filename,"g333%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_333,true,gfns::gfn__h,filename); - sprintf(filename,"psi%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__psi,true,gfns::gfn__h,filename); - sprintf(filename,"psi1%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_psi_1,true,gfns::gfn__h,filename); - sprintf(filename,"psi2%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_psi_2,true,gfns::gfn__h,filename); - sprintf(filename,"psi3%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_psi_3,true,gfns::gfn__h,filename); - sprintf(filename,"K11%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_11,true,gfns::gfn__h,filename); - sprintf(filename,"K12%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_12,true,gfns::gfn__h,filename); - sprintf(filename,"K13%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_13,true,gfns::gfn__h,filename); - sprintf(filename,"K22%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_22,true,gfns::gfn__h,filename); - sprintf(filename,"K23%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_23,true,gfns::gfn__h,filename); - sprintf(filename,"K33%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_33,true,gfns::gfn__h,filename); - sprintf(filename,"trK%02d.dat",state.my_proc); - if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__trK,true,gfns::gfn__h,filename); - - MPI_Abort(MPI_COMM_WORLD,1); -#endif - - if (status == 0) - then error_exit(ERROR_EXIT, - "***** interpolate_geometry(): error return %d from interpolator!\n", - status); /*NOTREACHED*/ - - return expansion_success; // *** NORMAL RETURN *** - } - } - - //****************************************************************************** - namespace - { - void convert_conformal_to_physical(patch_system &ps, bool print_msg_flag) - { - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - for (int isigma = p.min_isigma(); isigma <= p.max_isigma(); ++isigma) - { - - const fp psi = (p.gridfn(gfns::gfn__psi, irho, isigma)); - const fp psi3 = jtutil::pow3(psi); - const fp psi4 = jtutil::pow4(psi); - - const fp partial_d_psi_1 = p.gridfn(gfns::gfn__partial_d_psi_1, irho, isigma); - const fp partial_d_psi_2 = p.gridfn(gfns::gfn__partial_d_psi_2, irho, isigma); - const fp partial_d_psi_3 = p.gridfn(gfns::gfn__partial_d_psi_3, irho, isigma); - - const fp stored_g_dd_11 = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); - const fp stored_g_dd_12 = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); - const fp stored_g_dd_13 = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); - const fp stored_g_dd_22 = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); - const fp stored_g_dd_23 = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); - const fp stored_g_dd_33 = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); - - p.gridfn(gfns::gfn__g_dd_11, irho, isigma) *= psi4; - p.gridfn(gfns::gfn__g_dd_12, irho, isigma) *= psi4; - p.gridfn(gfns::gfn__g_dd_13, irho, isigma) *= psi4; - p.gridfn(gfns::gfn__g_dd_22, irho, isigma) *= psi4; - p.gridfn(gfns::gfn__g_dd_23, irho, isigma) *= psi4; - p.gridfn(gfns::gfn__g_dd_33, irho, isigma) *= psi4; - - p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_11 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_12 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_13 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_22 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_23 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_33 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_11 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_12 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_13 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_22 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_23 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_33 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_11 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_12 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_13 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_22 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_23 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma); - p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_33 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma); - - // K_ij = psi4 \tilde{A}_ij + (1/3) g_ij TrK, g_ij = psi4 \tilde{g}_ij - const fp stored_trKo3 = p.gridfn(gfns::gfn__trK, irho, isigma) / 3.0; - const fp stored_K_dd_11 = p.gridfn(gfns::gfn__K_dd_11, irho, isigma); - const fp stored_K_dd_12 = p.gridfn(gfns::gfn__K_dd_12, irho, isigma); - const fp stored_K_dd_13 = p.gridfn(gfns::gfn__K_dd_13, irho, isigma); - const fp stored_K_dd_22 = p.gridfn(gfns::gfn__K_dd_22, irho, isigma); - const fp stored_K_dd_23 = p.gridfn(gfns::gfn__K_dd_23, irho, isigma); - const fp stored_K_dd_33 = p.gridfn(gfns::gfn__K_dd_33, irho, isigma); - - p.gridfn(gfns::gfn__K_dd_11, irho, isigma) = psi4 * - (stored_K_dd_11 + stored_g_dd_11 * stored_trKo3); - p.gridfn(gfns::gfn__K_dd_12, irho, isigma) = psi4 * - (stored_K_dd_12 + stored_g_dd_12 * stored_trKo3); - p.gridfn(gfns::gfn__K_dd_13, irho, isigma) = psi4 * - (stored_K_dd_13 + stored_g_dd_13 * stored_trKo3); - p.gridfn(gfns::gfn__K_dd_22, irho, isigma) = psi4 * - (stored_K_dd_22 + stored_g_dd_22 * stored_trKo3); - p.gridfn(gfns::gfn__K_dd_23, irho, isigma) = psi4 * - (stored_K_dd_23 + stored_g_dd_23 * stored_trKo3); - p.gridfn(gfns::gfn__K_dd_33, irho, isigma) = psi4 * - (stored_K_dd_33 + stored_g_dd_33 * stored_trKo3); - - } // end for irho isigma - } - } - } - - namespace - { - bool h_is_finite(patch_system &ps, bool initial_flag, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, " checking that h is finite"); - - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - const fp h = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - if (!finite(h)) - then - { - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - const fp drho = jtutil::degrees_of_radians(rho); - const fp dsigma = jtutil::degrees_of_radians(sigma); - CCTK_VWarn(1, - __LINE__, __FILE__, CCTK_THORNSTRING, - "\n" - " h=%g isn't finite!\n" - " %s patch (rho,sigma)=(%g,%g) (drho,dsigma)=(%g,%g)\n", - double(h), - p.name(), double(rho), double(sigma), - double(drho), double(dsigma)); - return false; // *** found a NaN *** - } - } - } - } - return true; // *** all values finite *** - } - } - - //****************************************************************************** - namespace - { - bool geometry_is_finite(patch_system &ps, bool initial_flag, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, " checking that geometry is finite"); - - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - const fp g_dd_11 = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); - const fp g_dd_12 = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); - const fp g_dd_13 = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); - const fp g_dd_22 = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); - const fp g_dd_23 = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); - const fp g_dd_33 = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); - - const fp K_dd_11 = p.gridfn(gfns::gfn__K_dd_11, irho, isigma); - const fp K_dd_12 = p.gridfn(gfns::gfn__K_dd_12, irho, isigma); - const fp K_dd_13 = p.gridfn(gfns::gfn__K_dd_13, irho, isigma); - const fp K_dd_22 = p.gridfn(gfns::gfn__K_dd_22, irho, isigma); - const fp K_dd_23 = p.gridfn(gfns::gfn__K_dd_23, irho, isigma); - const fp K_dd_33 = p.gridfn(gfns::gfn__K_dd_33, irho, isigma); - - const fp partial_d_g_dd_111 = p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma); - const fp partial_d_g_dd_112 = p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma); - const fp partial_d_g_dd_113 = p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma); - const fp partial_d_g_dd_122 = p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma); - const fp partial_d_g_dd_123 = p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma); - const fp partial_d_g_dd_133 = p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma); - const fp partial_d_g_dd_211 = p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma); - const fp partial_d_g_dd_212 = p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma); - const fp partial_d_g_dd_213 = p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma); - const fp partial_d_g_dd_222 = p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma); - const fp partial_d_g_dd_223 = p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma); - const fp partial_d_g_dd_233 = p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma); - const fp partial_d_g_dd_311 = p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma); - const fp partial_d_g_dd_312 = p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma); - const fp partial_d_g_dd_313 = p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma); - const fp partial_d_g_dd_322 = p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma); - const fp partial_d_g_dd_323 = p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma); - const fp partial_d_g_dd_333 = p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma); - - if (!finite(g_dd_11) || !finite(g_dd_12) || !finite(g_dd_13) || !finite(g_dd_22) || !finite(g_dd_23) || !finite(g_dd_33) || !finite(K_dd_11) || !finite(K_dd_12) || !finite(K_dd_13) || !finite(K_dd_22) || !finite(K_dd_23) || !finite(K_dd_33) || !finite(partial_d_g_dd_111) || !finite(partial_d_g_dd_112) || !finite(partial_d_g_dd_113) || !finite(partial_d_g_dd_122) || !finite(partial_d_g_dd_123) || !finite(partial_d_g_dd_133) || !finite(partial_d_g_dd_211) || !finite(partial_d_g_dd_212) || !finite(partial_d_g_dd_213) || !finite(partial_d_g_dd_222) || !finite(partial_d_g_dd_223) || !finite(partial_d_g_dd_233) || !finite(partial_d_g_dd_311) || !finite(partial_d_g_dd_312) || !finite(partial_d_g_dd_313) || !finite(partial_d_g_dd_322) || !finite(partial_d_g_dd_323) || !finite(partial_d_g_dd_333)) - then - { - const fp h = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - const fp drho = jtutil::degrees_of_radians(rho); - const fp dsigma = jtutil::degrees_of_radians(sigma); - fp local_x, local_y, local_z; - p.xyz_of_r_rho_sigma(h, rho, sigma, local_x, local_y, local_z); - const fp global_x = ps.origin_x() + local_x; - const fp global_y = ps.origin_y() + local_y; - const fp global_z = ps.origin_z() + local_z; - CCTK_VWarn(1, - __LINE__, __FILE__, CCTK_THORNSTRING, - "\n" - " geometry isn't finite at %s patch\n" - " h=%g (rho,sigma)=(%g,%g) (drho,dsigma)=(%g,%g)\n" - " local_(x,y,z)=(%g,%g,%g)\n" - " global_(x,y,z)=(%g,%g,%g)\n" - " g_dd_11=%g _12=%g _13=%g\n" - " _22=%g _23=%g _33=%g\n" - " K_dd_11=%g _12=%g _13=%g\n" - " _22=%g _23=%g _33=%g\n" - " partial_d_g_dd_111=%g _112=%g _113=%g\n" - " _122=%g _123=%g _133=%g\n" - " partial_d_g_dd_211=%g _212=%g _213=%g\n" - " _222=%g _223=%g _233=%g\n" - " partial_d_g_dd_311=%g _312=%g _313=%g\n" - " _322=%g _323=%g _333=%g\n", - p.name(), - double(h), double(rho), double(sigma), - double(drho), double(dsigma), - double(local_x), double(local_y), double(local_z), - double(global_x), double(global_y), double(global_z), - double(g_dd_11), double(g_dd_12), double(g_dd_13), - double(g_dd_22), double(g_dd_23), double(g_dd_33), - double(K_dd_11), double(K_dd_12), double(K_dd_13), - double(K_dd_22), double(K_dd_23), double(K_dd_33), - double(partial_d_g_dd_111), - double(partial_d_g_dd_112), - double(partial_d_g_dd_113), - double(partial_d_g_dd_122), - double(partial_d_g_dd_123), - double(partial_d_g_dd_133), - double(partial_d_g_dd_211), - double(partial_d_g_dd_212), - double(partial_d_g_dd_213), - double(partial_d_g_dd_222), - double(partial_d_g_dd_223), - double(partial_d_g_dd_233), - double(partial_d_g_dd_311), - double(partial_d_g_dd_312), - double(partial_d_g_dd_313), - double(partial_d_g_dd_322), - double(partial_d_g_dd_323), - double(partial_d_g_dd_333)); - return false; // *** found a NaN *** - } - } - } - } - return true; // *** no NaNs found *** - } - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function computes the expansion Theta(h), and optionally also - // its Jacobian coefficients, (from which the Jacobian matrix may be - // computed later). This function uses a mixture of algebraic operations - // and (rho,sigma) finite differencing. The computation is done entirely - // on the nominal angular grid. - // - // N.b. This function #includes "cg.hh", which defines "dangerous" macros - // which will stay in effect for the rest of this compilation unit! - // - // Arguments: - // Jacobian_flag = true to compute the Jacobian coefficients, - // false to skip this. - // - // Results: - // This function returns true for a successful computation, or false - // if the computation failed because Theta_D <= 0 (this means the interpolated - // g_ij isn't positive definite). - // - namespace - { - bool compute_Theta(patch_system &ps, fp add_to_expansion, - bool Jacobian_flag, jtutil::norm *Theta_norms_ptr, - bool initial_flag, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, " computing Theta(h)"); - - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - // - // compute the X_ud and X_udd derivative coefficients - // ... n.b. this uses the *local* (x,y,z) coordinates - // - const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - fp xx, yy, zz; - p.xyz_of_r_rho_sigma(r, rho, sigma, xx, yy, zz); - - // 1st derivative coefficients X_ud - const fp X_ud_11 = p.partial_rho_wrt_x(xx, yy, zz); - const fp X_ud_12 = p.partial_rho_wrt_y(xx, yy, zz); - const fp X_ud_13 = p.partial_rho_wrt_z(xx, yy, zz); - const fp X_ud_21 = p.partial_sigma_wrt_x(xx, yy, zz); - const fp X_ud_22 = p.partial_sigma_wrt_y(xx, yy, zz); - const fp X_ud_23 = p.partial_sigma_wrt_z(xx, yy, zz); - - // 2nd derivative coefficient gridfns X_udd - const fp X_udd_111 = p.partial2_rho_wrt_xx(xx, yy, zz); - const fp X_udd_112 = p.partial2_rho_wrt_xy(xx, yy, zz); - const fp X_udd_113 = p.partial2_rho_wrt_xz(xx, yy, zz); - const fp X_udd_122 = p.partial2_rho_wrt_yy(xx, yy, zz); - const fp X_udd_123 = p.partial2_rho_wrt_yz(xx, yy, zz); - const fp X_udd_133 = p.partial2_rho_wrt_zz(xx, yy, zz); - const fp X_udd_211 = p.partial2_sigma_wrt_xx(xx, yy, zz); - const fp X_udd_212 = p.partial2_sigma_wrt_xy(xx, yy, zz); - const fp X_udd_213 = p.partial2_sigma_wrt_xz(xx, yy, zz); - const fp X_udd_222 = p.partial2_sigma_wrt_yy(xx, yy, zz); - const fp X_udd_223 = p.partial2_sigma_wrt_yz(xx, yy, zz); - const fp X_udd_233 = p.partial2_sigma_wrt_zz(xx, yy, zz); - -#define RATIONAL(num, den) (num / den) - -#define PARTIAL_RHO(ghosted_gridfn_name) \ - p.partial_rho(gfns::gfn__##ghosted_gridfn_name, irho, isigma) -#define PARTIAL_SIGMA(ghosted_gridfn_name) \ - p.partial_sigma(gfns::gfn__##ghosted_gridfn_name, irho, isigma) -#define PARTIAL_RHO_RHO(ghosted_gridfn_name) \ - p.partial_rho_rho(gfns::gfn__##ghosted_gridfn_name, irho, isigma) -#define PARTIAL_RHO_SIGMA(ghosted_gridfn_name) \ - p.partial_rho_sigma(gfns::gfn__##ghosted_gridfn_name, irho, isigma) -#define PARTIAL_SIGMA_SIGMA(ghosted_gridfn_name) \ - p.partial_sigma_sigma(gfns::gfn__##ghosted_gridfn_name, irho, isigma) - -#define h p.ghosted_gridfn(gfns::gfn__h, irho, isigma) -#define r h - -#define g_dd_11 p.gridfn(gfns::gfn__g_dd_11, irho, isigma) -#define g_dd_12 p.gridfn(gfns::gfn__g_dd_12, irho, isigma) -#define g_dd_13 p.gridfn(gfns::gfn__g_dd_13, irho, isigma) -#define g_dd_22 p.gridfn(gfns::gfn__g_dd_22, irho, isigma) -#define g_dd_23 p.gridfn(gfns::gfn__g_dd_23, irho, isigma) -#define g_dd_33 p.gridfn(gfns::gfn__g_dd_33, irho, isigma) -#define K_dd_11 p.gridfn(gfns::gfn__K_dd_11, irho, isigma) -#define K_dd_12 p.gridfn(gfns::gfn__K_dd_12, irho, isigma) -#define K_dd_13 p.gridfn(gfns::gfn__K_dd_13, irho, isigma) -#define K_dd_22 p.gridfn(gfns::gfn__K_dd_22, irho, isigma) -#define K_dd_23 p.gridfn(gfns::gfn__K_dd_23, irho, isigma) -#define K_dd_33 p.gridfn(gfns::gfn__K_dd_33, irho, isigma) - -#define partial_d_g_dd_111 p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma) -#define partial_d_g_dd_112 p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma) -#define partial_d_g_dd_113 p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma) -#define partial_d_g_dd_122 p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma) -#define partial_d_g_dd_123 p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma) -#define partial_d_g_dd_133 p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma) -#define partial_d_g_dd_211 p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma) -#define partial_d_g_dd_212 p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma) -#define partial_d_g_dd_213 p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma) -#define partial_d_g_dd_222 p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma) -#define partial_d_g_dd_223 p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma) -#define partial_d_g_dd_233 p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma) -#define partial_d_g_dd_311 p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma) -#define partial_d_g_dd_312 p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma) -#define partial_d_g_dd_313 p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma) -#define partial_d_g_dd_322 p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma) -#define partial_d_g_dd_323 p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma) -#define partial_d_g_dd_333 p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma) - -#define Theta p.gridfn(gfns::gfn__Theta, irho, isigma) - -#define partial_Theta_wrt_partial_d_h_1 \ - p.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_1, irho, isigma) -#define partial_Theta_wrt_partial_d_h_2 \ - p.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_2, irho, isigma) -#define partial_Theta_wrt_partial_dd_h_11 \ - p.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_11, irho, isigma) -#define partial_Theta_wrt_partial_dd_h_12 \ - p.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_12, irho, isigma) -#define partial_Theta_wrt_partial_dd_h_22 \ - p.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_22, irho, isigma) - -#define save_Theta p.gridfn(gfns::gfn__save_Theta, irho, isigma) -#define Delta_h p.gridfn(gfns::gfn__Delta_h, irho, isigma) - - fp g_uu_11; - fp g_uu_12; - fp g_uu_13; - fp g_uu_22; - fp g_uu_23; - fp g_uu_33; - fp K; - fp K_uu_11; - fp K_uu_12; - fp K_uu_13; - fp K_uu_22; - fp K_uu_23; - fp K_uu_33; - - fp partial_d_ln_sqrt_g_1; - fp partial_d_ln_sqrt_g_2; - fp partial_d_ln_sqrt_g_3; - - fp partial_d_g_uu_111; - fp partial_d_g_uu_112; - fp partial_d_g_uu_113; - fp partial_d_g_uu_122; - fp partial_d_g_uu_123; - fp partial_d_g_uu_133; - fp partial_d_g_uu_211; - fp partial_d_g_uu_212; - fp partial_d_g_uu_213; - fp partial_d_g_uu_222; - fp partial_d_g_uu_223; - fp partial_d_g_uu_233; - fp partial_d_g_uu_311; - fp partial_d_g_uu_312; - fp partial_d_g_uu_313; - fp partial_d_g_uu_322; - fp partial_d_g_uu_323; - fp partial_d_g_uu_333; - - fp Theta_A; - fp Theta_B; - fp Theta_C; - fp Theta_D; - - { - // g_uu - fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; - fp t18, t21; - t1 = g_dd_22; - t2 = g_dd_33; - t4 = g_dd_23; - t5 = t4 * t4; - t7 = g_dd_11; - t8 = t7 * t1; - t11 = g_dd_12; - t12 = t11 * t11; - t14 = g_dd_13; - t15 = t11 * t14; - t18 = t14 * t14; - t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); - g_uu_11 = (t1 * t2 - t5) * t21; - g_uu_12 = -(t11 * t2 - t14 * t4) * t21; - g_uu_13 = -(-t11 * t4 + t14 * t1) * t21; - g_uu_22 = (t7 * t2 - t18) * t21; - g_uu_23 = -(t7 * t4 - t15) * t21; - g_uu_33 = (t8 - t12) * t21; - } - - { - // K, K_uu - fp t1, t2, t4, t5, t8, t9, t12, t13, t15, t16; - fp t19, t20, t22, t24, t27, t30, t32, t35, t42, t44; - fp t46, t48, t50, t60, t62, t69, t71, t74, t85, t95; - t1 = g_uu_11; - t2 = K_dd_11; - t4 = g_uu_12; - t5 = K_dd_12; - t8 = g_uu_13; - t9 = K_dd_13; - t12 = g_uu_22; - t13 = K_dd_22; - t15 = g_uu_23; - t16 = K_dd_23; - t19 = g_uu_33; - t20 = K_dd_33; - K = t1 * t2 + 2.0 * t4 * t5 + 2.0 * t8 * t9 + t12 * t13 + 2.0 * t15 * t16 + t19 * t20; - t22 = t1 * t1; - t24 = t4 * t1; - t27 = t8 * t1; - t30 = t4 * t4; - t32 = t8 * t4; - t35 = t8 * t8; - K_uu_11 = t22 * t2 + 2.0 * t24 * t5 + 2.0 * t27 * t9 + t30 * t13 + 2.0 * t32 * t16 + t35 * t20; - t42 = t4 * t12; - t44 = t8 * t12; - t46 = t1 * t15; - t48 = t15 * t4; - t50 = t8 * t15; - K_uu_12 = t24 * t2 + t30 * t5 + t32 * t9 + t1 * t12 * t5 + t42 * t13 + t44 * t16 + t46 * t9 + t48 * t16 + - t50 * t20; - t60 = t4 * t19; - t62 = t8 * t19; - K_uu_13 = t27 * t2 + t32 * t5 + t35 * t9 + t46 * t5 + t48 * t13 + t50 * t16 + t1 * t19 * t9 + t60 * t16 + - t62 * t20; - t69 = t12 * t12; - t71 = t15 * t12; - t74 = t15 * t15; - K_uu_22 = t30 * t2 + 2.0 * t42 * t5 + 2.0 * t48 * t9 + t69 * t13 + 2.0 * t71 * t16 + t74 * t20; - t85 = t15 * t19; - K_uu_23 = t32 * t2 + t44 * t5 + t50 * t9 + t48 * t5 + t71 * t13 + t74 * t16 + t60 * t9 + t12 * t19 * t16 + - t85 * t20; - t95 = t19 * t19; - K_uu_33 = t35 * t2 + 2.0 * t50 * t5 + 2.0 * t62 * t9 + t74 * t13 + 2.0 * t85 * t16 + t95 * t20; - } - - { - // partial_d_g_uu - fp t1, t2, t3, t5, t6, t7, t10, t11, t12, t15; - fp t16, t18, t19, t22, t23, t28, t29, t31, t33, t35; - fp t36, t38, t40, t48, t49, t51, t53, t60, t62, t65; - fp t74, t76, t86, t88, t90, t93, t96, t98, t101, t148; - fp t150, t153, t156, t158, t161; - t1 = g_uu_11; - t2 = t1 * t1; - t3 = partial_d_g_dd_111; - t5 = g_uu_12; - t6 = t5 * t1; - t7 = partial_d_g_dd_112; - t10 = g_uu_13; - t11 = t10 * t1; - t12 = partial_d_g_dd_113; - t15 = t5 * t5; - t16 = partial_d_g_dd_122; - t18 = t10 * t5; - t19 = partial_d_g_dd_123; - t22 = t10 * t10; - t23 = partial_d_g_dd_133; - partial_d_g_uu_111 = -t2 * t3 - 2.0 * t6 * t7 - 2.0 * t11 * t12 - t15 * t16 - 2.0 * t18 * t19 - t22 * t23; - t28 = g_uu_22; - t29 = t1 * t28; - t31 = t5 * t28; - t33 = t10 * t28; - t35 = g_uu_23; - t36 = t1 * t35; - t38 = t5 * t35; - t40 = t10 * t35; - partial_d_g_uu_112 = -t6 * t3 - t15 * t7 - t18 * t12 - t29 * t7 - t31 * t16 - t33 * t19 - t36 * t12 - t38 * t19 - t40 * t23; - t48 = g_uu_33; - t49 = t1 * t48; - t51 = t48 * t5; - t53 = t10 * t48; - partial_d_g_uu_113 = -t11 * t3 - t18 * t7 - t22 * t12 - t36 * t7 - t38 * t16 - t40 * t19 - t49 * t12 - t51 * t19 - t53 * t23; - t60 = t28 * t28; - t62 = t35 * t28; - t65 = t35 * t35; - partial_d_g_uu_122 = -t15 * t3 - 2.0 * t31 * t7 - 2.0 * t38 * t12 - t60 * t16 - 2.0 * t62 * t19 - - t65 * t23; - t74 = t28 * t48; - t76 = t35 * t48; - partial_d_g_uu_123 = -t18 * t3 - t33 * t7 - t40 * t12 - t38 * t7 - t62 * t16 - t65 * t19 - t51 * t12 - t74 * t19 - t76 * t23; - t86 = t48 * t48; - partial_d_g_uu_133 = -t22 * t3 - 2.0 * t40 * t7 - 2.0 * t53 * t12 - t65 * t16 - 2.0 * t76 * t19 - - t86 * t23; - t88 = partial_d_g_dd_211; - t90 = partial_d_g_dd_212; - t93 = partial_d_g_dd_213; - t96 = partial_d_g_dd_222; - t98 = partial_d_g_dd_223; - t101 = partial_d_g_dd_233; - partial_d_g_uu_211 = -t2 * t88 - 2.0 * t6 * t90 - 2.0 * t11 * t93 - t15 * t96 - 2.0 * t18 * t98 - - t22 * t101; - partial_d_g_uu_212 = -t6 * t88 - t15 * t90 - t18 * t93 - t29 * t90 - t31 * t96 - t33 * t98 - t36 * t93 - t38 * t98 - t40 * t101; - partial_d_g_uu_213 = -t11 * t88 - t18 * t90 - t22 * t93 - t36 * t90 - t38 * t96 - t40 * t98 - t49 * t93 - t51 * t98 - t53 * t101; - partial_d_g_uu_222 = -t15 * t88 - 2.0 * t31 * t90 - 2.0 * t38 * t93 - t60 * t96 - 2.0 * t62 * t98 - t65 * t101; - partial_d_g_uu_223 = -t18 * t88 - t33 * t90 - t40 * t93 - t38 * t90 - t62 * t96 - t65 * t98 - t51 * t93 - t74 * t98 - t76 * t101; - partial_d_g_uu_233 = -t22 * t88 - 2.0 * t40 * t90 - 2.0 * t53 * t93 - t65 * t96 - 2.0 * t76 * t98 - t86 * t101; - t148 = partial_d_g_dd_311; - t150 = partial_d_g_dd_312; - t153 = partial_d_g_dd_313; - t156 = partial_d_g_dd_322; - t158 = partial_d_g_dd_323; - t161 = partial_d_g_dd_333; - partial_d_g_uu_311 = -t2 * t148 - 2.0 * t6 * t150 - 2.0 * t11 * t153 - t15 * t156 - 2.0 * t18 * t158 - t22 * t161; - partial_d_g_uu_312 = -t6 * t148 - t15 * t150 - t18 * t153 - t29 * t150 - t31 * t156 - t33 * t158 - t36 * t153 - t38 * t158 - t40 * t161; - partial_d_g_uu_313 = -t11 * t148 - t18 * t150 - t22 * t153 - t36 * t150 - t38 * t156 - t40 * t158 - t49 * t153 - t51 * t158 - t53 * t161; - partial_d_g_uu_322 = -t15 * t148 - 2.0 * t31 * t150 - 2.0 * t38 * t153 - t60 * t156 - 2.0 * t62 * t158 - t65 * t161; - partial_d_g_uu_323 = -t18 * t148 - t33 * t150 - t40 * t153 - t38 * t150 - t62 * t156 - t65 * t158 - t51 * t153 - t74 * t158 - t76 * t161; - partial_d_g_uu_333 = -t22 * t148 - 2.0 * t40 * t150 - 2.0 * t53 * t153 - t65 * t156 - 2.0 * t76 * t158 - t86 * t161; - } - - { - // partial_d_ln_sqrt_g - fp t1, t5, t8, t11, t15, t18; - t1 = g_uu_11; - t5 = g_uu_12; - t8 = g_uu_13; - t11 = g_uu_22; - t15 = g_uu_23; - t18 = g_uu_33; - partial_d_ln_sqrt_g_1 = RATIONAL(1.0, 2.0) * t1 * partial_d_g_dd_111 + t5 * partial_d_g_dd_112 + t8 * partial_d_g_dd_113 + RATIONAL(1.0, 2.0) * t11 * partial_d_g_dd_122 + t15 * partial_d_g_dd_123 + RATIONAL(1.0, 2.0) * t18 * partial_d_g_dd_133; - partial_d_ln_sqrt_g_2 = RATIONAL(1.0, 2.0) * t1 * partial_d_g_dd_211 + t5 * partial_d_g_dd_212 + t8 * partial_d_g_dd_213 + RATIONAL(1.0, 2.0) * t11 * partial_d_g_dd_222 + t15 * partial_d_g_dd_223 + RATIONAL(1.0, 2.0) * t18 * partial_d_g_dd_233; - partial_d_ln_sqrt_g_3 = RATIONAL(1.0, 2.0) * t1 * partial_d_g_dd_311 + t5 * partial_d_g_dd_312 + t8 * partial_d_g_dd_313 + RATIONAL(1.0, 2.0) * t11 * partial_d_g_dd_322 + t15 * partial_d_g_dd_323 + RATIONAL(1.0, 2.0) * t18 * partial_d_g_dd_333; - } - - { - // Theta_A, Theta_B, Theta_C, Theta_D - fp t1, t2, t3, t5, t6, t8, t9, t11, t12, t14; - fp t15, t17, t19, t25, t26, t27, t29, t31, t34, t35; - fp t37, t39, t40, t42, t44, t46, t47, t49, t56, t61; - fp t63, t65, t66, t67, t82, t93, t98, t100, t102, t106; - fp t107, t110, t111, t112, t116, t119, t120, t121, t123, t124; - fp t127, t128, t129, t130, t131, t133, t134, t135, t137, t138; - fp t139, t141, t142, t143, t148, t149, t150, t153, t154, t155; - fp t158, t159, t160, t163, t164, t167, t168, t171, t172, t177; - fp t181, t182, t185, t186, t189, t191, t197, t198, t200, t205; - fp t220, t224, t232, t239, t266, t273, t276, t280, t283, t289; - fp t292, t302, t303, t306, t307, t310, t311, t314, t317, t326; - fp t330, t334, t337, t340, t343, t353, t355, t356, t360, t362; - fp t366, t382, t387, t394, t431, t440, t444, t447, t450, t465; - t1 = g_uu_13; - t2 = t1 * t1; - t3 = 1 / r; - t5 = X_ud_13; - t6 = PARTIAL_RHO(h); - t8 = X_ud_23; - t9 = PARTIAL_SIGMA(h); - t11 = zz * t3 - t5 * t6 - t8 * t9; - t12 = t11 * t11; - t14 = yy * yy; - t15 = zz * zz; - t17 = r * r; - t19 = 1 / t17 / r; - t25 = X_ud_11; - t26 = t25 * t25; - t27 = PARTIAL_RHO_RHO(h); - t29 = X_ud_21; - t31 = PARTIAL_RHO_SIGMA(h); - t34 = t29 * t29; - t35 = PARTIAL_SIGMA_SIGMA(h); - t37 = (t14 + t15) * t19 - X_udd_111 * t6 - X_udd_211 * t9 - t26 * t27 - 2.0 * t29 * t25 * t31 - t34 * t35; - t39 = g_uu_23; - t40 = t39 * t39; - t42 = X_ud_12; - t44 = X_ud_22; - t46 = yy * t3 - t42 * t6 - t44 * t9; - t47 = t46 * t46; - t49 = xx * xx; - t56 = t5 * t5; - t61 = t8 * t8; - t63 = (t49 + t14) * t19 - X_udd_133 * t6 - X_udd_233 * t9 - t56 * t27 - 2.0 * t8 * t5 * t31 - t61 * t35; - t65 = t1 * t11; - t66 = g_uu_22; - t67 = t66 * t46; - t82 = -xx * yy * t19 - X_udd_112 * t6 - X_udd_212 * t9 - t25 * t42 * t27 - t29 * t42 * t31 - t25 * t44 * t31 - t29 * t44 * t35; - t93 = t42 * t42; - t98 = t44 * t44; - t100 = (t49 + t15) * t19 - X_udd_122 * t6 - X_udd_222 * t9 - t93 * t27 - 2.0 * t44 * t42 * t31 - - t98 * t35; - t102 = t39 * t11; - t106 = t1 * t12; - t107 = partial_d_g_uu_123; - t110 = g_uu_12; - t111 = t110 * t47; - t112 = partial_d_g_uu_112; - t116 = xx * t3 - t25 * t6 - t29 * t9; - t119 = t66 * t47; - t120 = partial_d_g_uu_212; - t121 = t120 * t116; - t123 = t39 * t47; - t124 = partial_d_g_uu_312; - t127 = g_uu_11; - t128 = t116 * t116; - t129 = t127 * t128; - t130 = partial_d_g_uu_113; - t131 = t130 * t11; - t133 = t1 * t128; - t134 = partial_d_g_uu_313; - t135 = t134 * t11; - t137 = g_uu_33; - t138 = t137 * t12; - t139 = t134 * t116; - t141 = -t2 * t12 * t37 - t40 * t47 * t63 - 2.0 * t65 * t67 * t82 - t40 * t12 * t100 - 2.0 * t102 * t67 * t100 - t106 * t107 * t46 - t111 * t112 * t116 - t119 * t121 - t123 * t124 * t116 - t129 * t131 - t133 * t135 - - t138 * t139; - t142 = t39 * t12; - t143 = partial_d_g_uu_213; - t148 = t1 * t116; - t149 = partial_d_g_uu_322; - t150 = t149 * t47; - t153 = t110 * t116; - t154 = partial_d_g_uu_222; - t155 = t154 * t47; - t158 = t127 * t116; - t159 = partial_d_g_uu_122; - t160 = t159 * t47; - t163 = partial_d_g_uu_333; - t164 = t163 * t12; - t167 = partial_d_g_uu_133; - t168 = t167 * t12; - t171 = partial_d_g_uu_233; - t172 = t171 * t12; - t177 = t110 * t46; - t181 = partial_d_g_uu_323; - t182 = t181 * t11; - t185 = t137 * t11; - t186 = t124 * t46; - t189 = -t142 * t143 * t116 - t106 * t130 * t116 + RATIONAL(-1.0, 2.0) * t148 * t150 + - RATIONAL(-1.0, 2.0) * t153 * t155 + RATIONAL(-1.0, 2.0) * t158 * t160 + RATIONAL(-1.0, 2.0) * t148 * t164 + RATIONAL(-1.0, 2.0) * t158 * t168 + RATIONAL(-1.0, 2.0) * t153 * t172 + RATIONAL(-1.0, 2.0) * t65 * t160 - 2.0 * t65 * t177 * t37 - t148 * t182 * t46 - t185 * t186 * t116; - t191 = t127 * t127; - t197 = t110 * t128; - t198 = t143 * t11; - t200 = t137 * t137; - t205 = t39 * t46; - t220 = -xx * zz * t19 - X_udd_113 * t6 - X_udd_213 * t9 - t25 * t5 * t27 - t29 * t5 * t31 - t25 * t8 * t31 - t29 * t8 * t35; - t224 = t12 * t11; - t232 = t1 * t220; - t239 = -t191 * t128 * t37 - 2.0 * t142 * t1 * t82 - t197 * t198 - t200 * t12 * t63 - t177 * t131 * t116 - 2.0 * t65 * t205 * t220 + RATIONAL(-1.0, 2.0) * t39 * t224 * t171 - t67 * t198 * t116 - t205 * t135 * t116 - 2.0 * t138 * t232 + RATIONAL(-1.0, 2.0) * t205 * t164 + RATIONAL(-1.0, 2.0) * t177 * t168; - t266 = -yy * zz * t19 - X_udd_123 * t6 - X_udd_223 * t9 - t42 * t5 * t27 - t44 * t5 * t31 - t42 * t8 * t31 - t44 * t8 * t35; - t273 = t110 * t110; - t276 = t47 * t46; - t280 = t39 * t266; - t283 = t158 * t37; - t289 = t148 * t266; - t292 = RATIONAL(-1.0, 2.0) * t67 * t172 + RATIONAL(-1.0, 2.0) * t185 * t150 + RATIONAL(-1.0, 2.0) * t102 * t155 - 2.0 * t197 * t127 * t82 - 2.0 * t133 * t127 * t220 - 2.0 * t133 * t110 * t266 + - RATIONAL(-1.0, 2.0) * t1 * t224 * t167 - t273 * t128 * t100 + RATIONAL(-1.0, 2.0) * t39 * t276 * t149 - 2.0 * t138 * t280 - 2.0 * t65 * t283 + RATIONAL(-1.0, 2.0) * t110 * t276 * t159 - 2.0 * t67 * t289; - t302 = partial_d_g_uu_311; - t303 = t302 * t128; - t306 = partial_d_g_uu_211; - t307 = t306 * t128; - t310 = partial_d_g_uu_111; - t311 = t310 * t128; - t314 = t148 * t63; - t317 = t153 * t266; - t326 = t107 * t11; - t330 = RATIONAL(-1.0, 2.0) * t66 * t276 * t154 - 2.0 * t273 * t46 * t116 * t82 + RATIONAL(-1.0, 2.0) * t205 * t303 + RATIONAL(-1.0, 2.0) * t67 * t307 + RATIONAL(-1.0, 2.0) * t177 * t311 - 2.0 * t205 * t314 - 2.0 * t205 * t317 + RATIONAL(-1.0, 2.0) * t185 * t303 + RATIONAL(-1.0, 2.0) * t102 * t307 + RATIONAL(-1.0, 2.0) * t65 * t311 - t111 * t326 - t158 * t326 * t46; - t334 = t158 * t82; - t337 = t110 * t82; - t340 = t158 * t220; - t343 = t153 * t100; - t353 = t112 * t46; - t355 = partial_d_g_uu_223; - t356 = t355 * t11; - t360 = t120 * t46; - t362 = -2.0 * t177 * t148 * t220 - 2.0 * t67 * t334 - 2.0 * t119 * t337 - 2.0 * t205 * t340 - 2.0 * t67 * t343 + RATIONAL(-1.0, 2.0) * t137 * t224 * t163 - t2 * t128 * t63 - t273 * t47 * t37 - t129 * t353 - - t119 * t356 - t123 * t182 - t133 * t186 - t197 * t360; - t366 = t181 * t46; - t382 = t66 * t66; - t387 = t128 * t116; - t394 = -t142 * t355 * t46 - t138 * t366 - 2.0 * t177 * t283 - 2.0 * t123 * t110 * t220 - 2.0 * t123 * t66 * t266 - t153 * t356 * t46 - t65 * t353 * t116 - t102 * t360 * t116 - t382 * t47 * t100 - 2.0 * t185 * t317 + RATIONAL(-1.0, 2.0) * t127 * t387 * t310 + RATIONAL(-1.0, 2.0) * t110 * t387 * t306; - t431 = RATIONAL(-1.0, 2.0) * t1 * t387 * t302 - 2.0 * t2 * t11 * t116 * t220 - 2.0 * t185 * t314 - 2.0 * t102 * t289 - 2.0 * t65 * t153 * t82 - 2.0 * t185 * t205 * t63 - 2.0 * t40 * t11 * t46 * t266 - 2.0 * t102 * t343 - 2.0 * t102 * t334 - 2.0 * t185 * t340 - 2.0 * t102 * t177 * t82 - 2.0 * t185 * t67 * t266 - 2.0 * t185 * t177 * t220; - Theta_A = t141 + t189 + t239 + t292 + t330 + t362 + t394 + t431; - t440 = t310 * t116 + t121 + t139 + t353 + t154 * t46 + t366 + t131 + t356 + t163 * t11 + t127 * t37 + 2.0 * t337 + 2.0 * t232; - t444 = partial_d_ln_sqrt_g_1; - t447 = partial_d_ln_sqrt_g_2; - t450 = partial_d_ln_sqrt_g_3; - t465 = t66 * t100 + 2.0 * t280 + t137 * t63 + t127 * t444 * t116 + t110 * t447 * t116 + t1 * t450 * t116 + t110 * t444 * t46 + t66 * t447 * t46 + t39 * t450 * t46 + t1 * t444 * t11 + t39 * t447 * t11 + t137 * t450 * t11; - Theta_B = t440 + t465; - Theta_C = K_uu_11 * t128 + 2.0 * K_uu_12 * t46 * t116 + 2.0 * K_uu_13 * t11 * t116 + K_uu_22 * t47 + 2.0 * K_uu_23 * t11 * t46 + K_uu_33 * t12; - Theta_D = t129 + 2.0 * t177 * t116 + 2.0 * t65 * t116 + t119 + 2.0 * t102 * t46 + t138; - } - - if (Theta_D <= 0) - then - { - CCTK_VWarn(1, __LINE__, __FILE__, CCTK_THORNSTRING, - "\n" - " compute_Theta(): Theta_D = $g^{ij} s_i s_j$ = %g <= 0\n" - " at %s patch rho=%g sigma=%g!\n" - " (i.e. the interpolated g_ij isn't positive definite)", - double(Theta_D), - p.name(), double(rho), double(sigma)); - - cout << g_dd_11 << "," << g_dd_12 << "," << g_dd_13 << "," << g_dd_22 << "," << g_dd_23 << "," << g_dd_33 << endl; - cout << xx << "," << yy << "," << zz << endl; - return false; // *** ERROR RETURN *** - } - - // compute H via equation (14) of my 1996 horizon finding paper - const fp sqrt_Theta_D = sqrt(Theta_D); - Theta = +Theta_A / (Theta_D * sqrt_Theta_D) + Theta_B / sqrt_Theta_D + Theta_C / Theta_D - K + add_to_expansion; - - // update running norms of Theta(h) function - if (Theta_norms_ptr != NULL) - then Theta_norms_ptr->data(Theta); - - if (Jacobian_flag) - then - { - // partial_Theta_wrt_partial_d_h, - // partial_Theta_wrt_partial_dd_h - fp t1, t2, t3, t4, t5, t7, t8, t10, t11, t13; - fp t14, t16, t18, t20, t22, t24, t26, t28, t29, t31; - fp t32, t35, t37, t38, t41, t42, t43, t46, t48, t52; - fp t54, t55, t59, t60, t63, t67, t68, t69, t70, t71; - fp t74, t76, t78, t80, t83, t85, t86, t92, t93, t94; - fp t98, t99, t102, t103, t104, t107, t108, t112, t113, t114; - fp t115, t116, t118, t119, t120, t122, t123, t126, t127, t128; - fp t133, t136, t140, t141, t142, t143, t153, t156, t158, t160; - fp t162, t165, t167, t168, t171, t172, t173, t174, t179, t183; - fp t185, t189, t190, t193, t194, t195, t197, t198, t202, t205; - fp t208, t209, t212, t216, t217, t218, t220, t222, t223, t224; - fp t226, t227, t232, t235, t236, t237, t238, t240, t247, t248; - fp t249, t254, t259, t263, t266, t267, t275, t278, t281, t284; - fp t287, t288, t291, t296, t297, t298, t300, t307, t309, t311; - fp t314, t316, t317, t322, t325, t326, t329, t334, t335, t336; - fp t340, t346, t350, t351, t352, t354, t357, t358, t359, t361; - fp t364, t365, t366, t368, t370, t373, t374, t376, t381, t385; - fp t386, t392, t398, t401, t404, t405, t407, t408, t411, t414; - fp t416, t417, t419, t421, t422, t424, t428, t431, t432, t434; - fp t437, t440, t442, t449, t454, t458, t461, t467, t470, t471; - fp t474, t475, t481, t485, t489, t494, t498, t503, t504, t505; - fp t507, t514, t518, t534, t536, t542, t545, t548, t551, t552; - fp t559, t561, t562, t565, t569, t571, t572, t573, t575, t576; - fp t588, t589, t590, t593, t594, t599, t601, t605, t608, t609; - fp t612, t613, t627, t632, t633, t640, t644, t652, t656, t664; - fp t669, t672, t677, t678, t680, t694, t704, t707, t712, t716; - fp t723, t738, t741, t746, t748, t750, t774, t776, t780, t785; - fp t787, t792, t796, t797, t799, t800, t802, t803, t805, t807; - fp t809, t811, t813, t815, t817, t819, t822, t824, t827, t829; - fp t832, t835, t837, t840, t843, t847, t860, t869, t871, t876; - fp t882, t886, t890, t891, t897, t899, t900, t902, t904, t905; - fp t907, t913, t920, t929, t930, t933, t938, t944, t947, t949; - fp t962, t970, t971, t976, t979, t983, t996, t997, t1000, t1001; - fp t1004, t1010, t1012, t1015, t1033, t1036, t1039, t1047, t1048, t1050; - fp t1062, t1065, t1070, t1074, t1075, t1078, t1080, t1082, t1087, t1093; - fp t1095, t1097, t1103, t1107, t1112, t1114, t1138, t1139, t1141, t1145; - fp t1150, t1163, t1166, t1169, t1174, t1186, t1189, t1192, t1200, t1214; - fp t1234, t1266, t1281, t1289, t1300, t1301, t1308, t1335, t1342, t1345; - fp t1364, t1370, t1405, t1414, t1427, t1457, t1460, t1463, t1465, t1469; - fp t1475, t1476, t1477, t1483, t1486, t1487, t1491, t1492, t1493, t1497; - fp t1505, t1508, t1510, t1513, t1516, t1517, t1520, t1526, t1536, t1547; - fp t1552, t1555, t1558, t1561, t1572, t1580, t1594, t1600, t1606, t1610; - fp t1622, t1629, t1639, t1641, t1643, t1645, t1648, t1655, t1659, t1660; - fp t1666, t1667, t1684, t1697, t1704, t1718, t1721, t1739, t1748, t1751; - fp t1757, t1760, t1761, t1768, t1771, t1783, t1785, t1788, t1791, t1803; - fp t1809, t1812, t1825; - t1 = g_uu_13; - t2 = X_ud_13; - t3 = t1 * t2; - t4 = g_uu_12; - t5 = 1 / r; - t7 = X_ud_11; - t8 = PARTIAL_RHO(h); - t10 = X_ud_21; - t11 = PARTIAL_SIGMA(h); - t13 = xx * t5 - t7 * t8 - t10 * t11; - t14 = t4 * t13; - t16 = r * r; - t18 = 1 / t16 / r; - t20 = X_udd_112; - t22 = X_udd_212; - t24 = X_ud_12; - t26 = PARTIAL_RHO_RHO(h); - t28 = t10 * t24; - t29 = PARTIAL_RHO_SIGMA(h); - t31 = X_ud_22; - t32 = t7 * t31; - t35 = PARTIAL_SIGMA_SIGMA(h); - t37 = -xx * yy * t18 - t20 * t8 - t22 * t11 - t7 * t24 * t26 - t28 * t29 - t32 * t29 - t10 * t31 * t35; - t38 = t14 * t37; - t41 = g_uu_22; - t42 = t41 * t24; - t43 = t1 * t13; - t46 = X_udd_123; - t48 = X_udd_223; - t52 = t31 * t2; - t54 = X_ud_23; - t55 = t24 * t54; - t59 = -yy * zz * t18 - t46 * t8 - t48 * t11 - t24 * t2 * t26 - t52 * t29 - t55 * t29 - t31 * t54 * t35; - t60 = t43 * t59; - t63 = g_uu_23; - t67 = yy * t5 - t24 * t8 - t31 * t11; - t68 = t63 * t67; - t69 = t1 * t7; - t70 = xx * xx; - t71 = yy * yy; - t74 = X_udd_133; - t76 = X_udd_233; - t78 = t2 * t2; - t80 = t54 * t2; - t83 = t54 * t54; - t85 = (t70 + t71) * t18 - t74 * t8 - t76 * t11 - t78 * t26 - 2.0 * t80 * t29 - t83 * t35; - t86 = t69 * t85; - t92 = zz * t5 - t2 * t8 - t54 * t11; - t93 = t63 * t92; - t94 = t4 * t67; - t98 = t41 * t67; - t99 = t69 * t59; - t102 = g_uu_33; - t103 = t102 * t92; - t104 = t43 * t74; - t107 = t1 * t92; - t108 = t4 * t7; - t112 = g_uu_11; - t113 = t112 * t13; - t114 = partial_d_g_uu_123; - t115 = t114 * t2; - t116 = t115 * t67; - t118 = partial_d_g_uu_211; - t119 = t118 * t13; - t120 = t119 * t7; - t122 = t63 * t2; - t123 = t94 * t37; - t126 = partial_d_g_uu_122; - t127 = t126 * t67; - t128 = t127 * t24; - t133 = t98 * t37; - t136 = X_udd_113; - t140 = 2.0 * t3 * t38 + 2.0 * t42 * t60 + 2.0 * t68 * t86 + 2.0 * t93 * t94 * t20 + 2.0 * t98 * t99 + 2.0 * t103 * t104 + 2.0 * t107 * t108 * t37 + t113 * t116 + t93 * t120 + 2.0 * t122 * t123 + t113 * t128 + 2.0 * t107 * t14 * t20 + 2.0 * t3 * t133 + 2.0 * t107 * t68 * t136; - t141 = partial_d_g_uu_311; - t142 = t141 * t13; - t143 = t142 * t7; - t153 = zz * zz; - t156 = X_udd_122; - t158 = X_udd_222; - t160 = t24 * t24; - t162 = t31 * t24; - t165 = t31 * t31; - t167 = (t70 + t153) * t18 - t156 * t8 - t158 * t11 - t160 * t26 - 2.0 * t162 * t29 - t165 * t35; - t168 = t108 * t167; - t171 = t13 * t13; - t172 = t112 * t171; - t173 = partial_d_g_uu_112; - t174 = t173 * t24; - t179 = X_udd_213; - t183 = t10 * t2; - t185 = t7 * t54; - t189 = -xx * zz * t18 - t136 * t8 - t179 * t11 - t7 * t2 * t26 - t183 * t29 - t185 * t29 - t10 * t54 * t35; - t190 = t68 * t189; - t193 = t112 * t7; - t194 = t114 * t92; - t195 = t194 * t67; - t197 = t4 * t4; - t198 = t197 * t67; - t202 = t108 * t59; - t205 = t193 * t37; - t208 = t102 * t2; - t209 = t14 * t59; - t212 = t63 * t24; - t216 = t63 * t63; - t217 = t92 * t92; - t218 = t216 * t217; - t220 = t103 * t143 + 2.0 * t94 * t43 * t136 + 2.0 * t107 * t98 * t20 + 2.0 * t68 * t104 + 2.0 * t93 * t168 + t172 * t174 + 2.0 * t3 * t190 + t193 * t195 + 2.0 * t198 * t7 * t37 + 2.0 * t103 * t202 + 2.0 * t93 * t205 + 2.0 * t208 * t209 + 2.0 * t107 * t212 * t189 + t218 * t156; - t222 = t1 * t1; - t223 = t222 * t217; - t224 = X_udd_111; - t226 = t102 * t102; - t227 = t226 * t217; - t232 = t113 * t189; - t235 = t67 * t67; - t236 = t41 * t235; - t237 = partial_d_g_uu_223; - t238 = t237 * t2; - t240 = t194 * t24; - t247 = partial_d_g_uu_333; - t248 = t247 * t92; - t249 = t248 * t2; - t254 = t113 * t136; - t259 = t1 * t171; - t263 = t193 * t189; - t266 = t223 * t224 + t227 * t74 + 2.0 * t107 * t42 * t37 + 2.0 * t208 * t232 + t236 * t238 + t113 * t240 + 2.0 * t93 * t98 * t156 + 2.0 * t68 * t202 + t43 * t249 + 2.0 * t93 * t42 * t167 + 2.0 * t103 * t254 + 2.0 * t212 * t209 + 2.0 * t259 * t4 * t46 + 2.0 * t103 * t263; - t267 = t98 * t167; - t275 = t14 * t46; - t278 = t43 * t46; - t281 = t113 * t224; - t284 = t113 * t37; - t287 = t102 * t217; - t288 = t63 * t46; - t291 = t113 * t20; - t296 = partial_d_g_uu_312; - t297 = t296 * t67; - t298 = t297 * t13; - t300 = t222 * t92; - t307 = X_udd_211; - t309 = t7 * t7; - t311 = t10 * t7; - t314 = t10 * t10; - t316 = (t71 + t153) * t18 - t224 * t8 - t307 * t11 - t309 * t26 - 2.0 * t311 * t29 - t314 * t35; - t317 = t113 * t316; - t322 = 2.0 * t122 * t267 + 2.0 * t94 * t69 * t189 + 4.0 * t43 * t263 + 2.0 * t103 * t275 + 2.0 * t98 * t278 + 2.0 * t107 * t281 + 2.0 * t122 * t284 + 2.0 * t287 * t288 + 2.0 * t93 * t291 + 2.0 * t68 * t275 + t208 * t298 + 2.0 * t300 * t7 * t189 + 2.0 * t3 * t317 + 2.0 * t103 * t86; - t325 = t4 * t24; - t326 = t325 * t189; - t329 = t43 * t85; - t334 = partial_d_g_uu_313; - t335 = t334 * t92; - t336 = t335 * t13; - t340 = t335 * t7; - t346 = t63 * t59; - t350 = partial_d_g_uu_111; - t351 = t350 * t13; - t352 = t351 * t7; - t354 = t193 * t316; - t357 = partial_d_g_uu_113; - t358 = t357 * t2; - t359 = t358 * t13; - t361 = t94 * t189; - t364 = partial_d_g_uu_323; - t365 = t364 * t2; - t366 = t365 * t67; - t368 = 2.0 * t103 * t326 + 2.0 * t208 * t329 + 2.0 * t212 * t329 + t212 * t336 + 4.0 * t68 * t326 + - t68 * t340 + 2.0 * t93 * t278 + 4.0 * t43 * t202 + 4.0 * t103 * t346 * t2 + t94 * t352 + 2.0 * t107 * t354 + t94 * t359 + 2.0 * t208 * t361 + t43 * t366; - t370 = t41 * t59 * t24; - t373 = t357 * t92; - t374 = t373 * t13; - t376 = t1 * t189; - t381 = t63 * t235; - t385 = partial_d_g_uu_133; - t386 = t385 * t217; - t392 = t4 * t20; - t398 = t350 * t171; - t401 = t118 * t171; - t404 = t334 * t2; - t405 = t404 * t13; - t407 = t4 * t37; - t408 = t407 * t24; - t411 = t43 * t189; - t414 = 4.0 * t68 * t370 + t325 * t374 + 4.0 * t103 * t376 * t2 + t98 * t120 + 2.0 * t381 * t41 * t46 + - RATIONAL(1.0, 2.0) * t193 * t386 + 2.0 * t381 * t4 * t136 + 2.0 * t236 * t392 + 2.0 * t259 * t112 * t136 + - RATIONAL(1.0, 2.0) * t3 * t398 + RATIONAL(1.0, 2.0) * t122 * t401 + t68 * t405 + 4.0 * t98 * t408 + 2.0 * t325 * t411; - t416 = t364 * t92; - t417 = t416 * t67; - t419 = t297 * t7; - t421 = t296 * t24; - t422 = t421 * t13; - t424 = t1 * t37; - t428 = t94 * t316; - t431 = t41 * t41; - t432 = t431 * t235; - t434 = t126 * t235; - t437 = t247 * t217; - t440 = t416 * t24; - t442 = t373 * t7; - t449 = t431 * t67; - t454 = t69 * t417 + t103 * t419 + t103 * t422 + 4.0 * t93 * t424 * t2 + 2.0 * t3 * t428 + t432 * t156 + RATIONAL(1.0, 2.0) * t193 * t434 + RATIONAL(1.0, 2.0) * t69 * t437 + t43 * t440 + t94 * t442 + 2.0 * t300 * t13 * t136 + t381 * t296 * t7 + 2.0 * t449 * t167 * t24 + t259 * t421; - t458 = t350 * t7; - t461 = t4 * t235; - t467 = t13 * t189; - t470 = t237 * t92; - t471 = t470 * t24; - t474 = t385 * t92; - t475 = t474 * t2; - t481 = t13 * t37; - t485 = t67 * t59; - t489 = t238 * t67; - t494 = RATIONAL(3.0, 2.0) * t259 * t141 * t7 + RATIONAL(3.0, 2.0) * t172 * t458 + t461 * t115 + 2.0 * t198 * t13 * t20 + 2.0 * t222 * t2 * t467 + 2.0 * t98 * t471 + t113 * t475 + 2.0 * t107 * t94 * t224 + 2.0 * t197 * t24 * t481 + 2.0 * t216 * t2 * t485 + t68 * t249 + t14 * t489 + t107 * t128 + 2.0 * t93 * t99; - t498 = t470 * t67; - t503 = partial_d_g_uu_233; - t504 = t503 * t92; - t505 = t504 * t2; - t507 = t4 * t171; - t514 = t216 * t92; - t518 = t334 * t7; - t534 = t108 * t498 + 2.0 * t103 * t94 * t136 + t14 * t505 + RATIONAL(3.0, 2.0) * t507 * t118 * t7 + 2.0 * t107 * t325 * t316 + 2.0 * t514 * t24 * t59 + t287 * t518 + t259 * t404 + RATIONAL(3.0, 2.0) * t461 * t126 * t24 + 2.0 * t514 * t67 * t46 + RATIONAL(1.0, 2.0) * t3 * t434 + 2.0 * t68 * t440 + t172 * t358 + 2.0 * t68 * t422; - t536 = partial_d_g_uu_213; - t542 = t98 * t59; - t545 = t68 * t85; - t548 = t216 * t235; - t551 = t536 * t13; - t552 = t551 * t2; - t559 = t174 * t13; - t561 = t536 * t92; - t562 = t561 * t7; - t565 = t226 * t92; - t569 = t94 * t475 + t507 * t536 * t2 + 2.0 * t43 * t340 + t14 * t471 + 2.0 * t208 * t542 + 2.0 * t208 * t545 + t548 * t74 + t98 * t505 + 2.0 * t93 * t552 + 2.0 * t94 * t240 + 2.0 * t113 * t442 + t107 * t559 + 2.0 * t14 * t562 + 2.0 * t565 * t85 * t2; - t571 = partial_d_g_uu_322; - t572 = t571 * t67; - t573 = t572 * t24; - t575 = t173 * t67; - t576 = t575 * t13; - t588 = partial_d_g_uu_212; - t589 = t588 * t24; - t590 = t589 * t13; - t593 = t588 * t67; - t594 = t593 * t13; - t599 = t575 * t7; - t601 = t63 * t217; - t605 = t141 * t171; - t608 = t43 * t573 + t3 * t576 + 2.0 * t103 * t405 + 2.0 * t43 * t419 + t103 * t573 + 2.0 * t107 * t359 + 2.0 * t514 * t167 * t2 + t93 * t590 + t381 * t365 + t122 * t594 + 2.0 * t103 * t98 * t46 + t107 * t599 + - 2.0 * t601 * t1 * t20 + RATIONAL(1.0, 2.0) * t208 * t605; - t609 = t593 * t7; - t612 = partial_d_g_uu_222; - t613 = t612 * t24; - t627 = t588 * t7; - t632 = t612 * t67; - t633 = t632 * t24; - t640 = t216 * t67; - t644 = 2.0 * t14 * t609 + RATIONAL(3.0, 2.0) * t236 * t613 + t93 * t609 + 2.0 * t113 * t599 + - RATIONAL(1.0, 2.0) * t42 * t401 + 2.0 * t107 * t116 + RATIONAL(1.0, 2.0) * t325 * t398 + 2.0 * t103 * t366 + t236 * t627 + 2.0 * t103 * t212 * t85 + t14 * t633 + 2.0 * t93 * t489 + RATIONAL(3.0, 2.0) * t381 * t571 * t24 + 2.0 * t640 * t85 * t24; - t652 = t364 * t24; - t656 = t1 * t217; - t664 = t247 * t2; - t669 = t1 * t136; - t672 = t503 * t217; - t677 = t112 * t112; - t678 = t677 * t171; - t680 = 4.0 * t14 * t205 + 2.0 * t103 * t68 * t74 + t287 * t652 + t461 * t173 * t7 + t656 * t114 * t24 + t601 * t237 * t24 + t507 * t589 + t601 * t536 * t7 + RATIONAL(3.0, 2.0) * t287 * t664 + RATIONAL(1.0, 2.0) * t212 * t437 + 2.0 * t287 * t669 + RATIONAL(1.0, 2.0) * t108 * t672 + RATIONAL(1.0, 2.0) * t42 * t672 + t678 * t224; - t694 = t677 * t13; - t704 = t571 * t235; - t707 = t612 * t235; - t712 = t222 * t13; - t716 = 2.0 * t98 * t590 + 2.0 * t300 * t316 * t2 + 2.0 * t94 * t559 + t98 * t562 + 2.0 * t122 * t60 + - t93 * t633 + 2.0 * t103 * t370 + 2.0 * t694 * t316 * t7 + RATIONAL(3.0, 2.0) * t656 * t385 * t2 + RATIONAL(3.0, 2.0) * t601 * t503 * t2 + RATIONAL(1.0, 2.0) * t208 * t704 + RATIONAL(1.0, 2.0) * t122 * t707 + - RATIONAL(1.0, 2.0) * t69 * t704 + 2.0 * t712 * t85 * t7; - t723 = t197 * t13; - t738 = t14 * t167; - t741 = t14 * t156; - t746 = t561 * t13; - t748 = t197 * t235; - t750 = 2.0 * t198 * t316 * t24 + t656 * t357 * t7 + 2.0 * t723 * t167 * t7 + t68 * t143 + 2.0 * t507 * t112 * t20 + 2.0 * t94 * t354 + t98 * t552 + RATIONAL(1.0, 2.0) * t108 * t707 + RATIONAL(1.0, 2.0) * t212 * t605 + 2.0 * t122 * t738 + 2.0 * t98 * t741 + 2.0 * t93 * t408 + t42 * t746 + t748 * t224; - t774 = t197 * t171; - t776 = t222 * t171; - t780 = 2.0 * t94 * t281 + 2.0 * t42 * t284 + 2.0 * t98 * t168 + t107 * t352 + 2.0 * t212 * t232 + 2.0 * t93 * t741 + RATIONAL(1.0, 2.0) * t325 * t386 + 2.0 * t42 * t738 + 2.0 * t98 * t205 + 2.0 * t98 * t291 + - 2.0 * t325 * t317 + 2.0 * t68 * t254 + t774 * t156 + t776 * t74 + 2.0 * t68 * t263; - t785 = pow(Theta_D, 1.0 * RATIONAL(1.0, 2.0)); - t787 = 1 / t785 / Theta_D; - t792 = -t458 - t627 - t518 - t174 - t613 - t652 - t358 - t238 - t664 - t112 * t224 - 2.0 * t392 - 2.0 * t669; - t796 = partial_d_ln_sqrt_g_1; - t797 = t112 * t796; - t799 = partial_d_ln_sqrt_g_2; - t800 = t4 * t799; - t802 = partial_d_ln_sqrt_g_3; - t803 = t1 * t802; - t805 = t4 * t796; - t807 = t41 * t799; - t809 = t63 * t802; - t811 = t1 * t796; - t813 = t63 * t799; - t815 = t102 * t802; - t817 = -t41 * t156 - 2.0 * t288 - t102 * t74 - t797 * t7 - t800 * t7 - t803 * t7 - t805 * t24 - t807 * t24 - t809 * t24 - t811 * t2 - t813 * t2 - t815 * t2; - t819 = 1 / t785; - t822 = K_uu_11 * t13; - t824 = K_uu_12; - t827 = t824 * t67; - t829 = K_uu_13; - t832 = t829 * t92; - t835 = K_uu_22 * t67; - t837 = K_uu_23; - t840 = t837 * t92; - t843 = K_uu_33 * t92; - t847 = 1 / Theta_D; - t860 = Theta_D * Theta_D; - t869 = RATIONAL(3.0, 2.0) * Theta_A / t785 / t860 + RATIONAL(1.0, 2.0) * Theta_B * t787 + Theta_C / t860; - partial_Theta_wrt_partial_d_h_1 = (t140 + t220 + t266 + t322 + t368 + t414 + t454 + - t494 + t534 + t569 + t608 + t644 + t680 + t716 + t750 + t780) * - t787 + - (t792 + t817) * t819 + (-2.0 * t822 * t7 - 2.0 * t824 * t24 * t13 - 2.0 * t827 * t7 - 2.0 * t829 * t2 * t13 - 2.0 * t832 * t7 - 2.0 * t835 * t24 - 2.0 * t837 * t2 * t67 - 2.0 * t840 * t24 - 2.0 * t843 * t2) * t847 - (-2.0 * t113 * t7 - 2.0 * t325 * t13 - 2.0 * t94 * t7 - 2.0 * t3 * t13 - 2.0 * t107 * t7 - 2.0 * t98 * t24 - 2.0 * t122 * t67 - 2.0 * t93 * t24 - 2.0 * t103 * t2) * t869; - t871 = t113 * t22; - t876 = t63 * t54; - t882 = t551 * t54; - t886 = t561 * t10; - t890 = t112 * t10; - t891 = t890 * t316; - t897 = t334 * t10; - t899 = 2.0 * t93 * t871 + t381 * t296 * t10 + t876 * t594 + 2.0 * t93 * t94 * t22 + t432 * t158 + 2.0 * t93 * t882 + t218 * t158 + 2.0 * t14 * t886 + t748 * t307 + 2.0 * t94 * t891 + t890 * t195 + t548 * t76 + t223 * t307 + t287 * t897; - t900 = t194 * t31; - t902 = t334 * t54; - t904 = t114 * t54; - t905 = t904 * t67; - t907 = t63 * t31; - t913 = t102 * t54; - t920 = t14 * t48; - t929 = t4 * t10; - t930 = t929 * t59; - t933 = t335 * t10; - t938 = t113 * t900 + t259 * t902 + t113 * t905 + 2.0 * t907 * t209 + 2.0 * t300 * t13 * t179 + 2.0 * t913 * t545 + t507 * t536 * t54 + t601 * t536 * t10 + 2.0 * t68 * t920 + 2.0 * t712 * t85 * t10 + 2.0 * t449 * t167 * t31 + 2.0 * t68 * t930 + t68 * t933 + 2.0 * t197 * t31 * t481; - t944 = t1 * t54; - t947 = t588 * t31; - t949 = t113 * t307; - t962 = t364 * t54; - t970 = t4 * t31; - t971 = t970 * t189; - t976 = t913 * t298 + 2.0 * t103 * t907 * t85 + 2.0 * t944 * t317 + t507 * t947 + 2.0 * t107 * t949 + - RATIONAL(3.0, 2.0) * t507 * t118 * t10 + 2.0 * t259 * t4 * t48 + t259 * t296 * t31 + 2.0 * t107 * t891 + - t381 * t962 + 2.0 * t198 * t13 * t22 + 2.0 * t103 * t68 * t76 + 2.0 * t103 * t971 + 2.0 * t876 * t60; - t979 = t416 * t31; - t983 = t351 * t10; - t996 = t1 * t10; - t997 = t996 * t85; - t1000 = t41 * t31; - t1001 = t1000 * t59; - t1004 = t996 * t59; - t1010 = t142 * t10; - t1012 = 2.0 * t907 * t329 + t43 * t979 + 2.0 * t913 * t361 + t107 * t983 + 2.0 * t944 * t38 + 4.0 * t93 * t424 * t54 + 2.0 * t107 * t929 * t37 + 2.0 * t103 * t94 * t179 + 2.0 * t68 * t997 + 2.0 * t103 * t1001 + - 2.0 * t98 * t1004 + t970 * t374 + 2.0 * t913 * t542 + t103 * t1010; - t1015 = t119 * t10; - t1033 = t43 * t48; - t1036 = t297 * t10; - t1039 = t373 * t10; - t1047 = t357 * t54; - t1048 = t1047 * t13; - t1050 = t93 * t1015 + 2.0 * t107 * t1000 * t37 + 2.0 * t259 * t112 * t179 + 2.0 * t970 * t411 + 2.0 * t944 * t133 + 2.0 * t93 * t1004 + 2.0 * t103 * t98 * t48 + t774 * t158 + 2.0 * t98 * t1033 + 2.0 * t43 * t1036 + 2.0 * t113 * t1039 + 2.0 * t1000 * t60 + 2.0 * t94 * t43 * t179 + t94 * t1048; - t1062 = t43 * t76; - t1065 = t113 * t179; - t1070 = t470 * t31; - t1074 = t237 * t54; - t1075 = t1074 * t67; - t1078 = t504 * t54; - t1080 = t474 * t54; - t1082 = 2.0 * t107 * t98 * t22 + 2.0 * t94 * t996 * t189 + t98 * t1015 + 2.0 * t970 * t317 + 2.0 * t876 * t123 + 2.0 * t68 * t1062 + 2.0 * t68 * t1065 + 2.0 * t944 * t428 + t14 * t1070 + 2.0 * t94 * t949 + t14 * t1075 + t94 * t1039 + t14 * t1078 + t113 * t1080; - t1087 = t112 * t189 * t10; - t1093 = t248 * t54; - t1095 = t127 * t31; - t1097 = t572 * t31; - t1103 = t296 * t13 * t31; - t1107 = t407 * t31; - t1112 = t632 * t31; - t1114 = 4.0 * t43 * t930 + 4.0 * t43 * t1087 + t227 * t76 + 4.0 * t68 * t971 + t68 * t1093 + t107 * t1095 + t103 * t1097 + 4.0 * t68 * t1001 + t98 * t1078 + 2.0 * t68 * t1103 + t678 * t307 + 4.0 * t98 * t1107 + - RATIONAL(1.0, 2.0) * t1000 * t672 + t93 * t1112; - t1138 = t173 * t31; - t1139 = t1138 * t13; - t1141 = t4 * t22; - t1145 = 2.0 * t381 * t41 * t48 + 2.0 * t216 * t54 * t485 + t103 * t1103 + RATIONAL(1.0, 2.0) * t996 * t704 + t103 * t1036 + t601 * t237 * t31 + t172 * t1047 + RATIONAL(3.0, 2.0) * t601 * t503 * t54 + - 2.0 * t514 * t31 * t59 + 2.0 * t514 * t67 * t48 + t776 * t76 + t107 * t1139 + 2.0 * t236 * t1141 + t996 * t417; - t1150 = t593 * t10; - t1163 = t947 * t13; - t1166 = t962 * t67; - t1169 = t575 * t10; - t1174 = t944 * t576 + t93 * t1150 + 2.0 * t723 * t167 * t10 + RATIONAL(1.0, 2.0) * t890 * t386 + RATIONAL(1.0, 2.0) * t929 * t672 + RATIONAL(1.0, 2.0) * t944 * t434 + RATIONAL(1.0, 2.0) * t907 * t437 + t93 * t1163 + t98 * t882 + t43 * t1166 + t1000 * t746 + t107 * t1169 + t43 * t1097 + 2.0 * t107 * t1048; - t1186 = t112 * t37 * t10; - t1189 = t929 * t167; - t1192 = t14 * t158; - t1200 = t43 * t1093 + t907 * t336 + 2.0 * t98 * t1070 + t113 * t1095 + 2.0 * t113 * t1169 + t68 * t1010 + t98 * t886 + t94 * t1080 + 4.0 * t14 * t1186 + 2.0 * t93 * t1189 + 2.0 * t93 * t1192 + 2.0 * t913 * t232 + 2.0 * t876 * t738 + t14 * t1112; - t1214 = t902 * t13; - t1234 = 2.0 * t107 * t14 * t22 + 2.0 * t1000 * t738 + 2.0 * t876 * t267 + 2.0 * t107 * t68 * t179 + - 2.0 * t94 * t900 + t68 * t1214 + 2.0 * t103 * t920 + 2.0 * t944 * t190 + 2.0 * t68 * t1087 + 2.0 * t93 * t98 * t158 + 2.0 * t907 * t232 + 2.0 * t93 * t1000 * t167 + 2.0 * t98 * t1192 + 2.0 * t98 * t1189; - t1266 = 2.0 * t103 * t1065 + t94 * t983 + 2.0 * t1000 * t284 + 2.0 * t198 * t316 * t31 + 2.0 * t107 * t907 * t189 + RATIONAL(1.0, 2.0) * t890 * t434 + 2.0 * t103 * t1166 + 2.0 * t43 * t933 + 2.0 * t103 * t930 + 2.0 * t94 * t1139 + 2.0 * t98 * t1163 + 2.0 * t98 * t1186 + RATIONAL(3.0, 2.0) * t259 * t141 * t10 + - 2.0 * t222 * t54 * t467; - t1281 = t588 * t10; - t1289 = t247 * t54; - t1300 = 2.0 * t300 * t10 * t189 + RATIONAL(3.0, 2.0) * t656 * t385 * t54 + t461 * t904 + t172 * t1138 + t236 * t1074 + 2.0 * t694 * t316 * t10 + t236 * t1281 + RATIONAL(3.0, 2.0) * t381 * t571 * t31 + - RATIONAL(3.0, 2.0) * t461 * t126 * t31 + RATIONAL(3.0, 2.0) * t287 * t1289 + 2.0 * t103 * t1087 + 2.0 * t107 * t905 + 2.0 * t68 * t979 + 2.0 * t98 * t871; - t1301 = t612 * t31; - t1308 = t364 * t31; - t1335 = RATIONAL(3.0, 2.0) * t236 * t1301 + 2.0 * t93 * t1075 + 2.0 * t14 * t1150 + t287 * t1308 + t656 * t114 * t31 + t461 * t173 * t10 + RATIONAL(1.0, 2.0) * t1000 * t401 + t656 * t357 * t10 + - 2.0 * t300 * t316 * t54 + 2.0 * t507 * t112 * t22 + 2.0 * t640 * t85 * t31 + 2.0 * t601 * t1 * t22 + RATIONAL(1.0, 2.0) * t876 * t707 + 2.0 * t565 * t85 * t54; - t1342 = t63 * t48; - t1345 = t1 * t179; - t1364 = t350 * t10; - t1370 = RATIONAL(1.0, 2.0) * t913 * t704 + 2.0 * t514 * t167 * t54 + 2.0 * t287 * t1342 + 2.0 * t287 * t1345 + RATIONAL(1.0, 2.0) * t970 * t398 + RATIONAL(1.0, 2.0) * t996 * t437 + RATIONAL(1.0, 2.0) * t907 * t605 + RATIONAL(1.0, 2.0) * t944 * t398 + RATIONAL(1.0, 2.0) * t876 * t401 + - RATIONAL(1.0, 2.0) * t913 * t605 + RATIONAL(1.0, 2.0) * t929 * t707 + RATIONAL(1.0, 2.0) * t970 * t386 + RATIONAL(3.0, 2.0) * t172 * t1364 + 2.0 * t198 * t10 * t37; - t1405 = 4.0 * t103 * t376 * t54 + 2.0 * t103 * t1214 + 4.0 * t103 * t346 * t54 + 2.0 * t93 * t1107 + - 2.0 * t107 * t94 * t307 + 2.0 * t107 * t970 * t316 + 2.0 * t913 * t209 + 2.0 * t381 * t4 * t179 + t929 * t498 + - 2.0 * t93 * t1033 + 2.0 * t103 * t997 + 2.0 * t103 * t1062 + 2.0 * t913 * t329 + 2.0 * t876 * t284 + 2.0 * t93 * t1186; - t1414 = -t1364 - t1281 - t897 - t1138 - t1301 - t1308 - t1047 - t1074 - t1289 - t112 * t307 - 2.0 * t1141 - 2.0 * t1345; - t1427 = -t41 * t158 - 2.0 * t1342 - t102 * t76 - t797 * t10 - t800 * t10 - t803 * t10 - t805 * t31 - - t807 * t31 - t809 * t31 - t811 * t54 - t813 * t54 - t815 * t54; - partial_Theta_wrt_partial_d_h_2 = (t899 + t938 + t976 + t1012 + t1050 + t1082 + t1114 + t1145 + t1174 + t1200 + t1234 + t1266 + t1300 + t1335 + t1370 + t1405) * t787 + (t1414 + t1427) * t819 + (-2.0 * t822 * t10 - 2.0 * t824 * t31 * t13 - 2.0 * t827 * t10 - 2.0 * t829 * t54 * t13 - 2.0 * t832 * t10 - 2.0 * t835 * t31 - 2.0 * t837 * t54 * t67 - 2.0 * t840 * t31 - 2.0 * t843 * t54) * t847 - (-2.0 * t113 * t10 - 2.0 * t970 * t13 - 2.0 * t94 * t10 - 2.0 * t944 * t13 - 2.0 * t107 * t10 - 2.0 * t98 * t31 - 2.0 * t876 * t67 - 2.0 * t93 * t31 - 2.0 * t103 * t54) * t869; - t1457 = t14 * t160; - t1460 = t69 * t2; - t1463 = t68 * t4; - t1465 = t13 * t24 * t2; - t1469 = t43 * t78; - t1475 = t103 * t4; - t1476 = t67 * t7; - t1477 = t1476 * t2; - t1483 = t212 * t2; - t1486 = t107 * t41; - t1487 = t1476 * t24; - t1491 = 2.0 * t98 * t1457 + 2.0 * t287 * t1460 + 2.0 * t1463 * t1465 + t774 * t160 + 2.0 * t68 * t1469 + 2.0 * t107 * t94 * t309 + 2.0 * t1475 * t1477 + 2.0 * t381 * t108 * t2 + 2.0 * t287 * t1483 + 2.0 * t1486 * t1487 + t218 * t160; - t1492 = t13 * t7; - t1493 = t1492 * t24; - t1497 = t113 * t309; - t1505 = t98 * t1; - t1508 = t103 * t41; - t1510 = t67 * t24 * t2; - t1513 = t93 * t4; - t1516 = t94 * t1; - t1517 = t1492 * t2; - t1520 = t107 * t4; - t1526 = 2.0 * t198 * t1493 + t223 * t309 + 2.0 * t107 * t1497 + 2.0 * t259 * t193 * t2 + 2.0 * t93 * t1457 + 2.0 * t1505 * t1465 + 2.0 * t1508 * t1510 + 2.0 * t1513 * t1487 + 2.0 * t1516 * t1517 + 2.0 * t1520 * t1493 + 2.0 * t103 * t68 * t78; - t1536 = t93 * t112; - t1547 = t93 * t1; - t1552 = t432 * t160 + 2.0 * t93 * t98 * t160 + t548 * t78 + 2.0 * t514 * t1510 + t748 * t309 + 2.0 * t1536 * t1493 + 2.0 * t300 * t1517 + 2.0 * t381 * t42 * t2 + 2.0 * t507 * t193 * t24 + 2.0 * t1547 * t1465 + - 2.0 * t1475 * t1465; - t1555 = t103 * t112; - t1558 = t98 * t112; - t1561 = t108 * t24; - t1572 = t68 * t112; - t1580 = 2.0 * t1547 * t1477 + 2.0 * t1555 * t1517 + 2.0 * t1558 * t1493 + 2.0 * t236 * t1561 + - 2.0 * t259 * t325 * t2 + t776 * t78 + t678 * t309 + t227 * t78 + 2.0 * t94 * t1497 + 2.0 * t1572 * t1517 + 2.0 * t103 * t1469 + 2.0 * t601 * t69 * t24; - partial_Theta_wrt_partial_dd_h_11 = (t1491 + t1526 + t1552 + t1580) * t787 + (-t112 * t309 - 2.0 * t1561 - 2.0 * t1460 - t41 * t160 - 2.0 * t1483 - t102 * t78) * t819; - t1594 = -t183 - t185; - t1600 = t67 * t10; - t1606 = -t28 - t32; - t1610 = t1 * t1594; - t1622 = 2.0 * t218 * t162 - 2.0 * t107 * t68 * t1594 + 2.0 * t432 * t162 + 4.0 * t1520 * t1600 * t7 + 2.0 * t776 * t80 - 2.0 * t601 * t1 * t1606 - 2.0 * t287 * t1610 + 2.0 * t223 * t311 + 2.0 * t748 * t311 - 2.0 * t93 * t94 * t1606 + 2.0 * t774 * t162; - t1629 = -t52 - t55; - t1639 = t113 * t1606; - t1641 = t113 * t1594; - t1643 = t14 * t1629; - t1645 = -t381 * t4 * t1594 - t300 * t13 * t1594 - t107 * t98 * t1606 - t259 * t4 * t1629 - t103 * t94 * t1594 - t107 * t14 * t1606 + t678 * t311 - t507 * t112 * t1606 - t93 * t1639 - t103 * t1641 - t103 * t1643; - t1648 = t43 * t1629; - t1655 = t13 * t54 * t2; - t1659 = t13 * t10; - t1660 = t1659 * t7; - t1666 = t13 * t31; - t1667 = t1666 * t24; - t1684 = -2.0 * t93 * t1648 + 2.0 * t227 * t80 + 4.0 * t103 * t1 * t1655 + 4.0 * t94 * t112 * t1660 - 2.0 * t198 * t13 * t1606 + 4.0 * t1513 * t1667 - 2.0 * t514 * t67 * t1629 - 2.0 * t94 * t43 * t1594 + 4.0 * t68 * t1 * t1655 + 4.0 * t98 * t4 * t1667 - 2.0 * t98 * t1639; - t1697 = t4 * t1606; - t1704 = t67 * t31; - t1718 = t63 * t1629; - t1721 = -2.0 * t259 * t112 * t1594 - 2.0 * t68 * t1643 - 2.0 * t68 * t1641 - 2.0 * t98 * t1648 + - 4.0 * t107 * t112 * t1660 - 2.0 * t236 * t1697 - 2.0 * t381 * t41 * t1629 + 4.0 * t93 * t41 * t1704 * t24 - 2.0 * t103 * t98 * t1629 + 2.0 * t548 * t80 + 4.0 * t103 * t63 * t67 * t54 * t2 - 2.0 * t287 * t1718; - partial_Theta_wrt_partial_dd_h_12 = (t1622 + 2.0 * t1645 + t1684 + t1721) * t787 + (-2.0 * t890 * t7 + 2.0 * t1697 + 2.0 * t1610 - 2.0 * t1000 * t24 + 2.0 * t1718 - 2.0 * t913 * t2) * t819; - t1739 = t996 * t54; - t1748 = t1704 * t54; - t1751 = t1600 * t54; - t1757 = t1600 * t31; - t1760 = 2.0 * t507 * t890 * t31 + 2.0 * t93 * t98 * t165 + t227 * t83 + t548 * t83 + 2.0 * t287 * t1739 + 2.0 * t259 * t970 * t54 + 2.0 * t601 * t996 * t31 + 2.0 * t514 * t1748 + 2.0 * t1547 * t1751 + 2.0 * t107 * t94 * t314 + 2.0 * t1486 * t1757; - t1761 = t907 * t54; - t1768 = t1659 * t31; - t1771 = t113 * t314; - t1783 = 2.0 * t287 * t1761 + t748 * t314 + t774 * t165 + t678 * t314 + t223 * t314 + 2.0 * t198 * t1768 + 2.0 * t94 * t1771 + 2.0 * t1513 * t1757 + 2.0 * t1520 * t1768 + 2.0 * t1475 * t1751 + 2.0 * t103 * t68 * t83; - t1785 = t1666 * t54; - t1788 = t1659 * t54; - t1791 = t43 * t83; - t1803 = t14 * t165; - t1809 = 2.0 * t1547 * t1785 + 2.0 * t1516 * t1788 + 2.0 * t68 * t1791 + 2.0 * t1558 * t1768 + 2.0 * t259 * t890 * t54 + 2.0 * t107 * t1771 + 2.0 * t1463 * t1785 + 2.0 * t98 * t1803 + t218 * t165 + t776 * t83 + - t432 * t165; - t1812 = t929 * t31; - t1825 = t1572 * t1788 + t1505 * t1785 + t236 * t1812 + t103 * t1791 + t300 * t1788 + t381 * t1000 * t54 + t381 * t929 * t54 + t93 * t1803 + t1555 * t1788 + t1536 * t1768 + t1475 * t1785 + t1508 * t1748; - partial_Theta_wrt_partial_dd_h_22 = (t1760 + t1783 + t1809 + 2.0 * t1825) * t787 + (-t112 * t314 - 2.0 * t1812 - 2.0 * t1739 - t41 * t165 - 2.0 * t1761 - t102 * t83) * t819; - } - } - } - } - - return true; // *** NORMAL RETURN *** - } - } - -} // namespace AHFinderDirect -#endif + + +#include "macrodef.h" +#ifdef With_AHF + +#include +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "myglobal.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +// all the code in this file is inside this namespace +namespace AHFinderDirect +{ + using jtutil::error_exit; + using jtutil::pow2; + using jtutil::pow4; + + namespace + { + + void setup_xyz_posns(patch_system &ps, bool print_msg_flag); + enum expansion_status + interpolate_geometry(patch_system *ps_ptr, + bool initial_flag, + bool print_msg_flag); + void convert_conformal_to_physical(patch_system &ps, + bool print_msg_flag); + + bool h_is_finite(patch_system &ps, bool initial_flag, + bool print_msg_flag); + bool geometry_is_finite(patch_system &ps, bool initial_flag, + bool print_msg_flag); + + bool compute_Theta(patch_system &ps, fp add_to_expansion, + bool Jacobian_flag, jtutil::norm *Theta_norms_ptr, + bool initial_flag, + bool print_msg_flag); + } + + extern struct state state; + //****************************************************************************** + enum expansion_status + expansion(patch_system *ps_ptr, fp add_to_expansion, + bool initial_flag, + bool Jacobian_flag /* = false */, + jtutil::norm *Theta_norms_ptr /* = NULL */) + { + const bool active_flag = (ps_ptr != NULL); + + if (active_flag) + then + { + // + // normal computation + // + + // fill in values of all ghosted gridfns in ghost zones + ps_ptr->synchronize(); + + if (!h_is_finite(*ps_ptr, initial_flag, false)) + then return expansion_failure__surface_nonfinite; + + // set up xyz positions of grid points + setup_xyz_posns(*ps_ptr, false); + } + + { + // this is the only function we call unconditionally; it looks at + // ps_ptr (non-NULL vs NULL) to choose a normal vs dummy computation + const enum expansion_status status = interpolate_geometry(ps_ptr, + initial_flag, + false); + + if (status != expansion_success) + then return status; // *** ERROR RETURN *** + if (active_flag) + convert_conformal_to_physical(*ps_ptr, false); + } + + if (active_flag) + then + { + if (!geometry_is_finite(*ps_ptr, initial_flag, false)) + then return expansion_failure__geometry_nonfinite; + + // compute remaining gridfns --> $\Theta$ + // and optionally also the Jacobian coefficients + // by algebraic ops and angular finite differencing + if (!compute_Theta(*ps_ptr, add_to_expansion, + Jacobian_flag, Theta_norms_ptr, + initial_flag, + false)) + then return expansion_failure__gij_not_positive_definite; + // *** ERROR RETURN *** + } + + return expansion_success; // *** NORMAL RETURN *** + } + + //****************************************************************************** + namespace + { + void setup_xyz_posns(patch_system &ps, bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " xyz positions and derivative coefficients"); + + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + + fp local_x, local_y, local_z; + p.xyz_of_r_rho_sigma(r, rho, sigma, local_x, local_y, local_z); + + const fp global_x = ps.origin_x() + local_x; + const fp global_y = ps.origin_y() + local_y; + const fp global_z = ps.origin_z() + local_z; + + p.gridfn(gfns::gfn__global_x, irho, isigma) = global_x; + p.gridfn(gfns::gfn__global_y, irho, isigma) = global_y; + p.gridfn(gfns::gfn__global_z, irho, isigma) = global_z; + + const fp global_xx = global_x * global_x; + const fp global_xy = global_x * global_y; + const fp global_xz = global_x * global_z; + const fp global_yy = global_y * global_y; + const fp global_yz = global_y * global_z; + const fp global_zz = global_z * global_z; + + p.gridfn(gfns::gfn__global_xx, irho, isigma) = global_xx; + p.gridfn(gfns::gfn__global_xy, irho, isigma) = global_xy; + p.gridfn(gfns::gfn__global_xz, irho, isigma) = global_xz; + p.gridfn(gfns::gfn__global_yy, irho, isigma) = global_yy; + p.gridfn(gfns::gfn__global_yz, irho, isigma) = global_yz; + p.gridfn(gfns::gfn__global_zz, irho, isigma) = global_zz; + } + } + } + } + } + + //****************************************************************************** + namespace + { + enum expansion_status + interpolate_geometry(patch_system *ps_ptr, + bool initial_flag, + bool print_msg_flag) + { + int status = 1; + +#define CAST_PTR_OR_NULL(type_, ptr_) \ + (ps_ptr == NULL) ? NULL : static_cast(ptr_) + + // + // ***** interpolation points ***** + // + const int N_interp_points = (ps_ptr == NULL) ? 0 : ps_ptr->N_grid_points(); + double *interp_coords[3] = { + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_x)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_y)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__global_z)), + }; + + double *const output_arrays[] = { + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_11)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_111)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_211)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_311)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_12)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_112)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_212)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_312)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_13)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_113)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_213)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_313)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_22)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_122)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_222)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_322)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_23)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_123)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_223)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_323)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__g_dd_33)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_133)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_233)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_g_dd_333)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__psi)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_psi_1)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_psi_2)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__partial_d_psi_3)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_11)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_12)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_13)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_22)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_23)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__K_dd_33)), + CAST_PTR_OR_NULL(double *, ps_ptr->gridfn_data(gfns::gfn__trK)), + }; + + const int N_output_arrays_dim = sizeof(output_arrays) / sizeof(output_arrays[0]); + const int N_output_arrays_use = N_output_arrays_dim; + + int s; + int Npts = 0; + for (int ncpu = 0; ncpu < state.N_procs; ncpu++) + { + + if (state.my_proc == ncpu) + Npts = N_interp_points; + + MPI_Bcast(&Npts, 1, MPI_INT, ncpu, MPI_COMM_WORLD); + + if (Npts != 0) + { + if (state.my_proc == ncpu) + { + memcpy(state.oX, interp_coords[0], Npts * sizeof(double)); + memcpy(state.oY, interp_coords[1], Npts * sizeof(double)); + memcpy(state.oZ, interp_coords[2], Npts * sizeof(double)); + } + MPI_Bcast(state.oX, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); + MPI_Bcast(state.oY, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); + MPI_Bcast(state.oZ, Npts, MPI_DOUBLE, ncpu, MPI_COMM_WORLD); + + // each cpu calls interpolator + s = globalInterpGFL(state.oX, state.oY, state.oZ, Npts, state.Data); // 1 succuss; 0 fail + + if (state.my_proc == ncpu) + { + status = s; + + if (status == 1) + { + for (int ngf = 0; ngf < N_output_arrays_use; ngf++) + { + memcpy(output_arrays[ngf], state.Data + ngf * N_interp_points, + sizeof(double) * N_interp_points); + } + } + else + { + char filename[100]; + sprintf(filename, "check%05d.dat", state.my_proc); + if (ps_ptr) + ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_11, true, gfns::gfn__h, filename); + // MPI_Abort(MPI_COMM_WORLD,1); + return expansion_failure__surface_outside_grid; + } + } + } + } + +#if 0 + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_11,true,gfns::gfn__h,"check.dat"); + char filename[100]; + sprintf(filename,"g311%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_311,true,gfns::gfn__h,filename); + sprintf(filename,"g12%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_12,true,gfns::gfn__h,filename); + sprintf(filename,"g112%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_112,true,gfns::gfn__h,filename); + sprintf(filename,"g212%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_212,true,gfns::gfn__h,filename); + sprintf(filename,"g312%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_312,true,gfns::gfn__h,filename); + sprintf(filename,"g13%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_13,true,gfns::gfn__h,filename); + sprintf(filename,"g113%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_113,true,gfns::gfn__h,filename); + sprintf(filename,"g213%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_213,true,gfns::gfn__h,filename); + sprintf(filename,"g313%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_313,true,gfns::gfn__h,filename); + sprintf(filename,"g22%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_22,true,gfns::gfn__h,filename); + sprintf(filename,"g122%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_122,true,gfns::gfn__h,filename); + sprintf(filename,"g222%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_222,true,gfns::gfn__h,filename); + sprintf(filename,"g322%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_322,true,gfns::gfn__h,filename); + sprintf(filename,"g23%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_23,true,gfns::gfn__h,filename); + sprintf(filename,"g123%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_123,true,gfns::gfn__h,filename); + sprintf(filename,"g223%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_223,true,gfns::gfn__h,filename); + sprintf(filename,"g323%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_323,true,gfns::gfn__h,filename); + sprintf(filename,"g33%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__g_dd_33,true,gfns::gfn__h,filename); + sprintf(filename,"g133%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_133,true,gfns::gfn__h,filename); + sprintf(filename,"g233%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_233,true,gfns::gfn__h,filename); + sprintf(filename,"g333%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_g_dd_333,true,gfns::gfn__h,filename); + sprintf(filename,"psi%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__psi,true,gfns::gfn__h,filename); + sprintf(filename,"psi1%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_psi_1,true,gfns::gfn__h,filename); + sprintf(filename,"psi2%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_psi_2,true,gfns::gfn__h,filename); + sprintf(filename,"psi3%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__partial_d_psi_3,true,gfns::gfn__h,filename); + sprintf(filename,"K11%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_11,true,gfns::gfn__h,filename); + sprintf(filename,"K12%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_12,true,gfns::gfn__h,filename); + sprintf(filename,"K13%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_13,true,gfns::gfn__h,filename); + sprintf(filename,"K22%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_22,true,gfns::gfn__h,filename); + sprintf(filename,"K23%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_23,true,gfns::gfn__h,filename); + sprintf(filename,"K33%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__K_dd_33,true,gfns::gfn__h,filename); + sprintf(filename,"trK%02d.dat",state.my_proc); + if(ps_ptr) ps_ptr->print_gridfn_with_xyz(gfns::gfn__trK,true,gfns::gfn__h,filename); + + MPI_Abort(MPI_COMM_WORLD,1); +#endif + + if (status == 0) + then error_exit(ERROR_EXIT, + "***** interpolate_geometry(): error return %d from interpolator!\n", + status); /*NOTREACHED*/ + + return expansion_success; // *** NORMAL RETURN *** + } + } + + //****************************************************************************** + namespace + { + void convert_conformal_to_physical(patch_system &ps, bool print_msg_flag) + { + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + for (int isigma = p.min_isigma(); isigma <= p.max_isigma(); ++isigma) + { + + const fp psi = (p.gridfn(gfns::gfn__psi, irho, isigma)); + const fp psi3 = jtutil::pow3(psi); + const fp psi4 = jtutil::pow4(psi); + + const fp partial_d_psi_1 = p.gridfn(gfns::gfn__partial_d_psi_1, irho, isigma); + const fp partial_d_psi_2 = p.gridfn(gfns::gfn__partial_d_psi_2, irho, isigma); + const fp partial_d_psi_3 = p.gridfn(gfns::gfn__partial_d_psi_3, irho, isigma); + + const fp stored_g_dd_11 = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); + const fp stored_g_dd_12 = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); + const fp stored_g_dd_13 = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); + const fp stored_g_dd_22 = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); + const fp stored_g_dd_23 = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); + const fp stored_g_dd_33 = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); + + p.gridfn(gfns::gfn__g_dd_11, irho, isigma) *= psi4; + p.gridfn(gfns::gfn__g_dd_12, irho, isigma) *= psi4; + p.gridfn(gfns::gfn__g_dd_13, irho, isigma) *= psi4; + p.gridfn(gfns::gfn__g_dd_22, irho, isigma) *= psi4; + p.gridfn(gfns::gfn__g_dd_23, irho, isigma) *= psi4; + p.gridfn(gfns::gfn__g_dd_33, irho, isigma) *= psi4; + + p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_11 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_12 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_13 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_22 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_23 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma) = 4.0 * psi3 * partial_d_psi_1 * stored_g_dd_33 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_11 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_12 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_13 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_22 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_23 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma) = 4.0 * psi3 * partial_d_psi_2 * stored_g_dd_33 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_11 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_12 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_13 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_22 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_23 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma); + p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma) = 4.0 * psi3 * partial_d_psi_3 * stored_g_dd_33 + psi4 * p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma); + + // K_ij = psi4 \tilde{A}_ij + (1/3) g_ij TrK, g_ij = psi4 \tilde{g}_ij + const fp stored_trKo3 = p.gridfn(gfns::gfn__trK, irho, isigma) / 3.0; + const fp stored_K_dd_11 = p.gridfn(gfns::gfn__K_dd_11, irho, isigma); + const fp stored_K_dd_12 = p.gridfn(gfns::gfn__K_dd_12, irho, isigma); + const fp stored_K_dd_13 = p.gridfn(gfns::gfn__K_dd_13, irho, isigma); + const fp stored_K_dd_22 = p.gridfn(gfns::gfn__K_dd_22, irho, isigma); + const fp stored_K_dd_23 = p.gridfn(gfns::gfn__K_dd_23, irho, isigma); + const fp stored_K_dd_33 = p.gridfn(gfns::gfn__K_dd_33, irho, isigma); + + p.gridfn(gfns::gfn__K_dd_11, irho, isigma) = psi4 * + (stored_K_dd_11 + stored_g_dd_11 * stored_trKo3); + p.gridfn(gfns::gfn__K_dd_12, irho, isigma) = psi4 * + (stored_K_dd_12 + stored_g_dd_12 * stored_trKo3); + p.gridfn(gfns::gfn__K_dd_13, irho, isigma) = psi4 * + (stored_K_dd_13 + stored_g_dd_13 * stored_trKo3); + p.gridfn(gfns::gfn__K_dd_22, irho, isigma) = psi4 * + (stored_K_dd_22 + stored_g_dd_22 * stored_trKo3); + p.gridfn(gfns::gfn__K_dd_23, irho, isigma) = psi4 * + (stored_K_dd_23 + stored_g_dd_23 * stored_trKo3); + p.gridfn(gfns::gfn__K_dd_33, irho, isigma) = psi4 * + (stored_K_dd_33 + stored_g_dd_33 * stored_trKo3); + + } // end for irho isigma + } + } + } + + namespace + { + bool h_is_finite(patch_system &ps, bool initial_flag, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, " checking that h is finite"); + + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + const fp h = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + if (!finite(h)) + then + { + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + const fp drho = jtutil::degrees_of_radians(rho); + const fp dsigma = jtutil::degrees_of_radians(sigma); + CCTK_VWarn(1, + __LINE__, __FILE__, CCTK_THORNSTRING, + "\n" + " h=%g isn't finite!\n" + " %s patch (rho,sigma)=(%g,%g) (drho,dsigma)=(%g,%g)\n", + double(h), + p.name(), double(rho), double(sigma), + double(drho), double(dsigma)); + return false; // *** found a NaN *** + } + } + } + } + return true; // *** all values finite *** + } + } + + //****************************************************************************** + namespace + { + bool geometry_is_finite(patch_system &ps, bool initial_flag, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, " checking that geometry is finite"); + + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + const fp g_dd_11 = p.gridfn(gfns::gfn__g_dd_11, irho, isigma); + const fp g_dd_12 = p.gridfn(gfns::gfn__g_dd_12, irho, isigma); + const fp g_dd_13 = p.gridfn(gfns::gfn__g_dd_13, irho, isigma); + const fp g_dd_22 = p.gridfn(gfns::gfn__g_dd_22, irho, isigma); + const fp g_dd_23 = p.gridfn(gfns::gfn__g_dd_23, irho, isigma); + const fp g_dd_33 = p.gridfn(gfns::gfn__g_dd_33, irho, isigma); + + const fp K_dd_11 = p.gridfn(gfns::gfn__K_dd_11, irho, isigma); + const fp K_dd_12 = p.gridfn(gfns::gfn__K_dd_12, irho, isigma); + const fp K_dd_13 = p.gridfn(gfns::gfn__K_dd_13, irho, isigma); + const fp K_dd_22 = p.gridfn(gfns::gfn__K_dd_22, irho, isigma); + const fp K_dd_23 = p.gridfn(gfns::gfn__K_dd_23, irho, isigma); + const fp K_dd_33 = p.gridfn(gfns::gfn__K_dd_33, irho, isigma); + + const fp partial_d_g_dd_111 = p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma); + const fp partial_d_g_dd_112 = p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma); + const fp partial_d_g_dd_113 = p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma); + const fp partial_d_g_dd_122 = p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma); + const fp partial_d_g_dd_123 = p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma); + const fp partial_d_g_dd_133 = p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma); + const fp partial_d_g_dd_211 = p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma); + const fp partial_d_g_dd_212 = p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma); + const fp partial_d_g_dd_213 = p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma); + const fp partial_d_g_dd_222 = p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma); + const fp partial_d_g_dd_223 = p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma); + const fp partial_d_g_dd_233 = p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma); + const fp partial_d_g_dd_311 = p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma); + const fp partial_d_g_dd_312 = p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma); + const fp partial_d_g_dd_313 = p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma); + const fp partial_d_g_dd_322 = p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma); + const fp partial_d_g_dd_323 = p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma); + const fp partial_d_g_dd_333 = p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma); + + if (!finite(g_dd_11) || !finite(g_dd_12) || !finite(g_dd_13) || !finite(g_dd_22) || !finite(g_dd_23) || !finite(g_dd_33) || !finite(K_dd_11) || !finite(K_dd_12) || !finite(K_dd_13) || !finite(K_dd_22) || !finite(K_dd_23) || !finite(K_dd_33) || !finite(partial_d_g_dd_111) || !finite(partial_d_g_dd_112) || !finite(partial_d_g_dd_113) || !finite(partial_d_g_dd_122) || !finite(partial_d_g_dd_123) || !finite(partial_d_g_dd_133) || !finite(partial_d_g_dd_211) || !finite(partial_d_g_dd_212) || !finite(partial_d_g_dd_213) || !finite(partial_d_g_dd_222) || !finite(partial_d_g_dd_223) || !finite(partial_d_g_dd_233) || !finite(partial_d_g_dd_311) || !finite(partial_d_g_dd_312) || !finite(partial_d_g_dd_313) || !finite(partial_d_g_dd_322) || !finite(partial_d_g_dd_323) || !finite(partial_d_g_dd_333)) + then + { + const fp h = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + const fp drho = jtutil::degrees_of_radians(rho); + const fp dsigma = jtutil::degrees_of_radians(sigma); + fp local_x, local_y, local_z; + p.xyz_of_r_rho_sigma(h, rho, sigma, local_x, local_y, local_z); + const fp global_x = ps.origin_x() + local_x; + const fp global_y = ps.origin_y() + local_y; + const fp global_z = ps.origin_z() + local_z; + CCTK_VWarn(1, + __LINE__, __FILE__, CCTK_THORNSTRING, + "\n" + " geometry isn't finite at %s patch\n" + " h=%g (rho,sigma)=(%g,%g) (drho,dsigma)=(%g,%g)\n" + " local_(x,y,z)=(%g,%g,%g)\n" + " global_(x,y,z)=(%g,%g,%g)\n" + " g_dd_11=%g _12=%g _13=%g\n" + " _22=%g _23=%g _33=%g\n" + " K_dd_11=%g _12=%g _13=%g\n" + " _22=%g _23=%g _33=%g\n" + " partial_d_g_dd_111=%g _112=%g _113=%g\n" + " _122=%g _123=%g _133=%g\n" + " partial_d_g_dd_211=%g _212=%g _213=%g\n" + " _222=%g _223=%g _233=%g\n" + " partial_d_g_dd_311=%g _312=%g _313=%g\n" + " _322=%g _323=%g _333=%g\n", + p.name(), + double(h), double(rho), double(sigma), + double(drho), double(dsigma), + double(local_x), double(local_y), double(local_z), + double(global_x), double(global_y), double(global_z), + double(g_dd_11), double(g_dd_12), double(g_dd_13), + double(g_dd_22), double(g_dd_23), double(g_dd_33), + double(K_dd_11), double(K_dd_12), double(K_dd_13), + double(K_dd_22), double(K_dd_23), double(K_dd_33), + double(partial_d_g_dd_111), + double(partial_d_g_dd_112), + double(partial_d_g_dd_113), + double(partial_d_g_dd_122), + double(partial_d_g_dd_123), + double(partial_d_g_dd_133), + double(partial_d_g_dd_211), + double(partial_d_g_dd_212), + double(partial_d_g_dd_213), + double(partial_d_g_dd_222), + double(partial_d_g_dd_223), + double(partial_d_g_dd_233), + double(partial_d_g_dd_311), + double(partial_d_g_dd_312), + double(partial_d_g_dd_313), + double(partial_d_g_dd_322), + double(partial_d_g_dd_323), + double(partial_d_g_dd_333)); + return false; // *** found a NaN *** + } + } + } + } + return true; // *** no NaNs found *** + } + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function computes the expansion Theta(h), and optionally also + // its Jacobian coefficients, (from which the Jacobian matrix may be + // computed later). This function uses a mixture of algebraic operations + // and (rho,sigma) finite differencing. The computation is done entirely + // on the nominal angular grid. + // + // N.b. This function #includes "cg.hh", which defines "dangerous" macros + // which will stay in effect for the rest of this compilation unit! + // + // Arguments: + // Jacobian_flag = true to compute the Jacobian coefficients, + // false to skip this. + // + // Results: + // This function returns true for a successful computation, or false + // if the computation failed because Theta_D <= 0 (this means the interpolated + // g_ij isn't positive definite). + // + namespace + { + bool compute_Theta(patch_system &ps, fp add_to_expansion, + bool Jacobian_flag, jtutil::norm *Theta_norms_ptr, + bool initial_flag, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, " computing Theta(h)"); + + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + // + // compute the X_ud and X_udd derivative coefficients + // ... n.b. this uses the *local* (x,y,z) coordinates + // + const fp r = p.ghosted_gridfn(gfns::gfn__h, irho, isigma); + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + fp xx, yy, zz; + p.xyz_of_r_rho_sigma(r, rho, sigma, xx, yy, zz); + + // 1st derivative coefficients X_ud + const fp X_ud_11 = p.partial_rho_wrt_x(xx, yy, zz); + const fp X_ud_12 = p.partial_rho_wrt_y(xx, yy, zz); + const fp X_ud_13 = p.partial_rho_wrt_z(xx, yy, zz); + const fp X_ud_21 = p.partial_sigma_wrt_x(xx, yy, zz); + const fp X_ud_22 = p.partial_sigma_wrt_y(xx, yy, zz); + const fp X_ud_23 = p.partial_sigma_wrt_z(xx, yy, zz); + + // 2nd derivative coefficient gridfns X_udd + const fp X_udd_111 = p.partial2_rho_wrt_xx(xx, yy, zz); + const fp X_udd_112 = p.partial2_rho_wrt_xy(xx, yy, zz); + const fp X_udd_113 = p.partial2_rho_wrt_xz(xx, yy, zz); + const fp X_udd_122 = p.partial2_rho_wrt_yy(xx, yy, zz); + const fp X_udd_123 = p.partial2_rho_wrt_yz(xx, yy, zz); + const fp X_udd_133 = p.partial2_rho_wrt_zz(xx, yy, zz); + const fp X_udd_211 = p.partial2_sigma_wrt_xx(xx, yy, zz); + const fp X_udd_212 = p.partial2_sigma_wrt_xy(xx, yy, zz); + const fp X_udd_213 = p.partial2_sigma_wrt_xz(xx, yy, zz); + const fp X_udd_222 = p.partial2_sigma_wrt_yy(xx, yy, zz); + const fp X_udd_223 = p.partial2_sigma_wrt_yz(xx, yy, zz); + const fp X_udd_233 = p.partial2_sigma_wrt_zz(xx, yy, zz); + +#define RATIONAL(num, den) (num / den) + +#define PARTIAL_RHO(ghosted_gridfn_name) \ + p.partial_rho(gfns::gfn__##ghosted_gridfn_name, irho, isigma) +#define PARTIAL_SIGMA(ghosted_gridfn_name) \ + p.partial_sigma(gfns::gfn__##ghosted_gridfn_name, irho, isigma) +#define PARTIAL_RHO_RHO(ghosted_gridfn_name) \ + p.partial_rho_rho(gfns::gfn__##ghosted_gridfn_name, irho, isigma) +#define PARTIAL_RHO_SIGMA(ghosted_gridfn_name) \ + p.partial_rho_sigma(gfns::gfn__##ghosted_gridfn_name, irho, isigma) +#define PARTIAL_SIGMA_SIGMA(ghosted_gridfn_name) \ + p.partial_sigma_sigma(gfns::gfn__##ghosted_gridfn_name, irho, isigma) + +#define h p.ghosted_gridfn(gfns::gfn__h, irho, isigma) +#define r h + +#define g_dd_11 p.gridfn(gfns::gfn__g_dd_11, irho, isigma) +#define g_dd_12 p.gridfn(gfns::gfn__g_dd_12, irho, isigma) +#define g_dd_13 p.gridfn(gfns::gfn__g_dd_13, irho, isigma) +#define g_dd_22 p.gridfn(gfns::gfn__g_dd_22, irho, isigma) +#define g_dd_23 p.gridfn(gfns::gfn__g_dd_23, irho, isigma) +#define g_dd_33 p.gridfn(gfns::gfn__g_dd_33, irho, isigma) +#define K_dd_11 p.gridfn(gfns::gfn__K_dd_11, irho, isigma) +#define K_dd_12 p.gridfn(gfns::gfn__K_dd_12, irho, isigma) +#define K_dd_13 p.gridfn(gfns::gfn__K_dd_13, irho, isigma) +#define K_dd_22 p.gridfn(gfns::gfn__K_dd_22, irho, isigma) +#define K_dd_23 p.gridfn(gfns::gfn__K_dd_23, irho, isigma) +#define K_dd_33 p.gridfn(gfns::gfn__K_dd_33, irho, isigma) + +#define partial_d_g_dd_111 p.gridfn(gfns::gfn__partial_d_g_dd_111, irho, isigma) +#define partial_d_g_dd_112 p.gridfn(gfns::gfn__partial_d_g_dd_112, irho, isigma) +#define partial_d_g_dd_113 p.gridfn(gfns::gfn__partial_d_g_dd_113, irho, isigma) +#define partial_d_g_dd_122 p.gridfn(gfns::gfn__partial_d_g_dd_122, irho, isigma) +#define partial_d_g_dd_123 p.gridfn(gfns::gfn__partial_d_g_dd_123, irho, isigma) +#define partial_d_g_dd_133 p.gridfn(gfns::gfn__partial_d_g_dd_133, irho, isigma) +#define partial_d_g_dd_211 p.gridfn(gfns::gfn__partial_d_g_dd_211, irho, isigma) +#define partial_d_g_dd_212 p.gridfn(gfns::gfn__partial_d_g_dd_212, irho, isigma) +#define partial_d_g_dd_213 p.gridfn(gfns::gfn__partial_d_g_dd_213, irho, isigma) +#define partial_d_g_dd_222 p.gridfn(gfns::gfn__partial_d_g_dd_222, irho, isigma) +#define partial_d_g_dd_223 p.gridfn(gfns::gfn__partial_d_g_dd_223, irho, isigma) +#define partial_d_g_dd_233 p.gridfn(gfns::gfn__partial_d_g_dd_233, irho, isigma) +#define partial_d_g_dd_311 p.gridfn(gfns::gfn__partial_d_g_dd_311, irho, isigma) +#define partial_d_g_dd_312 p.gridfn(gfns::gfn__partial_d_g_dd_312, irho, isigma) +#define partial_d_g_dd_313 p.gridfn(gfns::gfn__partial_d_g_dd_313, irho, isigma) +#define partial_d_g_dd_322 p.gridfn(gfns::gfn__partial_d_g_dd_322, irho, isigma) +#define partial_d_g_dd_323 p.gridfn(gfns::gfn__partial_d_g_dd_323, irho, isigma) +#define partial_d_g_dd_333 p.gridfn(gfns::gfn__partial_d_g_dd_333, irho, isigma) + +#define Theta p.gridfn(gfns::gfn__Theta, irho, isigma) + +#define partial_Theta_wrt_partial_d_h_1 \ + p.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_1, irho, isigma) +#define partial_Theta_wrt_partial_d_h_2 \ + p.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_2, irho, isigma) +#define partial_Theta_wrt_partial_dd_h_11 \ + p.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_11, irho, isigma) +#define partial_Theta_wrt_partial_dd_h_12 \ + p.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_12, irho, isigma) +#define partial_Theta_wrt_partial_dd_h_22 \ + p.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_22, irho, isigma) + +#define save_Theta p.gridfn(gfns::gfn__save_Theta, irho, isigma) +#define Delta_h p.gridfn(gfns::gfn__Delta_h, irho, isigma) + + fp g_uu_11; + fp g_uu_12; + fp g_uu_13; + fp g_uu_22; + fp g_uu_23; + fp g_uu_33; + fp K; + fp K_uu_11; + fp K_uu_12; + fp K_uu_13; + fp K_uu_22; + fp K_uu_23; + fp K_uu_33; + + fp partial_d_ln_sqrt_g_1; + fp partial_d_ln_sqrt_g_2; + fp partial_d_ln_sqrt_g_3; + + fp partial_d_g_uu_111; + fp partial_d_g_uu_112; + fp partial_d_g_uu_113; + fp partial_d_g_uu_122; + fp partial_d_g_uu_123; + fp partial_d_g_uu_133; + fp partial_d_g_uu_211; + fp partial_d_g_uu_212; + fp partial_d_g_uu_213; + fp partial_d_g_uu_222; + fp partial_d_g_uu_223; + fp partial_d_g_uu_233; + fp partial_d_g_uu_311; + fp partial_d_g_uu_312; + fp partial_d_g_uu_313; + fp partial_d_g_uu_322; + fp partial_d_g_uu_323; + fp partial_d_g_uu_333; + + fp Theta_A; + fp Theta_B; + fp Theta_C; + fp Theta_D; + + { + // g_uu + fp t1, t2, t4, t5, t7, t8, t11, t12, t14, t15; + fp t18, t21; + t1 = g_dd_22; + t2 = g_dd_33; + t4 = g_dd_23; + t5 = t4 * t4; + t7 = g_dd_11; + t8 = t7 * t1; + t11 = g_dd_12; + t12 = t11 * t11; + t14 = g_dd_13; + t15 = t11 * t14; + t18 = t14 * t14; + t21 = 1 / (t8 * t2 - t7 * t5 - t12 * t2 + 2.0 * t15 * t4 - t18 * t1); + g_uu_11 = (t1 * t2 - t5) * t21; + g_uu_12 = -(t11 * t2 - t14 * t4) * t21; + g_uu_13 = -(-t11 * t4 + t14 * t1) * t21; + g_uu_22 = (t7 * t2 - t18) * t21; + g_uu_23 = -(t7 * t4 - t15) * t21; + g_uu_33 = (t8 - t12) * t21; + } + + { + // K, K_uu + fp t1, t2, t4, t5, t8, t9, t12, t13, t15, t16; + fp t19, t20, t22, t24, t27, t30, t32, t35, t42, t44; + fp t46, t48, t50, t60, t62, t69, t71, t74, t85, t95; + t1 = g_uu_11; + t2 = K_dd_11; + t4 = g_uu_12; + t5 = K_dd_12; + t8 = g_uu_13; + t9 = K_dd_13; + t12 = g_uu_22; + t13 = K_dd_22; + t15 = g_uu_23; + t16 = K_dd_23; + t19 = g_uu_33; + t20 = K_dd_33; + K = t1 * t2 + 2.0 * t4 * t5 + 2.0 * t8 * t9 + t12 * t13 + 2.0 * t15 * t16 + t19 * t20; + t22 = t1 * t1; + t24 = t4 * t1; + t27 = t8 * t1; + t30 = t4 * t4; + t32 = t8 * t4; + t35 = t8 * t8; + K_uu_11 = t22 * t2 + 2.0 * t24 * t5 + 2.0 * t27 * t9 + t30 * t13 + 2.0 * t32 * t16 + t35 * t20; + t42 = t4 * t12; + t44 = t8 * t12; + t46 = t1 * t15; + t48 = t15 * t4; + t50 = t8 * t15; + K_uu_12 = t24 * t2 + t30 * t5 + t32 * t9 + t1 * t12 * t5 + t42 * t13 + t44 * t16 + t46 * t9 + t48 * t16 + + t50 * t20; + t60 = t4 * t19; + t62 = t8 * t19; + K_uu_13 = t27 * t2 + t32 * t5 + t35 * t9 + t46 * t5 + t48 * t13 + t50 * t16 + t1 * t19 * t9 + t60 * t16 + + t62 * t20; + t69 = t12 * t12; + t71 = t15 * t12; + t74 = t15 * t15; + K_uu_22 = t30 * t2 + 2.0 * t42 * t5 + 2.0 * t48 * t9 + t69 * t13 + 2.0 * t71 * t16 + t74 * t20; + t85 = t15 * t19; + K_uu_23 = t32 * t2 + t44 * t5 + t50 * t9 + t48 * t5 + t71 * t13 + t74 * t16 + t60 * t9 + t12 * t19 * t16 + + t85 * t20; + t95 = t19 * t19; + K_uu_33 = t35 * t2 + 2.0 * t50 * t5 + 2.0 * t62 * t9 + t74 * t13 + 2.0 * t85 * t16 + t95 * t20; + } + + { + // partial_d_g_uu + fp t1, t2, t3, t5, t6, t7, t10, t11, t12, t15; + fp t16, t18, t19, t22, t23, t28, t29, t31, t33, t35; + fp t36, t38, t40, t48, t49, t51, t53, t60, t62, t65; + fp t74, t76, t86, t88, t90, t93, t96, t98, t101, t148; + fp t150, t153, t156, t158, t161; + t1 = g_uu_11; + t2 = t1 * t1; + t3 = partial_d_g_dd_111; + t5 = g_uu_12; + t6 = t5 * t1; + t7 = partial_d_g_dd_112; + t10 = g_uu_13; + t11 = t10 * t1; + t12 = partial_d_g_dd_113; + t15 = t5 * t5; + t16 = partial_d_g_dd_122; + t18 = t10 * t5; + t19 = partial_d_g_dd_123; + t22 = t10 * t10; + t23 = partial_d_g_dd_133; + partial_d_g_uu_111 = -t2 * t3 - 2.0 * t6 * t7 - 2.0 * t11 * t12 - t15 * t16 - 2.0 * t18 * t19 - t22 * t23; + t28 = g_uu_22; + t29 = t1 * t28; + t31 = t5 * t28; + t33 = t10 * t28; + t35 = g_uu_23; + t36 = t1 * t35; + t38 = t5 * t35; + t40 = t10 * t35; + partial_d_g_uu_112 = -t6 * t3 - t15 * t7 - t18 * t12 - t29 * t7 - t31 * t16 - t33 * t19 - t36 * t12 - t38 * t19 - t40 * t23; + t48 = g_uu_33; + t49 = t1 * t48; + t51 = t48 * t5; + t53 = t10 * t48; + partial_d_g_uu_113 = -t11 * t3 - t18 * t7 - t22 * t12 - t36 * t7 - t38 * t16 - t40 * t19 - t49 * t12 - t51 * t19 - t53 * t23; + t60 = t28 * t28; + t62 = t35 * t28; + t65 = t35 * t35; + partial_d_g_uu_122 = -t15 * t3 - 2.0 * t31 * t7 - 2.0 * t38 * t12 - t60 * t16 - 2.0 * t62 * t19 - + t65 * t23; + t74 = t28 * t48; + t76 = t35 * t48; + partial_d_g_uu_123 = -t18 * t3 - t33 * t7 - t40 * t12 - t38 * t7 - t62 * t16 - t65 * t19 - t51 * t12 - t74 * t19 - t76 * t23; + t86 = t48 * t48; + partial_d_g_uu_133 = -t22 * t3 - 2.0 * t40 * t7 - 2.0 * t53 * t12 - t65 * t16 - 2.0 * t76 * t19 - + t86 * t23; + t88 = partial_d_g_dd_211; + t90 = partial_d_g_dd_212; + t93 = partial_d_g_dd_213; + t96 = partial_d_g_dd_222; + t98 = partial_d_g_dd_223; + t101 = partial_d_g_dd_233; + partial_d_g_uu_211 = -t2 * t88 - 2.0 * t6 * t90 - 2.0 * t11 * t93 - t15 * t96 - 2.0 * t18 * t98 - + t22 * t101; + partial_d_g_uu_212 = -t6 * t88 - t15 * t90 - t18 * t93 - t29 * t90 - t31 * t96 - t33 * t98 - t36 * t93 - t38 * t98 - t40 * t101; + partial_d_g_uu_213 = -t11 * t88 - t18 * t90 - t22 * t93 - t36 * t90 - t38 * t96 - t40 * t98 - t49 * t93 - t51 * t98 - t53 * t101; + partial_d_g_uu_222 = -t15 * t88 - 2.0 * t31 * t90 - 2.0 * t38 * t93 - t60 * t96 - 2.0 * t62 * t98 - t65 * t101; + partial_d_g_uu_223 = -t18 * t88 - t33 * t90 - t40 * t93 - t38 * t90 - t62 * t96 - t65 * t98 - t51 * t93 - t74 * t98 - t76 * t101; + partial_d_g_uu_233 = -t22 * t88 - 2.0 * t40 * t90 - 2.0 * t53 * t93 - t65 * t96 - 2.0 * t76 * t98 - t86 * t101; + t148 = partial_d_g_dd_311; + t150 = partial_d_g_dd_312; + t153 = partial_d_g_dd_313; + t156 = partial_d_g_dd_322; + t158 = partial_d_g_dd_323; + t161 = partial_d_g_dd_333; + partial_d_g_uu_311 = -t2 * t148 - 2.0 * t6 * t150 - 2.0 * t11 * t153 - t15 * t156 - 2.0 * t18 * t158 - t22 * t161; + partial_d_g_uu_312 = -t6 * t148 - t15 * t150 - t18 * t153 - t29 * t150 - t31 * t156 - t33 * t158 - t36 * t153 - t38 * t158 - t40 * t161; + partial_d_g_uu_313 = -t11 * t148 - t18 * t150 - t22 * t153 - t36 * t150 - t38 * t156 - t40 * t158 - t49 * t153 - t51 * t158 - t53 * t161; + partial_d_g_uu_322 = -t15 * t148 - 2.0 * t31 * t150 - 2.0 * t38 * t153 - t60 * t156 - 2.0 * t62 * t158 - t65 * t161; + partial_d_g_uu_323 = -t18 * t148 - t33 * t150 - t40 * t153 - t38 * t150 - t62 * t156 - t65 * t158 - t51 * t153 - t74 * t158 - t76 * t161; + partial_d_g_uu_333 = -t22 * t148 - 2.0 * t40 * t150 - 2.0 * t53 * t153 - t65 * t156 - 2.0 * t76 * t158 - t86 * t161; + } + + { + // partial_d_ln_sqrt_g + fp t1, t5, t8, t11, t15, t18; + t1 = g_uu_11; + t5 = g_uu_12; + t8 = g_uu_13; + t11 = g_uu_22; + t15 = g_uu_23; + t18 = g_uu_33; + partial_d_ln_sqrt_g_1 = RATIONAL(1.0, 2.0) * t1 * partial_d_g_dd_111 + t5 * partial_d_g_dd_112 + t8 * partial_d_g_dd_113 + RATIONAL(1.0, 2.0) * t11 * partial_d_g_dd_122 + t15 * partial_d_g_dd_123 + RATIONAL(1.0, 2.0) * t18 * partial_d_g_dd_133; + partial_d_ln_sqrt_g_2 = RATIONAL(1.0, 2.0) * t1 * partial_d_g_dd_211 + t5 * partial_d_g_dd_212 + t8 * partial_d_g_dd_213 + RATIONAL(1.0, 2.0) * t11 * partial_d_g_dd_222 + t15 * partial_d_g_dd_223 + RATIONAL(1.0, 2.0) * t18 * partial_d_g_dd_233; + partial_d_ln_sqrt_g_3 = RATIONAL(1.0, 2.0) * t1 * partial_d_g_dd_311 + t5 * partial_d_g_dd_312 + t8 * partial_d_g_dd_313 + RATIONAL(1.0, 2.0) * t11 * partial_d_g_dd_322 + t15 * partial_d_g_dd_323 + RATIONAL(1.0, 2.0) * t18 * partial_d_g_dd_333; + } + + { + // Theta_A, Theta_B, Theta_C, Theta_D + fp t1, t2, t3, t5, t6, t8, t9, t11, t12, t14; + fp t15, t17, t19, t25, t26, t27, t29, t31, t34, t35; + fp t37, t39, t40, t42, t44, t46, t47, t49, t56, t61; + fp t63, t65, t66, t67, t82, t93, t98, t100, t102, t106; + fp t107, t110, t111, t112, t116, t119, t120, t121, t123, t124; + fp t127, t128, t129, t130, t131, t133, t134, t135, t137, t138; + fp t139, t141, t142, t143, t148, t149, t150, t153, t154, t155; + fp t158, t159, t160, t163, t164, t167, t168, t171, t172, t177; + fp t181, t182, t185, t186, t189, t191, t197, t198, t200, t205; + fp t220, t224, t232, t239, t266, t273, t276, t280, t283, t289; + fp t292, t302, t303, t306, t307, t310, t311, t314, t317, t326; + fp t330, t334, t337, t340, t343, t353, t355, t356, t360, t362; + fp t366, t382, t387, t394, t431, t440, t444, t447, t450, t465; + t1 = g_uu_13; + t2 = t1 * t1; + t3 = 1 / r; + t5 = X_ud_13; + t6 = PARTIAL_RHO(h); + t8 = X_ud_23; + t9 = PARTIAL_SIGMA(h); + t11 = zz * t3 - t5 * t6 - t8 * t9; + t12 = t11 * t11; + t14 = yy * yy; + t15 = zz * zz; + t17 = r * r; + t19 = 1 / t17 / r; + t25 = X_ud_11; + t26 = t25 * t25; + t27 = PARTIAL_RHO_RHO(h); + t29 = X_ud_21; + t31 = PARTIAL_RHO_SIGMA(h); + t34 = t29 * t29; + t35 = PARTIAL_SIGMA_SIGMA(h); + t37 = (t14 + t15) * t19 - X_udd_111 * t6 - X_udd_211 * t9 - t26 * t27 - 2.0 * t29 * t25 * t31 - t34 * t35; + t39 = g_uu_23; + t40 = t39 * t39; + t42 = X_ud_12; + t44 = X_ud_22; + t46 = yy * t3 - t42 * t6 - t44 * t9; + t47 = t46 * t46; + t49 = xx * xx; + t56 = t5 * t5; + t61 = t8 * t8; + t63 = (t49 + t14) * t19 - X_udd_133 * t6 - X_udd_233 * t9 - t56 * t27 - 2.0 * t8 * t5 * t31 - t61 * t35; + t65 = t1 * t11; + t66 = g_uu_22; + t67 = t66 * t46; + t82 = -xx * yy * t19 - X_udd_112 * t6 - X_udd_212 * t9 - t25 * t42 * t27 - t29 * t42 * t31 - t25 * t44 * t31 - t29 * t44 * t35; + t93 = t42 * t42; + t98 = t44 * t44; + t100 = (t49 + t15) * t19 - X_udd_122 * t6 - X_udd_222 * t9 - t93 * t27 - 2.0 * t44 * t42 * t31 - + t98 * t35; + t102 = t39 * t11; + t106 = t1 * t12; + t107 = partial_d_g_uu_123; + t110 = g_uu_12; + t111 = t110 * t47; + t112 = partial_d_g_uu_112; + t116 = xx * t3 - t25 * t6 - t29 * t9; + t119 = t66 * t47; + t120 = partial_d_g_uu_212; + t121 = t120 * t116; + t123 = t39 * t47; + t124 = partial_d_g_uu_312; + t127 = g_uu_11; + t128 = t116 * t116; + t129 = t127 * t128; + t130 = partial_d_g_uu_113; + t131 = t130 * t11; + t133 = t1 * t128; + t134 = partial_d_g_uu_313; + t135 = t134 * t11; + t137 = g_uu_33; + t138 = t137 * t12; + t139 = t134 * t116; + t141 = -t2 * t12 * t37 - t40 * t47 * t63 - 2.0 * t65 * t67 * t82 - t40 * t12 * t100 - 2.0 * t102 * t67 * t100 - t106 * t107 * t46 - t111 * t112 * t116 - t119 * t121 - t123 * t124 * t116 - t129 * t131 - t133 * t135 - + t138 * t139; + t142 = t39 * t12; + t143 = partial_d_g_uu_213; + t148 = t1 * t116; + t149 = partial_d_g_uu_322; + t150 = t149 * t47; + t153 = t110 * t116; + t154 = partial_d_g_uu_222; + t155 = t154 * t47; + t158 = t127 * t116; + t159 = partial_d_g_uu_122; + t160 = t159 * t47; + t163 = partial_d_g_uu_333; + t164 = t163 * t12; + t167 = partial_d_g_uu_133; + t168 = t167 * t12; + t171 = partial_d_g_uu_233; + t172 = t171 * t12; + t177 = t110 * t46; + t181 = partial_d_g_uu_323; + t182 = t181 * t11; + t185 = t137 * t11; + t186 = t124 * t46; + t189 = -t142 * t143 * t116 - t106 * t130 * t116 + RATIONAL(-1.0, 2.0) * t148 * t150 + + RATIONAL(-1.0, 2.0) * t153 * t155 + RATIONAL(-1.0, 2.0) * t158 * t160 + RATIONAL(-1.0, 2.0) * t148 * t164 + RATIONAL(-1.0, 2.0) * t158 * t168 + RATIONAL(-1.0, 2.0) * t153 * t172 + RATIONAL(-1.0, 2.0) * t65 * t160 - 2.0 * t65 * t177 * t37 - t148 * t182 * t46 - t185 * t186 * t116; + t191 = t127 * t127; + t197 = t110 * t128; + t198 = t143 * t11; + t200 = t137 * t137; + t205 = t39 * t46; + t220 = -xx * zz * t19 - X_udd_113 * t6 - X_udd_213 * t9 - t25 * t5 * t27 - t29 * t5 * t31 - t25 * t8 * t31 - t29 * t8 * t35; + t224 = t12 * t11; + t232 = t1 * t220; + t239 = -t191 * t128 * t37 - 2.0 * t142 * t1 * t82 - t197 * t198 - t200 * t12 * t63 - t177 * t131 * t116 - 2.0 * t65 * t205 * t220 + RATIONAL(-1.0, 2.0) * t39 * t224 * t171 - t67 * t198 * t116 - t205 * t135 * t116 - 2.0 * t138 * t232 + RATIONAL(-1.0, 2.0) * t205 * t164 + RATIONAL(-1.0, 2.0) * t177 * t168; + t266 = -yy * zz * t19 - X_udd_123 * t6 - X_udd_223 * t9 - t42 * t5 * t27 - t44 * t5 * t31 - t42 * t8 * t31 - t44 * t8 * t35; + t273 = t110 * t110; + t276 = t47 * t46; + t280 = t39 * t266; + t283 = t158 * t37; + t289 = t148 * t266; + t292 = RATIONAL(-1.0, 2.0) * t67 * t172 + RATIONAL(-1.0, 2.0) * t185 * t150 + RATIONAL(-1.0, 2.0) * t102 * t155 - 2.0 * t197 * t127 * t82 - 2.0 * t133 * t127 * t220 - 2.0 * t133 * t110 * t266 + + RATIONAL(-1.0, 2.0) * t1 * t224 * t167 - t273 * t128 * t100 + RATIONAL(-1.0, 2.0) * t39 * t276 * t149 - 2.0 * t138 * t280 - 2.0 * t65 * t283 + RATIONAL(-1.0, 2.0) * t110 * t276 * t159 - 2.0 * t67 * t289; + t302 = partial_d_g_uu_311; + t303 = t302 * t128; + t306 = partial_d_g_uu_211; + t307 = t306 * t128; + t310 = partial_d_g_uu_111; + t311 = t310 * t128; + t314 = t148 * t63; + t317 = t153 * t266; + t326 = t107 * t11; + t330 = RATIONAL(-1.0, 2.0) * t66 * t276 * t154 - 2.0 * t273 * t46 * t116 * t82 + RATIONAL(-1.0, 2.0) * t205 * t303 + RATIONAL(-1.0, 2.0) * t67 * t307 + RATIONAL(-1.0, 2.0) * t177 * t311 - 2.0 * t205 * t314 - 2.0 * t205 * t317 + RATIONAL(-1.0, 2.0) * t185 * t303 + RATIONAL(-1.0, 2.0) * t102 * t307 + RATIONAL(-1.0, 2.0) * t65 * t311 - t111 * t326 - t158 * t326 * t46; + t334 = t158 * t82; + t337 = t110 * t82; + t340 = t158 * t220; + t343 = t153 * t100; + t353 = t112 * t46; + t355 = partial_d_g_uu_223; + t356 = t355 * t11; + t360 = t120 * t46; + t362 = -2.0 * t177 * t148 * t220 - 2.0 * t67 * t334 - 2.0 * t119 * t337 - 2.0 * t205 * t340 - 2.0 * t67 * t343 + RATIONAL(-1.0, 2.0) * t137 * t224 * t163 - t2 * t128 * t63 - t273 * t47 * t37 - t129 * t353 - + t119 * t356 - t123 * t182 - t133 * t186 - t197 * t360; + t366 = t181 * t46; + t382 = t66 * t66; + t387 = t128 * t116; + t394 = -t142 * t355 * t46 - t138 * t366 - 2.0 * t177 * t283 - 2.0 * t123 * t110 * t220 - 2.0 * t123 * t66 * t266 - t153 * t356 * t46 - t65 * t353 * t116 - t102 * t360 * t116 - t382 * t47 * t100 - 2.0 * t185 * t317 + RATIONAL(-1.0, 2.0) * t127 * t387 * t310 + RATIONAL(-1.0, 2.0) * t110 * t387 * t306; + t431 = RATIONAL(-1.0, 2.0) * t1 * t387 * t302 - 2.0 * t2 * t11 * t116 * t220 - 2.0 * t185 * t314 - 2.0 * t102 * t289 - 2.0 * t65 * t153 * t82 - 2.0 * t185 * t205 * t63 - 2.0 * t40 * t11 * t46 * t266 - 2.0 * t102 * t343 - 2.0 * t102 * t334 - 2.0 * t185 * t340 - 2.0 * t102 * t177 * t82 - 2.0 * t185 * t67 * t266 - 2.0 * t185 * t177 * t220; + Theta_A = t141 + t189 + t239 + t292 + t330 + t362 + t394 + t431; + t440 = t310 * t116 + t121 + t139 + t353 + t154 * t46 + t366 + t131 + t356 + t163 * t11 + t127 * t37 + 2.0 * t337 + 2.0 * t232; + t444 = partial_d_ln_sqrt_g_1; + t447 = partial_d_ln_sqrt_g_2; + t450 = partial_d_ln_sqrt_g_3; + t465 = t66 * t100 + 2.0 * t280 + t137 * t63 + t127 * t444 * t116 + t110 * t447 * t116 + t1 * t450 * t116 + t110 * t444 * t46 + t66 * t447 * t46 + t39 * t450 * t46 + t1 * t444 * t11 + t39 * t447 * t11 + t137 * t450 * t11; + Theta_B = t440 + t465; + Theta_C = K_uu_11 * t128 + 2.0 * K_uu_12 * t46 * t116 + 2.0 * K_uu_13 * t11 * t116 + K_uu_22 * t47 + 2.0 * K_uu_23 * t11 * t46 + K_uu_33 * t12; + Theta_D = t129 + 2.0 * t177 * t116 + 2.0 * t65 * t116 + t119 + 2.0 * t102 * t46 + t138; + } + + if (Theta_D <= 0) + then + { + CCTK_VWarn(1, __LINE__, __FILE__, CCTK_THORNSTRING, + "\n" + " compute_Theta(): Theta_D = $g^{ij} s_i s_j$ = %g <= 0\n" + " at %s patch rho=%g sigma=%g!\n" + " (i.e. the interpolated g_ij isn't positive definite)", + double(Theta_D), + p.name(), double(rho), double(sigma)); + + cout << g_dd_11 << "," << g_dd_12 << "," << g_dd_13 << "," << g_dd_22 << "," << g_dd_23 << "," << g_dd_33 << endl; + cout << xx << "," << yy << "," << zz << endl; + return false; // *** ERROR RETURN *** + } + + // compute H via equation (14) of my 1996 horizon finding paper + const fp sqrt_Theta_D = sqrt(Theta_D); + Theta = +Theta_A / (Theta_D * sqrt_Theta_D) + Theta_B / sqrt_Theta_D + Theta_C / Theta_D - K + add_to_expansion; + + // update running norms of Theta(h) function + if (Theta_norms_ptr != NULL) + then Theta_norms_ptr->data(Theta); + + if (Jacobian_flag) + then + { + // partial_Theta_wrt_partial_d_h, + // partial_Theta_wrt_partial_dd_h + fp t1, t2, t3, t4, t5, t7, t8, t10, t11, t13; + fp t14, t16, t18, t20, t22, t24, t26, t28, t29, t31; + fp t32, t35, t37, t38, t41, t42, t43, t46, t48, t52; + fp t54, t55, t59, t60, t63, t67, t68, t69, t70, t71; + fp t74, t76, t78, t80, t83, t85, t86, t92, t93, t94; + fp t98, t99, t102, t103, t104, t107, t108, t112, t113, t114; + fp t115, t116, t118, t119, t120, t122, t123, t126, t127, t128; + fp t133, t136, t140, t141, t142, t143, t153, t156, t158, t160; + fp t162, t165, t167, t168, t171, t172, t173, t174, t179, t183; + fp t185, t189, t190, t193, t194, t195, t197, t198, t202, t205; + fp t208, t209, t212, t216, t217, t218, t220, t222, t223, t224; + fp t226, t227, t232, t235, t236, t237, t238, t240, t247, t248; + fp t249, t254, t259, t263, t266, t267, t275, t278, t281, t284; + fp t287, t288, t291, t296, t297, t298, t300, t307, t309, t311; + fp t314, t316, t317, t322, t325, t326, t329, t334, t335, t336; + fp t340, t346, t350, t351, t352, t354, t357, t358, t359, t361; + fp t364, t365, t366, t368, t370, t373, t374, t376, t381, t385; + fp t386, t392, t398, t401, t404, t405, t407, t408, t411, t414; + fp t416, t417, t419, t421, t422, t424, t428, t431, t432, t434; + fp t437, t440, t442, t449, t454, t458, t461, t467, t470, t471; + fp t474, t475, t481, t485, t489, t494, t498, t503, t504, t505; + fp t507, t514, t518, t534, t536, t542, t545, t548, t551, t552; + fp t559, t561, t562, t565, t569, t571, t572, t573, t575, t576; + fp t588, t589, t590, t593, t594, t599, t601, t605, t608, t609; + fp t612, t613, t627, t632, t633, t640, t644, t652, t656, t664; + fp t669, t672, t677, t678, t680, t694, t704, t707, t712, t716; + fp t723, t738, t741, t746, t748, t750, t774, t776, t780, t785; + fp t787, t792, t796, t797, t799, t800, t802, t803, t805, t807; + fp t809, t811, t813, t815, t817, t819, t822, t824, t827, t829; + fp t832, t835, t837, t840, t843, t847, t860, t869, t871, t876; + fp t882, t886, t890, t891, t897, t899, t900, t902, t904, t905; + fp t907, t913, t920, t929, t930, t933, t938, t944, t947, t949; + fp t962, t970, t971, t976, t979, t983, t996, t997, t1000, t1001; + fp t1004, t1010, t1012, t1015, t1033, t1036, t1039, t1047, t1048, t1050; + fp t1062, t1065, t1070, t1074, t1075, t1078, t1080, t1082, t1087, t1093; + fp t1095, t1097, t1103, t1107, t1112, t1114, t1138, t1139, t1141, t1145; + fp t1150, t1163, t1166, t1169, t1174, t1186, t1189, t1192, t1200, t1214; + fp t1234, t1266, t1281, t1289, t1300, t1301, t1308, t1335, t1342, t1345; + fp t1364, t1370, t1405, t1414, t1427, t1457, t1460, t1463, t1465, t1469; + fp t1475, t1476, t1477, t1483, t1486, t1487, t1491, t1492, t1493, t1497; + fp t1505, t1508, t1510, t1513, t1516, t1517, t1520, t1526, t1536, t1547; + fp t1552, t1555, t1558, t1561, t1572, t1580, t1594, t1600, t1606, t1610; + fp t1622, t1629, t1639, t1641, t1643, t1645, t1648, t1655, t1659, t1660; + fp t1666, t1667, t1684, t1697, t1704, t1718, t1721, t1739, t1748, t1751; + fp t1757, t1760, t1761, t1768, t1771, t1783, t1785, t1788, t1791, t1803; + fp t1809, t1812, t1825; + t1 = g_uu_13; + t2 = X_ud_13; + t3 = t1 * t2; + t4 = g_uu_12; + t5 = 1 / r; + t7 = X_ud_11; + t8 = PARTIAL_RHO(h); + t10 = X_ud_21; + t11 = PARTIAL_SIGMA(h); + t13 = xx * t5 - t7 * t8 - t10 * t11; + t14 = t4 * t13; + t16 = r * r; + t18 = 1 / t16 / r; + t20 = X_udd_112; + t22 = X_udd_212; + t24 = X_ud_12; + t26 = PARTIAL_RHO_RHO(h); + t28 = t10 * t24; + t29 = PARTIAL_RHO_SIGMA(h); + t31 = X_ud_22; + t32 = t7 * t31; + t35 = PARTIAL_SIGMA_SIGMA(h); + t37 = -xx * yy * t18 - t20 * t8 - t22 * t11 - t7 * t24 * t26 - t28 * t29 - t32 * t29 - t10 * t31 * t35; + t38 = t14 * t37; + t41 = g_uu_22; + t42 = t41 * t24; + t43 = t1 * t13; + t46 = X_udd_123; + t48 = X_udd_223; + t52 = t31 * t2; + t54 = X_ud_23; + t55 = t24 * t54; + t59 = -yy * zz * t18 - t46 * t8 - t48 * t11 - t24 * t2 * t26 - t52 * t29 - t55 * t29 - t31 * t54 * t35; + t60 = t43 * t59; + t63 = g_uu_23; + t67 = yy * t5 - t24 * t8 - t31 * t11; + t68 = t63 * t67; + t69 = t1 * t7; + t70 = xx * xx; + t71 = yy * yy; + t74 = X_udd_133; + t76 = X_udd_233; + t78 = t2 * t2; + t80 = t54 * t2; + t83 = t54 * t54; + t85 = (t70 + t71) * t18 - t74 * t8 - t76 * t11 - t78 * t26 - 2.0 * t80 * t29 - t83 * t35; + t86 = t69 * t85; + t92 = zz * t5 - t2 * t8 - t54 * t11; + t93 = t63 * t92; + t94 = t4 * t67; + t98 = t41 * t67; + t99 = t69 * t59; + t102 = g_uu_33; + t103 = t102 * t92; + t104 = t43 * t74; + t107 = t1 * t92; + t108 = t4 * t7; + t112 = g_uu_11; + t113 = t112 * t13; + t114 = partial_d_g_uu_123; + t115 = t114 * t2; + t116 = t115 * t67; + t118 = partial_d_g_uu_211; + t119 = t118 * t13; + t120 = t119 * t7; + t122 = t63 * t2; + t123 = t94 * t37; + t126 = partial_d_g_uu_122; + t127 = t126 * t67; + t128 = t127 * t24; + t133 = t98 * t37; + t136 = X_udd_113; + t140 = 2.0 * t3 * t38 + 2.0 * t42 * t60 + 2.0 * t68 * t86 + 2.0 * t93 * t94 * t20 + 2.0 * t98 * t99 + 2.0 * t103 * t104 + 2.0 * t107 * t108 * t37 + t113 * t116 + t93 * t120 + 2.0 * t122 * t123 + t113 * t128 + 2.0 * t107 * t14 * t20 + 2.0 * t3 * t133 + 2.0 * t107 * t68 * t136; + t141 = partial_d_g_uu_311; + t142 = t141 * t13; + t143 = t142 * t7; + t153 = zz * zz; + t156 = X_udd_122; + t158 = X_udd_222; + t160 = t24 * t24; + t162 = t31 * t24; + t165 = t31 * t31; + t167 = (t70 + t153) * t18 - t156 * t8 - t158 * t11 - t160 * t26 - 2.0 * t162 * t29 - t165 * t35; + t168 = t108 * t167; + t171 = t13 * t13; + t172 = t112 * t171; + t173 = partial_d_g_uu_112; + t174 = t173 * t24; + t179 = X_udd_213; + t183 = t10 * t2; + t185 = t7 * t54; + t189 = -xx * zz * t18 - t136 * t8 - t179 * t11 - t7 * t2 * t26 - t183 * t29 - t185 * t29 - t10 * t54 * t35; + t190 = t68 * t189; + t193 = t112 * t7; + t194 = t114 * t92; + t195 = t194 * t67; + t197 = t4 * t4; + t198 = t197 * t67; + t202 = t108 * t59; + t205 = t193 * t37; + t208 = t102 * t2; + t209 = t14 * t59; + t212 = t63 * t24; + t216 = t63 * t63; + t217 = t92 * t92; + t218 = t216 * t217; + t220 = t103 * t143 + 2.0 * t94 * t43 * t136 + 2.0 * t107 * t98 * t20 + 2.0 * t68 * t104 + 2.0 * t93 * t168 + t172 * t174 + 2.0 * t3 * t190 + t193 * t195 + 2.0 * t198 * t7 * t37 + 2.0 * t103 * t202 + 2.0 * t93 * t205 + 2.0 * t208 * t209 + 2.0 * t107 * t212 * t189 + t218 * t156; + t222 = t1 * t1; + t223 = t222 * t217; + t224 = X_udd_111; + t226 = t102 * t102; + t227 = t226 * t217; + t232 = t113 * t189; + t235 = t67 * t67; + t236 = t41 * t235; + t237 = partial_d_g_uu_223; + t238 = t237 * t2; + t240 = t194 * t24; + t247 = partial_d_g_uu_333; + t248 = t247 * t92; + t249 = t248 * t2; + t254 = t113 * t136; + t259 = t1 * t171; + t263 = t193 * t189; + t266 = t223 * t224 + t227 * t74 + 2.0 * t107 * t42 * t37 + 2.0 * t208 * t232 + t236 * t238 + t113 * t240 + 2.0 * t93 * t98 * t156 + 2.0 * t68 * t202 + t43 * t249 + 2.0 * t93 * t42 * t167 + 2.0 * t103 * t254 + 2.0 * t212 * t209 + 2.0 * t259 * t4 * t46 + 2.0 * t103 * t263; + t267 = t98 * t167; + t275 = t14 * t46; + t278 = t43 * t46; + t281 = t113 * t224; + t284 = t113 * t37; + t287 = t102 * t217; + t288 = t63 * t46; + t291 = t113 * t20; + t296 = partial_d_g_uu_312; + t297 = t296 * t67; + t298 = t297 * t13; + t300 = t222 * t92; + t307 = X_udd_211; + t309 = t7 * t7; + t311 = t10 * t7; + t314 = t10 * t10; + t316 = (t71 + t153) * t18 - t224 * t8 - t307 * t11 - t309 * t26 - 2.0 * t311 * t29 - t314 * t35; + t317 = t113 * t316; + t322 = 2.0 * t122 * t267 + 2.0 * t94 * t69 * t189 + 4.0 * t43 * t263 + 2.0 * t103 * t275 + 2.0 * t98 * t278 + 2.0 * t107 * t281 + 2.0 * t122 * t284 + 2.0 * t287 * t288 + 2.0 * t93 * t291 + 2.0 * t68 * t275 + t208 * t298 + 2.0 * t300 * t7 * t189 + 2.0 * t3 * t317 + 2.0 * t103 * t86; + t325 = t4 * t24; + t326 = t325 * t189; + t329 = t43 * t85; + t334 = partial_d_g_uu_313; + t335 = t334 * t92; + t336 = t335 * t13; + t340 = t335 * t7; + t346 = t63 * t59; + t350 = partial_d_g_uu_111; + t351 = t350 * t13; + t352 = t351 * t7; + t354 = t193 * t316; + t357 = partial_d_g_uu_113; + t358 = t357 * t2; + t359 = t358 * t13; + t361 = t94 * t189; + t364 = partial_d_g_uu_323; + t365 = t364 * t2; + t366 = t365 * t67; + t368 = 2.0 * t103 * t326 + 2.0 * t208 * t329 + 2.0 * t212 * t329 + t212 * t336 + 4.0 * t68 * t326 + + t68 * t340 + 2.0 * t93 * t278 + 4.0 * t43 * t202 + 4.0 * t103 * t346 * t2 + t94 * t352 + 2.0 * t107 * t354 + t94 * t359 + 2.0 * t208 * t361 + t43 * t366; + t370 = t41 * t59 * t24; + t373 = t357 * t92; + t374 = t373 * t13; + t376 = t1 * t189; + t381 = t63 * t235; + t385 = partial_d_g_uu_133; + t386 = t385 * t217; + t392 = t4 * t20; + t398 = t350 * t171; + t401 = t118 * t171; + t404 = t334 * t2; + t405 = t404 * t13; + t407 = t4 * t37; + t408 = t407 * t24; + t411 = t43 * t189; + t414 = 4.0 * t68 * t370 + t325 * t374 + 4.0 * t103 * t376 * t2 + t98 * t120 + 2.0 * t381 * t41 * t46 + + RATIONAL(1.0, 2.0) * t193 * t386 + 2.0 * t381 * t4 * t136 + 2.0 * t236 * t392 + 2.0 * t259 * t112 * t136 + + RATIONAL(1.0, 2.0) * t3 * t398 + RATIONAL(1.0, 2.0) * t122 * t401 + t68 * t405 + 4.0 * t98 * t408 + 2.0 * t325 * t411; + t416 = t364 * t92; + t417 = t416 * t67; + t419 = t297 * t7; + t421 = t296 * t24; + t422 = t421 * t13; + t424 = t1 * t37; + t428 = t94 * t316; + t431 = t41 * t41; + t432 = t431 * t235; + t434 = t126 * t235; + t437 = t247 * t217; + t440 = t416 * t24; + t442 = t373 * t7; + t449 = t431 * t67; + t454 = t69 * t417 + t103 * t419 + t103 * t422 + 4.0 * t93 * t424 * t2 + 2.0 * t3 * t428 + t432 * t156 + RATIONAL(1.0, 2.0) * t193 * t434 + RATIONAL(1.0, 2.0) * t69 * t437 + t43 * t440 + t94 * t442 + 2.0 * t300 * t13 * t136 + t381 * t296 * t7 + 2.0 * t449 * t167 * t24 + t259 * t421; + t458 = t350 * t7; + t461 = t4 * t235; + t467 = t13 * t189; + t470 = t237 * t92; + t471 = t470 * t24; + t474 = t385 * t92; + t475 = t474 * t2; + t481 = t13 * t37; + t485 = t67 * t59; + t489 = t238 * t67; + t494 = RATIONAL(3.0, 2.0) * t259 * t141 * t7 + RATIONAL(3.0, 2.0) * t172 * t458 + t461 * t115 + 2.0 * t198 * t13 * t20 + 2.0 * t222 * t2 * t467 + 2.0 * t98 * t471 + t113 * t475 + 2.0 * t107 * t94 * t224 + 2.0 * t197 * t24 * t481 + 2.0 * t216 * t2 * t485 + t68 * t249 + t14 * t489 + t107 * t128 + 2.0 * t93 * t99; + t498 = t470 * t67; + t503 = partial_d_g_uu_233; + t504 = t503 * t92; + t505 = t504 * t2; + t507 = t4 * t171; + t514 = t216 * t92; + t518 = t334 * t7; + t534 = t108 * t498 + 2.0 * t103 * t94 * t136 + t14 * t505 + RATIONAL(3.0, 2.0) * t507 * t118 * t7 + 2.0 * t107 * t325 * t316 + 2.0 * t514 * t24 * t59 + t287 * t518 + t259 * t404 + RATIONAL(3.0, 2.0) * t461 * t126 * t24 + 2.0 * t514 * t67 * t46 + RATIONAL(1.0, 2.0) * t3 * t434 + 2.0 * t68 * t440 + t172 * t358 + 2.0 * t68 * t422; + t536 = partial_d_g_uu_213; + t542 = t98 * t59; + t545 = t68 * t85; + t548 = t216 * t235; + t551 = t536 * t13; + t552 = t551 * t2; + t559 = t174 * t13; + t561 = t536 * t92; + t562 = t561 * t7; + t565 = t226 * t92; + t569 = t94 * t475 + t507 * t536 * t2 + 2.0 * t43 * t340 + t14 * t471 + 2.0 * t208 * t542 + 2.0 * t208 * t545 + t548 * t74 + t98 * t505 + 2.0 * t93 * t552 + 2.0 * t94 * t240 + 2.0 * t113 * t442 + t107 * t559 + 2.0 * t14 * t562 + 2.0 * t565 * t85 * t2; + t571 = partial_d_g_uu_322; + t572 = t571 * t67; + t573 = t572 * t24; + t575 = t173 * t67; + t576 = t575 * t13; + t588 = partial_d_g_uu_212; + t589 = t588 * t24; + t590 = t589 * t13; + t593 = t588 * t67; + t594 = t593 * t13; + t599 = t575 * t7; + t601 = t63 * t217; + t605 = t141 * t171; + t608 = t43 * t573 + t3 * t576 + 2.0 * t103 * t405 + 2.0 * t43 * t419 + t103 * t573 + 2.0 * t107 * t359 + 2.0 * t514 * t167 * t2 + t93 * t590 + t381 * t365 + t122 * t594 + 2.0 * t103 * t98 * t46 + t107 * t599 + + 2.0 * t601 * t1 * t20 + RATIONAL(1.0, 2.0) * t208 * t605; + t609 = t593 * t7; + t612 = partial_d_g_uu_222; + t613 = t612 * t24; + t627 = t588 * t7; + t632 = t612 * t67; + t633 = t632 * t24; + t640 = t216 * t67; + t644 = 2.0 * t14 * t609 + RATIONAL(3.0, 2.0) * t236 * t613 + t93 * t609 + 2.0 * t113 * t599 + + RATIONAL(1.0, 2.0) * t42 * t401 + 2.0 * t107 * t116 + RATIONAL(1.0, 2.0) * t325 * t398 + 2.0 * t103 * t366 + t236 * t627 + 2.0 * t103 * t212 * t85 + t14 * t633 + 2.0 * t93 * t489 + RATIONAL(3.0, 2.0) * t381 * t571 * t24 + 2.0 * t640 * t85 * t24; + t652 = t364 * t24; + t656 = t1 * t217; + t664 = t247 * t2; + t669 = t1 * t136; + t672 = t503 * t217; + t677 = t112 * t112; + t678 = t677 * t171; + t680 = 4.0 * t14 * t205 + 2.0 * t103 * t68 * t74 + t287 * t652 + t461 * t173 * t7 + t656 * t114 * t24 + t601 * t237 * t24 + t507 * t589 + t601 * t536 * t7 + RATIONAL(3.0, 2.0) * t287 * t664 + RATIONAL(1.0, 2.0) * t212 * t437 + 2.0 * t287 * t669 + RATIONAL(1.0, 2.0) * t108 * t672 + RATIONAL(1.0, 2.0) * t42 * t672 + t678 * t224; + t694 = t677 * t13; + t704 = t571 * t235; + t707 = t612 * t235; + t712 = t222 * t13; + t716 = 2.0 * t98 * t590 + 2.0 * t300 * t316 * t2 + 2.0 * t94 * t559 + t98 * t562 + 2.0 * t122 * t60 + + t93 * t633 + 2.0 * t103 * t370 + 2.0 * t694 * t316 * t7 + RATIONAL(3.0, 2.0) * t656 * t385 * t2 + RATIONAL(3.0, 2.0) * t601 * t503 * t2 + RATIONAL(1.0, 2.0) * t208 * t704 + RATIONAL(1.0, 2.0) * t122 * t707 + + RATIONAL(1.0, 2.0) * t69 * t704 + 2.0 * t712 * t85 * t7; + t723 = t197 * t13; + t738 = t14 * t167; + t741 = t14 * t156; + t746 = t561 * t13; + t748 = t197 * t235; + t750 = 2.0 * t198 * t316 * t24 + t656 * t357 * t7 + 2.0 * t723 * t167 * t7 + t68 * t143 + 2.0 * t507 * t112 * t20 + 2.0 * t94 * t354 + t98 * t552 + RATIONAL(1.0, 2.0) * t108 * t707 + RATIONAL(1.0, 2.0) * t212 * t605 + 2.0 * t122 * t738 + 2.0 * t98 * t741 + 2.0 * t93 * t408 + t42 * t746 + t748 * t224; + t774 = t197 * t171; + t776 = t222 * t171; + t780 = 2.0 * t94 * t281 + 2.0 * t42 * t284 + 2.0 * t98 * t168 + t107 * t352 + 2.0 * t212 * t232 + 2.0 * t93 * t741 + RATIONAL(1.0, 2.0) * t325 * t386 + 2.0 * t42 * t738 + 2.0 * t98 * t205 + 2.0 * t98 * t291 + + 2.0 * t325 * t317 + 2.0 * t68 * t254 + t774 * t156 + t776 * t74 + 2.0 * t68 * t263; + t785 = pow(Theta_D, 1.0 * RATIONAL(1.0, 2.0)); + t787 = 1 / t785 / Theta_D; + t792 = -t458 - t627 - t518 - t174 - t613 - t652 - t358 - t238 - t664 - t112 * t224 - 2.0 * t392 - 2.0 * t669; + t796 = partial_d_ln_sqrt_g_1; + t797 = t112 * t796; + t799 = partial_d_ln_sqrt_g_2; + t800 = t4 * t799; + t802 = partial_d_ln_sqrt_g_3; + t803 = t1 * t802; + t805 = t4 * t796; + t807 = t41 * t799; + t809 = t63 * t802; + t811 = t1 * t796; + t813 = t63 * t799; + t815 = t102 * t802; + t817 = -t41 * t156 - 2.0 * t288 - t102 * t74 - t797 * t7 - t800 * t7 - t803 * t7 - t805 * t24 - t807 * t24 - t809 * t24 - t811 * t2 - t813 * t2 - t815 * t2; + t819 = 1 / t785; + t822 = K_uu_11 * t13; + t824 = K_uu_12; + t827 = t824 * t67; + t829 = K_uu_13; + t832 = t829 * t92; + t835 = K_uu_22 * t67; + t837 = K_uu_23; + t840 = t837 * t92; + t843 = K_uu_33 * t92; + t847 = 1 / Theta_D; + t860 = Theta_D * Theta_D; + t869 = RATIONAL(3.0, 2.0) * Theta_A / t785 / t860 + RATIONAL(1.0, 2.0) * Theta_B * t787 + Theta_C / t860; + partial_Theta_wrt_partial_d_h_1 = (t140 + t220 + t266 + t322 + t368 + t414 + t454 + + t494 + t534 + t569 + t608 + t644 + t680 + t716 + t750 + t780) * + t787 + + (t792 + t817) * t819 + (-2.0 * t822 * t7 - 2.0 * t824 * t24 * t13 - 2.0 * t827 * t7 - 2.0 * t829 * t2 * t13 - 2.0 * t832 * t7 - 2.0 * t835 * t24 - 2.0 * t837 * t2 * t67 - 2.0 * t840 * t24 - 2.0 * t843 * t2) * t847 - (-2.0 * t113 * t7 - 2.0 * t325 * t13 - 2.0 * t94 * t7 - 2.0 * t3 * t13 - 2.0 * t107 * t7 - 2.0 * t98 * t24 - 2.0 * t122 * t67 - 2.0 * t93 * t24 - 2.0 * t103 * t2) * t869; + t871 = t113 * t22; + t876 = t63 * t54; + t882 = t551 * t54; + t886 = t561 * t10; + t890 = t112 * t10; + t891 = t890 * t316; + t897 = t334 * t10; + t899 = 2.0 * t93 * t871 + t381 * t296 * t10 + t876 * t594 + 2.0 * t93 * t94 * t22 + t432 * t158 + 2.0 * t93 * t882 + t218 * t158 + 2.0 * t14 * t886 + t748 * t307 + 2.0 * t94 * t891 + t890 * t195 + t548 * t76 + t223 * t307 + t287 * t897; + t900 = t194 * t31; + t902 = t334 * t54; + t904 = t114 * t54; + t905 = t904 * t67; + t907 = t63 * t31; + t913 = t102 * t54; + t920 = t14 * t48; + t929 = t4 * t10; + t930 = t929 * t59; + t933 = t335 * t10; + t938 = t113 * t900 + t259 * t902 + t113 * t905 + 2.0 * t907 * t209 + 2.0 * t300 * t13 * t179 + 2.0 * t913 * t545 + t507 * t536 * t54 + t601 * t536 * t10 + 2.0 * t68 * t920 + 2.0 * t712 * t85 * t10 + 2.0 * t449 * t167 * t31 + 2.0 * t68 * t930 + t68 * t933 + 2.0 * t197 * t31 * t481; + t944 = t1 * t54; + t947 = t588 * t31; + t949 = t113 * t307; + t962 = t364 * t54; + t970 = t4 * t31; + t971 = t970 * t189; + t976 = t913 * t298 + 2.0 * t103 * t907 * t85 + 2.0 * t944 * t317 + t507 * t947 + 2.0 * t107 * t949 + + RATIONAL(3.0, 2.0) * t507 * t118 * t10 + 2.0 * t259 * t4 * t48 + t259 * t296 * t31 + 2.0 * t107 * t891 + + t381 * t962 + 2.0 * t198 * t13 * t22 + 2.0 * t103 * t68 * t76 + 2.0 * t103 * t971 + 2.0 * t876 * t60; + t979 = t416 * t31; + t983 = t351 * t10; + t996 = t1 * t10; + t997 = t996 * t85; + t1000 = t41 * t31; + t1001 = t1000 * t59; + t1004 = t996 * t59; + t1010 = t142 * t10; + t1012 = 2.0 * t907 * t329 + t43 * t979 + 2.0 * t913 * t361 + t107 * t983 + 2.0 * t944 * t38 + 4.0 * t93 * t424 * t54 + 2.0 * t107 * t929 * t37 + 2.0 * t103 * t94 * t179 + 2.0 * t68 * t997 + 2.0 * t103 * t1001 + + 2.0 * t98 * t1004 + t970 * t374 + 2.0 * t913 * t542 + t103 * t1010; + t1015 = t119 * t10; + t1033 = t43 * t48; + t1036 = t297 * t10; + t1039 = t373 * t10; + t1047 = t357 * t54; + t1048 = t1047 * t13; + t1050 = t93 * t1015 + 2.0 * t107 * t1000 * t37 + 2.0 * t259 * t112 * t179 + 2.0 * t970 * t411 + 2.0 * t944 * t133 + 2.0 * t93 * t1004 + 2.0 * t103 * t98 * t48 + t774 * t158 + 2.0 * t98 * t1033 + 2.0 * t43 * t1036 + 2.0 * t113 * t1039 + 2.0 * t1000 * t60 + 2.0 * t94 * t43 * t179 + t94 * t1048; + t1062 = t43 * t76; + t1065 = t113 * t179; + t1070 = t470 * t31; + t1074 = t237 * t54; + t1075 = t1074 * t67; + t1078 = t504 * t54; + t1080 = t474 * t54; + t1082 = 2.0 * t107 * t98 * t22 + 2.0 * t94 * t996 * t189 + t98 * t1015 + 2.0 * t970 * t317 + 2.0 * t876 * t123 + 2.0 * t68 * t1062 + 2.0 * t68 * t1065 + 2.0 * t944 * t428 + t14 * t1070 + 2.0 * t94 * t949 + t14 * t1075 + t94 * t1039 + t14 * t1078 + t113 * t1080; + t1087 = t112 * t189 * t10; + t1093 = t248 * t54; + t1095 = t127 * t31; + t1097 = t572 * t31; + t1103 = t296 * t13 * t31; + t1107 = t407 * t31; + t1112 = t632 * t31; + t1114 = 4.0 * t43 * t930 + 4.0 * t43 * t1087 + t227 * t76 + 4.0 * t68 * t971 + t68 * t1093 + t107 * t1095 + t103 * t1097 + 4.0 * t68 * t1001 + t98 * t1078 + 2.0 * t68 * t1103 + t678 * t307 + 4.0 * t98 * t1107 + + RATIONAL(1.0, 2.0) * t1000 * t672 + t93 * t1112; + t1138 = t173 * t31; + t1139 = t1138 * t13; + t1141 = t4 * t22; + t1145 = 2.0 * t381 * t41 * t48 + 2.0 * t216 * t54 * t485 + t103 * t1103 + RATIONAL(1.0, 2.0) * t996 * t704 + t103 * t1036 + t601 * t237 * t31 + t172 * t1047 + RATIONAL(3.0, 2.0) * t601 * t503 * t54 + + 2.0 * t514 * t31 * t59 + 2.0 * t514 * t67 * t48 + t776 * t76 + t107 * t1139 + 2.0 * t236 * t1141 + t996 * t417; + t1150 = t593 * t10; + t1163 = t947 * t13; + t1166 = t962 * t67; + t1169 = t575 * t10; + t1174 = t944 * t576 + t93 * t1150 + 2.0 * t723 * t167 * t10 + RATIONAL(1.0, 2.0) * t890 * t386 + RATIONAL(1.0, 2.0) * t929 * t672 + RATIONAL(1.0, 2.0) * t944 * t434 + RATIONAL(1.0, 2.0) * t907 * t437 + t93 * t1163 + t98 * t882 + t43 * t1166 + t1000 * t746 + t107 * t1169 + t43 * t1097 + 2.0 * t107 * t1048; + t1186 = t112 * t37 * t10; + t1189 = t929 * t167; + t1192 = t14 * t158; + t1200 = t43 * t1093 + t907 * t336 + 2.0 * t98 * t1070 + t113 * t1095 + 2.0 * t113 * t1169 + t68 * t1010 + t98 * t886 + t94 * t1080 + 4.0 * t14 * t1186 + 2.0 * t93 * t1189 + 2.0 * t93 * t1192 + 2.0 * t913 * t232 + 2.0 * t876 * t738 + t14 * t1112; + t1214 = t902 * t13; + t1234 = 2.0 * t107 * t14 * t22 + 2.0 * t1000 * t738 + 2.0 * t876 * t267 + 2.0 * t107 * t68 * t179 + + 2.0 * t94 * t900 + t68 * t1214 + 2.0 * t103 * t920 + 2.0 * t944 * t190 + 2.0 * t68 * t1087 + 2.0 * t93 * t98 * t158 + 2.0 * t907 * t232 + 2.0 * t93 * t1000 * t167 + 2.0 * t98 * t1192 + 2.0 * t98 * t1189; + t1266 = 2.0 * t103 * t1065 + t94 * t983 + 2.0 * t1000 * t284 + 2.0 * t198 * t316 * t31 + 2.0 * t107 * t907 * t189 + RATIONAL(1.0, 2.0) * t890 * t434 + 2.0 * t103 * t1166 + 2.0 * t43 * t933 + 2.0 * t103 * t930 + 2.0 * t94 * t1139 + 2.0 * t98 * t1163 + 2.0 * t98 * t1186 + RATIONAL(3.0, 2.0) * t259 * t141 * t10 + + 2.0 * t222 * t54 * t467; + t1281 = t588 * t10; + t1289 = t247 * t54; + t1300 = 2.0 * t300 * t10 * t189 + RATIONAL(3.0, 2.0) * t656 * t385 * t54 + t461 * t904 + t172 * t1138 + t236 * t1074 + 2.0 * t694 * t316 * t10 + t236 * t1281 + RATIONAL(3.0, 2.0) * t381 * t571 * t31 + + RATIONAL(3.0, 2.0) * t461 * t126 * t31 + RATIONAL(3.0, 2.0) * t287 * t1289 + 2.0 * t103 * t1087 + 2.0 * t107 * t905 + 2.0 * t68 * t979 + 2.0 * t98 * t871; + t1301 = t612 * t31; + t1308 = t364 * t31; + t1335 = RATIONAL(3.0, 2.0) * t236 * t1301 + 2.0 * t93 * t1075 + 2.0 * t14 * t1150 + t287 * t1308 + t656 * t114 * t31 + t461 * t173 * t10 + RATIONAL(1.0, 2.0) * t1000 * t401 + t656 * t357 * t10 + + 2.0 * t300 * t316 * t54 + 2.0 * t507 * t112 * t22 + 2.0 * t640 * t85 * t31 + 2.0 * t601 * t1 * t22 + RATIONAL(1.0, 2.0) * t876 * t707 + 2.0 * t565 * t85 * t54; + t1342 = t63 * t48; + t1345 = t1 * t179; + t1364 = t350 * t10; + t1370 = RATIONAL(1.0, 2.0) * t913 * t704 + 2.0 * t514 * t167 * t54 + 2.0 * t287 * t1342 + 2.0 * t287 * t1345 + RATIONAL(1.0, 2.0) * t970 * t398 + RATIONAL(1.0, 2.0) * t996 * t437 + RATIONAL(1.0, 2.0) * t907 * t605 + RATIONAL(1.0, 2.0) * t944 * t398 + RATIONAL(1.0, 2.0) * t876 * t401 + + RATIONAL(1.0, 2.0) * t913 * t605 + RATIONAL(1.0, 2.0) * t929 * t707 + RATIONAL(1.0, 2.0) * t970 * t386 + RATIONAL(3.0, 2.0) * t172 * t1364 + 2.0 * t198 * t10 * t37; + t1405 = 4.0 * t103 * t376 * t54 + 2.0 * t103 * t1214 + 4.0 * t103 * t346 * t54 + 2.0 * t93 * t1107 + + 2.0 * t107 * t94 * t307 + 2.0 * t107 * t970 * t316 + 2.0 * t913 * t209 + 2.0 * t381 * t4 * t179 + t929 * t498 + + 2.0 * t93 * t1033 + 2.0 * t103 * t997 + 2.0 * t103 * t1062 + 2.0 * t913 * t329 + 2.0 * t876 * t284 + 2.0 * t93 * t1186; + t1414 = -t1364 - t1281 - t897 - t1138 - t1301 - t1308 - t1047 - t1074 - t1289 - t112 * t307 - 2.0 * t1141 - 2.0 * t1345; + t1427 = -t41 * t158 - 2.0 * t1342 - t102 * t76 - t797 * t10 - t800 * t10 - t803 * t10 - t805 * t31 - + t807 * t31 - t809 * t31 - t811 * t54 - t813 * t54 - t815 * t54; + partial_Theta_wrt_partial_d_h_2 = (t899 + t938 + t976 + t1012 + t1050 + t1082 + t1114 + t1145 + t1174 + t1200 + t1234 + t1266 + t1300 + t1335 + t1370 + t1405) * t787 + (t1414 + t1427) * t819 + (-2.0 * t822 * t10 - 2.0 * t824 * t31 * t13 - 2.0 * t827 * t10 - 2.0 * t829 * t54 * t13 - 2.0 * t832 * t10 - 2.0 * t835 * t31 - 2.0 * t837 * t54 * t67 - 2.0 * t840 * t31 - 2.0 * t843 * t54) * t847 - (-2.0 * t113 * t10 - 2.0 * t970 * t13 - 2.0 * t94 * t10 - 2.0 * t944 * t13 - 2.0 * t107 * t10 - 2.0 * t98 * t31 - 2.0 * t876 * t67 - 2.0 * t93 * t31 - 2.0 * t103 * t54) * t869; + t1457 = t14 * t160; + t1460 = t69 * t2; + t1463 = t68 * t4; + t1465 = t13 * t24 * t2; + t1469 = t43 * t78; + t1475 = t103 * t4; + t1476 = t67 * t7; + t1477 = t1476 * t2; + t1483 = t212 * t2; + t1486 = t107 * t41; + t1487 = t1476 * t24; + t1491 = 2.0 * t98 * t1457 + 2.0 * t287 * t1460 + 2.0 * t1463 * t1465 + t774 * t160 + 2.0 * t68 * t1469 + 2.0 * t107 * t94 * t309 + 2.0 * t1475 * t1477 + 2.0 * t381 * t108 * t2 + 2.0 * t287 * t1483 + 2.0 * t1486 * t1487 + t218 * t160; + t1492 = t13 * t7; + t1493 = t1492 * t24; + t1497 = t113 * t309; + t1505 = t98 * t1; + t1508 = t103 * t41; + t1510 = t67 * t24 * t2; + t1513 = t93 * t4; + t1516 = t94 * t1; + t1517 = t1492 * t2; + t1520 = t107 * t4; + t1526 = 2.0 * t198 * t1493 + t223 * t309 + 2.0 * t107 * t1497 + 2.0 * t259 * t193 * t2 + 2.0 * t93 * t1457 + 2.0 * t1505 * t1465 + 2.0 * t1508 * t1510 + 2.0 * t1513 * t1487 + 2.0 * t1516 * t1517 + 2.0 * t1520 * t1493 + 2.0 * t103 * t68 * t78; + t1536 = t93 * t112; + t1547 = t93 * t1; + t1552 = t432 * t160 + 2.0 * t93 * t98 * t160 + t548 * t78 + 2.0 * t514 * t1510 + t748 * t309 + 2.0 * t1536 * t1493 + 2.0 * t300 * t1517 + 2.0 * t381 * t42 * t2 + 2.0 * t507 * t193 * t24 + 2.0 * t1547 * t1465 + + 2.0 * t1475 * t1465; + t1555 = t103 * t112; + t1558 = t98 * t112; + t1561 = t108 * t24; + t1572 = t68 * t112; + t1580 = 2.0 * t1547 * t1477 + 2.0 * t1555 * t1517 + 2.0 * t1558 * t1493 + 2.0 * t236 * t1561 + + 2.0 * t259 * t325 * t2 + t776 * t78 + t678 * t309 + t227 * t78 + 2.0 * t94 * t1497 + 2.0 * t1572 * t1517 + 2.0 * t103 * t1469 + 2.0 * t601 * t69 * t24; + partial_Theta_wrt_partial_dd_h_11 = (t1491 + t1526 + t1552 + t1580) * t787 + (-t112 * t309 - 2.0 * t1561 - 2.0 * t1460 - t41 * t160 - 2.0 * t1483 - t102 * t78) * t819; + t1594 = -t183 - t185; + t1600 = t67 * t10; + t1606 = -t28 - t32; + t1610 = t1 * t1594; + t1622 = 2.0 * t218 * t162 - 2.0 * t107 * t68 * t1594 + 2.0 * t432 * t162 + 4.0 * t1520 * t1600 * t7 + 2.0 * t776 * t80 - 2.0 * t601 * t1 * t1606 - 2.0 * t287 * t1610 + 2.0 * t223 * t311 + 2.0 * t748 * t311 - 2.0 * t93 * t94 * t1606 + 2.0 * t774 * t162; + t1629 = -t52 - t55; + t1639 = t113 * t1606; + t1641 = t113 * t1594; + t1643 = t14 * t1629; + t1645 = -t381 * t4 * t1594 - t300 * t13 * t1594 - t107 * t98 * t1606 - t259 * t4 * t1629 - t103 * t94 * t1594 - t107 * t14 * t1606 + t678 * t311 - t507 * t112 * t1606 - t93 * t1639 - t103 * t1641 - t103 * t1643; + t1648 = t43 * t1629; + t1655 = t13 * t54 * t2; + t1659 = t13 * t10; + t1660 = t1659 * t7; + t1666 = t13 * t31; + t1667 = t1666 * t24; + t1684 = -2.0 * t93 * t1648 + 2.0 * t227 * t80 + 4.0 * t103 * t1 * t1655 + 4.0 * t94 * t112 * t1660 - 2.0 * t198 * t13 * t1606 + 4.0 * t1513 * t1667 - 2.0 * t514 * t67 * t1629 - 2.0 * t94 * t43 * t1594 + 4.0 * t68 * t1 * t1655 + 4.0 * t98 * t4 * t1667 - 2.0 * t98 * t1639; + t1697 = t4 * t1606; + t1704 = t67 * t31; + t1718 = t63 * t1629; + t1721 = -2.0 * t259 * t112 * t1594 - 2.0 * t68 * t1643 - 2.0 * t68 * t1641 - 2.0 * t98 * t1648 + + 4.0 * t107 * t112 * t1660 - 2.0 * t236 * t1697 - 2.0 * t381 * t41 * t1629 + 4.0 * t93 * t41 * t1704 * t24 - 2.0 * t103 * t98 * t1629 + 2.0 * t548 * t80 + 4.0 * t103 * t63 * t67 * t54 * t2 - 2.0 * t287 * t1718; + partial_Theta_wrt_partial_dd_h_12 = (t1622 + 2.0 * t1645 + t1684 + t1721) * t787 + (-2.0 * t890 * t7 + 2.0 * t1697 + 2.0 * t1610 - 2.0 * t1000 * t24 + 2.0 * t1718 - 2.0 * t913 * t2) * t819; + t1739 = t996 * t54; + t1748 = t1704 * t54; + t1751 = t1600 * t54; + t1757 = t1600 * t31; + t1760 = 2.0 * t507 * t890 * t31 + 2.0 * t93 * t98 * t165 + t227 * t83 + t548 * t83 + 2.0 * t287 * t1739 + 2.0 * t259 * t970 * t54 + 2.0 * t601 * t996 * t31 + 2.0 * t514 * t1748 + 2.0 * t1547 * t1751 + 2.0 * t107 * t94 * t314 + 2.0 * t1486 * t1757; + t1761 = t907 * t54; + t1768 = t1659 * t31; + t1771 = t113 * t314; + t1783 = 2.0 * t287 * t1761 + t748 * t314 + t774 * t165 + t678 * t314 + t223 * t314 + 2.0 * t198 * t1768 + 2.0 * t94 * t1771 + 2.0 * t1513 * t1757 + 2.0 * t1520 * t1768 + 2.0 * t1475 * t1751 + 2.0 * t103 * t68 * t83; + t1785 = t1666 * t54; + t1788 = t1659 * t54; + t1791 = t43 * t83; + t1803 = t14 * t165; + t1809 = 2.0 * t1547 * t1785 + 2.0 * t1516 * t1788 + 2.0 * t68 * t1791 + 2.0 * t1558 * t1768 + 2.0 * t259 * t890 * t54 + 2.0 * t107 * t1771 + 2.0 * t1463 * t1785 + 2.0 * t98 * t1803 + t218 * t165 + t776 * t83 + + t432 * t165; + t1812 = t929 * t31; + t1825 = t1572 * t1788 + t1505 * t1785 + t236 * t1812 + t103 * t1791 + t300 * t1788 + t381 * t1000 * t54 + t381 * t929 * t54 + t93 * t1803 + t1555 * t1788 + t1536 * t1768 + t1475 * t1785 + t1508 * t1748; + partial_Theta_wrt_partial_dd_h_22 = (t1760 + t1783 + t1809 + 2.0 * t1825) * t787 + (-t112 * t314 - 2.0 * t1812 - 2.0 * t1739 - t41 * t165 - 2.0 * t1761 - t102 * t83) * t819; + } + } + } + } + + return true; // *** NORMAL RETURN *** + } + } + +} // namespace AHFinderDirect +#endif diff --git a/AMSS_NCKU_source/expansion_Jacobian.C b/AMSS_NCKU_source/AHF_Direct/expansion_Jacobian.C similarity index 97% rename from AMSS_NCKU_source/expansion_Jacobian.C rename to AMSS_NCKU_source/AHF_Direct/expansion_Jacobian.C index ba53210..014c2f2 100644 --- a/AMSS_NCKU_source/expansion_Jacobian.C +++ b/AMSS_NCKU_source/AHF_Direct/expansion_Jacobian.C @@ -1,386 +1,386 @@ - - -#include "macrodef.h" -#ifdef With_AHF - -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -namespace AHFinderDirect -{ - using jtutil::error_exit; - - namespace - { - - void expansion_Jacobian_partial_SD(patch_system &ps, Jacobian &Jac, - bool print_msg_flag); - - void add_ghost_zone_Jacobian(const patch_system &ps, - Jacobian &Jac, - fp mol, - const patch &xp, const ghost_zone &xmgz, - int x_II, - int xm_irho, int xm_isigma); - - enum expansion_status - expansion_Jacobian_dr_FD(patch_system *ps_ptr, Jacobian *Jac_ptr, fp add_to_expansion, - bool initial_flag, - bool print_msg_flag); - } - - //****************************************************************************** - - // - // If ps_ptr != NULL and Jac_ptr != NULL, this function computes the - // Jacobian matrix J[Theta(h)] of the expansion Theta(h). We assume - // that Theta(h) has already been computed. - // - // If ps_ptr == NULL and Jac_ptr == NULL, this function does a dummy - // computation, in which only any expansion() (and hence geometry - // interpolator) calls are done, these with the number of interpolation - // points set to 0 and all the output array pointers set to NULL. - // - // It's illegal for one but not both of ps_ptr and Jac_ptr to be NULL. - // - // Arguments: - // ps_ptr --> The patch system, or == NULL to do (only) a dummy computation. - // Jac_ptr --> The Jacobian, or == NULL to do (only) a dummy computation. - // add_to_expansion = A real number to add to the expansion. - // - // Results: - // This function returns a status code indicating whether the computation - // succeeded or failed, and if the latter, what caused the failure. - // - enum expansion_status - expansion_Jacobian(patch_system *ps_ptr, Jacobian *Jac_ptr, - fp add_to_expansion, - bool initial_flag, - bool print_msg_flag /* = false */) - { - const bool active_flag = (ps_ptr != NULL) && (Jac_ptr != NULL); - enum expansion_status status; - - if (active_flag) - then expansion_Jacobian_partial_SD(*ps_ptr, *Jac_ptr, - print_msg_flag); - // this function looks at ps_ptr and Jac_ptr (non-NULL vs NULL) - // to choose a normal vs dummy computation - { - status = expansion_Jacobian_dr_FD(ps_ptr, Jac_ptr, add_to_expansion, - initial_flag, - print_msg_flag); - if (status != expansion_success) - then return status; // *** ERROR RETURN *** - } - - return expansion_success; // *** NORMAL RETURN *** - } - // - // This function computes the partial derivative terms in the Jacobian - // matrix of the expansion Theta(h), by symbolic differentiation from - // the Jacobian coefficient (angular) gridfns. The Jacobian is traversed - // by rows, using equation (25) of my 1996 apparent horizon finding paper. - // - // Inputs (angular gridfns, on ghosted grid): - // h # shape of trial surface - // Theta # Theta(h) assumed to already be computed - // partial_Theta_wrt_partial_d_h # Jacobian coefficients - // partial_Theta_wrt_partial_dd_h # (also assumed to already be computed) - // - // Outputs: - // The Jacobian matrix is stored in the Jacobian object Jac. - // - namespace - { - void expansion_Jacobian_partial_SD(patch_system &ps, Jacobian &Jac, - bool print_msg_flag) - { - Jac.zero_matrix(); - ps.compute_synchronize_Jacobian(); - - for (int xpn = 0; xpn < ps.N_patches(); ++xpn) - { - patch &xp = ps.ith_patch(xpn); - - for (int x_irho = xp.min_irho(); x_irho <= xp.max_irho(); ++x_irho) - { - for (int x_isigma = xp.min_isigma(); x_isigma <= xp.max_isigma(); ++x_isigma) - { - // - // compute the main Jacobian terms for this grid point, i.e. - // partial Theta(this point x, Jacobian row II) - // --------------------------------------------- - // partial h(other points y, Jacobian column JJ) - // - - // Jacobian row index - const int II = ps.gpn_of_patch_irho_isigma(xp, x_irho, x_isigma); - - // Jacobian coefficients for this point - const fp Jacobian_coeff_rho = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_1, - x_irho, x_isigma); - const fp Jacobian_coeff_sigma = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_2, - x_irho, x_isigma); - const fp Jacobian_coeff_rho_rho = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_11, - x_irho, x_isigma); - const fp Jacobian_coeff_rho_sigma = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_12, - x_irho, x_isigma); - const fp Jacobian_coeff_sigma_sigma = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_22, - x_irho, x_isigma); - - // partial_rho, partial_rho_rho - { - for (int m_irho = xp.molecule_min_m(); - m_irho <= xp.molecule_max_m(); - ++m_irho) - { - const int xm_irho = x_irho + m_irho; - const fp Jac_rho = Jacobian_coeff_rho * xp.partial_rho_coeff(m_irho); - const fp Jac_rho_rho = Jacobian_coeff_rho_rho * xp.partial_rho_rho_coeff(m_irho); - const fp Jac_sum = Jac_rho + Jac_rho_rho; - if (xp.is_in_nominal_grid(xm_irho, x_isigma)) - then - { - const int xm_JJ = Jac.II_of_patch_irho_isigma(xp, xm_irho, x_isigma); - Jac.sum_into_element(II, xm_JJ, Jac_sum); - } - else - add_ghost_zone_Jacobian(ps, Jac, - Jac_sum, - xp, xp.minmax_rho_ghost_zone(m_irho < 0), - II, xm_irho, x_isigma); - } - } - - // partial_sigma, partial_sigma_sigma - { - for (int m_isigma = xp.molecule_min_m(); - m_isigma <= xp.molecule_max_m(); - ++m_isigma) - { - const int xm_isigma = x_isigma + m_isigma; - const fp Jac_sigma = Jacobian_coeff_sigma * xp.partial_sigma_coeff(m_isigma); - const fp Jac_sigma_sigma = Jacobian_coeff_sigma_sigma * xp.partial_sigma_sigma_coeff(m_isigma); - const fp Jac_sum = Jac_sigma + Jac_sigma_sigma; - if (xp.is_in_nominal_grid(x_irho, xm_isigma)) - then - { - const int xm_JJ = Jac.II_of_patch_irho_isigma(xp, x_irho, xm_isigma); - Jac.sum_into_element(II, xm_JJ, Jac_sum); - } - else - add_ghost_zone_Jacobian(ps, Jac, - Jac_sum, - xp, xp.minmax_sigma_ghost_zone(m_isigma < 0), - II, x_irho, xm_isigma); - } - } - - // partial_rho_sigma - { - for (int m_irho = xp.molecule_min_m(); - m_irho <= xp.molecule_max_m(); - ++m_irho) - { - for (int m_isigma = xp.molecule_min_m(); - m_isigma <= xp.molecule_max_m(); - ++m_isigma) - { - const int xm_irho = x_irho + m_irho; - const int xm_isigma = x_isigma + m_isigma; - const fp Jac_rho_sigma = Jacobian_coeff_rho_sigma * xp.partial_rho_sigma_coeff(m_irho, m_isigma); - if (xp.is_in_nominal_grid(xm_irho, xm_isigma)) - then - { - const int xm_JJ = Jac.II_of_patch_irho_isigma(xp, xm_irho, xm_isigma); - Jac.sum_into_element(II, xm_JJ, Jac_rho_sigma); - } - else - { - const ghost_zone &xmgz = xp.corner_ghost_zone_containing_point(m_irho < 0, m_isigma < 0, - xm_irho, xm_isigma); - add_ghost_zone_Jacobian(ps, Jac, - Jac_rho_sigma, - xp, xmgz, - II, xm_irho, xm_isigma); - } - } - } - } - } - } - } - } - } - - //****************************************************************************** - - // - // This function adds the ghost-zone Jacobian dependency contributions - // for a single ghost-zone point, to a Jacobian matrix. - // - // Arguments: - // ps = The patch system. - // Jac = (out) The Jacobian matrix. - // mol = The molecule coefficient. - // xp = The patch containing the center point of the molecule. - // xmgz = If the x+m point is in a ghost zone, this must be that ghost zone. - // If the x+m point is not in a ghost zone, this argument is ignored. - // x_II = The Jacobian row of the x point. - // xm_(irho,isigma) = The coordinates (in xp) of the x+m point of the molecule. - - namespace - { - void add_ghost_zone_Jacobian(const patch_system &ps, - Jacobian &Jac, - fp mol, - const patch &xp, const ghost_zone &xmgz, - int x_II, - int xm_irho, int xm_isigma) - { - const patch_edge &xme = xmgz.my_edge(); - const int xm_iperp = xme.iperp_of_irho_isigma(xm_irho, xm_isigma); - const int xm_ipar = xme.ipar_of_irho_isigma(xm_irho, xm_isigma); - - // FIXME: this won't change from one call to another - // ==> it would be more efficient to reuse the same buffer - // across multiple calls on this function - int global_min_ym, global_max_ym; - ps.synchronize_Jacobian_global_minmax_ym(global_min_ym, global_max_ym); - jtutil::array1d Jacobian_buffer(global_min_ym, global_max_ym); - - // on what other points y does this molecule point xm depend - // via the patch_system::synchronize() operation? - int y_iperp; - int y_posn, min_ym, max_ym; - const patch_edge &ye = ps.synchronize_Jacobian(xmgz, - xm_iperp, xm_ipar, - y_iperp, - y_posn, min_ym, max_ym, - Jacobian_buffer); - patch &yp = ye.my_patch(); - - // add the Jacobian contributions from the ym points - for (int ym = min_ym; ym <= max_ym; ++ym) - { - const int y_ipar = y_posn + ym; - const int y_irho = ye.irho_of_iperp_ipar(y_iperp, y_ipar); - const int y_isigma = ye.isigma_of_iperp_ipar(y_iperp, y_ipar); - const int y_JJ = Jac.II_of_patch_irho_isigma(yp, y_irho, y_isigma); - Jac.sum_into_element(x_II, y_JJ, mol * Jacobian_buffer(ym)); - } - } - } - - //****************************************************************************** - - // - // If ps_ptr != NULL and Jac_ptr != NULL, this function sums the d/dr - // terms into the Jacobian matrix of the expansion Theta(h), computing - // those terms by finite differencing. - // - // If ps_ptr == NULL and Jac_ptr == NULL, this function does a dummy - // computation, in which only any expansion() (and hence geometry - // interpolator) calls are done, these with the number of interpolation - // points set to 0 and all the output array pointers set to NULL. - // - // It's illegal for one but not both of ps_ptr and Jac_ptr to be NULL. - // - // The basic algorithm is that - // Jac += diag[ (Theta(h+epsilon) - Theta(h)) / epsilon ] - // - // Inputs (angular gridfns, on ghosted grid): - // h # shape of trial surface - // Theta # Theta(h) assumed to already be computed - // - // Outputs: - // Jac += d/dr terms - // - // Results: - // This function returns a status code indicating whether the computation - // succeeded or failed, and if the latter, what caused the failure. - // - namespace - { - enum expansion_status - expansion_Jacobian_dr_FD(patch_system *ps_ptr, Jacobian *Jac_ptr, fp add_to_expansion, - bool initial_flag, - bool print_msg_flag) - { - const bool active_flag = (ps_ptr != NULL) && (Jac_ptr != NULL); - - const double epsilon = 1e-6; - // compute Theta(h+epsilon) - if (active_flag) - then - { - ps_ptr->gridfn_copy(gfns::gfn__Theta, gfns::gfn__save_Theta); - ps_ptr->add_to_ghosted_gridfn(epsilon, gfns::gfn__h); - } - const enum expansion_status status = expansion(ps_ptr, add_to_expansion, - initial_flag); - if (status != expansion_success) - then return status; // *** ERROR RETURN *** - - if (active_flag) - then - { - for (int pn = 0; pn < ps_ptr->N_patches(); ++pn) - { - patch &p = ps_ptr->ith_patch(pn); - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - const int II = ps_ptr->gpn_of_patch_irho_isigma(p, irho, isigma); - const fp old_Theta = p.gridfn(gfns::gfn__save_Theta, - irho, isigma); - const fp new_Theta = p.gridfn(gfns::gfn__Theta, - irho, isigma); - const fp d_dr_term = (new_Theta - old_Theta) / epsilon; - Jac_ptr->sum_into_element(II, II, d_dr_term); - } - } - } - - // restore h and Theta - ps_ptr->add_to_ghosted_gridfn(-epsilon, gfns::gfn__h); - ps_ptr->gridfn_copy(gfns::gfn__save_Theta, gfns::gfn__Theta); - } - - return expansion_success; // *** NORMAL RETURN *** - } - } - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif + + +#include "macrodef.h" +#ifdef With_AHF + +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +namespace AHFinderDirect +{ + using jtutil::error_exit; + + namespace + { + + void expansion_Jacobian_partial_SD(patch_system &ps, Jacobian &Jac, + bool print_msg_flag); + + void add_ghost_zone_Jacobian(const patch_system &ps, + Jacobian &Jac, + fp mol, + const patch &xp, const ghost_zone &xmgz, + int x_II, + int xm_irho, int xm_isigma); + + enum expansion_status + expansion_Jacobian_dr_FD(patch_system *ps_ptr, Jacobian *Jac_ptr, fp add_to_expansion, + bool initial_flag, + bool print_msg_flag); + } + + //****************************************************************************** + + // + // If ps_ptr != NULL and Jac_ptr != NULL, this function computes the + // Jacobian matrix J[Theta(h)] of the expansion Theta(h). We assume + // that Theta(h) has already been computed. + // + // If ps_ptr == NULL and Jac_ptr == NULL, this function does a dummy + // computation, in which only any expansion() (and hence geometry + // interpolator) calls are done, these with the number of interpolation + // points set to 0 and all the output array pointers set to NULL. + // + // It's illegal for one but not both of ps_ptr and Jac_ptr to be NULL. + // + // Arguments: + // ps_ptr --> The patch system, or == NULL to do (only) a dummy computation. + // Jac_ptr --> The Jacobian, or == NULL to do (only) a dummy computation. + // add_to_expansion = A real number to add to the expansion. + // + // Results: + // This function returns a status code indicating whether the computation + // succeeded or failed, and if the latter, what caused the failure. + // + enum expansion_status + expansion_Jacobian(patch_system *ps_ptr, Jacobian *Jac_ptr, + fp add_to_expansion, + bool initial_flag, + bool print_msg_flag /* = false */) + { + const bool active_flag = (ps_ptr != NULL) && (Jac_ptr != NULL); + enum expansion_status status; + + if (active_flag) + then expansion_Jacobian_partial_SD(*ps_ptr, *Jac_ptr, + print_msg_flag); + // this function looks at ps_ptr and Jac_ptr (non-NULL vs NULL) + // to choose a normal vs dummy computation + { + status = expansion_Jacobian_dr_FD(ps_ptr, Jac_ptr, add_to_expansion, + initial_flag, + print_msg_flag); + if (status != expansion_success) + then return status; // *** ERROR RETURN *** + } + + return expansion_success; // *** NORMAL RETURN *** + } + // + // This function computes the partial derivative terms in the Jacobian + // matrix of the expansion Theta(h), by symbolic differentiation from + // the Jacobian coefficient (angular) gridfns. The Jacobian is traversed + // by rows, using equation (25) of my 1996 apparent horizon finding paper. + // + // Inputs (angular gridfns, on ghosted grid): + // h # shape of trial surface + // Theta # Theta(h) assumed to already be computed + // partial_Theta_wrt_partial_d_h # Jacobian coefficients + // partial_Theta_wrt_partial_dd_h # (also assumed to already be computed) + // + // Outputs: + // The Jacobian matrix is stored in the Jacobian object Jac. + // + namespace + { + void expansion_Jacobian_partial_SD(patch_system &ps, Jacobian &Jac, + bool print_msg_flag) + { + Jac.zero_matrix(); + ps.compute_synchronize_Jacobian(); + + for (int xpn = 0; xpn < ps.N_patches(); ++xpn) + { + patch &xp = ps.ith_patch(xpn); + + for (int x_irho = xp.min_irho(); x_irho <= xp.max_irho(); ++x_irho) + { + for (int x_isigma = xp.min_isigma(); x_isigma <= xp.max_isigma(); ++x_isigma) + { + // + // compute the main Jacobian terms for this grid point, i.e. + // partial Theta(this point x, Jacobian row II) + // --------------------------------------------- + // partial h(other points y, Jacobian column JJ) + // + + // Jacobian row index + const int II = ps.gpn_of_patch_irho_isigma(xp, x_irho, x_isigma); + + // Jacobian coefficients for this point + const fp Jacobian_coeff_rho = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_1, + x_irho, x_isigma); + const fp Jacobian_coeff_sigma = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_d_h_2, + x_irho, x_isigma); + const fp Jacobian_coeff_rho_rho = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_11, + x_irho, x_isigma); + const fp Jacobian_coeff_rho_sigma = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_12, + x_irho, x_isigma); + const fp Jacobian_coeff_sigma_sigma = xp.gridfn(gfns::gfn__partial_Theta_wrt_partial_dd_h_22, + x_irho, x_isigma); + + // partial_rho, partial_rho_rho + { + for (int m_irho = xp.molecule_min_m(); + m_irho <= xp.molecule_max_m(); + ++m_irho) + { + const int xm_irho = x_irho + m_irho; + const fp Jac_rho = Jacobian_coeff_rho * xp.partial_rho_coeff(m_irho); + const fp Jac_rho_rho = Jacobian_coeff_rho_rho * xp.partial_rho_rho_coeff(m_irho); + const fp Jac_sum = Jac_rho + Jac_rho_rho; + if (xp.is_in_nominal_grid(xm_irho, x_isigma)) + then + { + const int xm_JJ = Jac.II_of_patch_irho_isigma(xp, xm_irho, x_isigma); + Jac.sum_into_element(II, xm_JJ, Jac_sum); + } + else + add_ghost_zone_Jacobian(ps, Jac, + Jac_sum, + xp, xp.minmax_rho_ghost_zone(m_irho < 0), + II, xm_irho, x_isigma); + } + } + + // partial_sigma, partial_sigma_sigma + { + for (int m_isigma = xp.molecule_min_m(); + m_isigma <= xp.molecule_max_m(); + ++m_isigma) + { + const int xm_isigma = x_isigma + m_isigma; + const fp Jac_sigma = Jacobian_coeff_sigma * xp.partial_sigma_coeff(m_isigma); + const fp Jac_sigma_sigma = Jacobian_coeff_sigma_sigma * xp.partial_sigma_sigma_coeff(m_isigma); + const fp Jac_sum = Jac_sigma + Jac_sigma_sigma; + if (xp.is_in_nominal_grid(x_irho, xm_isigma)) + then + { + const int xm_JJ = Jac.II_of_patch_irho_isigma(xp, x_irho, xm_isigma); + Jac.sum_into_element(II, xm_JJ, Jac_sum); + } + else + add_ghost_zone_Jacobian(ps, Jac, + Jac_sum, + xp, xp.minmax_sigma_ghost_zone(m_isigma < 0), + II, x_irho, xm_isigma); + } + } + + // partial_rho_sigma + { + for (int m_irho = xp.molecule_min_m(); + m_irho <= xp.molecule_max_m(); + ++m_irho) + { + for (int m_isigma = xp.molecule_min_m(); + m_isigma <= xp.molecule_max_m(); + ++m_isigma) + { + const int xm_irho = x_irho + m_irho; + const int xm_isigma = x_isigma + m_isigma; + const fp Jac_rho_sigma = Jacobian_coeff_rho_sigma * xp.partial_rho_sigma_coeff(m_irho, m_isigma); + if (xp.is_in_nominal_grid(xm_irho, xm_isigma)) + then + { + const int xm_JJ = Jac.II_of_patch_irho_isigma(xp, xm_irho, xm_isigma); + Jac.sum_into_element(II, xm_JJ, Jac_rho_sigma); + } + else + { + const ghost_zone &xmgz = xp.corner_ghost_zone_containing_point(m_irho < 0, m_isigma < 0, + xm_irho, xm_isigma); + add_ghost_zone_Jacobian(ps, Jac, + Jac_rho_sigma, + xp, xmgz, + II, xm_irho, xm_isigma); + } + } + } + } + } + } + } + } + } + + //****************************************************************************** + + // + // This function adds the ghost-zone Jacobian dependency contributions + // for a single ghost-zone point, to a Jacobian matrix. + // + // Arguments: + // ps = The patch system. + // Jac = (out) The Jacobian matrix. + // mol = The molecule coefficient. + // xp = The patch containing the center point of the molecule. + // xmgz = If the x+m point is in a ghost zone, this must be that ghost zone. + // If the x+m point is not in a ghost zone, this argument is ignored. + // x_II = The Jacobian row of the x point. + // xm_(irho,isigma) = The coordinates (in xp) of the x+m point of the molecule. + + namespace + { + void add_ghost_zone_Jacobian(const patch_system &ps, + Jacobian &Jac, + fp mol, + const patch &xp, const ghost_zone &xmgz, + int x_II, + int xm_irho, int xm_isigma) + { + const patch_edge &xme = xmgz.my_edge(); + const int xm_iperp = xme.iperp_of_irho_isigma(xm_irho, xm_isigma); + const int xm_ipar = xme.ipar_of_irho_isigma(xm_irho, xm_isigma); + + // FIXME: this won't change from one call to another + // ==> it would be more efficient to reuse the same buffer + // across multiple calls on this function + int global_min_ym, global_max_ym; + ps.synchronize_Jacobian_global_minmax_ym(global_min_ym, global_max_ym); + jtutil::array1d Jacobian_buffer(global_min_ym, global_max_ym); + + // on what other points y does this molecule point xm depend + // via the patch_system::synchronize() operation? + int y_iperp; + int y_posn, min_ym, max_ym; + const patch_edge &ye = ps.synchronize_Jacobian(xmgz, + xm_iperp, xm_ipar, + y_iperp, + y_posn, min_ym, max_ym, + Jacobian_buffer); + patch &yp = ye.my_patch(); + + // add the Jacobian contributions from the ym points + for (int ym = min_ym; ym <= max_ym; ++ym) + { + const int y_ipar = y_posn + ym; + const int y_irho = ye.irho_of_iperp_ipar(y_iperp, y_ipar); + const int y_isigma = ye.isigma_of_iperp_ipar(y_iperp, y_ipar); + const int y_JJ = Jac.II_of_patch_irho_isigma(yp, y_irho, y_isigma); + Jac.sum_into_element(x_II, y_JJ, mol * Jacobian_buffer(ym)); + } + } + } + + //****************************************************************************** + + // + // If ps_ptr != NULL and Jac_ptr != NULL, this function sums the d/dr + // terms into the Jacobian matrix of the expansion Theta(h), computing + // those terms by finite differencing. + // + // If ps_ptr == NULL and Jac_ptr == NULL, this function does a dummy + // computation, in which only any expansion() (and hence geometry + // interpolator) calls are done, these with the number of interpolation + // points set to 0 and all the output array pointers set to NULL. + // + // It's illegal for one but not both of ps_ptr and Jac_ptr to be NULL. + // + // The basic algorithm is that + // Jac += diag[ (Theta(h+epsilon) - Theta(h)) / epsilon ] + // + // Inputs (angular gridfns, on ghosted grid): + // h # shape of trial surface + // Theta # Theta(h) assumed to already be computed + // + // Outputs: + // Jac += d/dr terms + // + // Results: + // This function returns a status code indicating whether the computation + // succeeded or failed, and if the latter, what caused the failure. + // + namespace + { + enum expansion_status + expansion_Jacobian_dr_FD(patch_system *ps_ptr, Jacobian *Jac_ptr, fp add_to_expansion, + bool initial_flag, + bool print_msg_flag) + { + const bool active_flag = (ps_ptr != NULL) && (Jac_ptr != NULL); + + const double epsilon = 1e-6; + // compute Theta(h+epsilon) + if (active_flag) + then + { + ps_ptr->gridfn_copy(gfns::gfn__Theta, gfns::gfn__save_Theta); + ps_ptr->add_to_ghosted_gridfn(epsilon, gfns::gfn__h); + } + const enum expansion_status status = expansion(ps_ptr, add_to_expansion, + initial_flag); + if (status != expansion_success) + then return status; // *** ERROR RETURN *** + + if (active_flag) + then + { + for (int pn = 0; pn < ps_ptr->N_patches(); ++pn) + { + patch &p = ps_ptr->ith_patch(pn); + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + const int II = ps_ptr->gpn_of_patch_irho_isigma(p, irho, isigma); + const fp old_Theta = p.gridfn(gfns::gfn__save_Theta, + irho, isigma); + const fp new_Theta = p.gridfn(gfns::gfn__Theta, + irho, isigma); + const fp d_dr_term = (new_Theta - old_Theta) / epsilon; + Jac_ptr->sum_into_element(II, II, d_dr_term); + } + } + } + + // restore h and Theta + ps_ptr->add_to_ghosted_gridfn(-epsilon, gfns::gfn__h); + ps_ptr->gridfn_copy(gfns::gfn__save_Theta, gfns::gfn__Theta); + } + + return expansion_success; // *** NORMAL RETURN *** + } + } + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif diff --git a/AMSS_NCKU_source/fd_grid.C b/AMSS_NCKU_source/AHF_Direct/fd_grid.C similarity index 95% rename from AMSS_NCKU_source/fd_grid.C rename to AMSS_NCKU_source/AHF_Direct/fd_grid.C index 62c5940..2b068e6 100644 --- a/AMSS_NCKU_source/fd_grid.C +++ b/AMSS_NCKU_source/AHF_Direct/fd_grid.C @@ -1,79 +1,79 @@ -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" - -namespace AHFinderDirect -{ - using jtutil::error_exit; - - //***************************************************************************** - - // - // This function computes a single coefficient of a 1st derivative - // molecule, for unit grid spacing. - // - // static - fp fd_grid::dx_coeff(int m) - { - switch (m) - { - case -2: - return FD_GRID__ORDER4__DX__COEFF_M2; - case -1: - return FD_GRID__ORDER4__DX__COEFF_M1; - case 0: - return FD_GRID__ORDER4__DX__COEFF_0; - case +1: - return FD_GRID__ORDER4__DX__COEFF_P1; - case +2: - return FD_GRID__ORDER4__DX__COEFF_P2; - - default: - cout << "***** fd_grid::dx_coeff(): m=" << m << " is outside order=4 molecule radius=" << FD_GRID__MOL_RADIUS << endl; - abort(); - } - } - - //***************************************************************************** - - // - // This function computes a single coefficient of a 2nd derivative - // molecule, for unit grid spacing. - // - // static - fp fd_grid::dxx_coeff(int m) - { - switch (m) - { - case -2: - return FD_GRID__ORDER4__DXX__COEFF_M2; - case -1: - return FD_GRID__ORDER4__DXX__COEFF_M1; - case 0: - return FD_GRID__ORDER4__DXX__COEFF_0; - case +1: - return FD_GRID__ORDER4__DXX__COEFF_P1; - case +2: - return FD_GRID__ORDER4__DXX__COEFF_P2; - - default: - cout << "***** fd_grid::dx_coeff(): m=" << m << " is outside order=4 molecule radius=" << FD_GRID__MOL_RADIUS << endl; - abort(); - } - } - - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" + +namespace AHFinderDirect +{ + using jtutil::error_exit; + + //***************************************************************************** + + // + // This function computes a single coefficient of a 1st derivative + // molecule, for unit grid spacing. + // + // static + fp fd_grid::dx_coeff(int m) + { + switch (m) + { + case -2: + return FD_GRID__ORDER4__DX__COEFF_M2; + case -1: + return FD_GRID__ORDER4__DX__COEFF_M1; + case 0: + return FD_GRID__ORDER4__DX__COEFF_0; + case +1: + return FD_GRID__ORDER4__DX__COEFF_P1; + case +2: + return FD_GRID__ORDER4__DX__COEFF_P2; + + default: + cout << "***** fd_grid::dx_coeff(): m=" << m << " is outside order=4 molecule radius=" << FD_GRID__MOL_RADIUS << endl; + abort(); + } + } + + //***************************************************************************** + + // + // This function computes a single coefficient of a 2nd derivative + // molecule, for unit grid spacing. + // + // static + fp fd_grid::dxx_coeff(int m) + { + switch (m) + { + case -2: + return FD_GRID__ORDER4__DXX__COEFF_M2; + case -1: + return FD_GRID__ORDER4__DXX__COEFF_M1; + case 0: + return FD_GRID__ORDER4__DXX__COEFF_0; + case +1: + return FD_GRID__ORDER4__DXX__COEFF_P1; + case +2: + return FD_GRID__ORDER4__DXX__COEFF_P2; + + default: + cout << "***** fd_grid::dx_coeff(): m=" << m << " is outside order=4 molecule radius=" << FD_GRID__MOL_RADIUS << endl; + abort(); + } + } + + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/fd_grid.h b/AMSS_NCKU_source/AHF_Direct/fd_grid.h similarity index 97% rename from AMSS_NCKU_source/fd_grid.h rename to AMSS_NCKU_source/AHF_Direct/fd_grid.h index ed52205..c9accf8 100644 --- a/AMSS_NCKU_source/fd_grid.h +++ b/AMSS_NCKU_source/AHF_Direct/fd_grid.h @@ -1,459 +1,459 @@ -#ifndef FD_GRID_H -#define FD_GRID_H -namespace AHFinderDirect -{ - - //****************************************************************************** - - // - // *** Implementation Notes -- Overview *** - // - - // - // The key design problem for our finite differencing is how to - // implement an entire family of 5(9) finite difference operations in - // 2D(3D) - // - // partial_rho partial_sigma - // partial_{rho,rho} partial_{rho,sigma} - // partial_{sigma,sigma} - // - // partial_x partial_y partial_z - // partial_xx partial_xy partial_xz - // partial_yy partial_yz - // partial_zz - // - // without having to write out the finite differencing molecules multiple - // times, and while still preserving maximum inline-function efficiency. - // In particular, mixed 2nd-order derivative operations like partial_xy - // should be automatically composed from the two individual 1st derivative - // operations (partial_x and partial_y). - // - - // - // Our basic approach is to define each finite difference molecule in - // a generic 1-dimensional form using an abstract "data(m)" interface. - // Here we use the terminology that a finite difference molecule is - // defined as - // out[k] = sum(m) c[m] * in[k+m] - // where c[] is the vector/matrix of molecule coefficients, and m is - // the (integer) relative grid coordinate within a molecule. - // - // That is, for example, we define the usual 2nd order centered 1st - // derivative operator as - // diff = 0.5*inv_delta_x*(data(+1) - data(-1)) - // leaving unspecified just what the data source is. We then use this - // with an appropriate data source (indexing along that gridfn array axis) - // for each directional derivative operation, and we compose two of - // these, using the first along x as the data source for the second - // along y, for the mixed 2nd-order derivative operation. - // - - //****************************************************************************** - - // - // *** Implementation Notes -- Techniques using C++ Templates *** - // - - // - // There are two plausible ways to use C++ templates - // [C++ templates are described in detail in chapter 13 of - // Stroustrup's "The C++ Programming Language" (3rd Edition), - // hereinafter "C++PL", and chapter 15 of Stroustrup's - // "The Design and Evolution of C++", hereinafter "D&EC++".] - // to write the sort of generic-at-compile-time code we want: - // - Template specializations for each axis, as discussed in D&EC++ - // section 15.10.3. - // - Overloaded functions for each axis, with an argument type - // (possibly that of an extra unused argument) selecting the - // appropriate axis and hence the appropriate function. This - // technique is discussed in D&EC++ section 15.6.3.1. - // - // Quoting from D&EC++ (section 15.6.3.1), - // - // The fundamental observation is that every property - // of a type or an algorithm can be represented by a - // type (possibly defined specificaly to do exactly - // that). That done, such a type can be used to guide - // the overload resolution to select a function that - // depends on the desired property. [...] - // - // Please note that thanks to inlining this resolution - // is done at compile-time, so the appropriate [...] - // function will be called directly without any run-time - // overhead. - // - // Quoting from C++PL3 (section 13.4), - // - // Passing [...] operations as a template parameter has two - // significant benefits compared to alternatives such as - // passing pointers to functions. Several operations can - // be passed as a single argument with no run-time cost. - // In addition, the [...] operators [passed this way] are - // trivial to inline, whereas inlininkg a call through a - // pointer to function requires exceptional attention from - // a compiler. - // - - // - // In my opinion the template-specialization design is cleaner, and it - // clearly has no run-time cost (whereas the overloaded-function design - // may have a run-time cost for constructing and passing unused objects), - // so we use it here. - // - // There are, however, two (non-fatal) problema with this approach: - // - Unfortunately, it appears C++ (or at least gcc 2.95.1) forbids - // template specialization within a class, so some of the functions - // which whould logically be class members, must instead be defined - // outside any class. We use the namespace fd_stuff:: to hide - // these from the outside world. - // - C++PL3, section C.13.3, states that - // Only class templates can be template arguments. - // so we have to use dummy classes around some of our template - // functions. To avoid extra constructor/destructor overhead, we - // make these template functions static. - // - - //****************************************************************************** - - // - // *** Implementation Notes -- Techniques using the C/C++ Preprocessor *** - // - - // - // The fundamental problem with the template approaches is portability: - // Although the C++ standard describes powerful template facilities, not - // all C++ compilers yet fully support these. As an alternative, we can - // use the C/C++ preprocessor. This is ugly and dangerous (global names!), - // but is probably simpler than any of the template approaches. It can - // provide the same finite differencing functionality and efficiency as - // the template-based approaches. - // - // Because of its greater portability, we use the preprocessor-based - // approach here. - // - - //****************************************************************************** - - // - // *** Implementation Notes -- Run-Time Choice of Molecules *** - // - // *If* we want to allow the finite differencing scheme to be changed - // at run-time (e.g. from a parameter file), there are three plausible - // ways to do this: - // - Using switch(molecule_type) , as is standard in C. This is - // simple, and for this particular application quite well-structured - // and maintainable (there are only a few different molecule types, - // all centralized in this file). - // - Using virtual functions, with molecule a virtual base class - // and individual molecules derived from it. This is elegant, but - // may have some performance problems (below). It also requires some - // sort of switch-based "object factory" to interface with with the - // molecule-choice parameters. - // - Write all the finite differencing code multiple times, once for - // each finite differencing scheme. - // - // The typical use of these functions will be from within a loop over - // a whole grid. In both cases we can expect excellent accuracy from - // modern hardware branch prediction (and thus minimal performance loss - // from the branching). It's reasonable to expect a compiler to fully - // inline the switch-based code, exposing all the gridfn array subscriptings - // to strength reduction etc, but this is much trickier for the - // virtual-function--based code. For this reason, the switch-based - // design seems superior to the virtual-function--based one. - // - // However, at present we don't implement any run-time selection: we - // "just" fix the finite differencing scheme at compile time via the - // preprocessor. - // - - //****************************************************************************** - - // - // *** finite difference molecules *** - // - - //************************************** - - // - // define the actual molecules - // - // In the following macros, we first define all the distinct floating- - // -point numbers appearing in a molecules as "K" constants (all > 0), - // then define the actual derivative and its molecule coefficients - // using +/- the "K" constants, with multiplies by 1.0 elided and 0 - // terms skipped in computing the derivative. This (hopefully) gives - // maximum efficiency by avoiding the generated code loading the same - // constants multiple times. - // - - // - // The molecule macros all take the following arguments: - // inv_delta_x_ = inverse of grid spacing in the finite differencing - // direction - // data_= a data-fetching function or macro: data_(ghosted_gfn, irho, isigma) - // is the data to be finite differenced - // irho_plus_m_ = a function or macro: irho_plus_m_(irho,m) returns the - // rho coordinate to be passed to data_() for the [m] - // molecule coefficient - // isigma_plus_m_ = same thing, for the sigma coordinate - // - // n.b. We grab the variables ghosted_gfn, irho, and isigma from the calling - // environment, and we define assorted local variables as needed! - // - - //************************************** - - // - // 2nd order - // - -#define FD_GRID__ORDER2__MOL_RADIUS 1 -#define FD_GRID__ORDER2__MOL_DIAMETER 3 - -#define FD_GRID__ORDER2__DX__KPM1 0.5 -#define FD_GRID__ORDER2__DX(inv_delta_x_, data_, \ - irho_plus_m_, isigma_plus_m_) \ - const fp data_p1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, +1), \ - isigma_plus_m_(isigma, +1)); \ - const fp data_m1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, -1), \ - isigma_plus_m_(isigma, -1)); \ - const fp sum = FD_GRID__ORDER2__DX__KPM1 * (data_p1 - data_m1); \ - return inv_delta_x_ * sum; /* end macro */ -#define FD_GRID__ORDER2__DX__COEFF_M1 (-FD_GRID__ORDER2__DX__KPM1) -#define FD_GRID__ORDER2__DX__COEFF_0 0.0 -#define FD_GRID__ORDER2__DX__COEFF_P1 (+FD_GRID__ORDER2__DX__KPM1) - -#define FD_GRID__ORDER2__DXX__K0 2.0 -#define FD_GRID__ORDER2__DXX(inv_delta_x_, data_, \ - irho_plus_m_, isigma_plus_m_) \ - const fp data_p1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, +1), \ - isigma_plus_m_(isigma, +1)); \ - const fp data_0 = data_(ghosted_gfn, \ - irho_plus_m_(irho, 0), \ - isigma_plus_m_(isigma, 0)); \ - const fp data_m1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, -1), \ - isigma_plus_m_(isigma, -1)); \ - const fp sum = data_m1 - FD_GRID__ORDER2__DXX__K0 * data_0 + data_p1; \ - return jtutil::pow2(inv_delta_x_) * sum; /* end macro */ -#define FD_GRID__ORDER2__DXX__COEFF_M1 1.0 -#define FD_GRID__ORDER2__DXX__COEFF_0 (-FD_GRID__ORDER2__DXX__K0) -#define FD_GRID__ORDER2__DXX__COEFF_P1 1.0 - - //************************************** - - // - // 4th order - // - -#define FD_GRID__ORDER4__MOL_RADIUS 2 -#define FD_GRID__ORDER4__MOL_DIAMETER 5 - -#define FD_GRID__ORDER4__DX__KPM2 (1.0 / 12.0) -#define FD_GRID__ORDER4__DX__KPM1 (8.0 / 12.0) -#define FD_GRID__ORDER4__DX(inv_delta_x_, data_, \ - irho_plus_m_, isigma_plus_m_) \ - const fp data_p2 = data_(ghosted_gfn, \ - irho_plus_m_(irho, +2), \ - isigma_plus_m_(isigma, +2)); \ - const fp data_p1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, +1), \ - isigma_plus_m_(isigma, +1)); \ - const fp data_m1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, -1), \ - isigma_plus_m_(isigma, -1)); \ - const fp data_m2 = data_(ghosted_gfn, \ - irho_plus_m_(irho, -2), \ - isigma_plus_m_(isigma, -2)); \ - const fp sum = FD_GRID__ORDER4__DX__KPM1 * (data_p1 - data_m1) + FD_GRID__ORDER4__DX__KPM2 * (data_m2 - data_p2); \ - /* printf("(%2d %2d) %f %f %f %f\n",irho, isigma,data_m2, data_m1,data_p1, data_p2);*/ \ - return inv_delta_x_ * sum; /* end macro */ -#define FD_GRID__ORDER4__DX__COEFF_M2 (+FD_GRID__ORDER4__DX__KPM2) -#define FD_GRID__ORDER4__DX__COEFF_M1 (-FD_GRID__ORDER4__DX__KPM1) -#define FD_GRID__ORDER4__DX__COEFF_0 0.0 -#define FD_GRID__ORDER4__DX__COEFF_P1 (+FD_GRID__ORDER4__DX__KPM1) -#define FD_GRID__ORDER4__DX__COEFF_P2 (-FD_GRID__ORDER4__DX__KPM2) - - //************************************** - -#define FD_GRID__ORDER4__DXX__KPM2 (1.0 / 12.0) -#define FD_GRID__ORDER4__DXX__KPM1 (16.0 / 12.0) -#define FD_GRID__ORDER4__DXX__K0 (30.0 / 12.0) -#define FD_GRID__ORDER4__DXX(inv_delta_x_, data_, \ - irho_plus_m_, isigma_plus_m_) \ - const fp data_p2 = data_(ghosted_gfn, \ - irho_plus_m_(irho, +2), \ - isigma_plus_m_(isigma, +2)); \ - const fp data_p1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, +1), \ - isigma_plus_m_(isigma, +1)); \ - const fp data_0 = data_(ghosted_gfn, \ - irho_plus_m_(irho, 0), \ - isigma_plus_m_(isigma, 0)); \ - const fp data_m1 = data_(ghosted_gfn, \ - irho_plus_m_(irho, -1), \ - isigma_plus_m_(isigma, -1)); \ - const fp data_m2 = data_(ghosted_gfn, \ - irho_plus_m_(irho, -2), \ - isigma_plus_m_(isigma, -2)); \ - const fp sum = -FD_GRID__ORDER4__DXX__K0 * data_0 + FD_GRID__ORDER4__DXX__KPM1 * (data_m1 + data_p1) - FD_GRID__ORDER4__DXX__KPM2 * (data_m2 + data_p2); \ - return jtutil::pow2(inv_delta_x_) * sum; /* end macro */ -#define FD_GRID__ORDER4__DXX__COEFF_M2 (-FD_GRID__ORDER4__DXX__KPM2) -#define FD_GRID__ORDER4__DXX__COEFF_M1 (+FD_GRID__ORDER4__DXX__KPM1) -#define FD_GRID__ORDER4__DXX__COEFF_0 (-FD_GRID__ORDER4__DXX__K0) -#define FD_GRID__ORDER4__DXX__COEFF_P1 (+FD_GRID__ORDER4__DXX__KPM1) -#define FD_GRID__ORDER4__DXX__COEFF_P2 (-FD_GRID__ORDER4__DXX__KPM2) - - //****************************************************************************** -#define FD_GRID__MOL_RADIUS FD_GRID__ORDER4__MOL_RADIUS -#define FD_GRID__MOL_DIAMETER FD_GRID__ORDER4__MOL_DIAMETER -#define FD_GRID__DX FD_GRID__ORDER4__DX -#define FD_GRID__DXX FD_GRID__ORDER4__DXX - -#define FD_GRID__MOL_AREA (FD_GRID__MOL_DIAMETER * FD_GRID__MOL_DIAMETER) - - //****************************************************************************** - - // - // ***** fd_grid - grid with finite differencing operations ***** - // - // An fd_grid is identical to a grid except that it also defines - // (rho,sigma)-coordinate finite differencing operations on gridfns. - // - - class fd_grid - : public grid - { - // - // molecule sizes - // - public: - // n.b. this interface implicitly assumes that all molecules - // are centered and are the same order and size - static int finite_diff_order() { return 4; } - static int molecule_radius() { return FD_GRID__MOL_RADIUS; } - static int molecule_diameter() { return FD_GRID__MOL_DIAMETER; } - static int molecule_min_m() { return -FD_GRID__MOL_RADIUS; } - static int molecule_max_m() { return FD_GRID__MOL_RADIUS; } - - // - // helper functions to compute (irho,isigma) + [m] - // along each axis - // - private: - static int rho_axis__irho_plus_m(int irho, int m) { return irho + m; } - static int rho_axis__isigma_plus_m(int isigma, int m) { return isigma; } - static int sigma_axis__irho_plus_m(int irho, int m) { return irho; } - static int sigma_axis__isigma_plus_m(int isigma, int m) { return isigma + m; } - - // - // ***** finite differencing ***** - // - public: - // 1st derivatives - fp partial_rho(int ghosted_gfn, int irho, int isigma) - const - { - FD_GRID__DX(inverse_delta_rho(), - ghosted_gridfn, - rho_axis__irho_plus_m, - rho_axis__isigma_plus_m); - } - fp partial_sigma(int ghosted_gfn, int irho, int isigma) - const - { - FD_GRID__DX(inverse_delta_sigma(), - ghosted_gridfn, - sigma_axis__irho_plus_m, - sigma_axis__isigma_plus_m); - } - - // "pure" 2nd derivatives - fp partial_rho_rho(int ghosted_gfn, int irho, int isigma) - const - { - FD_GRID__DXX(inverse_delta_rho(), - ghosted_gridfn, - rho_axis__irho_plus_m, - rho_axis__isigma_plus_m); - } - fp partial_sigma_sigma(int ghosted_gfn, int irho, int isigma) - const - { - FD_GRID__DXX(inverse_delta_sigma(), - ghosted_gridfn, - sigma_axis__irho_plus_m, - sigma_axis__isigma_plus_m); - } - - // mixed 2nd partial derivative - fp partial_rho_sigma(int ghosted_gfn, int irho, int isigma) - const - { - FD_GRID__DX(inverse_delta_rho(), - partial_sigma, - rho_axis__irho_plus_m, - rho_axis__isigma_plus_m); - } - - // - // ***** molecule coefficients ***** - // - public: - // molecule coefficients - // n.b. this interface implicitly assumes that all molecules - // are position-independent - fp partial_rho_coeff(int m) const - { - return inverse_delta_rho() * dx_coeff(m); - } - fp partial_sigma_coeff(int m) const - { - return inverse_delta_sigma() * dx_coeff(m); - } - fp partial_rho_rho_coeff(int m) const - { - return jtutil::pow2(inverse_delta_rho()) * dxx_coeff(m); - } - fp partial_sigma_sigma_coeff(int m) const - { - return jtutil::pow2(inverse_delta_sigma()) * dxx_coeff(m); - } - fp partial_rho_sigma_coeff(int m_rho, int m_sigma) const - { - return partial_rho_coeff(m_rho) * partial_sigma_coeff(m_sigma); - } - - // worker functions: molecule coefficients for unit grid spacing - private: - static fp dx_coeff(int m); - static fp dxx_coeff(int m); - - // - // ***** constructor, destructor ***** - // - public: - // constructor: pass through to grid:: constructor - fd_grid(const grid_array_pars &grid_array_pars_in, - const grid_pars &grid_pars_in) - : grid(grid_array_pars_in, grid_pars_in) - { - } - // compiler-generated default destructor is ok - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - fd_grid(const fd_grid &rhs); - fd_grid &operator=(const fd_grid &rhs); - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* FD_GRID_H */ +#ifndef FD_GRID_H +#define FD_GRID_H +namespace AHFinderDirect +{ + + //****************************************************************************** + + // + // *** Implementation Notes -- Overview *** + // + + // + // The key design problem for our finite differencing is how to + // implement an entire family of 5(9) finite difference operations in + // 2D(3D) + // + // partial_rho partial_sigma + // partial_{rho,rho} partial_{rho,sigma} + // partial_{sigma,sigma} + // + // partial_x partial_y partial_z + // partial_xx partial_xy partial_xz + // partial_yy partial_yz + // partial_zz + // + // without having to write out the finite differencing molecules multiple + // times, and while still preserving maximum inline-function efficiency. + // In particular, mixed 2nd-order derivative operations like partial_xy + // should be automatically composed from the two individual 1st derivative + // operations (partial_x and partial_y). + // + + // + // Our basic approach is to define each finite difference molecule in + // a generic 1-dimensional form using an abstract "data(m)" interface. + // Here we use the terminology that a finite difference molecule is + // defined as + // out[k] = sum(m) c[m] * in[k+m] + // where c[] is the vector/matrix of molecule coefficients, and m is + // the (integer) relative grid coordinate within a molecule. + // + // That is, for example, we define the usual 2nd order centered 1st + // derivative operator as + // diff = 0.5*inv_delta_x*(data(+1) - data(-1)) + // leaving unspecified just what the data source is. We then use this + // with an appropriate data source (indexing along that gridfn array axis) + // for each directional derivative operation, and we compose two of + // these, using the first along x as the data source for the second + // along y, for the mixed 2nd-order derivative operation. + // + + //****************************************************************************** + + // + // *** Implementation Notes -- Techniques using C++ Templates *** + // + + // + // There are two plausible ways to use C++ templates + // [C++ templates are described in detail in chapter 13 of + // Stroustrup's "The C++ Programming Language" (3rd Edition), + // hereinafter "C++PL", and chapter 15 of Stroustrup's + // "The Design and Evolution of C++", hereinafter "D&EC++".] + // to write the sort of generic-at-compile-time code we want: + // - Template specializations for each axis, as discussed in D&EC++ + // section 15.10.3. + // - Overloaded functions for each axis, with an argument type + // (possibly that of an extra unused argument) selecting the + // appropriate axis and hence the appropriate function. This + // technique is discussed in D&EC++ section 15.6.3.1. + // + // Quoting from D&EC++ (section 15.6.3.1), + // + // The fundamental observation is that every property + // of a type or an algorithm can be represented by a + // type (possibly defined specificaly to do exactly + // that). That done, such a type can be used to guide + // the overload resolution to select a function that + // depends on the desired property. [...] + // + // Please note that thanks to inlining this resolution + // is done at compile-time, so the appropriate [...] + // function will be called directly without any run-time + // overhead. + // + // Quoting from C++PL3 (section 13.4), + // + // Passing [...] operations as a template parameter has two + // significant benefits compared to alternatives such as + // passing pointers to functions. Several operations can + // be passed as a single argument with no run-time cost. + // In addition, the [...] operators [passed this way] are + // trivial to inline, whereas inlininkg a call through a + // pointer to function requires exceptional attention from + // a compiler. + // + + // + // In my opinion the template-specialization design is cleaner, and it + // clearly has no run-time cost (whereas the overloaded-function design + // may have a run-time cost for constructing and passing unused objects), + // so we use it here. + // + // There are, however, two (non-fatal) problema with this approach: + // - Unfortunately, it appears C++ (or at least gcc 2.95.1) forbids + // template specialization within a class, so some of the functions + // which whould logically be class members, must instead be defined + // outside any class. We use the namespace fd_stuff:: to hide + // these from the outside world. + // - C++PL3, section C.13.3, states that + // Only class templates can be template arguments. + // so we have to use dummy classes around some of our template + // functions. To avoid extra constructor/destructor overhead, we + // make these template functions static. + // + + //****************************************************************************** + + // + // *** Implementation Notes -- Techniques using the C/C++ Preprocessor *** + // + + // + // The fundamental problem with the template approaches is portability: + // Although the C++ standard describes powerful template facilities, not + // all C++ compilers yet fully support these. As an alternative, we can + // use the C/C++ preprocessor. This is ugly and dangerous (global names!), + // but is probably simpler than any of the template approaches. It can + // provide the same finite differencing functionality and efficiency as + // the template-based approaches. + // + // Because of its greater portability, we use the preprocessor-based + // approach here. + // + + //****************************************************************************** + + // + // *** Implementation Notes -- Run-Time Choice of Molecules *** + // + // *If* we want to allow the finite differencing scheme to be changed + // at run-time (e.g. from a parameter file), there are three plausible + // ways to do this: + // - Using switch(molecule_type) , as is standard in C. This is + // simple, and for this particular application quite well-structured + // and maintainable (there are only a few different molecule types, + // all centralized in this file). + // - Using virtual functions, with molecule a virtual base class + // and individual molecules derived from it. This is elegant, but + // may have some performance problems (below). It also requires some + // sort of switch-based "object factory" to interface with with the + // molecule-choice parameters. + // - Write all the finite differencing code multiple times, once for + // each finite differencing scheme. + // + // The typical use of these functions will be from within a loop over + // a whole grid. In both cases we can expect excellent accuracy from + // modern hardware branch prediction (and thus minimal performance loss + // from the branching). It's reasonable to expect a compiler to fully + // inline the switch-based code, exposing all the gridfn array subscriptings + // to strength reduction etc, but this is much trickier for the + // virtual-function--based code. For this reason, the switch-based + // design seems superior to the virtual-function--based one. + // + // However, at present we don't implement any run-time selection: we + // "just" fix the finite differencing scheme at compile time via the + // preprocessor. + // + + //****************************************************************************** + + // + // *** finite difference molecules *** + // + + //************************************** + + // + // define the actual molecules + // + // In the following macros, we first define all the distinct floating- + // -point numbers appearing in a molecules as "K" constants (all > 0), + // then define the actual derivative and its molecule coefficients + // using +/- the "K" constants, with multiplies by 1.0 elided and 0 + // terms skipped in computing the derivative. This (hopefully) gives + // maximum efficiency by avoiding the generated code loading the same + // constants multiple times. + // + + // + // The molecule macros all take the following arguments: + // inv_delta_x_ = inverse of grid spacing in the finite differencing + // direction + // data_= a data-fetching function or macro: data_(ghosted_gfn, irho, isigma) + // is the data to be finite differenced + // irho_plus_m_ = a function or macro: irho_plus_m_(irho,m) returns the + // rho coordinate to be passed to data_() for the [m] + // molecule coefficient + // isigma_plus_m_ = same thing, for the sigma coordinate + // + // n.b. We grab the variables ghosted_gfn, irho, and isigma from the calling + // environment, and we define assorted local variables as needed! + // + + //************************************** + + // + // 2nd order + // + +#define FD_GRID__ORDER2__MOL_RADIUS 1 +#define FD_GRID__ORDER2__MOL_DIAMETER 3 + +#define FD_GRID__ORDER2__DX__KPM1 0.5 +#define FD_GRID__ORDER2__DX(inv_delta_x_, data_, \ + irho_plus_m_, isigma_plus_m_) \ + const fp data_p1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, +1), \ + isigma_plus_m_(isigma, +1)); \ + const fp data_m1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, -1), \ + isigma_plus_m_(isigma, -1)); \ + const fp sum = FD_GRID__ORDER2__DX__KPM1 * (data_p1 - data_m1); \ + return inv_delta_x_ * sum; /* end macro */ +#define FD_GRID__ORDER2__DX__COEFF_M1 (-FD_GRID__ORDER2__DX__KPM1) +#define FD_GRID__ORDER2__DX__COEFF_0 0.0 +#define FD_GRID__ORDER2__DX__COEFF_P1 (+FD_GRID__ORDER2__DX__KPM1) + +#define FD_GRID__ORDER2__DXX__K0 2.0 +#define FD_GRID__ORDER2__DXX(inv_delta_x_, data_, \ + irho_plus_m_, isigma_plus_m_) \ + const fp data_p1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, +1), \ + isigma_plus_m_(isigma, +1)); \ + const fp data_0 = data_(ghosted_gfn, \ + irho_plus_m_(irho, 0), \ + isigma_plus_m_(isigma, 0)); \ + const fp data_m1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, -1), \ + isigma_plus_m_(isigma, -1)); \ + const fp sum = data_m1 - FD_GRID__ORDER2__DXX__K0 * data_0 + data_p1; \ + return jtutil::pow2(inv_delta_x_) * sum; /* end macro */ +#define FD_GRID__ORDER2__DXX__COEFF_M1 1.0 +#define FD_GRID__ORDER2__DXX__COEFF_0 (-FD_GRID__ORDER2__DXX__K0) +#define FD_GRID__ORDER2__DXX__COEFF_P1 1.0 + + //************************************** + + // + // 4th order + // + +#define FD_GRID__ORDER4__MOL_RADIUS 2 +#define FD_GRID__ORDER4__MOL_DIAMETER 5 + +#define FD_GRID__ORDER4__DX__KPM2 (1.0 / 12.0) +#define FD_GRID__ORDER4__DX__KPM1 (8.0 / 12.0) +#define FD_GRID__ORDER4__DX(inv_delta_x_, data_, \ + irho_plus_m_, isigma_plus_m_) \ + const fp data_p2 = data_(ghosted_gfn, \ + irho_plus_m_(irho, +2), \ + isigma_plus_m_(isigma, +2)); \ + const fp data_p1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, +1), \ + isigma_plus_m_(isigma, +1)); \ + const fp data_m1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, -1), \ + isigma_plus_m_(isigma, -1)); \ + const fp data_m2 = data_(ghosted_gfn, \ + irho_plus_m_(irho, -2), \ + isigma_plus_m_(isigma, -2)); \ + const fp sum = FD_GRID__ORDER4__DX__KPM1 * (data_p1 - data_m1) + FD_GRID__ORDER4__DX__KPM2 * (data_m2 - data_p2); \ + /* printf("(%2d %2d) %f %f %f %f\n",irho, isigma,data_m2, data_m1,data_p1, data_p2);*/ \ + return inv_delta_x_ * sum; /* end macro */ +#define FD_GRID__ORDER4__DX__COEFF_M2 (+FD_GRID__ORDER4__DX__KPM2) +#define FD_GRID__ORDER4__DX__COEFF_M1 (-FD_GRID__ORDER4__DX__KPM1) +#define FD_GRID__ORDER4__DX__COEFF_0 0.0 +#define FD_GRID__ORDER4__DX__COEFF_P1 (+FD_GRID__ORDER4__DX__KPM1) +#define FD_GRID__ORDER4__DX__COEFF_P2 (-FD_GRID__ORDER4__DX__KPM2) + + //************************************** + +#define FD_GRID__ORDER4__DXX__KPM2 (1.0 / 12.0) +#define FD_GRID__ORDER4__DXX__KPM1 (16.0 / 12.0) +#define FD_GRID__ORDER4__DXX__K0 (30.0 / 12.0) +#define FD_GRID__ORDER4__DXX(inv_delta_x_, data_, \ + irho_plus_m_, isigma_plus_m_) \ + const fp data_p2 = data_(ghosted_gfn, \ + irho_plus_m_(irho, +2), \ + isigma_plus_m_(isigma, +2)); \ + const fp data_p1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, +1), \ + isigma_plus_m_(isigma, +1)); \ + const fp data_0 = data_(ghosted_gfn, \ + irho_plus_m_(irho, 0), \ + isigma_plus_m_(isigma, 0)); \ + const fp data_m1 = data_(ghosted_gfn, \ + irho_plus_m_(irho, -1), \ + isigma_plus_m_(isigma, -1)); \ + const fp data_m2 = data_(ghosted_gfn, \ + irho_plus_m_(irho, -2), \ + isigma_plus_m_(isigma, -2)); \ + const fp sum = -FD_GRID__ORDER4__DXX__K0 * data_0 + FD_GRID__ORDER4__DXX__KPM1 * (data_m1 + data_p1) - FD_GRID__ORDER4__DXX__KPM2 * (data_m2 + data_p2); \ + return jtutil::pow2(inv_delta_x_) * sum; /* end macro */ +#define FD_GRID__ORDER4__DXX__COEFF_M2 (-FD_GRID__ORDER4__DXX__KPM2) +#define FD_GRID__ORDER4__DXX__COEFF_M1 (+FD_GRID__ORDER4__DXX__KPM1) +#define FD_GRID__ORDER4__DXX__COEFF_0 (-FD_GRID__ORDER4__DXX__K0) +#define FD_GRID__ORDER4__DXX__COEFF_P1 (+FD_GRID__ORDER4__DXX__KPM1) +#define FD_GRID__ORDER4__DXX__COEFF_P2 (-FD_GRID__ORDER4__DXX__KPM2) + + //****************************************************************************** +#define FD_GRID__MOL_RADIUS FD_GRID__ORDER4__MOL_RADIUS +#define FD_GRID__MOL_DIAMETER FD_GRID__ORDER4__MOL_DIAMETER +#define FD_GRID__DX FD_GRID__ORDER4__DX +#define FD_GRID__DXX FD_GRID__ORDER4__DXX + +#define FD_GRID__MOL_AREA (FD_GRID__MOL_DIAMETER * FD_GRID__MOL_DIAMETER) + + //****************************************************************************** + + // + // ***** fd_grid - grid with finite differencing operations ***** + // + // An fd_grid is identical to a grid except that it also defines + // (rho,sigma)-coordinate finite differencing operations on gridfns. + // + + class fd_grid + : public grid + { + // + // molecule sizes + // + public: + // n.b. this interface implicitly assumes that all molecules + // are centered and are the same order and size + static int finite_diff_order() { return 4; } + static int molecule_radius() { return FD_GRID__MOL_RADIUS; } + static int molecule_diameter() { return FD_GRID__MOL_DIAMETER; } + static int molecule_min_m() { return -FD_GRID__MOL_RADIUS; } + static int molecule_max_m() { return FD_GRID__MOL_RADIUS; } + + // + // helper functions to compute (irho,isigma) + [m] + // along each axis + // + private: + static int rho_axis__irho_plus_m(int irho, int m) { return irho + m; } + static int rho_axis__isigma_plus_m(int isigma, int m) { return isigma; } + static int sigma_axis__irho_plus_m(int irho, int m) { return irho; } + static int sigma_axis__isigma_plus_m(int isigma, int m) { return isigma + m; } + + // + // ***** finite differencing ***** + // + public: + // 1st derivatives + fp partial_rho(int ghosted_gfn, int irho, int isigma) + const + { + FD_GRID__DX(inverse_delta_rho(), + ghosted_gridfn, + rho_axis__irho_plus_m, + rho_axis__isigma_plus_m); + } + fp partial_sigma(int ghosted_gfn, int irho, int isigma) + const + { + FD_GRID__DX(inverse_delta_sigma(), + ghosted_gridfn, + sigma_axis__irho_plus_m, + sigma_axis__isigma_plus_m); + } + + // "pure" 2nd derivatives + fp partial_rho_rho(int ghosted_gfn, int irho, int isigma) + const + { + FD_GRID__DXX(inverse_delta_rho(), + ghosted_gridfn, + rho_axis__irho_plus_m, + rho_axis__isigma_plus_m); + } + fp partial_sigma_sigma(int ghosted_gfn, int irho, int isigma) + const + { + FD_GRID__DXX(inverse_delta_sigma(), + ghosted_gridfn, + sigma_axis__irho_plus_m, + sigma_axis__isigma_plus_m); + } + + // mixed 2nd partial derivative + fp partial_rho_sigma(int ghosted_gfn, int irho, int isigma) + const + { + FD_GRID__DX(inverse_delta_rho(), + partial_sigma, + rho_axis__irho_plus_m, + rho_axis__isigma_plus_m); + } + + // + // ***** molecule coefficients ***** + // + public: + // molecule coefficients + // n.b. this interface implicitly assumes that all molecules + // are position-independent + fp partial_rho_coeff(int m) const + { + return inverse_delta_rho() * dx_coeff(m); + } + fp partial_sigma_coeff(int m) const + { + return inverse_delta_sigma() * dx_coeff(m); + } + fp partial_rho_rho_coeff(int m) const + { + return jtutil::pow2(inverse_delta_rho()) * dxx_coeff(m); + } + fp partial_sigma_sigma_coeff(int m) const + { + return jtutil::pow2(inverse_delta_sigma()) * dxx_coeff(m); + } + fp partial_rho_sigma_coeff(int m_rho, int m_sigma) const + { + return partial_rho_coeff(m_rho) * partial_sigma_coeff(m_sigma); + } + + // worker functions: molecule coefficients for unit grid spacing + private: + static fp dx_coeff(int m); + static fp dxx_coeff(int m); + + // + // ***** constructor, destructor ***** + // + public: + // constructor: pass through to grid:: constructor + fd_grid(const grid_array_pars &grid_array_pars_in, + const grid_pars &grid_pars_in) + : grid(grid_array_pars_in, grid_pars_in) + { + } + // compiler-generated default destructor is ok + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + fd_grid(const fd_grid &rhs); + fd_grid &operator=(const fd_grid &rhs); + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* FD_GRID_H */ diff --git a/AMSS_NCKU_source/find_horizons.C b/AMSS_NCKU_source/AHF_Direct/find_horizons.C similarity index 96% rename from AMSS_NCKU_source/find_horizons.C rename to AMSS_NCKU_source/AHF_Direct/find_horizons.C index fb5f014..69bad46 100644 --- a/AMSS_NCKU_source/find_horizons.C +++ b/AMSS_NCKU_source/AHF_Direct/find_horizons.C @@ -1,137 +1,137 @@ - - -#include "macrodef.h" -#ifdef With_AHF - -#include -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -#include "horizon_sequence.h" -#include "BH_diagnostics.h" -#include "myglobal.h" - -namespace AHFinderDirect -{ - void recentering(patch_system &ps, double max_x, double max_y, double max_z, - double min_x, double min_y, double min_z, - double centroid_x, double centroid_y, double centroid_z); - extern struct state state; - - void AHFinderDirect_find_horizons(int HN, int *dumpid, - double *xc, double *yc, double *zc, double *xr, double *yr, double *zr, - bool *trigger, double *dT) - { - const int my_proc = state.my_proc; - horizon_sequence &hs = *state.my_hs; - if (my_proc == 0 && hs.N_horizons() != HN) - { - cout << "input number " << HN << " != " << "number of wanted horizons " << hs.N_horizons() << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - state.ADM->AH_Prepare_derivatives(); - - for (int hn = hs.init_hn(); hs.is_genuine(); hn = hs.next_hn()) - { - int ihn = hs.get_hn(); - assert(ihn > 0 && ihn <= HN); - ihn = ihn - 1; - - struct AH_data &AH_data = *state.AH_data_array[hn]; - - AH_data.find_trigger = trigger[ihn]; - if (AH_data.find_trigger) - { - if (AH_data.found_flag) - AH_data.initial_find_flag = false; - else if (AH_data.recentering_flag == false) - { - patch_system &ps = *AH_data.ps_ptr; - recentering(ps, xc[ihn] + xr[ihn] / 2, yc[ihn] + yr[ihn] / 2, zc[ihn] + zr[ihn] / 2, - xc[ihn] - xr[ihn] / 2, yc[ihn] - yr[ihn] / 2, zc[ihn] - zr[ihn] / 2, - xc[ihn], yc[ihn], zc[ihn]); - setup_initial_guess(ps, xc[ihn], yc[ihn], zc[ihn], xr[ihn], yr[ihn], zr[ihn]); - AH_data.initial_find_flag = true; - } - else - AH_data.stop_finding == true; - } - - } // end for hn - - Newton(state.N_procs, state.N_active_procs, my_proc, - *state.my_hs, state.AH_data_array, - state.isb, dumpid, dT); - } - - void AHFinderDirect_enforcefind(int HN, - double *xc, double *yc, double *zc, double *xr, double *yr, double *zr) - { - const int my_proc = state.my_proc; - horizon_sequence &hs = *state.my_hs; - if (my_proc == 0 && hs.N_horizons() != HN) - { - cout << "input number " << HN << " != " << "number of wanted horizons " << hs.N_horizons() << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - bool *trigger; - int *dumpid; - double *dTT; - trigger = new bool[HN]; - dumpid = new int[HN]; - dTT = new double[HN]; - for (int ihn = 0; ihn < HN; ihn++) - { - trigger[ihn] = true; - dumpid[ihn] = 1; - dTT[ihn] = 1; - } - - for (int hn = hs.init_hn(); hs.is_genuine(); hn = hs.next_hn()) - { - int ihn = hs.get_hn(); - assert(ihn > 0 && ihn <= HN); - - struct AH_data &AH_data = *state.AH_data_array[hn]; - - AH_data.find_trigger = true; - AH_data.stop_finding = false; - AH_data.found_flag = false; - AH_data.recentering_flag = false; - AH_data.initial_find_flag = true; - - } // end for hn - - AHFinderDirect_find_horizons(HN, dumpid, xc, yc, zc, xr, yr, zr, trigger, dTT); - - delete[] trigger; - delete[] dumpid; - delete[] dTT; - } -} // namespace AHFinderDirect -#endif + + +#include "macrodef.h" +#ifdef With_AHF + +#include +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +#include "horizon_sequence.h" +#include "BH_diagnostics.h" +#include "myglobal.h" + +namespace AHFinderDirect +{ + void recentering(patch_system &ps, double max_x, double max_y, double max_z, + double min_x, double min_y, double min_z, + double centroid_x, double centroid_y, double centroid_z); + extern struct state state; + + void AHFinderDirect_find_horizons(int HN, int *dumpid, + double *xc, double *yc, double *zc, double *xr, double *yr, double *zr, + bool *trigger, double *dT) + { + const int my_proc = state.my_proc; + horizon_sequence &hs = *state.my_hs; + if (my_proc == 0 && hs.N_horizons() != HN) + { + cout << "input number " << HN << " != " << "number of wanted horizons " << hs.N_horizons() << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + state.ADM->AH_Prepare_derivatives(); + + for (int hn = hs.init_hn(); hs.is_genuine(); hn = hs.next_hn()) + { + int ihn = hs.get_hn(); + assert(ihn > 0 && ihn <= HN); + ihn = ihn - 1; + + struct AH_data &AH_data = *state.AH_data_array[hn]; + + AH_data.find_trigger = trigger[ihn]; + if (AH_data.find_trigger) + { + if (AH_data.found_flag) + AH_data.initial_find_flag = false; + else if (AH_data.recentering_flag == false) + { + patch_system &ps = *AH_data.ps_ptr; + recentering(ps, xc[ihn] + xr[ihn] / 2, yc[ihn] + yr[ihn] / 2, zc[ihn] + zr[ihn] / 2, + xc[ihn] - xr[ihn] / 2, yc[ihn] - yr[ihn] / 2, zc[ihn] - zr[ihn] / 2, + xc[ihn], yc[ihn], zc[ihn]); + setup_initial_guess(ps, xc[ihn], yc[ihn], zc[ihn], xr[ihn], yr[ihn], zr[ihn]); + AH_data.initial_find_flag = true; + } + else + AH_data.stop_finding == true; + } + + } // end for hn + + Newton(state.N_procs, state.N_active_procs, my_proc, + *state.my_hs, state.AH_data_array, + state.isb, dumpid, dT); + } + + void AHFinderDirect_enforcefind(int HN, + double *xc, double *yc, double *zc, double *xr, double *yr, double *zr) + { + const int my_proc = state.my_proc; + horizon_sequence &hs = *state.my_hs; + if (my_proc == 0 && hs.N_horizons() != HN) + { + cout << "input number " << HN << " != " << "number of wanted horizons " << hs.N_horizons() << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + bool *trigger; + int *dumpid; + double *dTT; + trigger = new bool[HN]; + dumpid = new int[HN]; + dTT = new double[HN]; + for (int ihn = 0; ihn < HN; ihn++) + { + trigger[ihn] = true; + dumpid[ihn] = 1; + dTT[ihn] = 1; + } + + for (int hn = hs.init_hn(); hs.is_genuine(); hn = hs.next_hn()) + { + int ihn = hs.get_hn(); + assert(ihn > 0 && ihn <= HN); + + struct AH_data &AH_data = *state.AH_data_array[hn]; + + AH_data.find_trigger = true; + AH_data.stop_finding = false; + AH_data.found_flag = false; + AH_data.recentering_flag = false; + AH_data.initial_find_flag = true; + + } // end for hn + + AHFinderDirect_find_horizons(HN, dumpid, xc, yc, zc, xr, yr, zr, trigger, dTT); + + delete[] trigger; + delete[] dumpid; + delete[] dTT; + } +} // namespace AHFinderDirect +#endif diff --git a/AMSS_NCKU_source/fuzzy.C b/AMSS_NCKU_source/AHF_Direct/fuzzy.C similarity index 96% rename from AMSS_NCKU_source/fuzzy.C rename to AMSS_NCKU_source/AHF_Direct/fuzzy.C index a1f1672..b82529e 100644 --- a/AMSS_NCKU_source/fuzzy.C +++ b/AMSS_NCKU_source/AHF_Direct/fuzzy.C @@ -1,63 +1,63 @@ -#include -#include - -#include "stdc.h" -#include "util.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - template - bool fuzzy::EQ(fp_t x, fp_t y) - { - fp_t max_abs = jtutil::tmax(jtutil::abs(x), jtutil::abs(y)); - fp_t epsilon = jtutil::tmax(tolerance_, tolerance_ * max_abs); - - return jtutil::abs(x - y) <= epsilon; - } - - //****************************************************************************** - - template - bool fuzzy::is_integer(fp_t x) - { - int i = round::to_integer(x); - return EQ(x, fp_t(i)); - } - - //****************************************************************************** - - template - int fuzzy::floor(fp_t x) - { - return fuzzy::is_integer(x) - ? round::to_integer(x) - : round::floor(x); - } - - //****************************************************************************** - - template - int fuzzy::ceiling(fp_t x) - { - return fuzzy::is_integer(x) - ? round::to_integer(x) - : round::ceiling(x); - } - template <> - float fuzzy::tolerance_ = 1.0e-5; // about 100 * FLT_EPSILON - - template <> - double fuzzy::tolerance_ = 1.0e-12; // about 1e4 * DBL_EPSILON - - // template instantiations - template class fuzzy; - template class fuzzy; - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include + +#include "stdc.h" +#include "util.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + template + bool fuzzy::EQ(fp_t x, fp_t y) + { + fp_t max_abs = jtutil::tmax(jtutil::abs(x), jtutil::abs(y)); + fp_t epsilon = jtutil::tmax(tolerance_, tolerance_ * max_abs); + + return jtutil::abs(x - y) <= epsilon; + } + + //****************************************************************************** + + template + bool fuzzy::is_integer(fp_t x) + { + int i = round::to_integer(x); + return EQ(x, fp_t(i)); + } + + //****************************************************************************** + + template + int fuzzy::floor(fp_t x) + { + return fuzzy::is_integer(x) + ? round::to_integer(x) + : round::floor(x); + } + + //****************************************************************************** + + template + int fuzzy::ceiling(fp_t x) + { + return fuzzy::is_integer(x) + ? round::to_integer(x) + : round::ceiling(x); + } + template <> + float fuzzy::tolerance_ = 1.0e-5; // about 100 * FLT_EPSILON + + template <> + double fuzzy::tolerance_ = 1.0e-12; // about 1e4 * DBL_EPSILON + + // template instantiations + template class fuzzy; + template class fuzzy; + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/gfns.h b/AMSS_NCKU_source/AHF_Direct/gfns.h similarity index 95% rename from AMSS_NCKU_source/gfns.h rename to AMSS_NCKU_source/AHF_Direct/gfns.h index d11af68..876434e 100644 --- a/AMSS_NCKU_source/gfns.h +++ b/AMSS_NCKU_source/AHF_Direct/gfns.h @@ -1,98 +1,98 @@ -#ifndef GFNS_H -#define GFNS_H -namespace AHFinderDirect -{ - - namespace gfns - { - - // ghosted gridfns - enum - { - ghosted_min_gfn = -1, // must set this by hand so - // ghosted_max_gfn is still < 0 - gfn__h = ghosted_min_gfn, - ghosted_max_gfn = gfn__h - }; - - // nominal gridfns - enum - { - nominal_min_gfn = 1, - - // - // for a skeletal patch system we don't need any nominal gridfns - // - skeletal_nominal_max_gfn = nominal_min_gfn - 1, - - // - // most of these gridfns have access macros in "cg.hh"; - // the ones that don't are marked explicitly - // - gfn__global_x = nominal_min_gfn, // no access macro - gfn__global_y, // no access macro - gfn__global_z, // no access macro - - gfn__global_xx, // no access macro - gfn__global_xy, // no access macro - gfn__global_xz, // no access macro - gfn__global_yy, // no access macro - gfn__global_yz, // no access macro - gfn__global_zz, // no access macro - - gfn__g_dd_11, - gfn__g_dd_12, - gfn__g_dd_13, - gfn__g_dd_22, - gfn__g_dd_23, - gfn__g_dd_33, - gfn__partial_d_g_dd_111, - gfn__partial_d_g_dd_112, - gfn__partial_d_g_dd_113, - gfn__partial_d_g_dd_122, - gfn__partial_d_g_dd_123, - gfn__partial_d_g_dd_133, - gfn__partial_d_g_dd_211, - gfn__partial_d_g_dd_212, - gfn__partial_d_g_dd_213, - gfn__partial_d_g_dd_222, - gfn__partial_d_g_dd_223, - gfn__partial_d_g_dd_233, - gfn__partial_d_g_dd_311, - gfn__partial_d_g_dd_312, - gfn__partial_d_g_dd_313, - gfn__partial_d_g_dd_322, - gfn__partial_d_g_dd_323, - gfn__partial_d_g_dd_333, - gfn__K_dd_11, - gfn__K_dd_12, - gfn__K_dd_13, - gfn__K_dd_22, - gfn__K_dd_23, - gfn__K_dd_33, - gfn__trK, - - gfn__psi, // no access macro - gfn__partial_d_psi_1, // no access macro - gfn__partial_d_psi_2, // no access macro - gfn__partial_d_psi_3, // no access macro - - gfn__Theta, - gfn__partial_Theta_wrt_partial_d_h_1, - gfn__partial_Theta_wrt_partial_d_h_2, - gfn__partial_Theta_wrt_partial_dd_h_11, - gfn__partial_Theta_wrt_partial_dd_h_12, - gfn__partial_Theta_wrt_partial_dd_h_22, - gfn__Delta_h, - gfn__save_Theta, - gfn__oldh, // used for dh/dt - gfn__one, - nominal_max_gfn = gfn__one // no comma - }; - - } // namespace gfns:: - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* GFNS_H */ +#ifndef GFNS_H +#define GFNS_H +namespace AHFinderDirect +{ + + namespace gfns + { + + // ghosted gridfns + enum + { + ghosted_min_gfn = -1, // must set this by hand so + // ghosted_max_gfn is still < 0 + gfn__h = ghosted_min_gfn, + ghosted_max_gfn = gfn__h + }; + + // nominal gridfns + enum + { + nominal_min_gfn = 1, + + // + // for a skeletal patch system we don't need any nominal gridfns + // + skeletal_nominal_max_gfn = nominal_min_gfn - 1, + + // + // most of these gridfns have access macros in "cg.hh"; + // the ones that don't are marked explicitly + // + gfn__global_x = nominal_min_gfn, // no access macro + gfn__global_y, // no access macro + gfn__global_z, // no access macro + + gfn__global_xx, // no access macro + gfn__global_xy, // no access macro + gfn__global_xz, // no access macro + gfn__global_yy, // no access macro + gfn__global_yz, // no access macro + gfn__global_zz, // no access macro + + gfn__g_dd_11, + gfn__g_dd_12, + gfn__g_dd_13, + gfn__g_dd_22, + gfn__g_dd_23, + gfn__g_dd_33, + gfn__partial_d_g_dd_111, + gfn__partial_d_g_dd_112, + gfn__partial_d_g_dd_113, + gfn__partial_d_g_dd_122, + gfn__partial_d_g_dd_123, + gfn__partial_d_g_dd_133, + gfn__partial_d_g_dd_211, + gfn__partial_d_g_dd_212, + gfn__partial_d_g_dd_213, + gfn__partial_d_g_dd_222, + gfn__partial_d_g_dd_223, + gfn__partial_d_g_dd_233, + gfn__partial_d_g_dd_311, + gfn__partial_d_g_dd_312, + gfn__partial_d_g_dd_313, + gfn__partial_d_g_dd_322, + gfn__partial_d_g_dd_323, + gfn__partial_d_g_dd_333, + gfn__K_dd_11, + gfn__K_dd_12, + gfn__K_dd_13, + gfn__K_dd_22, + gfn__K_dd_23, + gfn__K_dd_33, + gfn__trK, + + gfn__psi, // no access macro + gfn__partial_d_psi_1, // no access macro + gfn__partial_d_psi_2, // no access macro + gfn__partial_d_psi_3, // no access macro + + gfn__Theta, + gfn__partial_Theta_wrt_partial_d_h_1, + gfn__partial_Theta_wrt_partial_d_h_2, + gfn__partial_Theta_wrt_partial_dd_h_11, + gfn__partial_Theta_wrt_partial_dd_h_12, + gfn__partial_Theta_wrt_partial_dd_h_22, + gfn__Delta_h, + gfn__save_Theta, + gfn__oldh, // used for dh/dt + gfn__one, + nominal_max_gfn = gfn__one // no comma + }; + + } // namespace gfns:: + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* GFNS_H */ diff --git a/AMSS_NCKU_source/ghost_zone.C b/AMSS_NCKU_source/AHF_Direct/ghost_zone.C similarity index 97% rename from AMSS_NCKU_source/ghost_zone.C rename to AMSS_NCKU_source/AHF_Direct/ghost_zone.C index c56de2d..b57eb41 100644 --- a/AMSS_NCKU_source/ghost_zone.C +++ b/AMSS_NCKU_source/AHF_Direct/ghost_zone.C @@ -1,604 +1,604 @@ -#include -#include -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" - -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" - -namespace AHFinderDirect -{ - using jtutil::error_exit; - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // These functions verify (assert()) that a ghost zone is indeed of - // the specified type, then static_cast to the appropriate derived class. - // - - const symmetry_ghost_zone &ghost_zone::cast_to_symmetry_ghost_zone() - const - { - assert(is_symmetry()); - return static_cast(*this); - } - - symmetry_ghost_zone &ghost_zone::cast_to_symmetry_ghost_zone() - { - assert(is_symmetry()); - return static_cast(*this); - } - - //************************************** - - const interpatch_ghost_zone &ghost_zone::cast_to_interpatch_ghost_zone() - const - { - assert(is_interpatch()); - return static_cast(*this); - } - - interpatch_ghost_zone &ghost_zone::cast_to_interpatch_ghost_zone() - { - assert(is_interpatch()); - return static_cast(*this); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function constructs a mirror-symmetry ghost zone object - // - symmetry_ghost_zone::symmetry_ghost_zone(const patch_edge &my_edge_in) - : ghost_zone(my_edge_in, - my_edge_in, // other edge == my edge - ghost_zone_is_symmetry) - { - // iperp_map: i --> (i of ghost zone) - i - iperp_map_ = new jtutil::cpm_map(min_iperp(), max_iperp(), - my_edge_in.fp_grid_outer_iperp()); - - // ipar_map_: identity map - ipar_map_ = new jtutil::cpm_map(extreme_min_ipar(), extreme_max_ipar()); - } - - //****************************************************************************** - - // - // This function constructs a periodic-symmetry ghost zone object. - // - symmetry_ghost_zone::symmetry_ghost_zone(const patch_edge &my_edge_in, const patch_edge &other_edge_in, - int my_edge_sample_ipar, int other_edge_sample_ipar, - bool ipar_map_is_plus) - : ghost_zone(my_edge_in, - other_edge_in, - ghost_zone_is_symmetry) - { - // - // perpendicular map - // - const fp fp_my_period_plane_iperp = my_edge().fp_grid_outer_iperp(); - const fp fp_other_period_plane_iperp = other_edge().fp_grid_outer_iperp(); - - // iperp mapping must be outside --> inside - // i.e. if both edges have iperp as the same min/max "direction", - // then the mapping is iperp increasing --> iperp decreasing - // (i.e. the map's sign is -1) - const bool is_iperp_map_plus = !(my_edge().is_min() == other_edge().is_min()); - iperp_map_ = new jtutil::cpm_map(min_iperp(), max_iperp(), - fp_my_period_plane_iperp, - fp_other_period_plane_iperp, - is_iperp_map_plus); - - // - // parallel map - // - ipar_map_ = new jtutil::cpm_map(extreme_min_ipar(), extreme_max_ipar(), - my_edge_sample_ipar, other_edge_sample_ipar, - ipar_map_is_plus); - } - - //****************************************************************************** - - // - // This function destroys a symmetry_ghost_zone object. - // - symmetry_ghost_zone::~symmetry_ghost_zone() - { - delete ipar_map_; - delete iperp_map_; - } - - //****************************************************************************** - - // - // This function "synchronizes" a ghost zone, i.e. it updates the - // ghost-zone values of the specified gridfns via the appropriate - // symmetry operations.The flags specify which part(s) of the ghost zone - // we want. - // - void symmetry_ghost_zone::synchronize(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners /* = true */, - bool want_noncorner /* = true */) - { - // printf("*Sync sym ghost zone in %s patch\n", my_patch().name()); - - for (int gfn = ghosted_min_gfn; gfn <= ghosted_max_gfn; ++gfn) - { - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - for (int ipar = min_ipar(iperp); ipar <= max_ipar(iperp); ++ipar) - { - // do we want to do this point? - if (!my_edge().ipar_is_in_selected_part(want_corners, want_noncorner, - ipar)) - then continue; // *** LOOP CONTROL *** - - const int sym_iperp = iperp_map_of_iperp(iperp); - const int sym_ipar = ipar_map_of_ipar(ipar); - const int sym_irho = other_edge() - .irho_of_iperp_ipar(sym_iperp, sym_ipar); - const int sym_isigma = other_edge() - .isigma_of_iperp_ipar(sym_iperp, sym_ipar); - const fp sym_gridfn = other_patch() - .ghosted_gridfn(gfn, sym_irho, sym_isigma); - - const int irho = my_edge().irho_of_iperp_ipar(iperp, ipar); - const int isigma = my_edge().isigma_of_iperp_ipar(iperp, ipar); - my_patch().ghosted_gridfn(gfn, irho, isigma) = sym_gridfn; - } - } - } - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function constructs an interpatch_ghost_zone object. - // - interpatch_ghost_zone::interpatch_ghost_zone(const patch_edge &my_edge_in, - const patch_edge &other_edge_in, - int patch_overlap_width) - : ghost_zone(my_edge_in, - other_edge_in, - ghost_zone_is_interpatch), - // remaining pointers are all set up properly by finish_setup() - other_patch_interp_(NULL), - other_iperp_(NULL), - min_ipar_used_(NULL), max_ipar_used_(NULL), - other_par_(NULL), - interp_result_buffer_(NULL), - Jacobian_y_ipar_posn_(NULL), Jacobian_buffer_(NULL) // no comma - { - // - // verify that we have the expected relationships between - // this and the other patch's (mu,nu,phi) coordinates: - // - - // perp coordinate is common to us and the other patch, so - // ghost zone must be min in one patch, max in the other - if (my_edge().is_min() == other_edge().is_min()) - then error_exit(ERROR_EXIT, - "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" - " my_patch().name()=\"%s\" my_edge().name()=%s\n" - " other_patch().name()=\"%s\" other_edge().name()=%s\n" - " ghost zone must be min in one patch, max in the other!\n", - my_patch().name(), my_edge().name(), - other_patch().name(), other_edge().name()); /*NOTREACHED*/ - - // coord in common between the two patches must be perp coord in both patches - // and this patch's tau coordinate must be other edge's parallel coordinate - const local_coords::coords_set common_coords_set = local_coords::coords_set_not(my_patch().coords_set_rho_sigma() ^ - other_patch().coords_set_rho_sigma()); - if (!((common_coords_set == my_edge().coords_set_perp()) && (common_coords_set == other_edge().coords_set_perp()) && (my_patch().coords_set_tau() == other_edge().coords_set_par()))) - then error_exit(PANIC_EXIT, - "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" - " (rho,sigma,tau) coordinates don't match up properly\n" - " between this patch/edge and the other patch/edge!\n" - " my_patch().name()=\"%s\" my_edge().name()=%s\n" - " other_patch().name()=\"%s\" other_edge().name()=%s\n" - " my_patch().coords_set_{rho,sigma,tau}={%s,%s,%s}\n" - " my_edge().coords_set_{perp,par}={%s,%s}\n" - " other_patch().coords_set_{rho,sigma,tau}={%s,%s,%s}\n" - " other_edge().coords_set_{perp,par}={%s,%s}\n", - my_patch().name(), my_edge().name(), - other_patch().name(), other_edge().name(), - local_coords::name_of_coords_set(my_patch().coords_set_rho()), - local_coords::name_of_coords_set(my_patch().coords_set_sigma()), - local_coords::name_of_coords_set(my_patch().coords_set_tau()), - local_coords::name_of_coords_set(my_edge().coords_set_perp()), - local_coords::name_of_coords_set(my_edge().coords_set_par()), - local_coords::name_of_coords_set(other_patch().coords_set_rho()), - local_coords::name_of_coords_set(other_patch().coords_set_sigma()), - local_coords::name_of_coords_set(other_patch().coords_set_tau()), - local_coords::name_of_coords_set(other_edge().coords_set_perp()), - local_coords::name_of_coords_set(other_edge().coords_set_par())); - /*NOTREACHED*/ - - // perp coordinate must match (mod 2*pi) across the two patches - // after taking into account any overlap - // ... eg patch_overlap_width = 3 would be - // p p p p p - // q q q q q - // so the overlap would be (patch_overlap_width-1) * delta - const fp other_overlap = (patch_overlap_width - 1) * other_edge().perp_map().delta_fp(); - const fp other_outer_perp_minus_overlap // move back inwards into other patch - // by overlap distance, to get a value - // that should match our own - // grid_outer_perp() value - = other_edge().grid_outer_perp() + (other_edge().is_min() ? +other_overlap : -other_overlap); - if (!local_coords::fuzzy_EQ_ang(my_edge().grid_outer_perp(), - other_outer_perp_minus_overlap)) - then error_exit(ERROR_EXIT, - "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" - " my_patch().name()=\"%s\" my_edge().name()=%s\n" - " other_patch().name()=\"%s\" other_edge().name()=%s\n" - " perp coordinate doesn't match (mod 2*pi) across the two patches!\n" - " my_edge().grid_outer_perp()=%g <--(compare this)\n" - " patch_overlap_width=%d other_overlap=%g\n" - " other_edge.grid_outer_perp()=%g\n" - " other_outer_perp_minus_overlap=%g <--(against this)\n", - my_patch().name(), my_edge().name(), - other_patch().name(), other_edge().name(), - double(my_edge().grid_outer_perp()), - patch_overlap_width, double(other_overlap), - double(other_edge().grid_outer_perp()), - double(other_outer_perp_minus_overlap)); /*NOTREACHED*/ - - // - // set up the iperp interpatch coordinate mapping - // (gives other patch's iperp coordinate for interpolation) - // - - // compute the iperp --> other_iperp mapping for a sample point; - // ... if the ghost zone is empty, then the sample point will necessarily - // be out-of-range in the ghost zone, so we use the *unchecked* - // conversions to avoid errors in this case - // ... we do the computation using the fact that perp is the same - // coordinate in both patches (modulo 2*pi radians = 360 degrees) - const int sample_iperp = outer_iperp(); - const fp sample_perp = my_edge().perp_map().fp_of_int_unchecked(sample_iperp); - // unchecked conversion here! - const fp other_sample_perp = other_patch() - .modulo_reduce_ang(other_edge().perp_is_rho(), - sample_perp); - const fp fp_other_sample_iperp = other_edge() - .fp_iperp_of_perp(other_sample_perp); - - // verify that this is fuzzily a grid point - if (!jtutil::fuzzy::is_integer(fp_other_sample_iperp)) - then error_exit(ERROR_EXIT, - "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" - " my_patch().name()=\"%s\" my_edge().name()=%s\n" - " other_patch().name()=\"%s\" other_edge().name()=%s\n" - " sample_iperp=%d sample_perp=%g\n" - " other_sample_perp=%g fp_other_sample_iperp=%g\n" - " ==> fp_other_sample_iperp isn't fuzzily an integer!\n" - " ==> patches aren't commensurate in the perpendicular coordinate!\n", - my_patch().name(), my_edge().name(), - other_patch().name(), other_edge().name(), - sample_iperp, double(sample_perp), - double(other_sample_perp), - double(fp_other_sample_iperp)); /*NOTREACHED*/ - const int other_sample_iperp = jtutil::round::to_integer(fp_other_sample_iperp); - - // compute the +/- sign (direction) of the iperp --> other_iperp mapping - // - // Since perp is the same in both patches (mod 2*pi radians = 360 degrees), - // the overall +/- sign is just the product of the signs of the two individual - // iperp <--> perp mappings. - // - // ... signs encoded as (floating-point) +/- 1.0 - const double iperp_map_sign_pm1 = jtutil::signum(my_edge().perp_map().delta_fp()) * jtutil::signum(other_edge().perp_map().delta_fp()); - // ... signs encoded as is_plus bool flag - const bool is_iperp_map_plus = (iperp_map_sign_pm1 > 0.0); - - // now we finally know enough to set up the other_iperp(iperp) - // coordinate mapping - other_iperp_ = new jtutil::cpm_map(min_iperp(), max_iperp(), - sample_iperp, other_sample_iperp, - is_iperp_map_plus); - } - - //****************************************************************************** - - // - // this function destroys an interpatch_ghost_zone object. - // - interpatch_ghost_zone::~interpatch_ghost_zone() - { - delete Jacobian_buffer_; - delete Jacobian_y_ipar_posn_; - delete interp_result_buffer_; - delete other_par_; - delete max_ipar_used_; - delete min_ipar_used_; - delete other_iperp_; - delete other_patch_interp_; - } - - //****************************************************************************** - - // - // These functions compute the [min,max] ipar of the ghost zone for - // a given iperp, taking into account how we treat the corners - // (cf. the example in the header comments in "ghost_zone.hh"): - // - // If an adjacent ghost zone is symmetry, - // we do not include that corner; - // If an adjacent ghost zone is interpatch, - // we include up to the diagonal line, and if we are a rho ghost zone, - // then also the diagonal line itself. E.g. For the example in the - // header comments "ghost_zone.hh", the +x ghost zone includes (6,6), - // (7,6), and (7,7), while the +y ghost zone includes (6,7) - // - // ... in the following 2 functions, - // the iabs() term includes the diagonal, - // so we must remove the diagonal for !is_rho, - // i.e. add 1 to min_ipar and subtract 1 from max_ipar - // - int interpatch_ghost_zone::min_ipar(int iperp) const - { - return min_par_adjacent_ghost_zone().is_symmetry() - ? my_edge().min_ipar_without_corners() - : my_edge().min_ipar_without_corners() - iabs(iperp - my_edge().nominal_grid_outer_iperp()) + (is_rho() ? 0 : 1); - } - - int interpatch_ghost_zone::max_ipar(int iperp) const - { - return max_par_adjacent_ghost_zone().is_symmetry() - ? my_edge().max_ipar_without_corners() - : my_edge().max_ipar_without_corners() + iabs(iperp - my_edge().nominal_grid_outer_iperp()) - (is_rho() ? 0 : 1); - } - - //****************************************************************************** - - // - // This function finishes the construction/setup of an interpatch_ghost_zone - // object. It - // - sets up the par coordinate mapping information - // - sets up the interpatch interpolator data pointer and result arrays - // - constructs the patch_interp object to interpolate from the *other* patch - // - // We use our ipar as the patch_interp's parindex. - // - void interpatch_ghost_zone::finish_setup(int interp_handle, - int interp_par_table_handle) - { - min_other_iperp_ = min(other_iperp(min_iperp()), - other_iperp(max_iperp())); - max_other_iperp_ = max(other_iperp(min_iperp()), - other_iperp(max_iperp())); - - // - // set up arrays giving actual [min,max] ipar that we'll use - // at each other_iperp (later on we will pass these arrays to the - // other patch's patch_interp object, with ipar being parindex there - // - min_ipar_used_ = new jtutil::array1d(min_other_iperp_, max_other_iperp_); - max_ipar_used_ = new jtutil::array1d(min_other_iperp_, max_other_iperp_); - { - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - (*min_ipar_used_)(other_iperp(iperp)) = min_ipar(iperp); - (*max_ipar_used_)(other_iperp(iperp)) = max_ipar(iperp); - } - } - - // - // set up array giving other patch's par coordinate for interpolation - // - - other_par_ = new jtutil::array2d(min_other_iperp_, max_other_iperp_, - extreme_min_ipar(), extreme_max_ipar()); - - { - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - for (int ipar = min_ipar(iperp); ipar <= max_ipar(iperp); ++ipar) - { - // compute the other_par corresponding to (iperp,ipar) - // ... here we use the fact (which we verified in our constructor) - // that other edge's parallel coordinate == our tau coordinate - // (at least modulo 2*pi radians = 360 degrees) - const fp perp = my_edge().perp_of_iperp(iperp); - const fp par = my_edge().par_of_ipar(ipar); - - const fp rho = my_edge().rho_of_perp_par(perp, par); - const fp sigma = my_edge().sigma_of_perp_par(perp, par); - - const fp tau = my_patch().tau_of_rho_sigma(rho, sigma); - const fp other_par = other_patch() - .modulo_reduce_ang(other_edge().par_is_rho(), tau); - - (*other_par_)(other_iperp(iperp), ipar) = other_par; - } - } - } - - // - // set up interpolation result buffer - // - interp_result_buffer_ = new jtutil::array3d(my_patch().ghosted_min_gfn(), - my_patch().ghosted_max_gfn(), - min_other_iperp_, max_other_iperp_, - extreme_min_ipar(), extreme_max_ipar()); - - // - // construct the patch_interp object to interpolate from the *other* patch - // ... the patch_interp should use gridfn data from it's (the other patch's) - // min/max par ghost zones if those (adjacent) adjacent ghost zones - // are symmetry, but not if they're interpatch, - // cf the header comments in "ghost_zone.hh" - // - const ghost_zone &other_ghost_zone = other_patch() - .ghost_zone_on_edge(other_edge()); - const bool ok_to_use_min_par_ghost_zone = other_ghost_zone.min_par_adjacent_ghost_zone() - .is_symmetry() - ? true - : false; - const bool ok_to_use_max_par_ghost_zone = other_ghost_zone.max_par_adjacent_ghost_zone() - .is_symmetry() - ? true - : false; - other_patch_interp_ = new patch_interp(other_edge(), - min_other_iperp_, max_other_iperp_, - *min_ipar_used_, *max_ipar_used_, - *other_par_, - ok_to_use_min_par_ghost_zone, - ok_to_use_max_par_ghost_zone, - interp_handle, interp_par_table_handle); - } - - //****************************************************************************** - - // - // This function asserts() that - // - we have a patch_interp object - // - our and the patch_interp object's notions of the "other patch" agree - // - the other patch has an interpatch ghost zone on this edge - // - the other patch's interpatch ghost zone on this edge, - // points back to our patch - // - void interpatch_ghost_zone::assert_fully_setup() const - { - assert(other_patch_interp_ != NULL); - assert(other_patch() == other_patch_interp_->my_patch()); - assert(other_patch() - .ghost_zone_on_edge(other_edge()) - .is_interpatch()); - assert(my_patch() == other_patch() - .ghost_zone_on_edge(other_edge()) - .other_patch()); - } - - //****************************************************************************** - - // - // This function "synchronizes" a ghost zone, i.e. it updates the - // ghost-zone values of the specified gridfns via the appropriate - // interpatch interpolations. - // - // The flags specify which part(s) of the ghost zone we want, but - // the present implementation only supports the case where all the - // flags are true , i.e. we want the entire ghost zone. - // - void interpatch_ghost_zone::synchronize(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners /* = true */, - bool want_noncorner /* = true */) - { -#ifdef DEBUG_AHFD - printf("*Sync interpatch ghost zone in %s\n", my_patch().name()); -#endif - - // make sure the caller wants the entire ghost zone - if (!(want_corners && want_noncorner)) - then error_exit(ERROR_EXIT, - "***** interpatch_ghost_zone::synchronize():\n" - " we only support operating on the *entire* ghost zone,\n" - " but we were passed flags specifying a proper subset!\n" - " want_corners=(int)%d want_noncorner=(int)%d\n", - want_corners, want_noncorner); /*NOTREACHED*/ - - // - // move from 'Compute_Jacobian' below - // - assert(other_patch_interp_ != NULL); - other_patch_interp_->molecule_minmax_ipar_m(Jacobian_min_y_ipar_m_, - Jacobian_max_y_ipar_m_); -#ifdef DEBUG_AHFD - printf("%d %d %d %d %d %d \n", Jacobian_min_y_ipar_m_, Jacobian_max_y_ipar_m_, - min_other_iperp_, max_other_iperp_, extreme_min_ipar(), extreme_max_ipar()); - getchar(); -#endif - - // /* - if (Jacobian_y_ipar_posn_ == NULL) - Jacobian_y_ipar_posn_ = new jtutil::array2d(min_other_iperp_, max_other_iperp_, - extreme_min_ipar(), extreme_max_ipar()); - if (Jacobian_buffer_ == NULL) - Jacobian_buffer_ = new jtutil::array3d(min_other_iperp_, max_other_iperp_, - extreme_min_ipar(), extreme_max_ipar(), - Jacobian_min_y_ipar_m_, Jacobian_max_y_ipar_m_); - - // do the interpolation into our result buffer - other_patch_interp_->interpolate(ghosted_min_gfn, ghosted_max_gfn, - *interp_result_buffer_, //); - *Jacobian_y_ipar_posn_, - *Jacobian_buffer_); - - // other_patch_interp_->molecule_posn(*Jacobian_y_ipar_posn_); - - // store the results back into our gridfns - for (int gfn = ghosted_min_gfn; gfn <= ghosted_max_gfn; ++gfn) - { - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - const int oiperp = other_iperp(iperp); - - for (int ipar = min_ipar(iperp); ipar <= max_ipar(iperp); ++ipar) - { - int irho = my_edge().irho_of_iperp_ipar(iperp, ipar); - int isigma = my_edge().isigma_of_iperp_ipar(iperp, ipar); - my_patch().ghosted_gridfn(gfn, irho, isigma) = (*interp_result_buffer_)(gfn, oiperp, ipar); - } - } - } - } - - //****************************************************************************** - - // - // This function allocates the internal buffers for the Jacobian, and - // computes that Jacobian - // partial synchronize gridfn(ghosted_gfn, iperp, ipar) - // ------------------------------------------------------------ - // partial other patch gridfn(ghosted_gfn, oiperp, posn+ipar_m) - // where - // oiperp = Jacobian_oiperp(iperp) - // posn = Jacobian_oipar_posn(iperp, ipar) - // into the internal buffers. - // - void interpatch_ghost_zone::compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners /* = true */, - bool want_noncorner /* = true */) - const - { - // make sure the caller wants the entire ghost zone - if (!(want_corners && want_noncorner)) - then error_exit(ERROR_EXIT, - "***** interpatch_ghost_zone::compute_Jacobian():\n" - " we only support operating on the *entire* ghost zone,\n" - " but we were passed flags specifying a proper subset!\n" - " want_corners=(int)%d want_noncorner=(int)%d\n", - want_corners, want_noncorner); /*NOTREACHED*/ - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" + +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" + +namespace AHFinderDirect +{ + using jtutil::error_exit; + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // These functions verify (assert()) that a ghost zone is indeed of + // the specified type, then static_cast to the appropriate derived class. + // + + const symmetry_ghost_zone &ghost_zone::cast_to_symmetry_ghost_zone() + const + { + assert(is_symmetry()); + return static_cast(*this); + } + + symmetry_ghost_zone &ghost_zone::cast_to_symmetry_ghost_zone() + { + assert(is_symmetry()); + return static_cast(*this); + } + + //************************************** + + const interpatch_ghost_zone &ghost_zone::cast_to_interpatch_ghost_zone() + const + { + assert(is_interpatch()); + return static_cast(*this); + } + + interpatch_ghost_zone &ghost_zone::cast_to_interpatch_ghost_zone() + { + assert(is_interpatch()); + return static_cast(*this); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function constructs a mirror-symmetry ghost zone object + // + symmetry_ghost_zone::symmetry_ghost_zone(const patch_edge &my_edge_in) + : ghost_zone(my_edge_in, + my_edge_in, // other edge == my edge + ghost_zone_is_symmetry) + { + // iperp_map: i --> (i of ghost zone) - i + iperp_map_ = new jtutil::cpm_map(min_iperp(), max_iperp(), + my_edge_in.fp_grid_outer_iperp()); + + // ipar_map_: identity map + ipar_map_ = new jtutil::cpm_map(extreme_min_ipar(), extreme_max_ipar()); + } + + //****************************************************************************** + + // + // This function constructs a periodic-symmetry ghost zone object. + // + symmetry_ghost_zone::symmetry_ghost_zone(const patch_edge &my_edge_in, const patch_edge &other_edge_in, + int my_edge_sample_ipar, int other_edge_sample_ipar, + bool ipar_map_is_plus) + : ghost_zone(my_edge_in, + other_edge_in, + ghost_zone_is_symmetry) + { + // + // perpendicular map + // + const fp fp_my_period_plane_iperp = my_edge().fp_grid_outer_iperp(); + const fp fp_other_period_plane_iperp = other_edge().fp_grid_outer_iperp(); + + // iperp mapping must be outside --> inside + // i.e. if both edges have iperp as the same min/max "direction", + // then the mapping is iperp increasing --> iperp decreasing + // (i.e. the map's sign is -1) + const bool is_iperp_map_plus = !(my_edge().is_min() == other_edge().is_min()); + iperp_map_ = new jtutil::cpm_map(min_iperp(), max_iperp(), + fp_my_period_plane_iperp, + fp_other_period_plane_iperp, + is_iperp_map_plus); + + // + // parallel map + // + ipar_map_ = new jtutil::cpm_map(extreme_min_ipar(), extreme_max_ipar(), + my_edge_sample_ipar, other_edge_sample_ipar, + ipar_map_is_plus); + } + + //****************************************************************************** + + // + // This function destroys a symmetry_ghost_zone object. + // + symmetry_ghost_zone::~symmetry_ghost_zone() + { + delete ipar_map_; + delete iperp_map_; + } + + //****************************************************************************** + + // + // This function "synchronizes" a ghost zone, i.e. it updates the + // ghost-zone values of the specified gridfns via the appropriate + // symmetry operations.The flags specify which part(s) of the ghost zone + // we want. + // + void symmetry_ghost_zone::synchronize(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners /* = true */, + bool want_noncorner /* = true */) + { + // printf("*Sync sym ghost zone in %s patch\n", my_patch().name()); + + for (int gfn = ghosted_min_gfn; gfn <= ghosted_max_gfn; ++gfn) + { + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + for (int ipar = min_ipar(iperp); ipar <= max_ipar(iperp); ++ipar) + { + // do we want to do this point? + if (!my_edge().ipar_is_in_selected_part(want_corners, want_noncorner, + ipar)) + then continue; // *** LOOP CONTROL *** + + const int sym_iperp = iperp_map_of_iperp(iperp); + const int sym_ipar = ipar_map_of_ipar(ipar); + const int sym_irho = other_edge() + .irho_of_iperp_ipar(sym_iperp, sym_ipar); + const int sym_isigma = other_edge() + .isigma_of_iperp_ipar(sym_iperp, sym_ipar); + const fp sym_gridfn = other_patch() + .ghosted_gridfn(gfn, sym_irho, sym_isigma); + + const int irho = my_edge().irho_of_iperp_ipar(iperp, ipar); + const int isigma = my_edge().isigma_of_iperp_ipar(iperp, ipar); + my_patch().ghosted_gridfn(gfn, irho, isigma) = sym_gridfn; + } + } + } + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function constructs an interpatch_ghost_zone object. + // + interpatch_ghost_zone::interpatch_ghost_zone(const patch_edge &my_edge_in, + const patch_edge &other_edge_in, + int patch_overlap_width) + : ghost_zone(my_edge_in, + other_edge_in, + ghost_zone_is_interpatch), + // remaining pointers are all set up properly by finish_setup() + other_patch_interp_(NULL), + other_iperp_(NULL), + min_ipar_used_(NULL), max_ipar_used_(NULL), + other_par_(NULL), + interp_result_buffer_(NULL), + Jacobian_y_ipar_posn_(NULL), Jacobian_buffer_(NULL) // no comma + { + // + // verify that we have the expected relationships between + // this and the other patch's (mu,nu,phi) coordinates: + // + + // perp coordinate is common to us and the other patch, so + // ghost zone must be min in one patch, max in the other + if (my_edge().is_min() == other_edge().is_min()) + then error_exit(ERROR_EXIT, + "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" + " my_patch().name()=\"%s\" my_edge().name()=%s\n" + " other_patch().name()=\"%s\" other_edge().name()=%s\n" + " ghost zone must be min in one patch, max in the other!\n", + my_patch().name(), my_edge().name(), + other_patch().name(), other_edge().name()); /*NOTREACHED*/ + + // coord in common between the two patches must be perp coord in both patches + // and this patch's tau coordinate must be other edge's parallel coordinate + const local_coords::coords_set common_coords_set = local_coords::coords_set_not(my_patch().coords_set_rho_sigma() ^ + other_patch().coords_set_rho_sigma()); + if (!((common_coords_set == my_edge().coords_set_perp()) && (common_coords_set == other_edge().coords_set_perp()) && (my_patch().coords_set_tau() == other_edge().coords_set_par()))) + then error_exit(PANIC_EXIT, + "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" + " (rho,sigma,tau) coordinates don't match up properly\n" + " between this patch/edge and the other patch/edge!\n" + " my_patch().name()=\"%s\" my_edge().name()=%s\n" + " other_patch().name()=\"%s\" other_edge().name()=%s\n" + " my_patch().coords_set_{rho,sigma,tau}={%s,%s,%s}\n" + " my_edge().coords_set_{perp,par}={%s,%s}\n" + " other_patch().coords_set_{rho,sigma,tau}={%s,%s,%s}\n" + " other_edge().coords_set_{perp,par}={%s,%s}\n", + my_patch().name(), my_edge().name(), + other_patch().name(), other_edge().name(), + local_coords::name_of_coords_set(my_patch().coords_set_rho()), + local_coords::name_of_coords_set(my_patch().coords_set_sigma()), + local_coords::name_of_coords_set(my_patch().coords_set_tau()), + local_coords::name_of_coords_set(my_edge().coords_set_perp()), + local_coords::name_of_coords_set(my_edge().coords_set_par()), + local_coords::name_of_coords_set(other_patch().coords_set_rho()), + local_coords::name_of_coords_set(other_patch().coords_set_sigma()), + local_coords::name_of_coords_set(other_patch().coords_set_tau()), + local_coords::name_of_coords_set(other_edge().coords_set_perp()), + local_coords::name_of_coords_set(other_edge().coords_set_par())); + /*NOTREACHED*/ + + // perp coordinate must match (mod 2*pi) across the two patches + // after taking into account any overlap + // ... eg patch_overlap_width = 3 would be + // p p p p p + // q q q q q + // so the overlap would be (patch_overlap_width-1) * delta + const fp other_overlap = (patch_overlap_width - 1) * other_edge().perp_map().delta_fp(); + const fp other_outer_perp_minus_overlap // move back inwards into other patch + // by overlap distance, to get a value + // that should match our own + // grid_outer_perp() value + = other_edge().grid_outer_perp() + (other_edge().is_min() ? +other_overlap : -other_overlap); + if (!local_coords::fuzzy_EQ_ang(my_edge().grid_outer_perp(), + other_outer_perp_minus_overlap)) + then error_exit(ERROR_EXIT, + "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" + " my_patch().name()=\"%s\" my_edge().name()=%s\n" + " other_patch().name()=\"%s\" other_edge().name()=%s\n" + " perp coordinate doesn't match (mod 2*pi) across the two patches!\n" + " my_edge().grid_outer_perp()=%g <--(compare this)\n" + " patch_overlap_width=%d other_overlap=%g\n" + " other_edge.grid_outer_perp()=%g\n" + " other_outer_perp_minus_overlap=%g <--(against this)\n", + my_patch().name(), my_edge().name(), + other_patch().name(), other_edge().name(), + double(my_edge().grid_outer_perp()), + patch_overlap_width, double(other_overlap), + double(other_edge().grid_outer_perp()), + double(other_outer_perp_minus_overlap)); /*NOTREACHED*/ + + // + // set up the iperp interpatch coordinate mapping + // (gives other patch's iperp coordinate for interpolation) + // + + // compute the iperp --> other_iperp mapping for a sample point; + // ... if the ghost zone is empty, then the sample point will necessarily + // be out-of-range in the ghost zone, so we use the *unchecked* + // conversions to avoid errors in this case + // ... we do the computation using the fact that perp is the same + // coordinate in both patches (modulo 2*pi radians = 360 degrees) + const int sample_iperp = outer_iperp(); + const fp sample_perp = my_edge().perp_map().fp_of_int_unchecked(sample_iperp); + // unchecked conversion here! + const fp other_sample_perp = other_patch() + .modulo_reduce_ang(other_edge().perp_is_rho(), + sample_perp); + const fp fp_other_sample_iperp = other_edge() + .fp_iperp_of_perp(other_sample_perp); + + // verify that this is fuzzily a grid point + if (!jtutil::fuzzy::is_integer(fp_other_sample_iperp)) + then error_exit(ERROR_EXIT, + "***** interpatch_ghost_zone::interpatch_ghost_zone:\n" + " my_patch().name()=\"%s\" my_edge().name()=%s\n" + " other_patch().name()=\"%s\" other_edge().name()=%s\n" + " sample_iperp=%d sample_perp=%g\n" + " other_sample_perp=%g fp_other_sample_iperp=%g\n" + " ==> fp_other_sample_iperp isn't fuzzily an integer!\n" + " ==> patches aren't commensurate in the perpendicular coordinate!\n", + my_patch().name(), my_edge().name(), + other_patch().name(), other_edge().name(), + sample_iperp, double(sample_perp), + double(other_sample_perp), + double(fp_other_sample_iperp)); /*NOTREACHED*/ + const int other_sample_iperp = jtutil::round::to_integer(fp_other_sample_iperp); + + // compute the +/- sign (direction) of the iperp --> other_iperp mapping + // + // Since perp is the same in both patches (mod 2*pi radians = 360 degrees), + // the overall +/- sign is just the product of the signs of the two individual + // iperp <--> perp mappings. + // + // ... signs encoded as (floating-point) +/- 1.0 + const double iperp_map_sign_pm1 = jtutil::signum(my_edge().perp_map().delta_fp()) * jtutil::signum(other_edge().perp_map().delta_fp()); + // ... signs encoded as is_plus bool flag + const bool is_iperp_map_plus = (iperp_map_sign_pm1 > 0.0); + + // now we finally know enough to set up the other_iperp(iperp) + // coordinate mapping + other_iperp_ = new jtutil::cpm_map(min_iperp(), max_iperp(), + sample_iperp, other_sample_iperp, + is_iperp_map_plus); + } + + //****************************************************************************** + + // + // this function destroys an interpatch_ghost_zone object. + // + interpatch_ghost_zone::~interpatch_ghost_zone() + { + delete Jacobian_buffer_; + delete Jacobian_y_ipar_posn_; + delete interp_result_buffer_; + delete other_par_; + delete max_ipar_used_; + delete min_ipar_used_; + delete other_iperp_; + delete other_patch_interp_; + } + + //****************************************************************************** + + // + // These functions compute the [min,max] ipar of the ghost zone for + // a given iperp, taking into account how we treat the corners + // (cf. the example in the header comments in "ghost_zone.hh"): + // + // If an adjacent ghost zone is symmetry, + // we do not include that corner; + // If an adjacent ghost zone is interpatch, + // we include up to the diagonal line, and if we are a rho ghost zone, + // then also the diagonal line itself. E.g. For the example in the + // header comments "ghost_zone.hh", the +x ghost zone includes (6,6), + // (7,6), and (7,7), while the +y ghost zone includes (6,7) + // + // ... in the following 2 functions, + // the iabs() term includes the diagonal, + // so we must remove the diagonal for !is_rho, + // i.e. add 1 to min_ipar and subtract 1 from max_ipar + // + int interpatch_ghost_zone::min_ipar(int iperp) const + { + return min_par_adjacent_ghost_zone().is_symmetry() + ? my_edge().min_ipar_without_corners() + : my_edge().min_ipar_without_corners() - iabs(iperp - my_edge().nominal_grid_outer_iperp()) + (is_rho() ? 0 : 1); + } + + int interpatch_ghost_zone::max_ipar(int iperp) const + { + return max_par_adjacent_ghost_zone().is_symmetry() + ? my_edge().max_ipar_without_corners() + : my_edge().max_ipar_without_corners() + iabs(iperp - my_edge().nominal_grid_outer_iperp()) - (is_rho() ? 0 : 1); + } + + //****************************************************************************** + + // + // This function finishes the construction/setup of an interpatch_ghost_zone + // object. It + // - sets up the par coordinate mapping information + // - sets up the interpatch interpolator data pointer and result arrays + // - constructs the patch_interp object to interpolate from the *other* patch + // + // We use our ipar as the patch_interp's parindex. + // + void interpatch_ghost_zone::finish_setup(int interp_handle, + int interp_par_table_handle) + { + min_other_iperp_ = min(other_iperp(min_iperp()), + other_iperp(max_iperp())); + max_other_iperp_ = max(other_iperp(min_iperp()), + other_iperp(max_iperp())); + + // + // set up arrays giving actual [min,max] ipar that we'll use + // at each other_iperp (later on we will pass these arrays to the + // other patch's patch_interp object, with ipar being parindex there + // + min_ipar_used_ = new jtutil::array1d(min_other_iperp_, max_other_iperp_); + max_ipar_used_ = new jtutil::array1d(min_other_iperp_, max_other_iperp_); + { + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + (*min_ipar_used_)(other_iperp(iperp)) = min_ipar(iperp); + (*max_ipar_used_)(other_iperp(iperp)) = max_ipar(iperp); + } + } + + // + // set up array giving other patch's par coordinate for interpolation + // + + other_par_ = new jtutil::array2d(min_other_iperp_, max_other_iperp_, + extreme_min_ipar(), extreme_max_ipar()); + + { + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + for (int ipar = min_ipar(iperp); ipar <= max_ipar(iperp); ++ipar) + { + // compute the other_par corresponding to (iperp,ipar) + // ... here we use the fact (which we verified in our constructor) + // that other edge's parallel coordinate == our tau coordinate + // (at least modulo 2*pi radians = 360 degrees) + const fp perp = my_edge().perp_of_iperp(iperp); + const fp par = my_edge().par_of_ipar(ipar); + + const fp rho = my_edge().rho_of_perp_par(perp, par); + const fp sigma = my_edge().sigma_of_perp_par(perp, par); + + const fp tau = my_patch().tau_of_rho_sigma(rho, sigma); + const fp other_par = other_patch() + .modulo_reduce_ang(other_edge().par_is_rho(), tau); + + (*other_par_)(other_iperp(iperp), ipar) = other_par; + } + } + } + + // + // set up interpolation result buffer + // + interp_result_buffer_ = new jtutil::array3d(my_patch().ghosted_min_gfn(), + my_patch().ghosted_max_gfn(), + min_other_iperp_, max_other_iperp_, + extreme_min_ipar(), extreme_max_ipar()); + + // + // construct the patch_interp object to interpolate from the *other* patch + // ... the patch_interp should use gridfn data from it's (the other patch's) + // min/max par ghost zones if those (adjacent) adjacent ghost zones + // are symmetry, but not if they're interpatch, + // cf the header comments in "ghost_zone.hh" + // + const ghost_zone &other_ghost_zone = other_patch() + .ghost_zone_on_edge(other_edge()); + const bool ok_to_use_min_par_ghost_zone = other_ghost_zone.min_par_adjacent_ghost_zone() + .is_symmetry() + ? true + : false; + const bool ok_to_use_max_par_ghost_zone = other_ghost_zone.max_par_adjacent_ghost_zone() + .is_symmetry() + ? true + : false; + other_patch_interp_ = new patch_interp(other_edge(), + min_other_iperp_, max_other_iperp_, + *min_ipar_used_, *max_ipar_used_, + *other_par_, + ok_to_use_min_par_ghost_zone, + ok_to_use_max_par_ghost_zone, + interp_handle, interp_par_table_handle); + } + + //****************************************************************************** + + // + // This function asserts() that + // - we have a patch_interp object + // - our and the patch_interp object's notions of the "other patch" agree + // - the other patch has an interpatch ghost zone on this edge + // - the other patch's interpatch ghost zone on this edge, + // points back to our patch + // + void interpatch_ghost_zone::assert_fully_setup() const + { + assert(other_patch_interp_ != NULL); + assert(other_patch() == other_patch_interp_->my_patch()); + assert(other_patch() + .ghost_zone_on_edge(other_edge()) + .is_interpatch()); + assert(my_patch() == other_patch() + .ghost_zone_on_edge(other_edge()) + .other_patch()); + } + + //****************************************************************************** + + // + // This function "synchronizes" a ghost zone, i.e. it updates the + // ghost-zone values of the specified gridfns via the appropriate + // interpatch interpolations. + // + // The flags specify which part(s) of the ghost zone we want, but + // the present implementation only supports the case where all the + // flags are true , i.e. we want the entire ghost zone. + // + void interpatch_ghost_zone::synchronize(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners /* = true */, + bool want_noncorner /* = true */) + { +#ifdef DEBUG_AHFD + printf("*Sync interpatch ghost zone in %s\n", my_patch().name()); +#endif + + // make sure the caller wants the entire ghost zone + if (!(want_corners && want_noncorner)) + then error_exit(ERROR_EXIT, + "***** interpatch_ghost_zone::synchronize():\n" + " we only support operating on the *entire* ghost zone,\n" + " but we were passed flags specifying a proper subset!\n" + " want_corners=(int)%d want_noncorner=(int)%d\n", + want_corners, want_noncorner); /*NOTREACHED*/ + + // + // move from 'Compute_Jacobian' below + // + assert(other_patch_interp_ != NULL); + other_patch_interp_->molecule_minmax_ipar_m(Jacobian_min_y_ipar_m_, + Jacobian_max_y_ipar_m_); +#ifdef DEBUG_AHFD + printf("%d %d %d %d %d %d \n", Jacobian_min_y_ipar_m_, Jacobian_max_y_ipar_m_, + min_other_iperp_, max_other_iperp_, extreme_min_ipar(), extreme_max_ipar()); + getchar(); +#endif + + // /* + if (Jacobian_y_ipar_posn_ == NULL) + Jacobian_y_ipar_posn_ = new jtutil::array2d(min_other_iperp_, max_other_iperp_, + extreme_min_ipar(), extreme_max_ipar()); + if (Jacobian_buffer_ == NULL) + Jacobian_buffer_ = new jtutil::array3d(min_other_iperp_, max_other_iperp_, + extreme_min_ipar(), extreme_max_ipar(), + Jacobian_min_y_ipar_m_, Jacobian_max_y_ipar_m_); + + // do the interpolation into our result buffer + other_patch_interp_->interpolate(ghosted_min_gfn, ghosted_max_gfn, + *interp_result_buffer_, //); + *Jacobian_y_ipar_posn_, + *Jacobian_buffer_); + + // other_patch_interp_->molecule_posn(*Jacobian_y_ipar_posn_); + + // store the results back into our gridfns + for (int gfn = ghosted_min_gfn; gfn <= ghosted_max_gfn; ++gfn) + { + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + const int oiperp = other_iperp(iperp); + + for (int ipar = min_ipar(iperp); ipar <= max_ipar(iperp); ++ipar) + { + int irho = my_edge().irho_of_iperp_ipar(iperp, ipar); + int isigma = my_edge().isigma_of_iperp_ipar(iperp, ipar); + my_patch().ghosted_gridfn(gfn, irho, isigma) = (*interp_result_buffer_)(gfn, oiperp, ipar); + } + } + } + } + + //****************************************************************************** + + // + // This function allocates the internal buffers for the Jacobian, and + // computes that Jacobian + // partial synchronize gridfn(ghosted_gfn, iperp, ipar) + // ------------------------------------------------------------ + // partial other patch gridfn(ghosted_gfn, oiperp, posn+ipar_m) + // where + // oiperp = Jacobian_oiperp(iperp) + // posn = Jacobian_oipar_posn(iperp, ipar) + // into the internal buffers. + // + void interpatch_ghost_zone::compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners /* = true */, + bool want_noncorner /* = true */) + const + { + // make sure the caller wants the entire ghost zone + if (!(want_corners && want_noncorner)) + then error_exit(ERROR_EXIT, + "***** interpatch_ghost_zone::compute_Jacobian():\n" + " we only support operating on the *entire* ghost zone,\n" + " but we were passed flags specifying a proper subset!\n" + " want_corners=(int)%d want_noncorner=(int)%d\n", + want_corners, want_noncorner); /*NOTREACHED*/ + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/ghost_zone.h b/AMSS_NCKU_source/AHF_Direct/ghost_zone.h similarity index 97% rename from AMSS_NCKU_source/ghost_zone.h rename to AMSS_NCKU_source/AHF_Direct/ghost_zone.h index 3306d25..4d54351 100644 --- a/AMSS_NCKU_source/ghost_zone.h +++ b/AMSS_NCKU_source/AHF_Direct/ghost_zone.h @@ -1,796 +1,796 @@ -#ifndef GHOST_ZONE_H -#define GHOST_ZONE_H -namespace AHFinderDirect -{ - - //***************************************************************************** - - // - // ***** design notes for ghost zones ***** - // - - // - // A ghost_zone object describes a patch's ghost zone, and knows how - // to compute gridfns there (we usually speak of "synchronizing" the - // ghost zone or zones) based on either the patch system's symmetry - // or interpolation from a neighboring patch. ghost_zone is an abstract - // base class, from which we derive two concrete classes: - // * A symmetry_ghost_zone object describes a ghost zone which is a - // (discrete) symmetry of spacetime, either mirror-image or periodic. - // Such an object knows how to fill in ghost-zone gridfn data from - // the "other side" of the symmetry. - // * An interpatch_ghost_zone object describes a ghost zone which - // overlaps another patch. Such an object knows how to get ghost - // zone gridfn data from the other patch. More accurately, it gets - // the data by asking (calling) the appropriate one of the other - // patch's patch_interp objects. - // Every patch has (points to) 4 ghost_zone objects, one for each of - // the patch's sides. See the comments in "patch.hh" for a "big picture" - // discussion of patches, patch edges, ghost zones, and patch interpolators. - // - - // - // There are some unobvious complications involved in synchronizing - // the ghost zone "corners", i.e. in ghost zone points that are outside - // the nominal grid in *both* coordinates. There are 3 basic cases here: - // * A corner between two symmetry ghost zones, for example the -x/-y - // corner in the example below. In this case it takes *two* sequential - // symmetry operations to get gridfn data in the corner from the - // nominal grid. Symmetry operations commute, so at each point we'll - // always get the same results independently of in which order we do - // the symmetry operations. Computationally, we actually do the operations - // in both orders, one order's results overwriting the other's, but - // this doesn't matter (because the results are the same). - // * A corner between two interpatch ghost zones, for example the +x/+y - // corner in the example below. In this case we could get the gridfn - // data by either of two distinct interpolation operations (presumably - // from two distinct patches), which would in general give slightly - // different results. In some ideal world we might do a centered - // interpolation using data from both patches, but this would be - // complicated: - // - it would require a 2-D interpolation - // - it would require bookkeeping for interpolating from multiple - // patches within the same ghost zone, indeed for the same ghost - // zone point - // At present, we follow a simpler approach: we split the corner down - // its diagonal, - // [for the points on the diagonal we make an arbitrary choice; - // at present this is that they belong to (and get their data via) - // the rho ghost zone.] - // and off-center the interpolation as necessary so each ghost-zone - // point gets data solely from the neighboring patch on its own side. - // * A corner between a symmetry and an interpatch ghost zone, for - // example the +x/-y or -x/+y corners in the example below. In this - // case we first do a symmetry operation in the neighboring patch, - // then a fully centered interpolation (using the data just obtained - // from a symmetry operation) to get data in the non-corner part of - // the interpatch ghost zone. After the interpatch interpolation, - // we do a final symmetry operation to get gridfn data in the corner. - // - // In general, then, a ghost zone is rhomboid-shaped: iperp lies in a - // fixed interval, while ipar lies in an interval which may depend on - // iperp. In general, this shape depends on the type (symmetry vs interpatch) - // of the adjacent ghost zones. - // - - // - // To properly handle all the symmetry/interpatch cases described above, - // we use a 3-phase algorithm to synchronize ghost zones: - // Phase 1: Fill in gridfn data at all the non-corner points of symmetry - // ghost zones, by using the symmetries to get this data from - // its "home patch" nominal grids. - // Phase 2: Fill in gridfn data in all the interpatch ghost zones, by - // interpatch interpolating from neighboring patches as described - // above. - // Phase 3: Fill in gridfn data at all the corner points of symmetry - // ghost zones, by using the symmetries to get this data from - // its "home patch" nominal grids or ghost zones. - // Here a given ghost zone corner may be either a full rectangle (so any - // given point is a member of both adjacent corners), or split down its - // diagonal (so any given point is a member of only one corner). This - // 3-phase algorithm is actually implemented by - // patch_system::synchronize() - // which in turn calls - // symmetry_ghost_zone::synchronize() - // interpatch_ghost_zone::synchronize() - // - - // - // For example, consider the +z patch in an octant patch system, with - // the ghost zones being 2 points wide. The following illustration is - // looking down the z axis, and uses (x,y) for the patch coordinates - // for simplicity: - // - // # // - // i+y i+y i+y i+y i+y i+y i+y // - // (-2,7) (-1,7) (0,7) (1,7) (2,7) (3,7) (4,7) (5,7) (6,7) (7,7) - // # /i+x - // # // - // i+y i+y i+y i+y i+y i+y // - // (-2,6) (-1,6) (0,6) (1,6) (2,6) (3,6) (4,6) (5,6) (6,6) (7,6) - // # /i+x i+x - // # // - // # // - // (-2,5) (-1,5) 2,5)--(1,5)--(2,5)--(3,5)--(4,5)--(5,5) (6,5) (7,5) - // s-x s-x # | i+x i+x - // # | - // # | - // (-2,4) (-1,4) (0,4) (1,4) (2,4) (3,4) (4,4) (5,4) (6,4) (7,4) - // s-x s-x # | i+x i+x - // # | - // # | - // (-2,3) (-1,3) (0,3) (1,3) (2,3) (3,3) (4,3) (5,3) (6,3) (7,3) - // s-x s-x # | i+x i+x - // # | - // # | - // (-2,2) (-1,2) (0,2) (1,2) (2,2) (3,2) (4,2) (5,2) (6,2) (7,2) - // s-x s-x # | i+x i+x - // # | - // # | - // (-2,1) (-1,1) (0,1) (1,1) (2,1) (3,1) (4,1) (5,1) (6,1) (7,1) - // s-x s-x # | i+x i+x - // # | - // # | - // #(-2,0)#(-1,0)##(0,0)##(1,0)##(2,0)##(3,0)##(4,0)##(5,0)##(6,0)##(7,0) - // s-x s-x # i+x i+x - // # - // s-y s-y s-y s-y s-y s-y - // (-2,-1)(-1,-1) (0,-1) (1,-1) (2,-1) (3,-1) (4,-1) (5,-1) (6,-1) (7,-1) - // # - // # - // s-y s-y s-y s-y s-y s-y - // (-2,-2)(-1,-2) (0,-2) (1,-2) (2,-2) (3,-2) (4,-2) (5,-2) (6,-2) (7,-2) - // # - // # - // - // For this example, - // * The xz plane and yz plane are marked with ### lines - // * The +z patch's nominal grid is ([0,5],[0,5]), i.e. 0 <= x,y <= 5; - // its boundary lines are shown with single lines --- and | . - // * The diagonal where we've split corners are marked with // lines. - // * The +z patch's ghost zones are - // -x: (-1,[-1,7]), (-2,[-2,7]) - // +x: (6,[-2,6]), (7,[-2,7]) - // -y: ([-2, 7],[-2,-1]) - // +y: ([-2,5],6), ([-2,6],7) - // * The regions where we will interpolate data from the +z patch are - // +x: ([ 3,4],[-2,7]) - // +y: ([-2,7],[ 3,4]) - // Note that in both cases the interpolation region includes the points - // computed by symmetry (in phase 1 of our 3-phase algorithm) on the - // adjacent edges! There are no interpolation regions inside the -x or - // -y boundaries, since no interpolation is needed across those boundaries - // of this patch. - // The diagonal *** line shows the boundary between the +x and +y ghost - // zones. - // - // Our 3-phase algorithm described above thus becomes: - // Phase 1: Fill in gridfn values at points marked with "s-x" below or - // "s-y" above via symmetry mirroring across the -x boundary - // (yz plane) or -y boundary (xz plane), as described by the - // +z patch's -x or -y symmetry_ghost_zone object respectively. - // Phase 2: Fill in gridfn values at points marked with "i+x" below or - // "i+y" above via interpatch interpolation from the neighboring - // patch across the +z patch's +x or +y boundary, as described - // by the +z patch's +x or +y interpatch_ghost_zone object - // respectively. - // Phase 3: Fill in gridfn values at points marked with "" below or - // "" above via symmetry mirroring across the -x boundary - // (yz plane) or -y boundary (xz plane), as described by the - // +z patch's -x or -y symmetry_ghost_zone object respectively. - // - - //***************************************************************************** - - // - // ghost_zone - abstract base class to describe ghost zone of patch - // - // This is an abstract base class describing a generic patch ghost zone. - // This might represent either of: - // - a discrete symmetry of spacetime (derived class symmetry_ghost_zone) - // - an overlap with another patch (derived class interpatch_ghost_zone) - // - - // - // N.b. const qualifiers in ghost_zone and its derived classes refer to - // the underlying gridfn data. - // - - // forward declarations - class symmetry_ghost_zone; - class interpatch_ghost_zone; - class patch_system; - - class ghost_zone - { - public: - // - // ***** main high-level client interface ***** - // - // "synchronize" a ghost zone, i.e. update the ghost-zone values - // of the specified gridfns via the appropriate sequence of - // symmetry operations and interpatch interpolations - // (flags specify which part(s) of the ghost zone we want) - // - virtual void synchronize(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners = true, - bool want_noncorner = true) = 0; - - public: - // - // ***** Jacobian of synchronize() ***** - // - // This function computes the Jacobian of the synchronize() - // operation into internal buffers; the following functions - // provide access to that Jacobian. - // - // FIXME: should these be moved out into a separate Jacobian - // object/class? - // - // Note that this function just computes the Jacobian of this - // ghost zone's synchronize() operation -- it does *NOT* take - // into account the 3-phase synchronization algorithm described - // in the header comments for this file. (That's done by - // patch_system::synchronize_Jacobian() and its subfunctions.) - // - // n.b. terminology is - // partial gridfn at x - // ------------------- - // partial gridfn at y - // - virtual void compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners = true, - bool want_noncorner = true) - const = 0; - - // - // The API in the remaining functions implicitly assumes that - // the Jacobian is independent of ghosted_gfn , and also that - // the structure of the Jacobian is such that the set of y points - // on which a single ghost-zone point depends, - // - has a single yiperp value (depending on our iperp, of course) - // - have a contiguous interval of yipar (depending on our iperp - // and ipar, of course), whose size is - // [or can be taken to be without an unreasonable - // amount of zero-padding] - // independent of our iperp and ipar; we parameterize this - // interval as yipar = posn+m where posn is determined by - // our iperp and ipar, and m has a fixed range independent - // of our iperp and ipar - // - - // what is the [min,max] range of m for this ghost zone? - virtual int Jacobian_min_y_ipar_m() const = 0; - virtual int Jacobian_max_y_ipar_m() const = 0; - - // what is the iperp of the Jacobian y points in their (y) patch? - virtual int Jacobian_y_iperp(int x_iperp) const = 0; - - // what is the posn value of the y points in this Jacobian row? - virtual int Jacobian_y_ipar_posn(int x_iperp, int x_ipar) const = 0; - - // what is the Jacobian - // partial synchronize() px.gridfn(ghosted_gfn, x_iperp, x_ipar) - // ------------------------------------------------------------- - // partial py.gridfn(ghosted_gfn, y_iperp, y_posn+y_ipar_m) - // where - // y_iperp = Jacobian_y_iperp(x_iperp) - // y_posn = Jacobian_y_ipar_posn(x_iperp, x_ipar) - virtual fp Jacobian(int x_iperp, int x_ipar, int y_ipar_m) const = 0; - - public: - // - // ***** low-level client interface ***** - // - - // to which patch/edge do we belong? - patch &my_patch() const { return my_patch_; } - const patch_edge &my_edge() const { return my_edge_; } - - // from which patch/edge do we get data? - patch &other_patch() const { return other_patch_; } - const patch_edge &other_edge() const { return other_edge_; } - - // what type of ghost zone are we? - bool is_interpatch() const { return is_interpatch_; } - bool is_symmetry() const { return !is_interpatch_; } - - // convenience forwarding functions down to patch_edge:: - bool is_min() const { return my_edge().is_min(); } - bool is_rho() const { return my_edge().is_rho(); } - - // min/max iperp of the ghost zone - int min_iperp() const - { - return my_patch() - .minmax_ang_ghost_zone__min_iperp(is_min(), is_rho()); - } - int max_iperp() const - { - return my_patch() - .minmax_ang_ghost_zone__max_iperp(is_min(), is_rho()); - } - - // inner/outer iperp of the ghost zone wrt our patch - int inner_iperp() const { return is_min() ? max_iperp() : min_iperp(); } - int outer_iperp() const { return is_min() ? min_iperp() : max_iperp(); } - - // extreme min/max ipar that might possibly be part of this ghost zone - // (derived classes may actually use a subset of this) - int extreme_min_ipar() const - { - return my_edge().min_ipar_with_corners(); - } - int extreme_max_ipar() const - { - return my_edge().max_ipar_with_corners(); - } - - // actual min/max ipar in the ghost zone at a particular iperp - // (may depend on type of the adjacent ghost zones) - virtual int min_ipar(int iperp) const = 0; - virtual int max_ipar(int iperp) const = 0; - - // point membership predicate - bool is_in_ghost_zone(int iperp, int ipar) - const - { - // n.b. don't test ipar until we're sure iperp is in range! - return (iperp >= min_iperp()) && (iperp <= max_iperp()) && (ipar >= min_ipar(iperp)) && (ipar <= max_ipar(iperp)); - } - - // adjacent ghost zones to our min/max corners - const ghost_zone &min_par_adjacent_ghost_zone() const - { - return my_patch() - .ghost_zone_on_edge(my_edge().min_par_adjacent_edge()); - } - const ghost_zone &max_par_adjacent_ghost_zone() const - { - return my_patch() - .ghost_zone_on_edge(my_edge().max_par_adjacent_edge()); - } - - // - // ***** safely cast to derived classes ***** - // - - // assert that gz is of specified type, - // then static_cast to derive type - const symmetry_ghost_zone &cast_to_symmetry_ghost_zone() const; - symmetry_ghost_zone &cast_to_symmetry_ghost_zone(); - const interpatch_ghost_zone &cast_to_interpatch_ghost_zone() const; - interpatch_ghost_zone &cast_to_interpatch_ghost_zone(); - - // - // ***** constructor, finish setup, destructor ***** - // - protected: - // ... values for is_interpatch_in constructor argument - // FIXME: these should really be bool, but then we couldn't - // use the "enum hack" for in-class constants - enum - { - ghost_zone_is_symmetry = false, - ghost_zone_is_interpatch = true // no comma - }; - - // constructor - // ... only used in implementing our derived classes; - // the rest of the world constructs our derived classes instead - ghost_zone(const patch_edge &my_edge_in, - const patch_edge &other_edge_in, - bool is_interpatch_in) - : my_patch_(my_edge_in.my_patch()), - my_edge_(my_edge_in), - other_patch_(other_edge_in.my_patch()), - other_edge_(other_edge_in), - is_interpatch_(is_interpatch_in) - { - } - - public: - // assert() that ghost zone is fully setup: - // defined here ==> no-op - // symmetry ghost zone ==> unchanged ==> no-op - // interpatch ghost zone ==> check consistency of this and the - // other patch's ghost zones and - // patch_interp objects - virtual void assert_fully_setup() const {} - - // destructor must be virtual to allow destruction - // of derived classes via ptr/ref to this class - virtual ~ghost_zone() {} - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them (either here or in derived classes) - ghost_zone(const ghost_zone &rhs); - ghost_zone &operator=(const ghost_zone &rhs); - - private: - patch &my_patch_; - const patch_edge &my_edge_; - patch &other_patch_; - const patch_edge &other_edge_; - const bool is_interpatch_; - }; - - //***************************************************************************** - - // - // symmetry_ghost_zone - derived class for spacetime-symmetry ghost zone - // - // In practice, there are two types of spacetime symmetry ghost zone: - // mirror symmetry and periodic symmetry. However, it turns out that the - // code needed to handle periodic BCs is basically a superset of that - // needed to handle mirror symmetries, so this class represents a generic - // symmetry ghost zone which may be of either type, and once constructed - // doesn't distinguish between the two. - // - // In general, a symmetry ghost zone implies that there's a 1-1 mapping - // between ghost zone points of this patch, and (a subset of the) interior - // points of this or another patch. If tensors are involved (this isn't - // used at present in the horizon finder), there's also a corresponding - // 1-1 mapping between (angular) tensor components. - // - // A mirror-symmetry ghost zone is specified by (the constructor arguments) - // - a patch edge - // - the (fp) perp coordinate of the mirror plane - // The mapping of ghost zone points is thus "just" the mirror imaging of - // iperp across the symmetry plane within this same patch. (The mapping - // leaves ipar invariant.) - // - // A periodic-symmetry ghost zone is specified by (the constructor arguments) - // - a patch edge (specifies the ghost zone) - // - the patch edge to which the ghost zone is to be mapped - // - a pair of ipar coordinates, one on this edge and one on the other edge, - // which map into each other - // - the sign of the ipar mapping (does increasing ipar on this edge map to - // increasing or decreasing ipar on the other edge?) - // The mapping of ghost zone points is the periodic mapping; this may map - // the ghost zone points to interior points of either this same patch or a - // different one. - // - // In general, the symmetry mapping of ghost zone points is of the form - // (iperp, ipar) --> (const +/- iperp, const +/- ipar) - // The iperp mapping is always in the direction - // outside the patch --> inside the patch - // while the ipar mapping might have either sign. - // If there are tensors, the corresponding mapping of tensor components is - // (index_perp, index_par) --> (+/-) (+/-) (index_perp, index_par) - // (that is, the two +/- signs are multiplied). - - // - // Since all the member functions are const , a symmetry_ghost_zone - // object is effectively always const . - // - class symmetry_ghost_zone - : public ghost_zone - { - public: - // - // ***** main high-level client interface ***** - // - // "synchronize" a ghost zone, i.e. update the ghost-zone values - // of the specified gridfns via the appropriate symmetry operations - // (flags specify which part(s) of the ghost zone we want) - // - void synchronize(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners = true, - bool want_noncorner = true); - - // - // ***** Jacobian of synchronize() ***** - // - // n.b. terminology is - // partial gridfn at x - // ------------------- - // partial gridfn at y - // - - // allocate internal buffers, compute Jacobian - // ... this function is a no-op in this class - void compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners = true, - bool want_noncorner = true) - const - { - } - - // what is the [min,max] range of m for this ghost zone? - int Jacobian_min_y_ipar_m() const { return 0; } - int Jacobian_max_y_ipar_m() const { return 0; } - - // what is the oiperp of the Jacobian points (= iperp in their patch)? - virtual int Jacobian_y_iperp(int x_iperp) const - { - return iperp_map_of_iperp(x_iperp); - } - - // what is the posn value of the points in this Jacobian row? - int Jacobian_y_ipar_posn(int x_iperp, int x_ipar) const - { - return ipar_map_of_ipar(x_ipar); - } - - // what is the Jacobian - // partial synchronize() px.gridfn(ghosted_gfn, x_iperp, x_ipar) - // ------------------------------------------------------------- - // partial py.gridfn(ghosted_gfn, y_iperp, y_posn+y_ipar_m) - // where - // y_iperp = Jacobian_y_iperp(x_iperp) - // y_posn = Jacobian_y_ipar_posn(x_iperp, x_ipar) - fp Jacobian(int x_iperp, int x_ipar, int y_ipar_m) const - { - return (y_ipar_m == 0) ? 1.0 : 0.0; - } - - // - // ***** low-level client interface ***** - // - - // symmetry-map coordinates - int iperp_map_of_iperp(int iperp) const - { - return iperp_map_->map(iperp); - } - int ipar_map_of_ipar(int ipar) const - { - return ipar_map_->map(ipar); - } - fp fp_sign_of_iperp_map() const - { - return iperp_map_->fp_sign(); - } - fp fp_sign_of_ipar_map() const - { - return ipar_map_->fp_sign(); - } - - // min/max ipar of the ghost zone - // ... we always include the corners - // (cf. the example at the start of this file) - int min_ipar(int iperp) const { return extreme_min_ipar(); } - int max_ipar(int iperp) const { return extreme_max_ipar(); } - - // - // ***** constructors, destructor ***** - // - public: - // constructor for mirror-symmetry ghost zone - symmetry_ghost_zone(const patch_edge &my_edge_in); - - // constructor for periodic-symmetry ghost zone - // ... ipar mapping specified by giving sample point and mapping sign - symmetry_ghost_zone(const patch_edge &my_edge_in, const patch_edge &other_edge_in, - int my_edge_sample_ipar, int other_edge_sample_ipar, - bool ipar_map_is_plus); - - ~symmetry_ghost_zone(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - symmetry_ghost_zone(const symmetry_ghost_zone &rhs); - symmetry_ghost_zone &operator=(const symmetry_ghost_zone &rhs); - - private: - // symmetry mappings for (iperp,ipar) - // ... we own these objects - const jtutil::cpm_map *iperp_map_; - const jtutil::cpm_map *ipar_map_; - }; - - //***************************************************************************** - - // - // interpatch_ghost_zone - derived class for interpatch ghost zone of a patch - // - // A ghost_zone object maps (my_iperp,my_ipar) coordinates to the other - // patch's (other_iperp,other_par) coordinates, then calls the other patch's - // patch_interp object to interpolate the other patch's data to those - // coordinates. - // - // Note that as described in the "design notes for ghost zones" - // comments above, interpatch_ghost_zone objects are constructed in - // the 2nd and 3rd phase of the overall construction process described - // at the comments at the start of "patch.hh" - // [done by our constructor] - // - set up the object itslf and its links to/from the patches and - // their edges - // [done by finish_setup()] - // - set up the interpatch mapping information, data pointers, and - // interpolation result buffer - // - construct the patch_interp object to interpolate from the other - // patch, and save a pointer to it - // - - class patch_interp; - - class interpatch_ghost_zone - : public ghost_zone - { - public: - // - // ***** main high-level client interface ***** - // - // "synchronize" a ghost zone, i.e. update the ghost-zone - // values of the specified gridfns via the appropriate - // interpatch interpolations - // (flags specify which part(s) of the ghost zone we want) - // - // ... the present implementation only supports the case where - // both flags are set - // - void synchronize(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners = true, - bool want_noncorner = true); - - // - // ***** Jacobian of synchronize() ***** - // - // n.b. terminology is - // partial gridfn at x - // ------------------- - // partial gridfn at y - // - - // allocate internal buffers, compute Jacobian - // - // ... the present implementation only supports the case where - // both flags are set - // - void compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, - bool want_corners = true, - bool want_noncorner = true) - const; - - // what is the [min,max] range of m for this ghost zone? - int Jacobian_min_y_ipar_m() const { return Jacobian_min_y_ipar_m_; } - int Jacobian_max_y_ipar_m() const { return Jacobian_max_y_ipar_m_; } - - // what is the iperp of the Jacobian y points in their (y) patch? - // ... the ipar row of grid points is actually the same, so - // we just have to translate x_iperp to the y patch's coordinates - int Jacobian_y_iperp(int x_iperp) const { return other_iperp(x_iperp); } - - // what is the posn value of the y points in this Jacobian row? - int Jacobian_y_ipar_posn(int x_iperp, int x_ipar) const - { - assert(Jacobian_y_ipar_posn_ != NULL); - const int y_iperp = Jacobian_y_iperp(x_iperp); - return (*Jacobian_y_ipar_posn_)(y_iperp, x_ipar); - } - - // what is the Jacobian - // partial synchronize() px.gridfn(ghosted_gfn, x_iperp, x_ipar) - // ------------------------------------------------------------- - // partial py.gridfn(ghosted_gfn, y_iperp, y_posn+y_ipar_m) - // where - // y_iperp = Jacobian_y_iperp(x_iperp) - // y_posn = Jacobian_y_ipar_posn(x_iperp, x_ipar) - fp Jacobian(int x_iperp, int x_ipar, int y_ipar_m) const - { - assert(Jacobian_buffer_ != NULL); - assert(y_ipar_m >= Jacobian_min_y_ipar_m_); - assert(y_ipar_m <= Jacobian_max_y_ipar_m_); - const int y_iperp = Jacobian_y_iperp(x_iperp); - return (*Jacobian_buffer_)(y_iperp, x_ipar, y_ipar_m); - } - - // - // ***** low-level client interface ***** - // - - public: - // check consistency of this and the other patch's ghost zones - // and patch_interp objects - void assert_fully_setup() const; - - // min/max ipar of the ghost zone for specified iperp - // with possibly "triangular" corners depending on the type - // (symmetry vs interpatch) of the adjacent ghost zones - // (cf. comments & example at the start of this file) - int min_ipar(int iperp) const; - int max_ipar(int iperp) const; - - // convert our iperp --> other patch's iperp - int other_iperp(int iperp) const - { - assert(other_iperp_ != NULL); - return other_iperp_->map(iperp); - } - - // - // ***** constructor, finish setup, destructor ***** - // - public: - interpatch_ghost_zone(const patch_edge &my_edge_in, - const patch_edge &other_edge_in, - int patch_overlap_width); - - // finish setup (requires adjacent-side ghost_zone objects - // to exist, though not to have finish_setup() called): - // - setup par coordinate mapping information - // - setup interpatch interpolator data pointers & result buffer - // - create patch_interp object to interpolate from *other* patch - void finish_setup(int interp_handle, int interp_par_table_handle); - - ~interpatch_ghost_zone(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - interpatch_ghost_zone(const interpatch_ghost_zone &rhs); - interpatch_ghost_zone &operator=(const interpatch_ghost_zone &rhs); - - private: - // - // all the remaining pointers are initialized to NULL pointers - // in our constructor, then finally allocated and set up by - // finish_setup() or compute_Jacobian() as appropriate - // - // FIXME: should these be moved out into a separate object/class - // for the interp stuff and/or another one for the Jacobian? - // - - // see comment in "patch_interp.hh" for why this is "const" - const patch_interp *other_patch_interp_; - - // other patch's iperp coordinates of our ghost zone points - // ... maps my_iperp --> other_iperp - jtutil::cpm_map *other_iperp_; - - // min/max values of other patch's iperp coordinates - // of our ghost zone points - int min_other_iperp_, max_other_iperp_; - - // [min,max]_ipar used at each other_iperp - // ... we will pass these arrays by reference - // to the other patch's patch_interp object - // ... index is (other_iperp) - jtutil::array1d *min_ipar_used_; - jtutil::array1d *max_ipar_used_; - - // other patch's (fp) parallel coordinates of our ghost zone points - // ... we will pass this array by reference - // to the other patch's patch_interp object - // using my_ipar as the patch_interp's parindex - // ... subscripts are (other_iperp, my_ipar) - jtutil::array2d *other_par_; - - // buffer into which the other patch's patch_interp object - // will store the interpolated gridfn values - // ... we will pass this array by reference - // to the other patch's patch_interp object - // using my_ipar as the patch_interp's parindex - // ... subscripts are (gfn, other_iperp,my_ipar) - jtutil::array3d *interp_result_buffer_; - - // - // stuff computed by compute_Jacobian() - // - // n.b. terminology is - // partial gridfn at x - // ------------------- - // partial gridfn at y - // - mutable int Jacobian_min_y_ipar_m_, Jacobian_max_y_ipar_m_; - - // other patch's y ipar posn for a Jacobian row - // ... subscripts are (oiperp, ipar) - mutable jtutil::array2d *Jacobian_y_ipar_posn_; - - // Jacobian values - // ... subscripts are (y_iperp, x_ipar, y_ipar_m) - mutable jtutil::array3d *Jacobian_buffer_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* GHOST_ZONE_H*/ +#ifndef GHOST_ZONE_H +#define GHOST_ZONE_H +namespace AHFinderDirect +{ + + //***************************************************************************** + + // + // ***** design notes for ghost zones ***** + // + + // + // A ghost_zone object describes a patch's ghost zone, and knows how + // to compute gridfns there (we usually speak of "synchronizing" the + // ghost zone or zones) based on either the patch system's symmetry + // or interpolation from a neighboring patch. ghost_zone is an abstract + // base class, from which we derive two concrete classes: + // * A symmetry_ghost_zone object describes a ghost zone which is a + // (discrete) symmetry of spacetime, either mirror-image or periodic. + // Such an object knows how to fill in ghost-zone gridfn data from + // the "other side" of the symmetry. + // * An interpatch_ghost_zone object describes a ghost zone which + // overlaps another patch. Such an object knows how to get ghost + // zone gridfn data from the other patch. More accurately, it gets + // the data by asking (calling) the appropriate one of the other + // patch's patch_interp objects. + // Every patch has (points to) 4 ghost_zone objects, one for each of + // the patch's sides. See the comments in "patch.hh" for a "big picture" + // discussion of patches, patch edges, ghost zones, and patch interpolators. + // + + // + // There are some unobvious complications involved in synchronizing + // the ghost zone "corners", i.e. in ghost zone points that are outside + // the nominal grid in *both* coordinates. There are 3 basic cases here: + // * A corner between two symmetry ghost zones, for example the -x/-y + // corner in the example below. In this case it takes *two* sequential + // symmetry operations to get gridfn data in the corner from the + // nominal grid. Symmetry operations commute, so at each point we'll + // always get the same results independently of in which order we do + // the symmetry operations. Computationally, we actually do the operations + // in both orders, one order's results overwriting the other's, but + // this doesn't matter (because the results are the same). + // * A corner between two interpatch ghost zones, for example the +x/+y + // corner in the example below. In this case we could get the gridfn + // data by either of two distinct interpolation operations (presumably + // from two distinct patches), which would in general give slightly + // different results. In some ideal world we might do a centered + // interpolation using data from both patches, but this would be + // complicated: + // - it would require a 2-D interpolation + // - it would require bookkeeping for interpolating from multiple + // patches within the same ghost zone, indeed for the same ghost + // zone point + // At present, we follow a simpler approach: we split the corner down + // its diagonal, + // [for the points on the diagonal we make an arbitrary choice; + // at present this is that they belong to (and get their data via) + // the rho ghost zone.] + // and off-center the interpolation as necessary so each ghost-zone + // point gets data solely from the neighboring patch on its own side. + // * A corner between a symmetry and an interpatch ghost zone, for + // example the +x/-y or -x/+y corners in the example below. In this + // case we first do a symmetry operation in the neighboring patch, + // then a fully centered interpolation (using the data just obtained + // from a symmetry operation) to get data in the non-corner part of + // the interpatch ghost zone. After the interpatch interpolation, + // we do a final symmetry operation to get gridfn data in the corner. + // + // In general, then, a ghost zone is rhomboid-shaped: iperp lies in a + // fixed interval, while ipar lies in an interval which may depend on + // iperp. In general, this shape depends on the type (symmetry vs interpatch) + // of the adjacent ghost zones. + // + + // + // To properly handle all the symmetry/interpatch cases described above, + // we use a 3-phase algorithm to synchronize ghost zones: + // Phase 1: Fill in gridfn data at all the non-corner points of symmetry + // ghost zones, by using the symmetries to get this data from + // its "home patch" nominal grids. + // Phase 2: Fill in gridfn data in all the interpatch ghost zones, by + // interpatch interpolating from neighboring patches as described + // above. + // Phase 3: Fill in gridfn data at all the corner points of symmetry + // ghost zones, by using the symmetries to get this data from + // its "home patch" nominal grids or ghost zones. + // Here a given ghost zone corner may be either a full rectangle (so any + // given point is a member of both adjacent corners), or split down its + // diagonal (so any given point is a member of only one corner). This + // 3-phase algorithm is actually implemented by + // patch_system::synchronize() + // which in turn calls + // symmetry_ghost_zone::synchronize() + // interpatch_ghost_zone::synchronize() + // + + // + // For example, consider the +z patch in an octant patch system, with + // the ghost zones being 2 points wide. The following illustration is + // looking down the z axis, and uses (x,y) for the patch coordinates + // for simplicity: + // + // # // + // i+y i+y i+y i+y i+y i+y i+y // + // (-2,7) (-1,7) (0,7) (1,7) (2,7) (3,7) (4,7) (5,7) (6,7) (7,7) + // # /i+x + // # // + // i+y i+y i+y i+y i+y i+y // + // (-2,6) (-1,6) (0,6) (1,6) (2,6) (3,6) (4,6) (5,6) (6,6) (7,6) + // # /i+x i+x + // # // + // # // + // (-2,5) (-1,5) 2,5)--(1,5)--(2,5)--(3,5)--(4,5)--(5,5) (6,5) (7,5) + // s-x s-x # | i+x i+x + // # | + // # | + // (-2,4) (-1,4) (0,4) (1,4) (2,4) (3,4) (4,4) (5,4) (6,4) (7,4) + // s-x s-x # | i+x i+x + // # | + // # | + // (-2,3) (-1,3) (0,3) (1,3) (2,3) (3,3) (4,3) (5,3) (6,3) (7,3) + // s-x s-x # | i+x i+x + // # | + // # | + // (-2,2) (-1,2) (0,2) (1,2) (2,2) (3,2) (4,2) (5,2) (6,2) (7,2) + // s-x s-x # | i+x i+x + // # | + // # | + // (-2,1) (-1,1) (0,1) (1,1) (2,1) (3,1) (4,1) (5,1) (6,1) (7,1) + // s-x s-x # | i+x i+x + // # | + // # | + // #(-2,0)#(-1,0)##(0,0)##(1,0)##(2,0)##(3,0)##(4,0)##(5,0)##(6,0)##(7,0) + // s-x s-x # i+x i+x + // # + // s-y s-y s-y s-y s-y s-y + // (-2,-1)(-1,-1) (0,-1) (1,-1) (2,-1) (3,-1) (4,-1) (5,-1) (6,-1) (7,-1) + // # + // # + // s-y s-y s-y s-y s-y s-y + // (-2,-2)(-1,-2) (0,-2) (1,-2) (2,-2) (3,-2) (4,-2) (5,-2) (6,-2) (7,-2) + // # + // # + // + // For this example, + // * The xz plane and yz plane are marked with ### lines + // * The +z patch's nominal grid is ([0,5],[0,5]), i.e. 0 <= x,y <= 5; + // its boundary lines are shown with single lines --- and | . + // * The diagonal where we've split corners are marked with // lines. + // * The +z patch's ghost zones are + // -x: (-1,[-1,7]), (-2,[-2,7]) + // +x: (6,[-2,6]), (7,[-2,7]) + // -y: ([-2, 7],[-2,-1]) + // +y: ([-2,5],6), ([-2,6],7) + // * The regions where we will interpolate data from the +z patch are + // +x: ([ 3,4],[-2,7]) + // +y: ([-2,7],[ 3,4]) + // Note that in both cases the interpolation region includes the points + // computed by symmetry (in phase 1 of our 3-phase algorithm) on the + // adjacent edges! There are no interpolation regions inside the -x or + // -y boundaries, since no interpolation is needed across those boundaries + // of this patch. + // The diagonal *** line shows the boundary between the +x and +y ghost + // zones. + // + // Our 3-phase algorithm described above thus becomes: + // Phase 1: Fill in gridfn values at points marked with "s-x" below or + // "s-y" above via symmetry mirroring across the -x boundary + // (yz plane) or -y boundary (xz plane), as described by the + // +z patch's -x or -y symmetry_ghost_zone object respectively. + // Phase 2: Fill in gridfn values at points marked with "i+x" below or + // "i+y" above via interpatch interpolation from the neighboring + // patch across the +z patch's +x or +y boundary, as described + // by the +z patch's +x or +y interpatch_ghost_zone object + // respectively. + // Phase 3: Fill in gridfn values at points marked with "" below or + // "" above via symmetry mirroring across the -x boundary + // (yz plane) or -y boundary (xz plane), as described by the + // +z patch's -x or -y symmetry_ghost_zone object respectively. + // + + //***************************************************************************** + + // + // ghost_zone - abstract base class to describe ghost zone of patch + // + // This is an abstract base class describing a generic patch ghost zone. + // This might represent either of: + // - a discrete symmetry of spacetime (derived class symmetry_ghost_zone) + // - an overlap with another patch (derived class interpatch_ghost_zone) + // + + // + // N.b. const qualifiers in ghost_zone and its derived classes refer to + // the underlying gridfn data. + // + + // forward declarations + class symmetry_ghost_zone; + class interpatch_ghost_zone; + class patch_system; + + class ghost_zone + { + public: + // + // ***** main high-level client interface ***** + // + // "synchronize" a ghost zone, i.e. update the ghost-zone values + // of the specified gridfns via the appropriate sequence of + // symmetry operations and interpatch interpolations + // (flags specify which part(s) of the ghost zone we want) + // + virtual void synchronize(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners = true, + bool want_noncorner = true) = 0; + + public: + // + // ***** Jacobian of synchronize() ***** + // + // This function computes the Jacobian of the synchronize() + // operation into internal buffers; the following functions + // provide access to that Jacobian. + // + // FIXME: should these be moved out into a separate Jacobian + // object/class? + // + // Note that this function just computes the Jacobian of this + // ghost zone's synchronize() operation -- it does *NOT* take + // into account the 3-phase synchronization algorithm described + // in the header comments for this file. (That's done by + // patch_system::synchronize_Jacobian() and its subfunctions.) + // + // n.b. terminology is + // partial gridfn at x + // ------------------- + // partial gridfn at y + // + virtual void compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners = true, + bool want_noncorner = true) + const = 0; + + // + // The API in the remaining functions implicitly assumes that + // the Jacobian is independent of ghosted_gfn , and also that + // the structure of the Jacobian is such that the set of y points + // on which a single ghost-zone point depends, + // - has a single yiperp value (depending on our iperp, of course) + // - have a contiguous interval of yipar (depending on our iperp + // and ipar, of course), whose size is + // [or can be taken to be without an unreasonable + // amount of zero-padding] + // independent of our iperp and ipar; we parameterize this + // interval as yipar = posn+m where posn is determined by + // our iperp and ipar, and m has a fixed range independent + // of our iperp and ipar + // + + // what is the [min,max] range of m for this ghost zone? + virtual int Jacobian_min_y_ipar_m() const = 0; + virtual int Jacobian_max_y_ipar_m() const = 0; + + // what is the iperp of the Jacobian y points in their (y) patch? + virtual int Jacobian_y_iperp(int x_iperp) const = 0; + + // what is the posn value of the y points in this Jacobian row? + virtual int Jacobian_y_ipar_posn(int x_iperp, int x_ipar) const = 0; + + // what is the Jacobian + // partial synchronize() px.gridfn(ghosted_gfn, x_iperp, x_ipar) + // ------------------------------------------------------------- + // partial py.gridfn(ghosted_gfn, y_iperp, y_posn+y_ipar_m) + // where + // y_iperp = Jacobian_y_iperp(x_iperp) + // y_posn = Jacobian_y_ipar_posn(x_iperp, x_ipar) + virtual fp Jacobian(int x_iperp, int x_ipar, int y_ipar_m) const = 0; + + public: + // + // ***** low-level client interface ***** + // + + // to which patch/edge do we belong? + patch &my_patch() const { return my_patch_; } + const patch_edge &my_edge() const { return my_edge_; } + + // from which patch/edge do we get data? + patch &other_patch() const { return other_patch_; } + const patch_edge &other_edge() const { return other_edge_; } + + // what type of ghost zone are we? + bool is_interpatch() const { return is_interpatch_; } + bool is_symmetry() const { return !is_interpatch_; } + + // convenience forwarding functions down to patch_edge:: + bool is_min() const { return my_edge().is_min(); } + bool is_rho() const { return my_edge().is_rho(); } + + // min/max iperp of the ghost zone + int min_iperp() const + { + return my_patch() + .minmax_ang_ghost_zone__min_iperp(is_min(), is_rho()); + } + int max_iperp() const + { + return my_patch() + .minmax_ang_ghost_zone__max_iperp(is_min(), is_rho()); + } + + // inner/outer iperp of the ghost zone wrt our patch + int inner_iperp() const { return is_min() ? max_iperp() : min_iperp(); } + int outer_iperp() const { return is_min() ? min_iperp() : max_iperp(); } + + // extreme min/max ipar that might possibly be part of this ghost zone + // (derived classes may actually use a subset of this) + int extreme_min_ipar() const + { + return my_edge().min_ipar_with_corners(); + } + int extreme_max_ipar() const + { + return my_edge().max_ipar_with_corners(); + } + + // actual min/max ipar in the ghost zone at a particular iperp + // (may depend on type of the adjacent ghost zones) + virtual int min_ipar(int iperp) const = 0; + virtual int max_ipar(int iperp) const = 0; + + // point membership predicate + bool is_in_ghost_zone(int iperp, int ipar) + const + { + // n.b. don't test ipar until we're sure iperp is in range! + return (iperp >= min_iperp()) && (iperp <= max_iperp()) && (ipar >= min_ipar(iperp)) && (ipar <= max_ipar(iperp)); + } + + // adjacent ghost zones to our min/max corners + const ghost_zone &min_par_adjacent_ghost_zone() const + { + return my_patch() + .ghost_zone_on_edge(my_edge().min_par_adjacent_edge()); + } + const ghost_zone &max_par_adjacent_ghost_zone() const + { + return my_patch() + .ghost_zone_on_edge(my_edge().max_par_adjacent_edge()); + } + + // + // ***** safely cast to derived classes ***** + // + + // assert that gz is of specified type, + // then static_cast to derive type + const symmetry_ghost_zone &cast_to_symmetry_ghost_zone() const; + symmetry_ghost_zone &cast_to_symmetry_ghost_zone(); + const interpatch_ghost_zone &cast_to_interpatch_ghost_zone() const; + interpatch_ghost_zone &cast_to_interpatch_ghost_zone(); + + // + // ***** constructor, finish setup, destructor ***** + // + protected: + // ... values for is_interpatch_in constructor argument + // FIXME: these should really be bool, but then we couldn't + // use the "enum hack" for in-class constants + enum + { + ghost_zone_is_symmetry = false, + ghost_zone_is_interpatch = true // no comma + }; + + // constructor + // ... only used in implementing our derived classes; + // the rest of the world constructs our derived classes instead + ghost_zone(const patch_edge &my_edge_in, + const patch_edge &other_edge_in, + bool is_interpatch_in) + : my_patch_(my_edge_in.my_patch()), + my_edge_(my_edge_in), + other_patch_(other_edge_in.my_patch()), + other_edge_(other_edge_in), + is_interpatch_(is_interpatch_in) + { + } + + public: + // assert() that ghost zone is fully setup: + // defined here ==> no-op + // symmetry ghost zone ==> unchanged ==> no-op + // interpatch ghost zone ==> check consistency of this and the + // other patch's ghost zones and + // patch_interp objects + virtual void assert_fully_setup() const {} + + // destructor must be virtual to allow destruction + // of derived classes via ptr/ref to this class + virtual ~ghost_zone() {} + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them (either here or in derived classes) + ghost_zone(const ghost_zone &rhs); + ghost_zone &operator=(const ghost_zone &rhs); + + private: + patch &my_patch_; + const patch_edge &my_edge_; + patch &other_patch_; + const patch_edge &other_edge_; + const bool is_interpatch_; + }; + + //***************************************************************************** + + // + // symmetry_ghost_zone - derived class for spacetime-symmetry ghost zone + // + // In practice, there are two types of spacetime symmetry ghost zone: + // mirror symmetry and periodic symmetry. However, it turns out that the + // code needed to handle periodic BCs is basically a superset of that + // needed to handle mirror symmetries, so this class represents a generic + // symmetry ghost zone which may be of either type, and once constructed + // doesn't distinguish between the two. + // + // In general, a symmetry ghost zone implies that there's a 1-1 mapping + // between ghost zone points of this patch, and (a subset of the) interior + // points of this or another patch. If tensors are involved (this isn't + // used at present in the horizon finder), there's also a corresponding + // 1-1 mapping between (angular) tensor components. + // + // A mirror-symmetry ghost zone is specified by (the constructor arguments) + // - a patch edge + // - the (fp) perp coordinate of the mirror plane + // The mapping of ghost zone points is thus "just" the mirror imaging of + // iperp across the symmetry plane within this same patch. (The mapping + // leaves ipar invariant.) + // + // A periodic-symmetry ghost zone is specified by (the constructor arguments) + // - a patch edge (specifies the ghost zone) + // - the patch edge to which the ghost zone is to be mapped + // - a pair of ipar coordinates, one on this edge and one on the other edge, + // which map into each other + // - the sign of the ipar mapping (does increasing ipar on this edge map to + // increasing or decreasing ipar on the other edge?) + // The mapping of ghost zone points is the periodic mapping; this may map + // the ghost zone points to interior points of either this same patch or a + // different one. + // + // In general, the symmetry mapping of ghost zone points is of the form + // (iperp, ipar) --> (const +/- iperp, const +/- ipar) + // The iperp mapping is always in the direction + // outside the patch --> inside the patch + // while the ipar mapping might have either sign. + // If there are tensors, the corresponding mapping of tensor components is + // (index_perp, index_par) --> (+/-) (+/-) (index_perp, index_par) + // (that is, the two +/- signs are multiplied). + + // + // Since all the member functions are const , a symmetry_ghost_zone + // object is effectively always const . + // + class symmetry_ghost_zone + : public ghost_zone + { + public: + // + // ***** main high-level client interface ***** + // + // "synchronize" a ghost zone, i.e. update the ghost-zone values + // of the specified gridfns via the appropriate symmetry operations + // (flags specify which part(s) of the ghost zone we want) + // + void synchronize(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners = true, + bool want_noncorner = true); + + // + // ***** Jacobian of synchronize() ***** + // + // n.b. terminology is + // partial gridfn at x + // ------------------- + // partial gridfn at y + // + + // allocate internal buffers, compute Jacobian + // ... this function is a no-op in this class + void compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners = true, + bool want_noncorner = true) + const + { + } + + // what is the [min,max] range of m for this ghost zone? + int Jacobian_min_y_ipar_m() const { return 0; } + int Jacobian_max_y_ipar_m() const { return 0; } + + // what is the oiperp of the Jacobian points (= iperp in their patch)? + virtual int Jacobian_y_iperp(int x_iperp) const + { + return iperp_map_of_iperp(x_iperp); + } + + // what is the posn value of the points in this Jacobian row? + int Jacobian_y_ipar_posn(int x_iperp, int x_ipar) const + { + return ipar_map_of_ipar(x_ipar); + } + + // what is the Jacobian + // partial synchronize() px.gridfn(ghosted_gfn, x_iperp, x_ipar) + // ------------------------------------------------------------- + // partial py.gridfn(ghosted_gfn, y_iperp, y_posn+y_ipar_m) + // where + // y_iperp = Jacobian_y_iperp(x_iperp) + // y_posn = Jacobian_y_ipar_posn(x_iperp, x_ipar) + fp Jacobian(int x_iperp, int x_ipar, int y_ipar_m) const + { + return (y_ipar_m == 0) ? 1.0 : 0.0; + } + + // + // ***** low-level client interface ***** + // + + // symmetry-map coordinates + int iperp_map_of_iperp(int iperp) const + { + return iperp_map_->map(iperp); + } + int ipar_map_of_ipar(int ipar) const + { + return ipar_map_->map(ipar); + } + fp fp_sign_of_iperp_map() const + { + return iperp_map_->fp_sign(); + } + fp fp_sign_of_ipar_map() const + { + return ipar_map_->fp_sign(); + } + + // min/max ipar of the ghost zone + // ... we always include the corners + // (cf. the example at the start of this file) + int min_ipar(int iperp) const { return extreme_min_ipar(); } + int max_ipar(int iperp) const { return extreme_max_ipar(); } + + // + // ***** constructors, destructor ***** + // + public: + // constructor for mirror-symmetry ghost zone + symmetry_ghost_zone(const patch_edge &my_edge_in); + + // constructor for periodic-symmetry ghost zone + // ... ipar mapping specified by giving sample point and mapping sign + symmetry_ghost_zone(const patch_edge &my_edge_in, const patch_edge &other_edge_in, + int my_edge_sample_ipar, int other_edge_sample_ipar, + bool ipar_map_is_plus); + + ~symmetry_ghost_zone(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + symmetry_ghost_zone(const symmetry_ghost_zone &rhs); + symmetry_ghost_zone &operator=(const symmetry_ghost_zone &rhs); + + private: + // symmetry mappings for (iperp,ipar) + // ... we own these objects + const jtutil::cpm_map *iperp_map_; + const jtutil::cpm_map *ipar_map_; + }; + + //***************************************************************************** + + // + // interpatch_ghost_zone - derived class for interpatch ghost zone of a patch + // + // A ghost_zone object maps (my_iperp,my_ipar) coordinates to the other + // patch's (other_iperp,other_par) coordinates, then calls the other patch's + // patch_interp object to interpolate the other patch's data to those + // coordinates. + // + // Note that as described in the "design notes for ghost zones" + // comments above, interpatch_ghost_zone objects are constructed in + // the 2nd and 3rd phase of the overall construction process described + // at the comments at the start of "patch.hh" + // [done by our constructor] + // - set up the object itslf and its links to/from the patches and + // their edges + // [done by finish_setup()] + // - set up the interpatch mapping information, data pointers, and + // interpolation result buffer + // - construct the patch_interp object to interpolate from the other + // patch, and save a pointer to it + // + + class patch_interp; + + class interpatch_ghost_zone + : public ghost_zone + { + public: + // + // ***** main high-level client interface ***** + // + // "synchronize" a ghost zone, i.e. update the ghost-zone + // values of the specified gridfns via the appropriate + // interpatch interpolations + // (flags specify which part(s) of the ghost zone we want) + // + // ... the present implementation only supports the case where + // both flags are set + // + void synchronize(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners = true, + bool want_noncorner = true); + + // + // ***** Jacobian of synchronize() ***** + // + // n.b. terminology is + // partial gridfn at x + // ------------------- + // partial gridfn at y + // + + // allocate internal buffers, compute Jacobian + // + // ... the present implementation only supports the case where + // both flags are set + // + void compute_Jacobian(int ghosted_min_gfn, int ghosted_max_gfn, + bool want_corners = true, + bool want_noncorner = true) + const; + + // what is the [min,max] range of m for this ghost zone? + int Jacobian_min_y_ipar_m() const { return Jacobian_min_y_ipar_m_; } + int Jacobian_max_y_ipar_m() const { return Jacobian_max_y_ipar_m_; } + + // what is the iperp of the Jacobian y points in their (y) patch? + // ... the ipar row of grid points is actually the same, so + // we just have to translate x_iperp to the y patch's coordinates + int Jacobian_y_iperp(int x_iperp) const { return other_iperp(x_iperp); } + + // what is the posn value of the y points in this Jacobian row? + int Jacobian_y_ipar_posn(int x_iperp, int x_ipar) const + { + assert(Jacobian_y_ipar_posn_ != NULL); + const int y_iperp = Jacobian_y_iperp(x_iperp); + return (*Jacobian_y_ipar_posn_)(y_iperp, x_ipar); + } + + // what is the Jacobian + // partial synchronize() px.gridfn(ghosted_gfn, x_iperp, x_ipar) + // ------------------------------------------------------------- + // partial py.gridfn(ghosted_gfn, y_iperp, y_posn+y_ipar_m) + // where + // y_iperp = Jacobian_y_iperp(x_iperp) + // y_posn = Jacobian_y_ipar_posn(x_iperp, x_ipar) + fp Jacobian(int x_iperp, int x_ipar, int y_ipar_m) const + { + assert(Jacobian_buffer_ != NULL); + assert(y_ipar_m >= Jacobian_min_y_ipar_m_); + assert(y_ipar_m <= Jacobian_max_y_ipar_m_); + const int y_iperp = Jacobian_y_iperp(x_iperp); + return (*Jacobian_buffer_)(y_iperp, x_ipar, y_ipar_m); + } + + // + // ***** low-level client interface ***** + // + + public: + // check consistency of this and the other patch's ghost zones + // and patch_interp objects + void assert_fully_setup() const; + + // min/max ipar of the ghost zone for specified iperp + // with possibly "triangular" corners depending on the type + // (symmetry vs interpatch) of the adjacent ghost zones + // (cf. comments & example at the start of this file) + int min_ipar(int iperp) const; + int max_ipar(int iperp) const; + + // convert our iperp --> other patch's iperp + int other_iperp(int iperp) const + { + assert(other_iperp_ != NULL); + return other_iperp_->map(iperp); + } + + // + // ***** constructor, finish setup, destructor ***** + // + public: + interpatch_ghost_zone(const patch_edge &my_edge_in, + const patch_edge &other_edge_in, + int patch_overlap_width); + + // finish setup (requires adjacent-side ghost_zone objects + // to exist, though not to have finish_setup() called): + // - setup par coordinate mapping information + // - setup interpatch interpolator data pointers & result buffer + // - create patch_interp object to interpolate from *other* patch + void finish_setup(int interp_handle, int interp_par_table_handle); + + ~interpatch_ghost_zone(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + interpatch_ghost_zone(const interpatch_ghost_zone &rhs); + interpatch_ghost_zone &operator=(const interpatch_ghost_zone &rhs); + + private: + // + // all the remaining pointers are initialized to NULL pointers + // in our constructor, then finally allocated and set up by + // finish_setup() or compute_Jacobian() as appropriate + // + // FIXME: should these be moved out into a separate object/class + // for the interp stuff and/or another one for the Jacobian? + // + + // see comment in "patch_interp.hh" for why this is "const" + const patch_interp *other_patch_interp_; + + // other patch's iperp coordinates of our ghost zone points + // ... maps my_iperp --> other_iperp + jtutil::cpm_map *other_iperp_; + + // min/max values of other patch's iperp coordinates + // of our ghost zone points + int min_other_iperp_, max_other_iperp_; + + // [min,max]_ipar used at each other_iperp + // ... we will pass these arrays by reference + // to the other patch's patch_interp object + // ... index is (other_iperp) + jtutil::array1d *min_ipar_used_; + jtutil::array1d *max_ipar_used_; + + // other patch's (fp) parallel coordinates of our ghost zone points + // ... we will pass this array by reference + // to the other patch's patch_interp object + // using my_ipar as the patch_interp's parindex + // ... subscripts are (other_iperp, my_ipar) + jtutil::array2d *other_par_; + + // buffer into which the other patch's patch_interp object + // will store the interpolated gridfn values + // ... we will pass this array by reference + // to the other patch's patch_interp object + // using my_ipar as the patch_interp's parindex + // ... subscripts are (gfn, other_iperp,my_ipar) + jtutil::array3d *interp_result_buffer_; + + // + // stuff computed by compute_Jacobian() + // + // n.b. terminology is + // partial gridfn at x + // ------------------- + // partial gridfn at y + // + mutable int Jacobian_min_y_ipar_m_, Jacobian_max_y_ipar_m_; + + // other patch's y ipar posn for a Jacobian row + // ... subscripts are (oiperp, ipar) + mutable jtutil::array2d *Jacobian_y_ipar_posn_; + + // Jacobian values + // ... subscripts are (y_iperp, x_ipar, y_ipar_m) + mutable jtutil::array3d *Jacobian_buffer_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* GHOST_ZONE_H*/ diff --git a/AMSS_NCKU_source/gr.h b/AMSS_NCKU_source/AHF_Direct/gr.h similarity index 95% rename from AMSS_NCKU_source/gr.h rename to AMSS_NCKU_source/AHF_Direct/gr.h index 156887d..3ed00ae 100644 --- a/AMSS_NCKU_source/gr.h +++ b/AMSS_NCKU_source/AHF_Direct/gr.h @@ -1,40 +1,40 @@ -#ifndef GR_H -#define GR_H -namespace AHFinderDirect -{ - - enum expansion_status - { - expansion_success, - - expansion_failure__surface_nonfinite, - - expansion_failure__surface_too_large, - - expansion_failure__surface_outside_grid, - - expansion_failure__surface_in_excised_region, - - expansion_failure__geometry_nonfinite, - - expansion_failure__gij_not_positive_definite // no comma - }; - - // expansion.cc - enum expansion_status - expansion(patch_system *ps_ptr, fp add_to_expansion, - bool initial_flag, - bool Jacobian_flag = false, - jtutil::norm *H_norms_ptr = NULL); - - // expansion_Jacobian.cc - enum expansion_status - expansion_Jacobian(patch_system *ps_ptr, Jacobian *Jac_ptr, - fp add_to_expansion, - bool initial_flag, - bool print_msg_flag = false); - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* GR_H */ +#ifndef GR_H +#define GR_H +namespace AHFinderDirect +{ + + enum expansion_status + { + expansion_success, + + expansion_failure__surface_nonfinite, + + expansion_failure__surface_too_large, + + expansion_failure__surface_outside_grid, + + expansion_failure__surface_in_excised_region, + + expansion_failure__geometry_nonfinite, + + expansion_failure__gij_not_positive_definite // no comma + }; + + // expansion.cc + enum expansion_status + expansion(patch_system *ps_ptr, fp add_to_expansion, + bool initial_flag, + bool Jacobian_flag = false, + jtutil::norm *H_norms_ptr = NULL); + + // expansion_Jacobian.cc + enum expansion_status + expansion_Jacobian(patch_system *ps_ptr, Jacobian *Jac_ptr, + fp add_to_expansion, + bool initial_flag, + bool print_msg_flag = false); + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* GR_H */ diff --git a/AMSS_NCKU_source/horizon_sequence.C b/AMSS_NCKU_source/AHF_Direct/horizon_sequence.C similarity index 95% rename from AMSS_NCKU_source/horizon_sequence.C rename to AMSS_NCKU_source/AHF_Direct/horizon_sequence.C index 76f3715..a1c3e1b 100644 --- a/AMSS_NCKU_source/horizon_sequence.C +++ b/AMSS_NCKU_source/AHF_Direct/horizon_sequence.C @@ -1,76 +1,76 @@ -#include -#include - -#include "stdc.h" -#include "util.h" - -#include "horizon_sequence.h" - -namespace AHFinderDirect -{ - - horizon_sequence::horizon_sequence(int N_horizons_in) - : N_horizons_(N_horizons_in), - my_N_horizons_(0), // sequence starts out empty - posn_(-1), - my_hn_(new int[N_horizons_in]) - { - } - - horizon_sequence::~horizon_sequence() - { - delete[] my_hn_; - } - // - // This function appends hn to the sequence. It returns the new value - // of my_N_horizons(). - // - int horizon_sequence::append_hn(int hn) - { - assert(hn > 0); // can only append genuine horizons - assert(my_N_horizons_ < N_horizons_); // make sure there's space for it - my_hn_[my_N_horizons_++] = hn; - posn_ = 0; - return my_N_horizons_; - } - - //****************************************************************************** - - // - // This function computes the internal position immediately following - // a given internal position in the sequence. - // - // Arguments: - // p = (in) The current internal position, with posn_ semantics - // - // Results: - // This function returns the next internal position after p. - // - int horizon_sequence::next_posn(int pos) - const - { - return (pos < 0) ? pos - 1 - : (pos + 1 < my_N_horizons_) ? pos + 1 - : -1; - } - - //****************************************************************************** - - // - // This function determines whether or not a given hn is genuine. - // - bool horizon_sequence::is_hn_genuine(int hn) - const - { - for (int pos = 0; pos < my_N_horizons_; ++pos) - { - if (my_hn_[pos] == hn) - then return true; - } - - return false; - } - - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include + +#include "stdc.h" +#include "util.h" + +#include "horizon_sequence.h" + +namespace AHFinderDirect +{ + + horizon_sequence::horizon_sequence(int N_horizons_in) + : N_horizons_(N_horizons_in), + my_N_horizons_(0), // sequence starts out empty + posn_(-1), + my_hn_(new int[N_horizons_in]) + { + } + + horizon_sequence::~horizon_sequence() + { + delete[] my_hn_; + } + // + // This function appends hn to the sequence. It returns the new value + // of my_N_horizons(). + // + int horizon_sequence::append_hn(int hn) + { + assert(hn > 0); // can only append genuine horizons + assert(my_N_horizons_ < N_horizons_); // make sure there's space for it + my_hn_[my_N_horizons_++] = hn; + posn_ = 0; + return my_N_horizons_; + } + + //****************************************************************************** + + // + // This function computes the internal position immediately following + // a given internal position in the sequence. + // + // Arguments: + // p = (in) The current internal position, with posn_ semantics + // + // Results: + // This function returns the next internal position after p. + // + int horizon_sequence::next_posn(int pos) + const + { + return (pos < 0) ? pos - 1 + : (pos + 1 < my_N_horizons_) ? pos + 1 + : -1; + } + + //****************************************************************************** + + // + // This function determines whether or not a given hn is genuine. + // + bool horizon_sequence::is_hn_genuine(int hn) + const + { + for (int pos = 0; pos < my_N_horizons_; ++pos) + { + if (my_hn_[pos] == hn) + then return true; + } + + return false; + } + + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/horizon_sequence.h b/AMSS_NCKU_source/AHF_Direct/horizon_sequence.h similarity index 95% rename from AMSS_NCKU_source/horizon_sequence.h rename to AMSS_NCKU_source/AHF_Direct/horizon_sequence.h index 5b0a825..7603fd8 100644 --- a/AMSS_NCKU_source/horizon_sequence.h +++ b/AMSS_NCKU_source/AHF_Direct/horizon_sequence.h @@ -1,72 +1,72 @@ -#ifndef HORIZON_SEQUENCE_H -#define HORIZON_SEQUENCE_H -namespace AHFinderDirect -{ - class horizon_sequence - { - public: - int N_horizons() const { return N_horizons_; } - - int my_N_horizons() const { return my_N_horizons_; } - - bool has_genuine_horizons() const { return my_N_horizons_ > 0; } - - bool is_dummy() const { return posn_is_dummy(posn_); } - bool is_genuine() const { return posn_is_genuine(posn_); } - - bool is_next_genuine() const - { - return posn_is_genuine(next_posn(posn_)); - } - - int dummy_number() const { return is_genuine() ? 0 : -posn_; } - - int get_hn() const - { - return posn_is_genuine(posn_) ? my_hn_[posn_] : 0; - } - - bool is_hn_genuine(int hn) const; - - int init_hn() - { - posn_ = (my_N_horizons_ == 0) ? -1 : 0; - return get_hn(); - } - - int next_hn() - { - posn_ = next_posn(posn_); - return get_hn(); - } - - horizon_sequence(int N_horizons); - ~horizon_sequence(); - - int append_hn(int hn); - - private: - bool posn_is_genuine(int pos) const - { - return (pos >= 0) && (pos < my_N_horizons_); - } - bool posn_is_dummy(int pos) const - { - return !posn_is_genuine(pos); - } - - int next_posn(int pos) const; - - private: - const int N_horizons_; - int my_N_horizons_; - - int posn_; - - int *my_hn_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* HORIZON_SEQUENCE_H */ +#ifndef HORIZON_SEQUENCE_H +#define HORIZON_SEQUENCE_H +namespace AHFinderDirect +{ + class horizon_sequence + { + public: + int N_horizons() const { return N_horizons_; } + + int my_N_horizons() const { return my_N_horizons_; } + + bool has_genuine_horizons() const { return my_N_horizons_ > 0; } + + bool is_dummy() const { return posn_is_dummy(posn_); } + bool is_genuine() const { return posn_is_genuine(posn_); } + + bool is_next_genuine() const + { + return posn_is_genuine(next_posn(posn_)); + } + + int dummy_number() const { return is_genuine() ? 0 : -posn_; } + + int get_hn() const + { + return posn_is_genuine(posn_) ? my_hn_[posn_] : 0; + } + + bool is_hn_genuine(int hn) const; + + int init_hn() + { + posn_ = (my_N_horizons_ == 0) ? -1 : 0; + return get_hn(); + } + + int next_hn() + { + posn_ = next_posn(posn_); + return get_hn(); + } + + horizon_sequence(int N_horizons); + ~horizon_sequence(); + + int append_hn(int hn); + + private: + bool posn_is_genuine(int pos) const + { + return (pos >= 0) && (pos < my_N_horizons_); + } + bool posn_is_dummy(int pos) const + { + return !posn_is_genuine(pos); + } + + int next_posn(int pos) const; + + private: + const int N_horizons_; + int my_N_horizons_; + + int posn_; + + int *my_hn_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* HORIZON_SEQUENCE_H */ diff --git a/AMSS_NCKU_source/ilucg.f90 b/AMSS_NCKU_source/AHF_Direct/ilucg.f90 similarity index 96% rename from AMSS_NCKU_source/ilucg.f90 rename to AMSS_NCKU_source/AHF_Direct/ilucg.f90 index 3443353..f15222e 100644 --- a/AMSS_NCKU_source/ilucg.f90 +++ b/AMSS_NCKU_source/AHF_Direct/ilucg.f90 @@ -1,521 +1,521 @@ - -! adopted from J. THORNBURG's code dilucg.f - - subroutine ILUCG(N,IA,JA,A,B,X,ITEMP,RTEMP,EPS,MAXITER,ISTATUS) - - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION IA(*),JA(*),A(*),B(*),X(*),ITEMP(*),RTEMP(*) -! -! INCOMPLETE LU DECOMPOSITION-CONJUGATE GRADIENT -! - -- - - -! WHERE: -! |N| IS THE NUMBER OF EQUATIONS. IF N < 0, ITEMP AND -! RTEMP CONTAIN THE ILU FROM A PREVIOUS CALL AND -! B AND X ARE THE NEW RHS AND INITIAL GUESS. -! IA IS AN INTEGER ARRAY DIMENSIONED |N|+1. IA(I) IS THE -! INDEX INTO ARRAYS JA AND A OF THE FIRST NON-ZERO -! ELEMENT IN ROW I. LET MAX=IA(|N|+1)-IA(1). -! JA IS AN INTEGER ARRAY DIMENSIONED MAX. JA(K) GIVES -! THE COLUMN NUMBER OF A(K). -! A IS A DOUBLE PRECISION ARRAY DIMENSIONED MAX. IT CONTAINS THE -! NONZERO ELEMENTS OF THE MATRIX STORED BY ROW. -! B CONTAINS THE RHS VECTOR. -! X IS A DOUBLE PRECISION ARRAY DIMENSIONED |N|. ON ENTRY, IT CONTAINS -! AN INITIAL ESTIMATE; ON EXIT, THE SOLUTION. -! ITEMP IS AN INTEGER SCRATCH ARRAY DIMENSIONED 3*(|N|+MAX)+2. -! RTEMP IS A DOUBLE PRECISION SCRATCH ARRAY DIMENSIONED 4*|N|+MAX. -! EPS IS THE CONVERGENCE CRITERIA. IT SPECIFIES THE RELATIVE -! ERROR ALLOWED IN THE SOLUTION. TO BE PRECISE, CONVERGENCE -! IS DEEMED TO HAVE OCCURED WHEN THE INFINITY-NORM OF THE -! CHANGE IN THE SOLUTION IN ONE ITERATION IS .LE. EPS * THE -! INFINITY-NORM OF THE CURRENT SOLUTION. HOWEVER, IF EPS -! .LT. 0.0D0, IT IS INTERNALLY SCALED BY THE MACHINE PRECISION, -! SO THAT, FOR EXAMPLE, EPS = -256.0D0 WILL ALLOW THE LAST 8 BITS -! OF THE SOLUTION TO BE IN ERROR. -! MAXITER GIVES THE REQUESTED NUMBER OF ITERATIONS, -! OR IS 0 FOR "NO LIMIT". -! ISTATUS IS AN INTEGER VARIABLE, WHICH IS SET TO: -! -I IF THERE IS AN ERROR IN THE MATRIX STRUCTURE IN ROW I -! (SUCH AS A ZERO ELEMENT ON THE DIAGONAL). -! 0 IF THE ITERATION FAILED TO REACH THE CONVERGENCE CRITERION -! IN ITER ITERATIONS. -! +I IF THE ITERATION CONVERGED IN I ITERATIONS. -! REFERENCE: -! D.S.KERSHAW,"THE INCOMPLETE CHOLESKY-CONJUGATE GRADIENT -! METHOD FOR INTERATIVE SOLUTION OF LINEAR EQUATIONS", -! J.COMPUT.PHYS. JAN 1978 PP 43-65 -! - LOGICAL DLU0 - NP=IABS(N) - ISTATUS=0 - IF (NP.EQ.0) GO TO 20 -! CALCULATE INDICES FOR BREAKING UP TEMPORARY ARRAYS. - N1=NP+1 - MAX=IA(N1)-IA(1) - ILU=1 - JLU=ILU+N1 - ID=JLU+MAX - IC=ID+NP - JC=IC+N1 - JCI=JC+MAX - IR=1 - IP=IR+NP - IS1=IP+NP - IS2=IS1+NP - IALU=IS2+NP - IF (N.LT.0) GO TO 10 -! DO INCOMPLETE LU DECOMPOSITION - IF (DLU0(NP,IA,JA,A,ITEMP(IC),ITEMP(JC),ITEMP(JCI),RTEMP(IALU), & - ITEMP(ILU),ITEMP(JLU),ITEMP(ID),RTEMP(IR),IERROR)) GOTO 20 -! AND DO CONJUGATE GRADIENT ITERATIONS -10 CALL DNCG0(NP,IA,JA,A,B,X,ITEMP(ILU),ITEMP(JLU),ITEMP(ID), & - RTEMP(IALU),RTEMP(IR),RTEMP(IP),RTEMP(IS1),RTEMP(IS2), & - EPS,MAXITER,ITER) -! ITER IS ACTUAL NUMBER OF ITERATIONS (NEGATIVE IF NO CONVERGENCE) - ISTATUS = ITER - IF (ITER .LT. 0) ISTATUS = 0 - RETURN -! ERROR RETURN FROM INCOMPLETE LU DECOMPOSITION -20 ISTATUS = -IERROR - RETURN - END -!------------------------------------------------------------------------------ - LOGICAL FUNCTION DLU0(N,IA,JA,A,IC,JC,JCI,ALU,ILU,JLU,ID,V,IE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION IA(*),JA(*),A(*),IC(*),JC(*),JCI(*),ALU(*),ILU(*),JLU(*),ID(N),V(N) - LOGICAL NODIAG - COMMON /ICBD00/ ICBAD -! INCOMPLETE LU DECOMPOSITION -! WHERE: -! N,IA,JA, AND A ARE DESCRIBED IN SUBROUTINE ILUCG -! IC IS AN INTEGER ARRAY DIMENSIONED N+1, IC(J) GIVES THE -! INDEX OF THE FIRST NONZERO ELEMENT IN COLMN J IN -! ARRAY JC. -! JC IS AN INTEGER ARRAY WITH THE SAME DIMENSION AS A. -! JC(K) GIVES THE ROW NUMBER OF THE K'TH ELEMENT IN -! THE COLUMN STRUCTURE. -! JCI IS AN INTEGER ARRAY WITH THE SAME DIMENSION AS A. -! JCI(K) GIVES THE INDEX INTO ARRAY A OF THE K'TH ELEMENT -! OF THE COLUMN STRUCTURE. -! ALU HAS THE SAME DIMENSION AS A. ON EXIT, IT WILL -! CONTAIN THE INCOMPLETE LU DECOMPOSITION OF A WITH THE -! RECIPROCALS OF THE DIAGONAL ELEMENTS OF U. -! ILU AND JLU CORRESPONDS TO IA AND JA BUT FOR ALU. -! ID IS AN INTEGER ARRAY DIMENSIONED N. IT CONTAINS -! INDICES TO THE DIAGONAL ELEMENTS OF U. -! V IS A REAL SCRATCH VECTOR OF LENGTH N. -! IE GIVES THE ROW NUMBER IN ERROR IF AN ERROR OCCURED -! (RETURN VALUE .TRUE.), OR IS UNUSED IF ALL IS WELL -! (RETURN VALUE .FALSE.). -! -! RETURN VALUE = .FALSE. IF ALL IS WELL, .TRUE. IF ERROR. -! -! NOTE: DLU0 SETS ARGUMENTS IC THROUGH V. -! - ICBAD=0 -! ZERO COUNT OF ZERO DIAGONAL ELEMENTS IN U. -! -! FIRST CHECK STRUCTURE OF A AND BUILD COLUMN STRUCTURE - DO 10 I=1,N - IC(I)=0 -10 CONTINUE - DO 30 I=1,N - KS=IA(I) - KE=IA(I+1)-1 - NODIAG=.TRUE. - DO 20 K=KS,KE - J=JA(K) - IF (J.LT.1.OR.J.GT.N) GO TO 210 - IC(J)=IC(J)+1 - IF (J.EQ.I) NODIAG=.FALSE. -20 CONTINUE - IF (NODIAG) GO TO 210 -30 CONTINUE -! MAKE IC INTO INDICES - KOLD=IC(1) - IC(1)=1 - DO 40 I=1,N - KNEW=IC(I+1) - IF (KOLD.EQ.0) GO TO 210 - IC(I+1)=IC(I)+KOLD - KOLD=KNEW -40 CONTINUE -! SET JC AND JCI FOR COLUMN STRUCTURE - DO 60 I=1,N - KS=IA(I) - KE=IA(I+1)-1 - DO 50 K=KS,KE - J=JA(K) - L=IC(J) - IC(J)=L+1 - JC(L)=I - JCI(L)=K -50 CONTINUE -60 CONTINUE -! FIX UP IC - KOLD=IC(1) - IC(1)=1 - DO 70 I=1,N - KNEW=IC(I+1) - IC(I+1)=KOLD - KOLD=KNEW -70 CONTINUE -! FIND SORTED ROW STRUCTURE FROM SORTED COLUMN STRUCTURE - NP=N+1 - DO 80 I=1,NP - ILU(I)=IA(I) -80 CONTINUE -! MOVE ELEMENTS, SET JLU AND ID - DO 100 J=1,N - KS=IC(J) - KE=IC(J+1)-1 - DO 90 K=KS,KE - I=JC(K) - L=ILU(I) - ILU(I)=L+1 - JLU(L)=J - KK=JCI(K) - ALU(L)=A(KK) - IF (I.EQ.J) ID(J)=L -90 CONTINUE -100 CONTINUE -! RESET ILU (COULD JUST USE IA) - DO 110 I=1,NP - ILU(I)=IA(I) -110 CONTINUE -! FINISHED WITH SORTED COLUMN AND ROW STRUCTURE -! -! DO LU DECOMPOSITION USING GAUSSIAN ELIMINATION - DO 120 I=1,N - V(I)=0.0D0 -120 CONTINUE - DO 200 IROW=1,N - I=ID(IROW) - PIVOT=ALU(I) - IF (PIVOT.NE.0.0D0) GO TO 140 -! THIS CASE MAKES THE ILU LESS ACCURATE - ICBAD=ICBAD+1 - KS=ILU(IROW) - KE=ILU(IROW+1)-1 - DO 130 K=KS,KE - PIVOT=PIVOT+DABS(ALU(K)) -130 CONTINUE - IF (PIVOT.EQ.0.0D0) GO TO 220 -140 PIVOT=1.0D0/PIVOT - ALU(I)=PIVOT - KKS=I+1 - KKE=ILU(IROW+1)-1 - IF (KKS.GT.KKE) GO TO 160 - DO 150 K=KKS,KKE - J=JLU(K) - V(J)=ALU(K) -150 CONTINUE -! FIX L IN COLUMN IROW AND DO PARTIAL LU IN SUBMATRIX -160 KS=IC(IROW) - KE=IC(IROW+1)-1 - DO 190 K=KS,KE - I=JC(K) - IF (I.LE.IROW) GO TO 190 - LS=ILU(I) - LE=ILU(I+1)-1 - DO 180 L=LS,LE - J=JLU(L) - IF (J.LT.IROW) GO TO 180 - IF (J.GT.IROW) GO TO 170 - AMULT=ALU(L)*PIVOT - ALU(L)=AMULT - IF (AMULT.EQ.0.0) GO TO 190 - GO TO 180 -170 IF (V(J).EQ.0.0D0) GO TO 180 - ALU(L)=ALU(L)-AMULT*V(J) -180 CONTINUE -190 CONTINUE -! RESET V - IF (KKS.GT.KKE) GO TO 200 - DO 195 K=KKS,KKE - J=JLU(K) - V(J)=0.0D0 -195 CONTINUE -200 CONTINUE -! NORMAL RETURN - DLU0 = .FALSE. - RETURN -! ERROR RETURNS -210 IE=I - DLU0 = .TRUE. - RETURN -220 IE=IROW - DLU0 = .TRUE. - RETURN - END -!------------------------------------------------------------------------------------- - SUBROUTINE DNCG0(N,IA,JA,A,B,X,ILU,JLU,ID,ALU,R,P,S1,S2,EPS,ITER,IE) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION IA(*),JA(*),A(*),B(N),X(N),ILU(*),JLU(*),ALU(*),ID(N),R(N),P(N),S1(N),S2(N) -! NONSYMMETRIC CONJUGATE GRADIENT -! WHERE: -! N,IA,JA,A,B, AND X ARE DESCRIBED IN SUBROUTINE DILUCG. -! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW OF LU. -! JLU GIVES COLUMN NUMBER. -! ID GIVES INDEX OF DIAGONAL ELEMENT OF U. -! ALU HAS NONZERO ELEMENTS OF LU MATRIX STORED BY ROW -! WITH RECIPROCALS OF DIAGONAL ELEMENTS OF U. -! R,P,S1, AND S2 ARE VECTORS OF LENGTH N USED IN THE -! ITERATIONS. -! EPS IS CONVERGENCE CRITERIA. (DESCRIBED IN SUBROUTINE -! DILUCG). -! ITER IS MAX NUMBER OF ITERATIONS, OR 0 FOR "NO LIMIT". -! IE GIVES ACTUAL NUMBER OF ITERATIONS, NEGATIVE IF -! NO CONVERGENCE. -! -! R0=B-A*X0 - CALL DMUL10(N,IA,JA,A,X,R) - DO 10 I=1,N - R(I)=B(I)-R(I) -10 CONTINUE -! P0=(UT*U)(-1)*AT*(L*LT)(-1)*R0 -! FIRST SOLVE L*LT*S1=R0 - CALL DSUBL0(N,ILU,JLU,ID,ALU,R,S1) -! TIMES TRANSPOSE OF A - CALL DMUL20(N,IA,JA,A,S1,S2) -! THEN SOLVE UT*U*P=S2 - CALL DSUBU0(N,ILU,JLU,ID,ALU,S2,P) - IE=0 - RDOT = DGVV(R,S1,N) -! LOOP BEGINS HERE -20 CALL DMUL30(N,ILU,JLU,ID,ALU,P,S2) - - PDOT = DGVV(P,S2,N) - - IF (PDOT.EQ.0.0D0) RETURN - - ALPHA=RDOT/PDOT - XMAX=0.0D0 - XDIF=0.0D0 - DO 30 I=1,N - AP=ALPHA*P(I) - X(I)=X(I)+AP - AP=DABS(AP) - XX=DABS(X(I)) - IF (AP.GT.XDIF) XDIF=AP - IF (XX.GT.XMAX) XMAX=XX -30 CONTINUE - IE=IE+1 - IF ((EPS .GT. 0.0D0) .AND. (XDIF .LE. EPS * XMAX)) RETURN - IF ((EPS .LT. 0.0D0) .AND. (XMAX + XDIF/DABS(EPS) .EQ. XMAX)) RETURN -! -! EXCEEDED ITERATION LIMIT? -! - IF ((ITER .NE. 0) .AND. (IE .GE. ITER)) GO TO 60 - CALL DMUL10(N,IA,JA,A,P,S2) - DO 40 I=1,N - R(I)=R(I)-ALPHA*S2(I) -40 CONTINUE - CALL DSUBL0(N,ILU,JLU,ID,ALU,R,S1) - RRDOT = DGVV(R,S1,N) - BETA=RRDOT/RDOT - RDOT=RRDOT - CALL DMUL20(N,IA,JA,A,S1,S2) - CALL DSUBU0(N,ILU,JLU,ID,ALU,S2,S1) - DO 50 I=1,N - P(I)=S1(I)+BETA*P(I) -50 CONTINUE - GO TO 20 -60 IE=-IE - RETURN - END -!------------------------------------------------------------------------------------------------------ - SUBROUTINE DMUL10(N,IA,JA,A,B,X) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION IA(*),JA(*),A(*),B(N),X(N) -! MULTIPLY A TIMES B TO GET X -! WHERE: -! N IS THE ORDER OF THE MATRIX -! IA GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW -! JA GIVES COLUMN NUMBER -! A CONTAINS THE NONZERO ELEMENTS OF THE NONSYMMETRIC -! MATRIX STORED BY ROW -! B IS THE VECTOR -! X IS THE PRODUCT (MUST BE DIFFERENT FROM B) - - DO 20 I=1,N - KS=IA(I) - KE=IA(I+1)-1 - SUM=0.0D0 - DO 10 K=KS,KE - J=JA(K) - SUM=SUM+A(K)*B(J) -10 CONTINUE - X(I)=SUM -20 CONTINUE - RETURN - END -!-------------------------------------------------------------------------------------------------------- - SUBROUTINE DMUL20(N,IA,JA,A,B,X) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION IA(*),JA(*),A(*),B(N),X(N) -! MULTIPLY TRANSPOSE OF A TIMES B TO GET X -! WHERE: -! N IS THE ORDER OF THE MATRIX -! IA GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW -! JA GIVES COLUMN NUMBER -! A CONTAINS THE NONZERO ELEMENTS OF THE NONSYMMETRIC -! MATRIX STORED BY ROW -! B IS THE VECTOR -! X IS THE PRODUCT (MUST BE DIFFERENT FROM B) - - DO 10 I=1,N - X(I)=0.0D0 -10 CONTINUE - DO 30 I=1,N - KS=IA(I) - KE=IA(I+1)-1 - BB=B(I) - DO 20 K=KS,KE - J=JA(K) - X(J)=X(J)+A(K)*BB -20 CONTINUE -30 CONTINUE - RETURN - END -!--------------------------------------------------------------------------------------------------------- - SUBROUTINE DMUL30(N,ILU,JLU,ID,ALU,B,X) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION ILU(*),JLU(*),ID(*),ALU(*),B(N),X(N) -! MULTIPLY TRANSPOSE OF U TIMES U TIMES B TO GET X -! WHERE: -! N IS THE ORDER OF THE MATRIX -! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW OF LU -! JLU GIVES COLUMN NUMBER -! ID GIVES INDEX OF DIAGONAL ELEMENT OF U -! ALU HAS NONZERO ELEMENTS OF LU MATRIX STORED BY ROW -! WITH RECIPROCALS OF DIAGONAL ELEMENTS -! B IS THE VECTOR -! X IS THE PRODUCT UT*U*B (X MUST BE DIFFERENT FROM B) - - DO 10 I=1,N - X(I)=0.0D0 -10 CONTINUE - DO 50 I=1,N - KS=ID(I)+1 - KE=ILU(I+1)-1 - DIAG=1.0D0/ALU(KS-1) - XX=DIAG*B(I) - IF (KS.GT.KE) GO TO 30 - DO 20 K=KS,KE - J=JLU(K) - XX=XX+ALU(K)*B(J) -20 CONTINUE -30 X(I)=X(I)+DIAG*XX - IF (KS.GT.KE) GO TO 50 - DO 40 K=KS,KE - J=JLU(K) - X(J)=X(J)+ALU(K)*XX -40 CONTINUE -50 CONTINUE - RETURN - END -!---------------------------------------------------------------------------------------------------------- - SUBROUTINE DSUBU0(N,ILU,JLU,ID,ALU,B,X) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION ILU(*),JLU(*),ID(*),ALU(*),B(N),X(N) -! DO FORWARD AND BACK SUBSTITUTION TO SOLVE UT*U*X=B -! WHERE: -! N IS THE ORDER OF THE MATRIX -! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW OF LU -! JLU GIVES COLUMN NUMBER -! ID GIVES INDEX OF DIAGONAL ELEMENT OF U -! ALU HAS NONZERO ELMENTS OF LU MATRIX STORED BY ROW -! WITH RECIPROCALS OF DIAGONAL ELEMENTS OF U -! B IS THE RHS VECTOR -! X IS THE SOLUTION VECTOR - - NP=N+1 - DO 10 I=1,N - X(I)=B(I) -10 CONTINUE -! FORWARD SUBSTITUTION - DO 30 I=1,N - KS=ID(I)+1 - KE=ILU(I+1)-1 - XX=X(I)*ALU(KS-1) - X(I)=XX - IF (KS.GT.KE) GO TO 30 - DO 20 K=KS,KE - J=JLU(K) - X(J)=X(J)-ALU(K)*XX -20 CONTINUE -30 CONTINUE -! BACK SUBSTITUTION - DO 60 II=1,N - I=NP-II - KS=ID(I)+1 - KE=ILU(I+1)-1 - SUM=0.0D0 - IF (KS.GT.KE) GO TO 50 - DO 40 K=KS,KE - J=JLU(K) - SUM=SUM+ALU(K)*X(J) -40 CONTINUE -50 X(I)=(X(I)-SUM)*ALU(KS-1) -60 CONTINUE - RETURN - END -!-------------------------------------------------------------------------------------------------------------- - SUBROUTINE DSUBL0(N,ILU,JLU,ID,ALU,B,X) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION ILU(*),JLU(*),ID(*),ALU(*),B(N),X(N) -! DO FORWARD AND BACK SUBSTITUTION TO SOLVE L*LT*X=B -! WHERE: -! N IS THE ORDER OF THE MATRIX -! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW LU -! JLU GIVES THE COLUMN NUMBER -! ID GIVES INDEX OF DIAGONAL ELEMENT OF U -! ALU HAS NONZERO ELEMENTS OF LU MATRIX STORED BY ROW -! DIAGONAL ELEMENTS OF L ARE 1.0 AND NOT STORED -! B IS THE RHS VECTOR -! X IS THE SOLUTION VECTOR - - NP=N+1 - DO 10 I=1,N - X(I)=B(I) -10 CONTINUE -! FORWARD SUBSTITUTION - DO 30 I=1,N - KS=ILU(I) - KE=ID(I)-1 - IF (KS.GT.KE) GO TO 30 - SUM=0.0D0 - DO 20 K=KS,KE - J=JLU(K) - SUM=SUM+ALU(K)*X(J) -20 CONTINUE - X(I)=X(I)-SUM -30 CONTINUE -! BACK SUBSTITUTION - DO 50 II=1,N - I=NP-II - KS=ILU(I) - KE=ID(I)-1 - IF (KS.GT.KE) GO TO 50 - XX=X(I) - IF (XX.EQ.0.0) GO TO 50 - DO 40 K=KS,KE - J=JLU(K) - X(J)=X(J)-ALU(K)*XX -40 CONTINUE -50 CONTINUE - RETURN - END -!------------------------------------------------------------------------------------------------------------------ - DOUBLE PRECISION FUNCTION DGVV(V,W,N) - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION V(N),W(N) -! SUBROUTINE TO COMPUTE DOUBLE PRECISION VECTOR DOT PRODUCT. -! Optimized using Intel oneMKL BLAS ddot -! Mathematical equivalence: DGVV = sum_{i=1}^{N} V(i)*W(i) - - DOUBLE PRECISION, EXTERNAL :: DDOT - DGVV = DDOT(N, V, 1, W, 1) - RETURN - END + +! adopted from J. THORNBURG's code dilucg.f + + subroutine ILUCG(N,IA,JA,A,B,X,ITEMP,RTEMP,EPS,MAXITER,ISTATUS) + + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION IA(*),JA(*),A(*),B(*),X(*),ITEMP(*),RTEMP(*) +! +! INCOMPLETE LU DECOMPOSITION-CONJUGATE GRADIENT +! - -- - - +! WHERE: +! |N| IS THE NUMBER OF EQUATIONS. IF N < 0, ITEMP AND +! RTEMP CONTAIN THE ILU FROM A PREVIOUS CALL AND +! B AND X ARE THE NEW RHS AND INITIAL GUESS. +! IA IS AN INTEGER ARRAY DIMENSIONED |N|+1. IA(I) IS THE +! INDEX INTO ARRAYS JA AND A OF THE FIRST NON-ZERO +! ELEMENT IN ROW I. LET MAX=IA(|N|+1)-IA(1). +! JA IS AN INTEGER ARRAY DIMENSIONED MAX. JA(K) GIVES +! THE COLUMN NUMBER OF A(K). +! A IS A DOUBLE PRECISION ARRAY DIMENSIONED MAX. IT CONTAINS THE +! NONZERO ELEMENTS OF THE MATRIX STORED BY ROW. +! B CONTAINS THE RHS VECTOR. +! X IS A DOUBLE PRECISION ARRAY DIMENSIONED |N|. ON ENTRY, IT CONTAINS +! AN INITIAL ESTIMATE; ON EXIT, THE SOLUTION. +! ITEMP IS AN INTEGER SCRATCH ARRAY DIMENSIONED 3*(|N|+MAX)+2. +! RTEMP IS A DOUBLE PRECISION SCRATCH ARRAY DIMENSIONED 4*|N|+MAX. +! EPS IS THE CONVERGENCE CRITERIA. IT SPECIFIES THE RELATIVE +! ERROR ALLOWED IN THE SOLUTION. TO BE PRECISE, CONVERGENCE +! IS DEEMED TO HAVE OCCURED WHEN THE INFINITY-NORM OF THE +! CHANGE IN THE SOLUTION IN ONE ITERATION IS .LE. EPS * THE +! INFINITY-NORM OF THE CURRENT SOLUTION. HOWEVER, IF EPS +! .LT. 0.0D0, IT IS INTERNALLY SCALED BY THE MACHINE PRECISION, +! SO THAT, FOR EXAMPLE, EPS = -256.0D0 WILL ALLOW THE LAST 8 BITS +! OF THE SOLUTION TO BE IN ERROR. +! MAXITER GIVES THE REQUESTED NUMBER OF ITERATIONS, +! OR IS 0 FOR "NO LIMIT". +! ISTATUS IS AN INTEGER VARIABLE, WHICH IS SET TO: +! -I IF THERE IS AN ERROR IN THE MATRIX STRUCTURE IN ROW I +! (SUCH AS A ZERO ELEMENT ON THE DIAGONAL). +! 0 IF THE ITERATION FAILED TO REACH THE CONVERGENCE CRITERION +! IN ITER ITERATIONS. +! +I IF THE ITERATION CONVERGED IN I ITERATIONS. +! REFERENCE: +! D.S.KERSHAW,"THE INCOMPLETE CHOLESKY-CONJUGATE GRADIENT +! METHOD FOR INTERATIVE SOLUTION OF LINEAR EQUATIONS", +! J.COMPUT.PHYS. JAN 1978 PP 43-65 +! + LOGICAL DLU0 + NP=IABS(N) + ISTATUS=0 + IF (NP.EQ.0) GO TO 20 +! CALCULATE INDICES FOR BREAKING UP TEMPORARY ARRAYS. + N1=NP+1 + MAX=IA(N1)-IA(1) + ILU=1 + JLU=ILU+N1 + ID=JLU+MAX + IC=ID+NP + JC=IC+N1 + JCI=JC+MAX + IR=1 + IP=IR+NP + IS1=IP+NP + IS2=IS1+NP + IALU=IS2+NP + IF (N.LT.0) GO TO 10 +! DO INCOMPLETE LU DECOMPOSITION + IF (DLU0(NP,IA,JA,A,ITEMP(IC),ITEMP(JC),ITEMP(JCI),RTEMP(IALU), & + ITEMP(ILU),ITEMP(JLU),ITEMP(ID),RTEMP(IR),IERROR)) GOTO 20 +! AND DO CONJUGATE GRADIENT ITERATIONS +10 CALL DNCG0(NP,IA,JA,A,B,X,ITEMP(ILU),ITEMP(JLU),ITEMP(ID), & + RTEMP(IALU),RTEMP(IR),RTEMP(IP),RTEMP(IS1),RTEMP(IS2), & + EPS,MAXITER,ITER) +! ITER IS ACTUAL NUMBER OF ITERATIONS (NEGATIVE IF NO CONVERGENCE) + ISTATUS = ITER + IF (ITER .LT. 0) ISTATUS = 0 + RETURN +! ERROR RETURN FROM INCOMPLETE LU DECOMPOSITION +20 ISTATUS = -IERROR + RETURN + END +!------------------------------------------------------------------------------ + LOGICAL FUNCTION DLU0(N,IA,JA,A,IC,JC,JCI,ALU,ILU,JLU,ID,V,IE) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION IA(*),JA(*),A(*),IC(*),JC(*),JCI(*),ALU(*),ILU(*),JLU(*),ID(N),V(N) + LOGICAL NODIAG + COMMON /ICBD00/ ICBAD +! INCOMPLETE LU DECOMPOSITION +! WHERE: +! N,IA,JA, AND A ARE DESCRIBED IN SUBROUTINE ILUCG +! IC IS AN INTEGER ARRAY DIMENSIONED N+1, IC(J) GIVES THE +! INDEX OF THE FIRST NONZERO ELEMENT IN COLMN J IN +! ARRAY JC. +! JC IS AN INTEGER ARRAY WITH THE SAME DIMENSION AS A. +! JC(K) GIVES THE ROW NUMBER OF THE K'TH ELEMENT IN +! THE COLUMN STRUCTURE. +! JCI IS AN INTEGER ARRAY WITH THE SAME DIMENSION AS A. +! JCI(K) GIVES THE INDEX INTO ARRAY A OF THE K'TH ELEMENT +! OF THE COLUMN STRUCTURE. +! ALU HAS THE SAME DIMENSION AS A. ON EXIT, IT WILL +! CONTAIN THE INCOMPLETE LU DECOMPOSITION OF A WITH THE +! RECIPROCALS OF THE DIAGONAL ELEMENTS OF U. +! ILU AND JLU CORRESPONDS TO IA AND JA BUT FOR ALU. +! ID IS AN INTEGER ARRAY DIMENSIONED N. IT CONTAINS +! INDICES TO THE DIAGONAL ELEMENTS OF U. +! V IS A REAL SCRATCH VECTOR OF LENGTH N. +! IE GIVES THE ROW NUMBER IN ERROR IF AN ERROR OCCURED +! (RETURN VALUE .TRUE.), OR IS UNUSED IF ALL IS WELL +! (RETURN VALUE .FALSE.). +! +! RETURN VALUE = .FALSE. IF ALL IS WELL, .TRUE. IF ERROR. +! +! NOTE: DLU0 SETS ARGUMENTS IC THROUGH V. +! + ICBAD=0 +! ZERO COUNT OF ZERO DIAGONAL ELEMENTS IN U. +! +! FIRST CHECK STRUCTURE OF A AND BUILD COLUMN STRUCTURE + DO 10 I=1,N + IC(I)=0 +10 CONTINUE + DO 30 I=1,N + KS=IA(I) + KE=IA(I+1)-1 + NODIAG=.TRUE. + DO 20 K=KS,KE + J=JA(K) + IF (J.LT.1.OR.J.GT.N) GO TO 210 + IC(J)=IC(J)+1 + IF (J.EQ.I) NODIAG=.FALSE. +20 CONTINUE + IF (NODIAG) GO TO 210 +30 CONTINUE +! MAKE IC INTO INDICES + KOLD=IC(1) + IC(1)=1 + DO 40 I=1,N + KNEW=IC(I+1) + IF (KOLD.EQ.0) GO TO 210 + IC(I+1)=IC(I)+KOLD + KOLD=KNEW +40 CONTINUE +! SET JC AND JCI FOR COLUMN STRUCTURE + DO 60 I=1,N + KS=IA(I) + KE=IA(I+1)-1 + DO 50 K=KS,KE + J=JA(K) + L=IC(J) + IC(J)=L+1 + JC(L)=I + JCI(L)=K +50 CONTINUE +60 CONTINUE +! FIX UP IC + KOLD=IC(1) + IC(1)=1 + DO 70 I=1,N + KNEW=IC(I+1) + IC(I+1)=KOLD + KOLD=KNEW +70 CONTINUE +! FIND SORTED ROW STRUCTURE FROM SORTED COLUMN STRUCTURE + NP=N+1 + DO 80 I=1,NP + ILU(I)=IA(I) +80 CONTINUE +! MOVE ELEMENTS, SET JLU AND ID + DO 100 J=1,N + KS=IC(J) + KE=IC(J+1)-1 + DO 90 K=KS,KE + I=JC(K) + L=ILU(I) + ILU(I)=L+1 + JLU(L)=J + KK=JCI(K) + ALU(L)=A(KK) + IF (I.EQ.J) ID(J)=L +90 CONTINUE +100 CONTINUE +! RESET ILU (COULD JUST USE IA) + DO 110 I=1,NP + ILU(I)=IA(I) +110 CONTINUE +! FINISHED WITH SORTED COLUMN AND ROW STRUCTURE +! +! DO LU DECOMPOSITION USING GAUSSIAN ELIMINATION + DO 120 I=1,N + V(I)=0.0D0 +120 CONTINUE + DO 200 IROW=1,N + I=ID(IROW) + PIVOT=ALU(I) + IF (PIVOT.NE.0.0D0) GO TO 140 +! THIS CASE MAKES THE ILU LESS ACCURATE + ICBAD=ICBAD+1 + KS=ILU(IROW) + KE=ILU(IROW+1)-1 + DO 130 K=KS,KE + PIVOT=PIVOT+DABS(ALU(K)) +130 CONTINUE + IF (PIVOT.EQ.0.0D0) GO TO 220 +140 PIVOT=1.0D0/PIVOT + ALU(I)=PIVOT + KKS=I+1 + KKE=ILU(IROW+1)-1 + IF (KKS.GT.KKE) GO TO 160 + DO 150 K=KKS,KKE + J=JLU(K) + V(J)=ALU(K) +150 CONTINUE +! FIX L IN COLUMN IROW AND DO PARTIAL LU IN SUBMATRIX +160 KS=IC(IROW) + KE=IC(IROW+1)-1 + DO 190 K=KS,KE + I=JC(K) + IF (I.LE.IROW) GO TO 190 + LS=ILU(I) + LE=ILU(I+1)-1 + DO 180 L=LS,LE + J=JLU(L) + IF (J.LT.IROW) GO TO 180 + IF (J.GT.IROW) GO TO 170 + AMULT=ALU(L)*PIVOT + ALU(L)=AMULT + IF (AMULT.EQ.0.0) GO TO 190 + GO TO 180 +170 IF (V(J).EQ.0.0D0) GO TO 180 + ALU(L)=ALU(L)-AMULT*V(J) +180 CONTINUE +190 CONTINUE +! RESET V + IF (KKS.GT.KKE) GO TO 200 + DO 195 K=KKS,KKE + J=JLU(K) + V(J)=0.0D0 +195 CONTINUE +200 CONTINUE +! NORMAL RETURN + DLU0 = .FALSE. + RETURN +! ERROR RETURNS +210 IE=I + DLU0 = .TRUE. + RETURN +220 IE=IROW + DLU0 = .TRUE. + RETURN + END +!------------------------------------------------------------------------------------- + SUBROUTINE DNCG0(N,IA,JA,A,B,X,ILU,JLU,ID,ALU,R,P,S1,S2,EPS,ITER,IE) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION IA(*),JA(*),A(*),B(N),X(N),ILU(*),JLU(*),ALU(*),ID(N),R(N),P(N),S1(N),S2(N) +! NONSYMMETRIC CONJUGATE GRADIENT +! WHERE: +! N,IA,JA,A,B, AND X ARE DESCRIBED IN SUBROUTINE DILUCG. +! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW OF LU. +! JLU GIVES COLUMN NUMBER. +! ID GIVES INDEX OF DIAGONAL ELEMENT OF U. +! ALU HAS NONZERO ELEMENTS OF LU MATRIX STORED BY ROW +! WITH RECIPROCALS OF DIAGONAL ELEMENTS OF U. +! R,P,S1, AND S2 ARE VECTORS OF LENGTH N USED IN THE +! ITERATIONS. +! EPS IS CONVERGENCE CRITERIA. (DESCRIBED IN SUBROUTINE +! DILUCG). +! ITER IS MAX NUMBER OF ITERATIONS, OR 0 FOR "NO LIMIT". +! IE GIVES ACTUAL NUMBER OF ITERATIONS, NEGATIVE IF +! NO CONVERGENCE. +! +! R0=B-A*X0 + CALL DMUL10(N,IA,JA,A,X,R) + DO 10 I=1,N + R(I)=B(I)-R(I) +10 CONTINUE +! P0=(UT*U)(-1)*AT*(L*LT)(-1)*R0 +! FIRST SOLVE L*LT*S1=R0 + CALL DSUBL0(N,ILU,JLU,ID,ALU,R,S1) +! TIMES TRANSPOSE OF A + CALL DMUL20(N,IA,JA,A,S1,S2) +! THEN SOLVE UT*U*P=S2 + CALL DSUBU0(N,ILU,JLU,ID,ALU,S2,P) + IE=0 + RDOT = DGVV(R,S1,N) +! LOOP BEGINS HERE +20 CALL DMUL30(N,ILU,JLU,ID,ALU,P,S2) + + PDOT = DGVV(P,S2,N) + + IF (PDOT.EQ.0.0D0) RETURN + + ALPHA=RDOT/PDOT + XMAX=0.0D0 + XDIF=0.0D0 + DO 30 I=1,N + AP=ALPHA*P(I) + X(I)=X(I)+AP + AP=DABS(AP) + XX=DABS(X(I)) + IF (AP.GT.XDIF) XDIF=AP + IF (XX.GT.XMAX) XMAX=XX +30 CONTINUE + IE=IE+1 + IF ((EPS .GT. 0.0D0) .AND. (XDIF .LE. EPS * XMAX)) RETURN + IF ((EPS .LT. 0.0D0) .AND. (XMAX + XDIF/DABS(EPS) .EQ. XMAX)) RETURN +! +! EXCEEDED ITERATION LIMIT? +! + IF ((ITER .NE. 0) .AND. (IE .GE. ITER)) GO TO 60 + CALL DMUL10(N,IA,JA,A,P,S2) + DO 40 I=1,N + R(I)=R(I)-ALPHA*S2(I) +40 CONTINUE + CALL DSUBL0(N,ILU,JLU,ID,ALU,R,S1) + RRDOT = DGVV(R,S1,N) + BETA=RRDOT/RDOT + RDOT=RRDOT + CALL DMUL20(N,IA,JA,A,S1,S2) + CALL DSUBU0(N,ILU,JLU,ID,ALU,S2,S1) + DO 50 I=1,N + P(I)=S1(I)+BETA*P(I) +50 CONTINUE + GO TO 20 +60 IE=-IE + RETURN + END +!------------------------------------------------------------------------------------------------------ + SUBROUTINE DMUL10(N,IA,JA,A,B,X) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION IA(*),JA(*),A(*),B(N),X(N) +! MULTIPLY A TIMES B TO GET X +! WHERE: +! N IS THE ORDER OF THE MATRIX +! IA GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW +! JA GIVES COLUMN NUMBER +! A CONTAINS THE NONZERO ELEMENTS OF THE NONSYMMETRIC +! MATRIX STORED BY ROW +! B IS THE VECTOR +! X IS THE PRODUCT (MUST BE DIFFERENT FROM B) + + DO 20 I=1,N + KS=IA(I) + KE=IA(I+1)-1 + SUM=0.0D0 + DO 10 K=KS,KE + J=JA(K) + SUM=SUM+A(K)*B(J) +10 CONTINUE + X(I)=SUM +20 CONTINUE + RETURN + END +!-------------------------------------------------------------------------------------------------------- + SUBROUTINE DMUL20(N,IA,JA,A,B,X) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION IA(*),JA(*),A(*),B(N),X(N) +! MULTIPLY TRANSPOSE OF A TIMES B TO GET X +! WHERE: +! N IS THE ORDER OF THE MATRIX +! IA GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW +! JA GIVES COLUMN NUMBER +! A CONTAINS THE NONZERO ELEMENTS OF THE NONSYMMETRIC +! MATRIX STORED BY ROW +! B IS THE VECTOR +! X IS THE PRODUCT (MUST BE DIFFERENT FROM B) + + DO 10 I=1,N + X(I)=0.0D0 +10 CONTINUE + DO 30 I=1,N + KS=IA(I) + KE=IA(I+1)-1 + BB=B(I) + DO 20 K=KS,KE + J=JA(K) + X(J)=X(J)+A(K)*BB +20 CONTINUE +30 CONTINUE + RETURN + END +!--------------------------------------------------------------------------------------------------------- + SUBROUTINE DMUL30(N,ILU,JLU,ID,ALU,B,X) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION ILU(*),JLU(*),ID(*),ALU(*),B(N),X(N) +! MULTIPLY TRANSPOSE OF U TIMES U TIMES B TO GET X +! WHERE: +! N IS THE ORDER OF THE MATRIX +! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW OF LU +! JLU GIVES COLUMN NUMBER +! ID GIVES INDEX OF DIAGONAL ELEMENT OF U +! ALU HAS NONZERO ELEMENTS OF LU MATRIX STORED BY ROW +! WITH RECIPROCALS OF DIAGONAL ELEMENTS +! B IS THE VECTOR +! X IS THE PRODUCT UT*U*B (X MUST BE DIFFERENT FROM B) + + DO 10 I=1,N + X(I)=0.0D0 +10 CONTINUE + DO 50 I=1,N + KS=ID(I)+1 + KE=ILU(I+1)-1 + DIAG=1.0D0/ALU(KS-1) + XX=DIAG*B(I) + IF (KS.GT.KE) GO TO 30 + DO 20 K=KS,KE + J=JLU(K) + XX=XX+ALU(K)*B(J) +20 CONTINUE +30 X(I)=X(I)+DIAG*XX + IF (KS.GT.KE) GO TO 50 + DO 40 K=KS,KE + J=JLU(K) + X(J)=X(J)+ALU(K)*XX +40 CONTINUE +50 CONTINUE + RETURN + END +!---------------------------------------------------------------------------------------------------------- + SUBROUTINE DSUBU0(N,ILU,JLU,ID,ALU,B,X) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION ILU(*),JLU(*),ID(*),ALU(*),B(N),X(N) +! DO FORWARD AND BACK SUBSTITUTION TO SOLVE UT*U*X=B +! WHERE: +! N IS THE ORDER OF THE MATRIX +! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW OF LU +! JLU GIVES COLUMN NUMBER +! ID GIVES INDEX OF DIAGONAL ELEMENT OF U +! ALU HAS NONZERO ELMENTS OF LU MATRIX STORED BY ROW +! WITH RECIPROCALS OF DIAGONAL ELEMENTS OF U +! B IS THE RHS VECTOR +! X IS THE SOLUTION VECTOR + + NP=N+1 + DO 10 I=1,N + X(I)=B(I) +10 CONTINUE +! FORWARD SUBSTITUTION + DO 30 I=1,N + KS=ID(I)+1 + KE=ILU(I+1)-1 + XX=X(I)*ALU(KS-1) + X(I)=XX + IF (KS.GT.KE) GO TO 30 + DO 20 K=KS,KE + J=JLU(K) + X(J)=X(J)-ALU(K)*XX +20 CONTINUE +30 CONTINUE +! BACK SUBSTITUTION + DO 60 II=1,N + I=NP-II + KS=ID(I)+1 + KE=ILU(I+1)-1 + SUM=0.0D0 + IF (KS.GT.KE) GO TO 50 + DO 40 K=KS,KE + J=JLU(K) + SUM=SUM+ALU(K)*X(J) +40 CONTINUE +50 X(I)=(X(I)-SUM)*ALU(KS-1) +60 CONTINUE + RETURN + END +!-------------------------------------------------------------------------------------------------------------- + SUBROUTINE DSUBL0(N,ILU,JLU,ID,ALU,B,X) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION ILU(*),JLU(*),ID(*),ALU(*),B(N),X(N) +! DO FORWARD AND BACK SUBSTITUTION TO SOLVE L*LT*X=B +! WHERE: +! N IS THE ORDER OF THE MATRIX +! ILU GIVES INDEX OF FIRST NONZERO ELEMENT IN ROW LU +! JLU GIVES THE COLUMN NUMBER +! ID GIVES INDEX OF DIAGONAL ELEMENT OF U +! ALU HAS NONZERO ELEMENTS OF LU MATRIX STORED BY ROW +! DIAGONAL ELEMENTS OF L ARE 1.0 AND NOT STORED +! B IS THE RHS VECTOR +! X IS THE SOLUTION VECTOR + + NP=N+1 + DO 10 I=1,N + X(I)=B(I) +10 CONTINUE +! FORWARD SUBSTITUTION + DO 30 I=1,N + KS=ILU(I) + KE=ID(I)-1 + IF (KS.GT.KE) GO TO 30 + SUM=0.0D0 + DO 20 K=KS,KE + J=JLU(K) + SUM=SUM+ALU(K)*X(J) +20 CONTINUE + X(I)=X(I)-SUM +30 CONTINUE +! BACK SUBSTITUTION + DO 50 II=1,N + I=NP-II + KS=ILU(I) + KE=ID(I)-1 + IF (KS.GT.KE) GO TO 50 + XX=X(I) + IF (XX.EQ.0.0) GO TO 50 + DO 40 K=KS,KE + J=JLU(K) + X(J)=X(J)-ALU(K)*XX +40 CONTINUE +50 CONTINUE + RETURN + END +!------------------------------------------------------------------------------------------------------------------ + DOUBLE PRECISION FUNCTION DGVV(V,W,N) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION V(N),W(N) +! SUBROUTINE TO COMPUTE DOUBLE PRECISION VECTOR DOT PRODUCT. +! Optimized using Intel oneMKL BLAS ddot +! Mathematical equivalence: DGVV = sum_{i=1}^{N} V(i)*W(i) + + DOUBLE PRECISION, EXTERNAL :: DDOT + DGVV = DDOT(N, V, 1, W, 1) + RETURN + END diff --git a/AMSS_NCKU_source/ilucg.h b/AMSS_NCKU_source/AHF_Direct/ilucg.h similarity index 94% rename from AMSS_NCKU_source/ilucg.h rename to AMSS_NCKU_source/AHF_Direct/ilucg.h index d4d41df..3ba4215 100644 --- a/AMSS_NCKU_source/ilucg.h +++ b/AMSS_NCKU_source/AHF_Direct/ilucg.h @@ -1,24 +1,24 @@ - -#ifndef ILUCG_H -#define ILUCG_H - -#ifdef fortran1 -#define f_ilucg ilucg -#endif -#ifdef fortran2 -#define f_ilucg ILUCG -#endif -#ifdef fortran3 -#define f_ilucg ilucg_ -#endif - -extern "C" -{ - void f_ilucg(const int &N, - const int *IA, const int *JA, const double *A, - const double *B, double *X, - int *ITEMP, double *RTEMP, - const double &EPS, const int &ITER, int &ISTATUS); -} - -#endif /* ILUCG_H */ + +#ifndef ILUCG_H +#define ILUCG_H + +#ifdef fortran1 +#define f_ilucg ilucg +#endif +#ifdef fortran2 +#define f_ilucg ILUCG +#endif +#ifdef fortran3 +#define f_ilucg ilucg_ +#endif + +extern "C" +{ + void f_ilucg(const int &N, + const int *IA, const int *JA, const double *A, + const double *B, double *X, + int *ITEMP, double *RTEMP, + const double &EPS, const int &ITER, int &ISTATUS); +} + +#endif /* ILUCG_H */ diff --git a/AMSS_NCKU_source/initial_guess.C b/AMSS_NCKU_source/AHF_Direct/initial_guess.C similarity index 96% rename from AMSS_NCKU_source/initial_guess.C rename to AMSS_NCKU_source/AHF_Direct/initial_guess.C index b39b37a..90a5714 100644 --- a/AMSS_NCKU_source/initial_guess.C +++ b/AMSS_NCKU_source/AHF_Direct/initial_guess.C @@ -1,132 +1,132 @@ -#include -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -#include "horizon_sequence.h" -#include "BH_diagnostics.h" -#include "myglobal.h" - -namespace AHFinderDirect -{ - extern struct state state; - //****************************************************************************** - - // ellipsoid has global-coordinates center (A,B,C), radius (a,b,c) - // angular coordinate system has center (U,V,W) - // - // direction cosines wrt angular coordinate center are (xcos,ycos,zcos) - // i.e. a point has coordinates (U+xcos*r, V+ycos*r, W+zcos*r) - // - // then the equation of the ellipsoid is - // (U+xcos*r - A)^2 (V+ycos*r - B)^2 (W+zcos*r - C)^2 - // ----------------- + ---------------- + ----------------- = 1 - // a^2 b^2 c^2 - // - // to solve this, we introduce intermediate variables - // AU = A - U - // BV = B - V - // CW = C - W - // - void setup_initial_guess(patch_system &ps, - fp x_center, fp y_center, fp z_center, - fp x_radius, fp y_radius, fp z_radius) - { - for (int pn = 0; pn < ps.N_patches(); ++pn) - { - patch &p = ps.ith_patch(pn); - - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - fp xcos, ycos, zcos; - p.xyzcos_of_rho_sigma(rho, sigma, xcos, ycos, zcos); - - // set up variables used by Maple-generated code - const fp AU = x_center - ps.origin_x(); - const fp BV = y_center - ps.origin_y(); - const fp CW = z_center - ps.origin_z(); - const fp a = x_radius; - const fp b = y_radius; - const fp c = z_radius; - - // compute the solutions r_plus and r_minus - fp r_plus, r_minus; - { - fp t1, t2, t3, t5, t6, t7, t9, t10, t12, t28; - fp t30, t33, t35, t36, t40, t42, t43, t48, t49, t52; - fp t55; - t1 = a * a; - t2 = b * b; - t3 = t1 * t2; - t5 = t3 * zcos * CW; - t6 = c * c; - t7 = t1 * t6; - t9 = t7 * ycos * BV; - t10 = t2 * t6; - t12 = t10 * xcos * AU; - t28 = xcos * xcos; - t30 = CW * CW; - t33 = BV * BV; - t35 = t10 * t28; - t36 = ycos * ycos; - t40 = AU * AU; - t42 = t7 * t36; - t43 = zcos * zcos; - t48 = t3 * t43; - t49 = -2.0 * t1 * zcos * CW * ycos * BV - 2.0 * t2 * zcos * CW * xcos * AU - 2.0 * t6 * ycos * BV * xcos * AU + t2 * t28 * t30 + t6 * t28 * t33 - t35 + t1 * t36 * t30 + t6 * t36 * t40 - t42 + t1 * t43 * t33 + t2 * t43 * t40 - - t48; - t52 = sqrt(-t3 * t6 * t49); - t55 = 1 / (t35 + t42 + t48); - r_plus = (t5 + t9 + t12 + t52) * t55; - r_minus = (t5 + t9 + t12 - t52) * t55; - } - - // exactly one of the solutions (call it r) should be positive - fp r; - if ((r_plus > 0.0) && (r_minus < 0.0)) - then r = r_plus; - else if ((r_plus < 0.0) && (r_minus > 0.0)) - then r = r_minus; - else if (state.my_proc == 0) - printf("\nsetup_coord_ellipsoid():\nexpected exactly one r>0 solution to quadratic, got 0 or 2!\n%s patch (irho,isigma)=(%d,%d) ==> (rho,sigma)=(%g,%g)\ndirection cosines (xcos,ycos,zcos)=(%g,%g,%g)\nr_plus=%g r_minus=%g\n==> this probably means the initial guess surface doesn't contain\nthe local origin point, or more generally that the initial\nguess surface isn't a Strahlkoerper (\"star-shaped region\")\nwith respect to the local origin point\n", p.name(), irho, isigma, double(rho), double(sigma), double(xcos), double(ycos), double(zcos), double(r_plus), double(r_minus)); - - // r = horizon radius at this grid point - p.ghosted_gridfn(gfns::gfn__h, irho, isigma) = r; - } - } - } - } - - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +#include "horizon_sequence.h" +#include "BH_diagnostics.h" +#include "myglobal.h" + +namespace AHFinderDirect +{ + extern struct state state; + //****************************************************************************** + + // ellipsoid has global-coordinates center (A,B,C), radius (a,b,c) + // angular coordinate system has center (U,V,W) + // + // direction cosines wrt angular coordinate center are (xcos,ycos,zcos) + // i.e. a point has coordinates (U+xcos*r, V+ycos*r, W+zcos*r) + // + // then the equation of the ellipsoid is + // (U+xcos*r - A)^2 (V+ycos*r - B)^2 (W+zcos*r - C)^2 + // ----------------- + ---------------- + ----------------- = 1 + // a^2 b^2 c^2 + // + // to solve this, we introduce intermediate variables + // AU = A - U + // BV = B - V + // CW = C - W + // + void setup_initial_guess(patch_system &ps, + fp x_center, fp y_center, fp z_center, + fp x_radius, fp y_radius, fp z_radius) + { + for (int pn = 0; pn < ps.N_patches(); ++pn) + { + patch &p = ps.ith_patch(pn); + + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + fp xcos, ycos, zcos; + p.xyzcos_of_rho_sigma(rho, sigma, xcos, ycos, zcos); + + // set up variables used by Maple-generated code + const fp AU = x_center - ps.origin_x(); + const fp BV = y_center - ps.origin_y(); + const fp CW = z_center - ps.origin_z(); + const fp a = x_radius; + const fp b = y_radius; + const fp c = z_radius; + + // compute the solutions r_plus and r_minus + fp r_plus, r_minus; + { + fp t1, t2, t3, t5, t6, t7, t9, t10, t12, t28; + fp t30, t33, t35, t36, t40, t42, t43, t48, t49, t52; + fp t55; + t1 = a * a; + t2 = b * b; + t3 = t1 * t2; + t5 = t3 * zcos * CW; + t6 = c * c; + t7 = t1 * t6; + t9 = t7 * ycos * BV; + t10 = t2 * t6; + t12 = t10 * xcos * AU; + t28 = xcos * xcos; + t30 = CW * CW; + t33 = BV * BV; + t35 = t10 * t28; + t36 = ycos * ycos; + t40 = AU * AU; + t42 = t7 * t36; + t43 = zcos * zcos; + t48 = t3 * t43; + t49 = -2.0 * t1 * zcos * CW * ycos * BV - 2.0 * t2 * zcos * CW * xcos * AU - 2.0 * t6 * ycos * BV * xcos * AU + t2 * t28 * t30 + t6 * t28 * t33 - t35 + t1 * t36 * t30 + t6 * t36 * t40 - t42 + t1 * t43 * t33 + t2 * t43 * t40 - + t48; + t52 = sqrt(-t3 * t6 * t49); + t55 = 1 / (t35 + t42 + t48); + r_plus = (t5 + t9 + t12 + t52) * t55; + r_minus = (t5 + t9 + t12 - t52) * t55; + } + + // exactly one of the solutions (call it r) should be positive + fp r; + if ((r_plus > 0.0) && (r_minus < 0.0)) + then r = r_plus; + else if ((r_plus < 0.0) && (r_minus > 0.0)) + then r = r_minus; + else if (state.my_proc == 0) + printf("\nsetup_coord_ellipsoid():\nexpected exactly one r>0 solution to quadratic, got 0 or 2!\n%s patch (irho,isigma)=(%d,%d) ==> (rho,sigma)=(%g,%g)\ndirection cosines (xcos,ycos,zcos)=(%g,%g,%g)\nr_plus=%g r_minus=%g\n==> this probably means the initial guess surface doesn't contain\nthe local origin point, or more generally that the initial\nguess surface isn't a Strahlkoerper (\"star-shaped region\")\nwith respect to the local origin point\n", p.name(), irho, isigma, double(rho), double(sigma), double(xcos), double(ycos), double(zcos), double(r_plus), double(r_minus)); + + // r = horizon radius at this grid point + p.ghosted_gridfn(gfns::gfn__h, irho, isigma) = r; + } + } + } + } + + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/linear_map.C b/AMSS_NCKU_source/AHF_Direct/linear_map.C similarity index 97% rename from AMSS_NCKU_source/linear_map.C rename to AMSS_NCKU_source/AHF_Direct/linear_map.C index df6e7e8..ddcd743 100644 --- a/AMSS_NCKU_source/linear_map.C +++ b/AMSS_NCKU_source/AHF_Direct/linear_map.C @@ -1,244 +1,244 @@ -#include -#include - -#include "stdc.h" -#include "util.h" -#include "linear_map.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - template - linear_map::linear_map(int min_int_in, int max_int_in, - fp_t min_fp_in, fp_t delta_fp_in, fp_t max_fp_in) - : delta_(delta_fp_in), inverse_delta_(1.0 / delta_fp_in), - min_int_(min_int_in), max_int_(max_int_in) - { - constructor_common(min_fp_in, max_fp_in); - } - - template - linear_map::linear_map(const linear_map &lm_in, - int min_int_in, int max_int_in) // subrange - : delta_(lm_in.delta_fp()), inverse_delta_(lm_in.inverse_delta_fp()), - min_int_(min_int_in), max_int_(max_int_in) - { - if (!(is_in_range(min_int_in) && is_in_range(max_int_in))) - then error_exit(ERROR_EXIT, - "***** linear_map::linear_map:\n" - " min_int_in=%d and/or max_int_in=%d\n" - " aren't in integer range [%d,%d] of existing linear_map!\n", - min_int_, max_int_, - lm_in.min_int(), lm_in.max_int()); /*NOTREACHED*/ - - constructor_common(lm_in.fp_of_int_unchecked(min_int_in), - lm_in.fp_of_int_unchecked(max_int_in)); - } - - //****************************************************************************** - - // - // This function does the common argument validation and setup for - // all the constructors of class linear_map:: . - // - template - void linear_map::constructor_common(fp_t min_fp_in, fp_t max_fp_in) - // assumes - // min_int_, max_int_, delta_, inverse_delta_ - // are already initialized - // ==> ok to use min_int(), max_int(), delta_fp(), inverse_delta_fp() - // ... other class members *not* yet initialized - { - origin_ = 0.0; // temp value - origin_ = min_fp_in - fp_of_int_unchecked(min_int()); - - // this should be guaranteed by the above calculation - assert(fuzzy::EQ(fp_of_int_unchecked(min_int()), min_fp_in)); - - // this is a test of the consistency of the input arguments - if (fuzzy::NE(fp_of_int_unchecked(max_int()), max_fp_in)) - then error_exit(ERROR_EXIT, - "***** linear_map::linear_map:\n" - " int range [%d,%d]\n" - " and fp range [%g(%g)%g]\n" - " are (fuzzily) inconsistent!\n", - min_int(), max_int(), - double(min_fp_in), double(delta_fp()), double(max_fp_in)); - /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function converts fp --> int coordinate, returning the result - // as an fp (which need not be fuzzily integral). - // - template - fp_t linear_map::fp_int_of_fp(fp_t x) - const - { - if (!is_in_range(x)) - then error_exit(ERROR_EXIT, - "***** linear_map::fp_int_of_fp:\n" - " fp value x=%g is (fuzzily) outside the grid!\n" - " {min(delta)max}_fp = %g(%g)%g\n", - double(x), - double(min_fp()), double(delta_fp()), double(max_fp())); - /*NOTREACHED*/ - - return inverse_delta_ * (x - origin_); - } - - //****************************************************************************** - - // - // This function converts fp --> int and checks that the result is - // fuzzily integral. (The nia argument specifies what to do if the - // result *isn't* fuzzily integral.) - // - // FIXME: - // Having to explicitly specify the namespace for jtutil::round:: - // is ++ugly. :( - // - template - int linear_map::int_of_fp(fp_t x, noninteger_action nia /* = nia_error */) - const - { - const fp_t fp_int = fp_int_of_fp(x); - - if (fuzzy::is_integer(fp_int)) - then - { - // x is (fuzzily) a grid point ==> return that - return jtutil::round::to_integer(fp_int); // *** EARLY RETURN *** - } - - // get to here ==> x isn't (fuzzily) a grid point - static const char *const noninteger_msg = - "%s linear_map::int_of_fp:\n" - " x=%g isn't (fuzzily) a grid point!\n" - " {min(delta)max}_fp() = %g(%g)%g\n"; - switch (nia) - { - case nia_error: - error_exit(ERROR_EXIT, - noninteger_msg, - "*****", - double(x), - double(min_fp()), double(delta_fp()), double(max_fp())); - /*NOTREACHED*/ - - case nia_warning: - printf(noninteger_msg, - "---", - double(x), - double(min_fp()), double(delta_fp()), double(max_fp())); - // fall through - - case nia_round: - return jtutil::round::to_integer(fp_int); // *** EARLY RETURN *** - - case nia_floor: - return jtutil::round::floor(fp_int); // *** EARLY RETURN *** - - case nia_ceiling: - return jtutil::round::ceiling(fp_int); // *** EARLY RETURN *** - - default: - error_exit(PANIC_EXIT, - "***** linear_map::int_of_fp: illegal nia=(int)%d\n" - " (this should never happen!)\n", - int(nia)); /*NOTREACHED*/ - } - return 0; // dummy return to quiet gcc - // (which doesn't grok that error_exit() never returns) - } - - //****************************************************************************** - - // - // This function converts "delta" spacings in the fp coordinate to - // corresponding "delta" spacings in the int coordinate, and checks that - // the result is fuzzily integral. (The nia argument specifies what to - // do if the result *isn't* fuzzily integral.) - // - // FIXME: - // Having to explicitly specify the namespace for jtutil::round:: - // is ++ugly. :( - // - template - int linear_map::delta_int_of_delta_fp(fp_t delta_x, noninteger_action nia /* = nia_error */) - const - { - const fp_t fp_delta_int = inverse_delta_ * delta_x; - - if (fuzzy::is_integer(fp_delta_int)) - then - { - // delta_x is (fuzzily) an integer number of grid spacings - // ==> return that - return jtutil::round::to_integer(fp_delta_int); - // *** EARLY RETURN *** - } - - // get to here ==> delta_x isn't (fuzzily) an integer number of grid spacings - static const char *const noninteger_msg = - "%s linear_map::delta_int_of_delta_fp:\n" - " delta_x=%g isn't (fuzzily) an integer number of grid spacings!\n" - " {min(delta)max}_fp() = %g(%g)%g\n"; - switch (nia) - { - case nia_error: - error_exit(ERROR_EXIT, - noninteger_msg, - "*****", - double(delta_x), - double(min_fp()), double(delta_fp()), double(max_fp())); - /*NOTREACHED*/ - - case nia_warning: - printf(noninteger_msg, - "---", - double(delta_x), - double(min_fp()), double(delta_fp()), double(max_fp())); - // fall through - - case nia_round: - return jtutil::round::to_integer(fp_delta_int); - // *** EARLY RETURN *** - - case nia_floor: - return jtutil::round::floor(fp_delta_int); // *** EARLY RETURN *** - - case nia_ceiling: - return jtutil::round::ceiling(fp_delta_int); - // *** EARLY RETURN *** - - default: - error_exit(PANIC_EXIT, - "***** linear_map::delta_int_of_delta_fp: illegal nia=(int)%d\n" - " (this should never happen!)\n", - int(nia)); /*NOTREACHED*/ - } - return 0; // dummy return to quiet gcc - // (which doesn't grok that error_exit() never returns) - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // ***** template instantiation ***** - // - - template class linear_map; - template class linear_map; - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include + +#include "stdc.h" +#include "util.h" +#include "linear_map.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + template + linear_map::linear_map(int min_int_in, int max_int_in, + fp_t min_fp_in, fp_t delta_fp_in, fp_t max_fp_in) + : delta_(delta_fp_in), inverse_delta_(1.0 / delta_fp_in), + min_int_(min_int_in), max_int_(max_int_in) + { + constructor_common(min_fp_in, max_fp_in); + } + + template + linear_map::linear_map(const linear_map &lm_in, + int min_int_in, int max_int_in) // subrange + : delta_(lm_in.delta_fp()), inverse_delta_(lm_in.inverse_delta_fp()), + min_int_(min_int_in), max_int_(max_int_in) + { + if (!(is_in_range(min_int_in) && is_in_range(max_int_in))) + then error_exit(ERROR_EXIT, + "***** linear_map::linear_map:\n" + " min_int_in=%d and/or max_int_in=%d\n" + " aren't in integer range [%d,%d] of existing linear_map!\n", + min_int_, max_int_, + lm_in.min_int(), lm_in.max_int()); /*NOTREACHED*/ + + constructor_common(lm_in.fp_of_int_unchecked(min_int_in), + lm_in.fp_of_int_unchecked(max_int_in)); + } + + //****************************************************************************** + + // + // This function does the common argument validation and setup for + // all the constructors of class linear_map:: . + // + template + void linear_map::constructor_common(fp_t min_fp_in, fp_t max_fp_in) + // assumes + // min_int_, max_int_, delta_, inverse_delta_ + // are already initialized + // ==> ok to use min_int(), max_int(), delta_fp(), inverse_delta_fp() + // ... other class members *not* yet initialized + { + origin_ = 0.0; // temp value + origin_ = min_fp_in - fp_of_int_unchecked(min_int()); + + // this should be guaranteed by the above calculation + assert(fuzzy::EQ(fp_of_int_unchecked(min_int()), min_fp_in)); + + // this is a test of the consistency of the input arguments + if (fuzzy::NE(fp_of_int_unchecked(max_int()), max_fp_in)) + then error_exit(ERROR_EXIT, + "***** linear_map::linear_map:\n" + " int range [%d,%d]\n" + " and fp range [%g(%g)%g]\n" + " are (fuzzily) inconsistent!\n", + min_int(), max_int(), + double(min_fp_in), double(delta_fp()), double(max_fp_in)); + /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function converts fp --> int coordinate, returning the result + // as an fp (which need not be fuzzily integral). + // + template + fp_t linear_map::fp_int_of_fp(fp_t x) + const + { + if (!is_in_range(x)) + then error_exit(ERROR_EXIT, + "***** linear_map::fp_int_of_fp:\n" + " fp value x=%g is (fuzzily) outside the grid!\n" + " {min(delta)max}_fp = %g(%g)%g\n", + double(x), + double(min_fp()), double(delta_fp()), double(max_fp())); + /*NOTREACHED*/ + + return inverse_delta_ * (x - origin_); + } + + //****************************************************************************** + + // + // This function converts fp --> int and checks that the result is + // fuzzily integral. (The nia argument specifies what to do if the + // result *isn't* fuzzily integral.) + // + // FIXME: + // Having to explicitly specify the namespace for jtutil::round:: + // is ++ugly. :( + // + template + int linear_map::int_of_fp(fp_t x, noninteger_action nia /* = nia_error */) + const + { + const fp_t fp_int = fp_int_of_fp(x); + + if (fuzzy::is_integer(fp_int)) + then + { + // x is (fuzzily) a grid point ==> return that + return jtutil::round::to_integer(fp_int); // *** EARLY RETURN *** + } + + // get to here ==> x isn't (fuzzily) a grid point + static const char *const noninteger_msg = + "%s linear_map::int_of_fp:\n" + " x=%g isn't (fuzzily) a grid point!\n" + " {min(delta)max}_fp() = %g(%g)%g\n"; + switch (nia) + { + case nia_error: + error_exit(ERROR_EXIT, + noninteger_msg, + "*****", + double(x), + double(min_fp()), double(delta_fp()), double(max_fp())); + /*NOTREACHED*/ + + case nia_warning: + printf(noninteger_msg, + "---", + double(x), + double(min_fp()), double(delta_fp()), double(max_fp())); + // fall through + + case nia_round: + return jtutil::round::to_integer(fp_int); // *** EARLY RETURN *** + + case nia_floor: + return jtutil::round::floor(fp_int); // *** EARLY RETURN *** + + case nia_ceiling: + return jtutil::round::ceiling(fp_int); // *** EARLY RETURN *** + + default: + error_exit(PANIC_EXIT, + "***** linear_map::int_of_fp: illegal nia=(int)%d\n" + " (this should never happen!)\n", + int(nia)); /*NOTREACHED*/ + } + return 0; // dummy return to quiet gcc + // (which doesn't grok that error_exit() never returns) + } + + //****************************************************************************** + + // + // This function converts "delta" spacings in the fp coordinate to + // corresponding "delta" spacings in the int coordinate, and checks that + // the result is fuzzily integral. (The nia argument specifies what to + // do if the result *isn't* fuzzily integral.) + // + // FIXME: + // Having to explicitly specify the namespace for jtutil::round:: + // is ++ugly. :( + // + template + int linear_map::delta_int_of_delta_fp(fp_t delta_x, noninteger_action nia /* = nia_error */) + const + { + const fp_t fp_delta_int = inverse_delta_ * delta_x; + + if (fuzzy::is_integer(fp_delta_int)) + then + { + // delta_x is (fuzzily) an integer number of grid spacings + // ==> return that + return jtutil::round::to_integer(fp_delta_int); + // *** EARLY RETURN *** + } + + // get to here ==> delta_x isn't (fuzzily) an integer number of grid spacings + static const char *const noninteger_msg = + "%s linear_map::delta_int_of_delta_fp:\n" + " delta_x=%g isn't (fuzzily) an integer number of grid spacings!\n" + " {min(delta)max}_fp() = %g(%g)%g\n"; + switch (nia) + { + case nia_error: + error_exit(ERROR_EXIT, + noninteger_msg, + "*****", + double(delta_x), + double(min_fp()), double(delta_fp()), double(max_fp())); + /*NOTREACHED*/ + + case nia_warning: + printf(noninteger_msg, + "---", + double(delta_x), + double(min_fp()), double(delta_fp()), double(max_fp())); + // fall through + + case nia_round: + return jtutil::round::to_integer(fp_delta_int); + // *** EARLY RETURN *** + + case nia_floor: + return jtutil::round::floor(fp_delta_int); // *** EARLY RETURN *** + + case nia_ceiling: + return jtutil::round::ceiling(fp_delta_int); + // *** EARLY RETURN *** + + default: + error_exit(PANIC_EXIT, + "***** linear_map::delta_int_of_delta_fp: illegal nia=(int)%d\n" + " (this should never happen!)\n", + int(nia)); /*NOTREACHED*/ + } + return 0; // dummy return to quiet gcc + // (which doesn't grok that error_exit() never returns) + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // ***** template instantiation ***** + // + + template class linear_map; + template class linear_map; + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/linear_map.h b/AMSS_NCKU_source/AHF_Direct/linear_map.h similarity index 96% rename from AMSS_NCKU_source/linear_map.h rename to AMSS_NCKU_source/AHF_Direct/linear_map.h index 66a6618..6c8bc3c 100644 --- a/AMSS_NCKU_source/linear_map.h +++ b/AMSS_NCKU_source/AHF_Direct/linear_map.h @@ -1,131 +1,131 @@ -#ifndef AHFINDERDIRECT__LINEAR_MAP_HH -#define AHFINDERDIRECT__LINEAR_MAP_HH -namespace AHFinderDirect -{ - namespace jtutil - { - - template - class linear_map - { - public: - // integer bounds info - int min_int() const { return min_int_; } - int max_int() const { return max_int_; } - int N_points() const - { - return jtutil::how_many_in_range(min_int_, max_int_); - } - bool is_in_range(int i) const - { - return (i >= min_int()) && (i <= max_int()); - } - int clamp(int i) const - { - if (i < min_int()) - then return min_int(); - else if (i > max_int()) - then return max_int(); - else - return i; - } - - // convert int --> fp - fp_t fp_of_int_unchecked(int i) const - { - return origin_ + delta_ * i; - } - fp_t fp_of_int(int i) const - { - assert(is_in_range(i)); - return fp_of_int_unchecked(i); - } - - // converg delta_int --> delta_fp - fp_t delta_fp_of_delta_int(int delta_i) const - { - return delta_ * delta_i; - } - - // fp bounds info - fp_t origin() const { return origin_; } - fp_t delta_fp() const { return delta_; } - fp_t inverse_delta_fp() const { return inverse_delta_; } - fp_t min_fp() const { return fp_of_int_unchecked(min_int_); } - fp_t max_fp() const { return fp_of_int_unchecked(max_int_); } - bool is_in_range(fp_t x) const - { - return fuzzy::GE(x, min_fp()) && fuzzy::LE(x, max_fp()); - } - fp_t clamp(fp_t x) const - { - if (x < min_fp()) - then return min_fp(); - else if (x > max_fp()) - then return max_fp(); - else - return x; - } - - // convert linear map indices <--> C-style 0-origin indices - int zero_origin_int(int i) const { return i - min_int(); } - int map_int(int zero_origin_i) { return zero_origin_i + min_int(); } - - // convert fp --> int coordinate, but return result as fp - // (which need not be fuzzily integral) - fp_t fp_int_of_fp(fp_t x) const; - - // convert fp --> int, check being fuzzily integral - enum noninteger_action // what to do if "int" - // isn't fuzzily integral? - { - nia_error, // jtutil::error_exit(...) - nia_warning, // print warning msg, - // then round to nearest - nia_round, // (silently) round to nearest - nia_floor, // (silently) round to -infinity - nia_ceiling // (silently) round to +infinity - }; - int int_of_fp(fp_t x, noninteger_action nia = nia_error) const; - - // convert delta_fp --> delta_int, check being fuzzily integral - int delta_int_of_delta_fp(fp_t delta_x, - noninteger_action nia = nia_error) - const; - - // constructors - linear_map(int min_int_in, int max_int_in, - fp_t min_fp_in, fp_t delta_fp_in, fp_t max_fp_in); - // ... construct with subrange of existing linear_map - linear_map(const linear_map &lm_in, - int min_int_in, int max_int_in); - - // no need for explicit destructor, compiler-generated no-op is ok - - // no need for copy constructor or assignment operator, - // compiler-generated defaults are ok - - private: - // common code (argument validation & setup) for all constructors - // assumes min_int_, max_int_, delta_ already initialized, - // other class members *not* initialized - void constructor_common(fp_t min_fp_in, fp_t max_fp_in); - - // these define the actual mapping - // via the fp_of_int() function (above) - fp_t origin_, delta_; - - // cache of 1.0/delta_ - // ==> avoids fp divide in inverse_delta_fp() - // ==> also makes fp --> int conversions slightly faster - fp_t inverse_delta_; - - const int min_int_, max_int_; - }; - - //****************************************************************************** - - } // namespace jtutil -} // namespace AHFinderDirect - -#endif /* AHFINDERDIRECT__LINEAR_MAP_HH */ +#ifndef AHFINDERDIRECT__LINEAR_MAP_HH +#define AHFINDERDIRECT__LINEAR_MAP_HH +namespace AHFinderDirect +{ + namespace jtutil + { + + template + class linear_map + { + public: + // integer bounds info + int min_int() const { return min_int_; } + int max_int() const { return max_int_; } + int N_points() const + { + return jtutil::how_many_in_range(min_int_, max_int_); + } + bool is_in_range(int i) const + { + return (i >= min_int()) && (i <= max_int()); + } + int clamp(int i) const + { + if (i < min_int()) + then return min_int(); + else if (i > max_int()) + then return max_int(); + else + return i; + } + + // convert int --> fp + fp_t fp_of_int_unchecked(int i) const + { + return origin_ + delta_ * i; + } + fp_t fp_of_int(int i) const + { + assert(is_in_range(i)); + return fp_of_int_unchecked(i); + } + + // converg delta_int --> delta_fp + fp_t delta_fp_of_delta_int(int delta_i) const + { + return delta_ * delta_i; + } + + // fp bounds info + fp_t origin() const { return origin_; } + fp_t delta_fp() const { return delta_; } + fp_t inverse_delta_fp() const { return inverse_delta_; } + fp_t min_fp() const { return fp_of_int_unchecked(min_int_); } + fp_t max_fp() const { return fp_of_int_unchecked(max_int_); } + bool is_in_range(fp_t x) const + { + return fuzzy::GE(x, min_fp()) && fuzzy::LE(x, max_fp()); + } + fp_t clamp(fp_t x) const + { + if (x < min_fp()) + then return min_fp(); + else if (x > max_fp()) + then return max_fp(); + else + return x; + } + + // convert linear map indices <--> C-style 0-origin indices + int zero_origin_int(int i) const { return i - min_int(); } + int map_int(int zero_origin_i) { return zero_origin_i + min_int(); } + + // convert fp --> int coordinate, but return result as fp + // (which need not be fuzzily integral) + fp_t fp_int_of_fp(fp_t x) const; + + // convert fp --> int, check being fuzzily integral + enum noninteger_action // what to do if "int" + // isn't fuzzily integral? + { + nia_error, // jtutil::error_exit(...) + nia_warning, // print warning msg, + // then round to nearest + nia_round, // (silently) round to nearest + nia_floor, // (silently) round to -infinity + nia_ceiling // (silently) round to +infinity + }; + int int_of_fp(fp_t x, noninteger_action nia = nia_error) const; + + // convert delta_fp --> delta_int, check being fuzzily integral + int delta_int_of_delta_fp(fp_t delta_x, + noninteger_action nia = nia_error) + const; + + // constructors + linear_map(int min_int_in, int max_int_in, + fp_t min_fp_in, fp_t delta_fp_in, fp_t max_fp_in); + // ... construct with subrange of existing linear_map + linear_map(const linear_map &lm_in, + int min_int_in, int max_int_in); + + // no need for explicit destructor, compiler-generated no-op is ok + + // no need for copy constructor or assignment operator, + // compiler-generated defaults are ok + + private: + // common code (argument validation & setup) for all constructors + // assumes min_int_, max_int_, delta_ already initialized, + // other class members *not* initialized + void constructor_common(fp_t min_fp_in, fp_t max_fp_in); + + // these define the actual mapping + // via the fp_of_int() function (above) + fp_t origin_, delta_; + + // cache of 1.0/delta_ + // ==> avoids fp divide in inverse_delta_fp() + // ==> also makes fp --> int conversions slightly faster + fp_t inverse_delta_; + + const int min_int_, max_int_; + }; + + //****************************************************************************** + + } // namespace jtutil +} // namespace AHFinderDirect + +#endif /* AHFINDERDIRECT__LINEAR_MAP_HH */ diff --git a/AMSS_NCKU_source/miscfp.C b/AMSS_NCKU_source/AHF_Direct/miscfp.C similarity index 95% rename from AMSS_NCKU_source/miscfp.C rename to AMSS_NCKU_source/AHF_Direct/miscfp.C index a63ebf7..0717191 100644 --- a/AMSS_NCKU_source/miscfp.C +++ b/AMSS_NCKU_source/AHF_Direct/miscfp.C @@ -1,66 +1,66 @@ -#include -#include - -#include "cctk.h" - -#include "stdc.h" -#include "util.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - double signum(double x) - { - if (x == 0.0) - then return 0.0; - else - return (x > 0.0) ? 1.0 : -1.0; - } - double hypot3(double x, double y, double z) - { - return sqrt(x * x + y * y + z * z); - } - double arctan_xy(double x, double y) - { - return ((x == 0.0) && (y == 0.0)) ? 0.0 : atan2(y, x); - } - double modulo_reduce(double x, double xmod, double xmin, double xmax) - { - double xx = x; - - while (fuzzy::LT(xx, xmin)) - { - xx += xmod; - } - - while (fuzzy::GT(xx, xmax)) - { - xx -= xmod; - } - - if (!(fuzzy::GE(xx, xmin) && fuzzy::LE(xx, xmax))) - then error_exit(ERROR_EXIT, - "***** modulo_reduce(): no modulo value is fuzzily within specified range!\n" - " x = %g xmod = %g\n" - " [xmin,xmax] = [%g,%g]\n" - " ==> xx = %g\n", - x, xmod, - xmin, xmax, - xx); /*NOTREACHED*/ - - return xx; - } - template - void zero_C_array(int N, fp_t array[]) - { - for (int i = 0; i < N; ++i) - { - array[i] = 0; - } - } - - template void zero_C_array(int, CCTK_REAL[]); - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include + +#include "cctk.h" + +#include "stdc.h" +#include "util.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + double signum(double x) + { + if (x == 0.0) + then return 0.0; + else + return (x > 0.0) ? 1.0 : -1.0; + } + double hypot3(double x, double y, double z) + { + return sqrt(x * x + y * y + z * z); + } + double arctan_xy(double x, double y) + { + return ((x == 0.0) && (y == 0.0)) ? 0.0 : atan2(y, x); + } + double modulo_reduce(double x, double xmod, double xmin, double xmax) + { + double xx = x; + + while (fuzzy::LT(xx, xmin)) + { + xx += xmod; + } + + while (fuzzy::GT(xx, xmax)) + { + xx -= xmod; + } + + if (!(fuzzy::GE(xx, xmin) && fuzzy::LE(xx, xmax))) + then error_exit(ERROR_EXIT, + "***** modulo_reduce(): no modulo value is fuzzily within specified range!\n" + " x = %g xmod = %g\n" + " [xmin,xmax] = [%g,%g]\n" + " ==> xx = %g\n", + x, xmod, + xmin, xmax, + xx); /*NOTREACHED*/ + + return xx; + } + template + void zero_C_array(int N, fp_t array[]) + { + for (int i = 0; i < N; ++i) + { + array[i] = 0; + } + } + + template void zero_C_array(int, CCTK_REAL[]); + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/myglobal.h b/AMSS_NCKU_source/AHF_Direct/myglobal.h similarity index 95% rename from AMSS_NCKU_source/myglobal.h rename to AMSS_NCKU_source/AHF_Direct/myglobal.h index ef48a9d..e9503fd 100644 --- a/AMSS_NCKU_source/myglobal.h +++ b/AMSS_NCKU_source/AHF_Direct/myglobal.h @@ -1,65 +1,65 @@ -#ifndef MYGLOBAL_H -#define MYGLOBAL_H - -#include "var.h" -#include "MyList.h" - -#ifdef USE_GPU -#include "bssn_gpu_class.h" -#else -#include "bssn_class.h" -#endif - -#include "driver.h" - -namespace AHFinderDirect -{ - - int globalInterpGFL(double *X, double *Y, double *Z, int Ns, - double *Data); - - int globalInterpGFLlash(double *X, double *Y, double *Z, int Ns, - double *Data); - - void AHFinderDirect_setup(MyList *AHList, MyList *GaugeList, bssn_class *ADM, - int Symmetry, int HN, double *PhysTime); - - void AHFinderDirect_cleanup(); - - void AHFinderDirect_find_horizons(int HN, int *dumpid, - double *xc, double *yc, double *zc, double *xr, double *yr, double *zr, - bool *trigger, double *); - - void AHFinderDirect_enforcefind(int HN, - double *xc, double *yc, double *zc, double *xr, double *yr, double *zr); - // - struct state - { - int N_procs; // total number of processors - int my_proc; // processor number of this processor - // (0 to N_procs-1) - - int Symmetry; - double *PhysTime; - - MyList *AHList; - MyList *GaugeList; - - bssn_class *ADM; - - int N_horizons; // total number of genuine horizons - // being searched for - int N_active_procs; // total number of active processors - // (the active processors are processor - // numbers 0 to N_active_procs-1) - - struct iteration_status_buffers isb; - - horizon_sequence *my_hs; - - struct AH_data **AH_data_array; - - double *Data, *oX, *oY, *oZ; - }; -} -#endif /* MYGLOBAL_H */ +#ifndef MYGLOBAL_H +#define MYGLOBAL_H + +#include "var.h" +#include "MyList.h" + +#ifdef USE_GPU +#include "bssn_gpu_class.h" +#else +#include "bssn_class.h" +#endif + +#include "driver.h" + +namespace AHFinderDirect +{ + + int globalInterpGFL(double *X, double *Y, double *Z, int Ns, + double *Data); + + int globalInterpGFLlash(double *X, double *Y, double *Z, int Ns, + double *Data); + + void AHFinderDirect_setup(MyList *AHList, MyList *GaugeList, bssn_class *ADM, + int Symmetry, int HN, double *PhysTime); + + void AHFinderDirect_cleanup(); + + void AHFinderDirect_find_horizons(int HN, int *dumpid, + double *xc, double *yc, double *zc, double *xr, double *yr, double *zr, + bool *trigger, double *); + + void AHFinderDirect_enforcefind(int HN, + double *xc, double *yc, double *zc, double *xr, double *yr, double *zr); + // + struct state + { + int N_procs; // total number of processors + int my_proc; // processor number of this processor + // (0 to N_procs-1) + + int Symmetry; + double *PhysTime; + + MyList *AHList; + MyList *GaugeList; + + bssn_class *ADM; + + int N_horizons; // total number of genuine horizons + // being searched for + int N_active_procs; // total number of active processors + // (the active processors are processor + // numbers 0 to N_active_procs-1) + + struct iteration_status_buffers isb; + + horizon_sequence *my_hs; + + struct AH_data **AH_data_array; + + double *Data, *oX, *oY, *oZ; + }; +} +#endif /* MYGLOBAL_H */ diff --git a/AMSS_NCKU_source/norm.C b/AMSS_NCKU_source/AHF_Direct/norm.C similarity index 95% rename from AMSS_NCKU_source/norm.C rename to AMSS_NCKU_source/AHF_Direct/norm.C index 857d9c6..e94016e 100644 --- a/AMSS_NCKU_source/norm.C +++ b/AMSS_NCKU_source/AHF_Direct/norm.C @@ -1,68 +1,68 @@ -#include -#include -#include - -#include "util.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - - template - norm::norm() - : N_(0L), - sum_(0.0), sum2_(0.0), - max_abs_value_(0.0), min_abs_value_(0.0), - max_value_(0.0), min_value_(0.0) - { - } - - template - void norm::reset() - { - N_ = 0L; - sum_ = 0.0; - sum2_ = 0.0; - max_abs_value_ = 0.0; - min_abs_value_ = 0.0; - max_value_ = 0.0; - min_value_ = 0.0; - } - - template - void norm::data(fp_t x) - { - sum_ += x; - sum2_ += x * x; - - const fp_t abs_x = jtutil::abs(x); - max_abs_value_ = jtutil::tmax(max_abs_value_, abs_x); - min_abs_value_ = (N_ == 0) ? abs_x : jtutil::tmin(min_abs_value_, abs_x); - - min_value_ = (N_ == 0) ? x : jtutil::tmin(min_value_, x); - max_value_ = (N_ == 0) ? x : jtutil::tmax(max_value_, x); - - ++N_; - } - - template - fp_t norm::mean() const { return sum_ / fp_t(N_); } - template - fp_t norm::two_norm() const { return sqrt(sum2_); } - template - fp_t norm::rms_norm() const - { - assert(is_nonempty()); - return sqrt(sum2_ / fp_t(N_)); - } - - template class jtutil::norm; - template class jtutil::norm; - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - } // namespace jtutil -} // namespace AHFinderDirect +#include +#include +#include + +#include "util.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + + template + norm::norm() + : N_(0L), + sum_(0.0), sum2_(0.0), + max_abs_value_(0.0), min_abs_value_(0.0), + max_value_(0.0), min_value_(0.0) + { + } + + template + void norm::reset() + { + N_ = 0L; + sum_ = 0.0; + sum2_ = 0.0; + max_abs_value_ = 0.0; + min_abs_value_ = 0.0; + max_value_ = 0.0; + min_value_ = 0.0; + } + + template + void norm::data(fp_t x) + { + sum_ += x; + sum2_ += x * x; + + const fp_t abs_x = jtutil::abs(x); + max_abs_value_ = jtutil::tmax(max_abs_value_, abs_x); + min_abs_value_ = (N_ == 0) ? abs_x : jtutil::tmin(min_abs_value_, abs_x); + + min_value_ = (N_ == 0) ? x : jtutil::tmin(min_value_, x); + max_value_ = (N_ == 0) ? x : jtutil::tmax(max_value_, x); + + ++N_; + } + + template + fp_t norm::mean() const { return sum_ / fp_t(N_); } + template + fp_t norm::two_norm() const { return sqrt(sum2_); } + template + fp_t norm::rms_norm() const + { + assert(is_nonempty()); + return sqrt(sum2_ / fp_t(N_)); + } + + template class jtutil::norm; + template class jtutil::norm; + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/patch.C b/AMSS_NCKU_source/AHF_Direct/patch.C similarity index 97% rename from AMSS_NCKU_source/patch.C rename to AMSS_NCKU_source/AHF_Direct/patch.C index 22929e3..d1eee84 100644 --- a/AMSS_NCKU_source/patch.C +++ b/AMSS_NCKU_source/AHF_Direct/patch.C @@ -1,955 +1,955 @@ -#include -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" - -namespace AHFinderDirect -{ - using jtutil::error_exit; - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function constructs a patch object. - // - patch::patch(patch_system &my_patch_system_in, int patch_number_in, - const char name_in[], bool is_plus_in, char ctype_in, - local_coords::coords_set coords_set_rho_in, - local_coords::coords_set coords_set_sigma_in, - local_coords::coords_set coords_set_tau_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in) - - : fd_grid(grid_array_pars_in, grid_pars_in), - - my_patch_system_(my_patch_system_in), - patch_number_(patch_number_in), - name_(name_in), - is_plus_(is_plus_in), ctype_(ctype_in), - - coords_set_rho_(coords_set_rho_in), - coords_set_sigma_(coords_set_sigma_in), - coords_set_tau_(coords_set_tau_in), - - min_rho_patch_edge_(*new patch_edge(*this, side_is_min, side_is_rho)), - max_rho_patch_edge_(*new patch_edge(*this, side_is_max, side_is_rho)), - min_sigma_patch_edge_(*new patch_edge(*this, side_is_min, side_is_sigma)), - max_sigma_patch_edge_(*new patch_edge(*this, side_is_max, side_is_sigma)), - - min_rho_ghost_zone_(NULL), - max_rho_ghost_zone_(NULL), - min_sigma_ghost_zone_(NULL), - max_sigma_ghost_zone_(NULL) // no comma - - { - } - - //****************************************************************************** - - // - // This function destroys a patch object. - // - patch::~patch() - { - // no need to check for null pointers, since delete NULL is a silent no-op - - delete max_sigma_ghost_zone_; - delete min_sigma_ghost_zone_; - delete max_rho_ghost_zone_; - delete min_rho_ghost_zone_; - - delete &max_sigma_patch_edge_; - delete &min_sigma_patch_edge_; - delete &max_rho_patch_edge_; - delete &min_rho_patch_edge_; - } - - //****************************************************************************** - - // - // This function constructs a z_patch object. - // - z_patch::z_patch(patch_system &my_patch_system_in, int patch_number_in, - const char *name_in, bool is_plus_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in) - : patch(my_patch_system_in, patch_number_in, - name_in, is_plus_in, 'z', - local_coords::coords_set_mu, local_coords::coords_set_nu, - local_coords::coords_set_phi, - grid_array_pars_in, grid_pars_in) - { - } - - //****************************************************************************** - - // - // This function constructs an x_patch object. - // - x_patch::x_patch(patch_system &my_patch_system_in, int patch_number_in, - const char *name_in, bool is_plus_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in) - : patch(my_patch_system_in, patch_number_in, - name_in, is_plus_in, 'x', - local_coords::coords_set_nu, local_coords::coords_set_phi, - local_coords::coords_set_mu, - grid_array_pars_in, grid_pars_in) - { - } - - //****************************************************************************** - - // - // This function constructs a y_patch object. - // - y_patch::y_patch(patch_system &my_patch_system_in, int patch_number_in, - const char *name_in, bool is_plus_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in) - : patch(my_patch_system_in, patch_number_in, - name_in, is_plus_in, 'y', - local_coords::coords_set_mu, local_coords::coords_set_phi, - local_coords::coords_set_nu, - grid_array_pars_in, grid_pars_in) - { - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function computes the (rho,sigma) induced 2-D metric from the - // 3-D (x,y,z) metric of the space containing the patch, as per p.33 of - // my apparent horizon finding notes. - // - // Arguments: - // (r,rho,sigma) = The coordinates where the Jacobian is wanted. - // partial_surface_r_wrt_(rho,sigma) - // = The partial derivatives of the surface radius with respect to - // the (rho,sigma) coordinates. - // g_{xx,xy,xz,yy,yz,zz} = The xyz 3-metric components $g_{ij}$. - // g_{rho_rho,rho_sigma,sigma_sigma} = The (rho,sigma) induced 2-D metric. - // - // Results: - // This function returns the Jacobian of the (rho,sigma) induced 2-D metric. - // - fp patch::rho_sigma_metric(fp r, fp rho, fp sigma, - fp partial_surface_r_wrt_rho, - fp partial_surface_r_wrt_sigma, - fp g_xx, fp g_xy, fp g_xz, - fp g_yy, fp g_yz, - fp g_zz, - fp &g_rho_rho, fp &g_rho_sigma, - fp &g_sigma_sigma) - const - { - fp partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma; - fp partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma; - fp partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma; - partial_xyz_wrt_r_rho_sigma(r, rho, sigma, - partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, - partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, - partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); - - const fp dx_wrt_rho = partial_x_wrt_rho + partial_x_wrt_r * partial_surface_r_wrt_rho; - const fp dx_wrt_sigma = partial_x_wrt_sigma + partial_x_wrt_r * partial_surface_r_wrt_sigma; - const fp dy_wrt_rho = partial_y_wrt_rho + partial_y_wrt_r * partial_surface_r_wrt_rho; - const fp dy_wrt_sigma = partial_y_wrt_sigma + partial_y_wrt_r * partial_surface_r_wrt_sigma; - const fp dz_wrt_rho = partial_z_wrt_rho + partial_z_wrt_r * partial_surface_r_wrt_rho; - const fp dz_wrt_sigma = partial_z_wrt_sigma + partial_z_wrt_r * partial_surface_r_wrt_sigma; - - g_rho_rho = +dx_wrt_rho * dx_wrt_rho * g_xx + 2.0 * dx_wrt_rho * dy_wrt_rho * g_xy + 2.0 * dx_wrt_rho * dz_wrt_rho * g_xz + dy_wrt_rho * dy_wrt_rho * g_yy + 2.0 * dy_wrt_rho * dz_wrt_rho * g_yz + dz_wrt_rho * dz_wrt_rho * g_zz; - g_rho_sigma = +dx_wrt_rho * dx_wrt_sigma * g_xx + (dx_wrt_rho * dy_wrt_sigma + dy_wrt_rho * dx_wrt_sigma) * g_xy + (dx_wrt_rho * dz_wrt_sigma + dz_wrt_rho * dx_wrt_sigma) * g_xz + dy_wrt_rho * dy_wrt_sigma * g_yy + (dy_wrt_rho * dz_wrt_sigma + dz_wrt_rho * dy_wrt_sigma) * g_yz + dz_wrt_rho * dz_wrt_sigma * g_zz; - g_sigma_sigma = +dx_wrt_sigma * dx_wrt_sigma * g_xx + 2.0 * dx_wrt_sigma * dy_wrt_sigma * g_xy + 2.0 * dx_wrt_sigma * dz_wrt_sigma * g_xz + dy_wrt_sigma * dy_wrt_sigma * g_yy + 2.0 * dy_wrt_sigma * dz_wrt_sigma * g_yz + dz_wrt_sigma * dz_wrt_sigma * g_zz; - - return g_rho_rho * g_sigma_sigma - jtutil::pow2(g_rho_sigma); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function decodes the character-string name of an integration method - // into an enum integration_method . See the comments in "patch.hh" on the - // declaration of enum integration_method for details on the methods and - // their character-string names. - // - // static - enum patch::integration_method - patch::decode_integration_method(const char method_string[]) - { - if ((strcmp(method_string, "trapezoid") == 0) || (strcmp(method_string, "trapezoid rule") == 0)) - return integration_method__trapezoid; - else if ((strcmp(method_string, "Simpson") == 0) || (strcmp(method_string, "Simpson's rule") == 0)) - return integration_method__Simpson; - else if ((strcmp(method_string, "Simpson (variant)") == 0) || (strcmp(method_string, "Simpson's rule (variant)") == 0)) - return integration_method__Simpson_variant; - else if (strcmp(method_string, "automatic choice") == 0) - return integration_method__automatic_choice; - else - error_exit(ERROR_EXIT, - "***** patch::decode_integration_method():\n" - " unknown method_string=\"%s\"!\n", - method_string); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function computes an approximation to the arc length of a surface - // over the patch's nominal bounds along the rho direction (i.e. in a - // dsigma=constant plane where dsigma is a multiple of 90 degrees) - // - // Arguments: - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp patch::rho_arc_length(int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const - { - fp dsigma; - if (is_valid_dsigma(0.0)) - then dsigma = 0.0; - else if (is_valid_dsigma(90.0)) - then dsigma = 90.0; - else if (is_valid_dsigma(180.0)) - then dsigma = 180.0; - else if (is_valid_dsigma(-90.0)) - then dsigma = -90.0; - else - error_exit(PANIC_EXIT, - "***** patch::rho_arc_length(): can't find valid dsigma\n" - " which is a multiple of 90 degrees!\n" - " %s patch: [min,max]_dsigma()=[%g,%g]\n", - name(), min_dsigma(), max_dsigma()); - const fp sigma = sigma_of_dsigma(dsigma); - const int isigma = isigma_of_sigma(sigma); - - fp sum = 0.0; - - for (int irho = min_irho(); irho <= max_irho(); ++irho) - { - const fp rho = rho_of_irho(irho); - const fp r = ghosted_gridfn(ghosted_radius_gfn, irho, isigma); - const fp partial_surface_r_wrt_rho = partial_rho(ghosted_radius_gfn, irho, isigma); - const fp partial_surface_r_wrt_sigma = partial_sigma(ghosted_radius_gfn, irho, isigma); - - const fp g_xx = gridfn(g_xx_gfn, irho, isigma); - const fp g_xy = gridfn(g_xy_gfn, irho, isigma); - const fp g_xz = gridfn(g_xz_gfn, irho, isigma); - const fp g_yy = gridfn(g_yy_gfn, irho, isigma); - const fp g_yz = gridfn(g_yz_gfn, irho, isigma); - const fp g_zz = gridfn(g_zz_gfn, irho, isigma); - - fp g_rho_rho, g_rho_sigma, g_sigma_sigma; - rho_sigma_metric(r, rho, sigma, - partial_surface_r_wrt_rho, - partial_surface_r_wrt_sigma, - g_xx, g_xy, g_xz, - g_yy, g_yz, - g_zz, - g_rho_rho, g_rho_sigma, - g_sigma_sigma); - - const fp coeff = integration_coeff(method, - max_irho() - min_irho(), - irho - min_irho()); - - sum += coeff * sqrt(g_rho_rho); - } - - return delta_rho() * sum; - } - - //****************************************************************************** - - // - // This function computes an approximation to the arc length of a surface - // over the patch's nominal bounds along the sigma direction (i.e. in a - // drho=constant plane where drho is a multiple of 90 degrees) - // - // Arguments: - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp patch::sigma_arc_length(int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const - { - fp drho; - if (is_valid_drho(0.0)) - then drho = 0.0; - else if (is_valid_drho(90.0)) - then drho = 90.0; - else if (is_valid_drho(180.0)) - then drho = 180.0; - else if (is_valid_drho(-90.0)) - then drho = -90.0; - else - error_exit(PANIC_EXIT, - "***** patch::sigma_arc_length(): can't find valid drho\n" - " which is a multiple of 90 degrees!\n" - " %s patch: [min,max]_drho()=[%g,%g]\n", - name(), min_drho(), max_drho()); - const fp rho = rho_of_drho(drho); - const int irho = irho_of_rho(rho); - - fp sum = 0.0; - - for (int isigma = min_isigma(); isigma <= max_isigma(); ++isigma) - { - const fp sigma = sigma_of_isigma(isigma); - const fp r = ghosted_gridfn(ghosted_radius_gfn, irho, isigma); - const fp partial_surface_r_wrt_rho = partial_rho(ghosted_radius_gfn, irho, isigma); - const fp partial_surface_r_wrt_sigma = partial_sigma(ghosted_radius_gfn, irho, isigma); - - const fp g_xx = gridfn(g_xx_gfn, irho, isigma); - const fp g_xy = gridfn(g_xy_gfn, irho, isigma); - const fp g_xz = gridfn(g_xz_gfn, irho, isigma); - const fp g_yy = gridfn(g_yy_gfn, irho, isigma); - const fp g_yz = gridfn(g_yz_gfn, irho, isigma); - const fp g_zz = gridfn(g_zz_gfn, irho, isigma); - - fp g_rho_rho, g_rho_sigma, g_sigma_sigma; - rho_sigma_metric(r, rho, sigma, - partial_surface_r_wrt_rho, - partial_surface_r_wrt_sigma, - g_xx, g_xy, g_xz, - g_yy, g_yz, - g_zz, - g_rho_rho, g_rho_sigma, - g_sigma_sigma); - - const fp coeff = integration_coeff(method, - max_isigma() - min_isigma(), - isigma - min_isigma()); - - sum += coeff * sqrt(g_sigma_sigma); - } - - return delta_sigma() * sum; - } - - //****************************************************************************** - - // - // This function computes the arc length of a surface in the specified - // plane ("xz" or "yz") over the patch's nominal bounds. - // - // Arguments: - // plane[] = (in) "xz" or "yz" to specify the plane. - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp z_patch::plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const - { - if ((plane[0] == 'x') && (plane[1] == 'z')) - then // xz-plane = rotation about y = nu arc = sigma sigma - return sigma_arc_length(ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - else if ((plane[0] == 'y') && (plane[1] == 'z')) - then // yz-plane = rotation about x = mu arc = rho arc - return rho_arc_length(ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - else - error_exit(ERROR_EXIT, - "***** z_patch::plane_arc_length(): %s patch, plane=\"%s\", but\n" - " this patch doesn't contain that plane!\n", - name(), plane); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function computes the arc length of a surface in the specified - // plane ("xy" or "xz") over the patch's nominal bounds. - // - // Arguments: - // plane[] = (in) "xy" or "xz" to specify the plane. - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp x_patch::plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const - { - if ((plane[0] == 'x') && (plane[1] == 'y')) - then // xy-plane = rotation about z = phi arc = sigma arc - return sigma_arc_length(ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - else if ((plane[0] == 'x') && (plane[1] == 'z')) - then // xz-plane = rotation about y = nu arc = rho arc - return rho_arc_length(ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - else - error_exit(ERROR_EXIT, - "***** x_patch::plane_arc_length(): %s patch, plane=\"%s\", but\n" - " this patch doesn't contain that plane!\n", - name(), plane); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function computes the arc length of a surface in the specified - // plane ("xy" or "yz") over the patch's nominal bounds. - // - // Arguments: - // plane[] = (in) "xy" or "yz" to specify the plane. - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp y_patch::plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const - { - if ((plane[0] == 'x') && (plane[1] == 'y')) - then // xy-plane = rotation about z = phi arc = sigma arc - return sigma_arc_length(ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - else if ((plane[0] == 'y') && (plane[1] == 'z')) - then // yz-plane = rotation about x = mu arc = rho arc - return rho_arc_length(ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - else - error_exit(ERROR_EXIT, - "***** y_patch::plane_arc_length(): %s patch, plane=\"%s\", but\n" - " this patch doesn't contain that plane!\n", - name(), plane); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function computes an approximation to the (surface) integral of - // a gridfn over the patch's nominal area, - // $\int f(\rho,\sigma) \, dA$ - // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ - // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma). - // - // Arguments: - // unknown_src_gfn = (in) The gridfn to be integrated. This may be - // either nominal-grid or ghosted-grid; n.b. in - // the latter case the integral is still done only - // over the patch's nominal area. - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp patch::integrate_gridfn(int unknown_src_gfn, - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const - { - const bool src_is_ghosted = is_valid_ghosted_gfn(unknown_src_gfn); - - fp sum = 0.0; - for (int irho = min_irho(); irho <= max_irho(); ++irho) - { - for (int isigma = min_isigma(); isigma <= max_isigma(); ++isigma) - { - const fp fn = unknown_gridfn(src_is_ghosted, - unknown_src_gfn, irho, isigma); - - const fp rho = rho_of_irho(irho); - const fp sigma = sigma_of_isigma(isigma); - const fp r = ghosted_gridfn(ghosted_radius_gfn, irho, isigma); - const fp partial_surface_r_wrt_rho = partial_rho(ghosted_radius_gfn, irho, isigma); - const fp partial_surface_r_wrt_sigma = partial_sigma(ghosted_radius_gfn, irho, isigma); - - const fp g_xx = gridfn(g_xx_gfn, irho, isigma); - const fp g_xy = gridfn(g_xy_gfn, irho, isigma); - const fp g_xz = gridfn(g_xz_gfn, irho, isigma); - const fp g_yy = gridfn(g_yy_gfn, irho, isigma); - const fp g_yz = gridfn(g_yz_gfn, irho, isigma); - const fp g_zz = gridfn(g_zz_gfn, irho, isigma); - - fp g_rho_rho, g_rho_sigma, g_sigma_sigma; - const fp Jac = rho_sigma_metric(r, rho, sigma, - partial_surface_r_wrt_rho, - partial_surface_r_wrt_sigma, - g_xx, g_xy, g_xz, - g_yy, g_yz, - g_zz, - g_rho_rho, g_rho_sigma, - g_sigma_sigma); - - const fp coeff_rho = integration_coeff(method, - max_irho() - min_irho(), - irho - min_irho()); - const fp coeff_sigma = integration_coeff(method, - max_isigma() - min_isigma(), - isigma - min_isigma()); - - sum += coeff_rho * coeff_sigma * fn * sqrt(jtutil::abs(Jac)); - } - } - - return delta_rho() * delta_sigma() * sum; - } - - //****************************************************************************** - - // - // This function computes the integration coefficients for - // integrate_gridfn() . That is, if we write - // $\int_{x_0}^{x_N} f(x) \, dx - // \approx \Delta x \, \sum_{i=0}^N c_i f(x_i)$ - // then this function computes $c_i$. - // - // For method == integration_method__automatic_choice the choices are - // N=1 trapezoid - // N=2 Simpson - // N=3 trapezoid - // N=4 Simpson - // N=5 trapezoid - // N=6 Simpson - // N=7 and up Simpson variant - // - // Arguments: - // method = Specifies the integration method. - // N = The number of integration *intervals*. (The number of integration - // *points* is N+1.) - // i = Specifies the point at which the coefficient is desired. - // - // static - fp patch::integration_coeff(enum integration_method method, int N, int i) - { - assert(i >= 0); - assert(i <= N); - - if (method == integration_method__automatic_choice) - then - { - if (N >= 7) - then method = integration_method__Simpson_variant; - else if ((N % 2) == 0) - then method = integration_method__Simpson; - else - method = integration_method__trapezoid; - } - - switch (method) - { - case integration_method__trapezoid: - if ((i == 0) || (i == N)) - then return 0.5; - else - return 1.0; - - case integration_method__Simpson: - if ((N % 2) != 0) - then error_exit(ERROR_EXIT, - "***** patch::integration_coeff():\n" - " Simpson's rule requires N to be even, but N=%d!\n", - N); /*NOTREACHED*/ - if ((i == 0) || (i == N)) - then return 1.0 / 3.0; - else if ((i % 2) == 0) - then return 2.0 / 3.0; - else - return 4.0 / 3.0; - - case integration_method__Simpson_variant: - if (N < 7) - then error_exit(ERROR_EXIT, - "***** patch::integration_coeff():\n" - " Simpson's rule (variant) requires N >= 7, but N=%d!\n", - N); /*NOTREACHED*/ - if ((i == 0) || (i == N)) - then return 17.0 / 48.0; - else if ((i == 1) || (i == N - 1)) - then return 59.0 / 48.0; - else if ((i == 2) || (i == N - 2)) - then return 43.0 / 48.0; - else if ((i == 3) || (i == N - 3)) - then return 49.0 / 48.0; - else - return 1.0; - - default: - error_exit(ERROR_EXIT, - "***** patch::integration_coeff(): unknown method=(int)%d!\n" - " (this should never happen!)\n", - int(method)); /*NOTREACHED*/ - } - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function returns a reference to the ghost zone on a specified - // edge, after first assert()ing that the edge belongs to this patch. - // - // N.b. This function can't be inline in "patch.hh" because it needs - // member functions of class patch_edge, which comes after class patch - // in our #include order. - // - ghost_zone &patch::ghost_zone_on_edge(const patch_edge &e) - const - { - assert(e.my_patch() == *this); - return minmax_ang_ghost_zone(e.is_min(), e.is_rho()); - } - - //****************************************************************************** - - // - // This function determines which of the two adjacent ghost zones meeting - // at a specified corner, contains a specified point. If the point isn't - // in either ghost zone, an error_exit() is done. If the point is in both - // ghost zones, it's arbitrary which one will be chosen. - // - // Arguments: - // {rho,sigma}_is_min = Specify the corner (and implicitly the ghost zones). - // irho,isigma = Specify the point. - // - // Results: - // This function returns (a reference to) the desired ghost zone. - ghost_zone &patch::corner_ghost_zone_containing_point(bool rho_is_min, bool sigma_is_min, - int irho, int isigma) - const - { - ghost_zone &rho_gz = minmax_rho_ghost_zone(rho_is_min); - ghost_zone &sigma_gz = minmax_sigma_ghost_zone(sigma_is_min); - - const patch_edge &rho_edge = rho_gz.my_edge(); - const patch_edge &sigma_edge = sigma_gz.my_edge(); - - const int rho_iperp = rho_edge.iperp_of_irho_isigma(irho, isigma); - const int rho_ipar = rho_edge.ipar_of_irho_isigma(irho, isigma); - const int sigma_iperp = sigma_edge.iperp_of_irho_isigma(irho, isigma); - const int sigma_ipar = sigma_edge.ipar_of_irho_isigma(irho, isigma); - - const bool is_in_rho_ghost_zone = rho_gz.is_in_ghost_zone(rho_iperp, rho_ipar); - const bool is_in_sigma_ghost_zone = sigma_gz.is_in_ghost_zone(sigma_iperp, sigma_ipar); - - // check that point is in at least one ghost zone - if (!is_in_rho_ghost_zone && !is_in_sigma_ghost_zone) - then error_exit(ERROR_EXIT, - "***** patch::corner_ghost_zone_containing_point():\n" - " neither ghost zone contains point (this should never happen)!\n" - " patch=%s rho_is_min=(int)%d sigma_is_min=(int)%d\n" - " irho=%d isigma=%d\n", - name(), int(rho_is_min), int(sigma_is_min), - irho, isigma); /*NOTREACHED*/ - - return is_in_rho_ghost_zone ? rho_gz : sigma_gz; - } - - //****************************************************************************** - - // - // This function determines which ghost zone contains a specified - // noncorner point. - // - // If the point isn't in any ghost zone of this patch, or if the point - // is in the corner of a ghost zone, an error_exit() is done. - // - // Arguments: - // irho,isigma = Specify the point. - // - // Results: - // This function returns (a reference to) the desired ghost zone. - ghost_zone &patch::ghost_zone_containing_noncorner_point(int irho, int isigma) - const - { - // n.b. these loops must use _int_ variables for the loop - // to terminate! - for (int want_min = false; want_min <= true; ++want_min) - { - for (int want_rho = false; want_rho <= true; ++want_rho) - { - const patch_edge &e = minmax_ang_patch_edge(want_min, want_rho); - const int iperp = e.iperp_of_irho_isigma(irho, isigma); - const int ipar = e.ipar_of_irho_isigma(irho, isigma); - - ghost_zone &gz = minmax_ang_ghost_zone(want_min, want_rho); - if (gz.is_in_ghost_zone(iperp, ipar) && gz.my_edge().ipar_is_in_noncorner(ipar)) - then return gz; - } - } - - error_exit(ERROR_EXIT, - "***** patch::ghost_zone_containing_noncorner_point():\n" - " no ghost zone contains point (this should never happen)!\n" - " patch=%s irho=%d isigma=%d\n", - name(), irho, isigma); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function assert()s that a specified ghost zone of this patch - // hasn't already been set up, then constructs it as a mirror-symmetry - // ghost zone and properly links this to/from the patch. - // - void patch::create_mirror_symmetry_ghost_zone(const patch_edge &my_edge) - { - // make sure we belong to the right patch - assert(my_edge.my_patch() == *this); - - symmetry_ghost_zone *temp = new symmetry_ghost_zone(my_edge); - set_ghost_zone(my_edge, temp); - } - - //****************************************************************************** - - // - // This function assert()s that a specified ghost zone of this patch - // hasn't already been set up, then creates it as a periodic-symmetry - // ghost zone and properly links this to/from the patch. - // - void patch::create_periodic_symmetry_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, - bool is_ipar_map_plus) - { - // make sure we belong to the right patch - assert(my_edge.my_patch() == *this); - - int my_sample_ipar = my_edge.min_ipar_without_corners(); - int other_sample_ipar = is_ipar_map_plus - ? other_edge.min_ipar_without_corners() - : other_edge.max_ipar_without_corners(); - - symmetry_ghost_zone *temp = new symmetry_ghost_zone(my_edge, other_edge, - my_sample_ipar, other_sample_ipar, - is_ipar_map_plus); - set_ghost_zone(my_edge, temp); - } - - //****************************************************************************** - - // - // This function assert()s that a specified ghost zone of this patch - // hasn't already been set up, then creates it as an interpatch ghost - // zone (with lots of NULL pointers for info we can't compute yet) - // and properly links this to/from the patch. - // - void patch::create_interpatch_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, - int patch_overlap_width) - { - // make sure we belong to the right patch - assert(my_edge.my_patch() == *this); - - interpatch_ghost_zone *temp = new interpatch_ghost_zone(my_edge, other_edge, - patch_overlap_width); - set_ghost_zone(my_edge, temp); - } - - //****************************************************************************** - - // - // This is a helper function for setup_*_ghost_zone(). This function - // assert()s that one of the ghost zone pointers (which one is selected - // by edge ) is NULL, then stores a value in it. - // - void patch::set_ghost_zone(const patch_edge &edge, ghost_zone *gzp) - { - ghost_zone *&ghost_zone_ptr_to_set = edge.is_min() - ? (edge.is_rho() ? min_rho_ghost_zone_ : min_sigma_ghost_zone_) - : (edge.is_rho() ? max_rho_ghost_zone_ : max_sigma_ghost_zone_); - - assert(ghost_zone_ptr_to_set == NULL); - ghost_zone_ptr_to_set = gzp; - } - - //****************************************************************************** - - // - // This function finds which patch edge is adjacent to a neighboring - // patch q, or does an error_exit() if q isn't actually a neighboring patch. - // The computation is done using only (rho,sigma) coordinate sets and - // min/max dang bounds ==> it's ok to use this function in setting up - // interpatch ghost zones. - // - // Arguments: - // q = The (supposedly) neighboring patch. - // patch_overlap_width = The number of grid points these patches overlap. - // If this is nonzero, then these patches must have the - // same grid spacing in the perpendicular direction. - // - const patch_edge &patch::edge_adjacent_to_patch(const patch &q, - int patch_overlap_width /* = 0 */) - const - { - const patch &p = *this; - - // which (rho,sigma) coordinate do the patches have in common? - // ... this is the perp coordinate for the border - const local_coords::coords_set common_coord_set = p.coords_set_rho_sigma() & q.coords_set_rho_sigma(); - - // is this coordinate rho or sigma in each patch? - const bool common_is_p_rho = (common_coord_set == p.coords_set_rho()); - const bool common_is_p_sigma = (common_coord_set == p.coords_set_sigma()); - if ((common_is_p_rho ^ common_is_p_sigma) != 0x1) - then error_exit(ERROR_EXIT, - "***** patch::edge_adjacent_to_patch():\n" - " common coordinate isn't exactly one of p.{rho,sigma}!\n" - " p.name()=\"%s\" q.name()=\"%s\"\n" - " common_coord_set=%s\n" - " common_is_p_rho=%d common_is_p_sigma=%d\n", - p.name(), q.name(), - local_coords::name_of_coords_set(common_coord_set), - int(common_is_p_rho), int(common_is_p_sigma)); - /*NOTREACHED*/ - const bool common_is_q_rho = (common_coord_set == q.coords_set_rho()); - const bool common_is_q_sigma = (common_coord_set == q.coords_set_sigma()); - if ((common_is_q_rho ^ common_is_q_sigma) != 0x1) - then error_exit(ERROR_EXIT, - "***** patch::edge_adjacent_to_patch():\n" - " common coordinate isn't exactly one of q.{rho,sigma}!\n" - " p.name()=\"%s\" q.name()=\"%s\"\n" - " common_coord_set=%s\n" - " common_is_q_rho=%d common_is_q_sigma=%d\n", - p.name(), q.name(), - local_coords::name_of_coords_set(common_coord_set), - int(common_is_q_rho), int(common_is_q_sigma)); - /*NOTREACHED*/ - - // how much do the patches overlap? - // ... eg patch_overlap_width = 3 would be - // p p p p p - // q q q q q - // so the overlap would be (patch_overlap_width-1) * delta = 2 * delta - if ((patch_overlap_width - 1 != 0) && jtutil::fuzzy::NE(p.delta_dang(common_is_p_rho), - q.delta_dang(common_is_q_rho))) - then error_exit(ERROR_EXIT, - "***** patch::edge_adjacent_to_patch():\n" - " patch_overlap_width != 0 must have same perp grid spacing in both patches!\n" - " p.name()=\"%s\" q.name()=\"%s\"\n" - " common_coord_set=%s\n" - " common_is_p_rho=%d common_is_q_rho=%d\n" - " p.delta_dang(common_is_p_rho)=%g\n" - " q.delta_dang(common_is_q_rho)=%g\n", - p.name(), q.name(), - local_coords::name_of_coords_set(common_coord_set), - int(common_is_p_rho), int(common_is_q_rho), - double(p.delta_dang(common_is_p_rho)), - double(q.delta_dang(common_is_q_rho))); /*NOTREACHED*/ - - const fp doverlap = fp(patch_overlap_width - 1) * p.delta_dang(common_is_p_rho); - - // where is the common boundary relative to the min/max sides of each patch? - const bool common_is_p_min_q_max = local_coords::fuzzy_EQ_dang(p.min_dang(common_is_p_rho), - q.max_dang(common_is_q_rho) - doverlap); - const bool common_is_p_max_q_min = local_coords::fuzzy_EQ_dang(p.max_dang(common_is_p_rho), - q.min_dang(common_is_q_rho) + doverlap); - if ((common_is_p_min_q_max ^ common_is_p_max_q_min) != 0x1) - then error_exit(ERROR_EXIT, - "***** patch::edge_adjacent_to_patch():\n" - " common coordinate isn't exactly one of {pmax/qmin, pmin/qmax}!\n" - " p.name()=\"%s\" q.name()=\"%s\"\n" - " common_coord_set=%s\n" - " common_is_p_rho=%d common_is_q_rho=%d\n" - " p.delta_dang(common_is_p_rho)=%g\n" - " q.delta_dang(common_is_q_rho)=%g\n" - " patch_overlap_width=%d doverlap=%g\n" - " common_is_p_min_q_max=%d common_is_p_max_q_min=%d\n", - p.name(), q.name(), - local_coords::name_of_coords_set(common_coord_set), - int(common_is_p_rho), int(common_is_q_rho), - double(p.delta_dang(common_is_p_rho)), - double(q.delta_dang(common_is_q_rho)), - patch_overlap_width, double(doverlap), - int(common_is_p_min_q_max), int(common_is_p_max_q_min)); - /*NOTREACHED*/ - - return p.minmax_ang_patch_edge(common_is_p_min_q_max, common_is_p_rho); - } - - //****************************************************************************** - - // - // This function verifies (via assert()) that all ghost zones of this - // patch have been fully set up. - // - void patch::assert_all_ghost_zones_fully_setup() const - { - assert(min_rho_ghost_zone_ != NULL); - assert(max_rho_ghost_zone_ != NULL); - assert(min_sigma_ghost_zone_ != NULL); - assert(max_sigma_ghost_zone_ != NULL); - - // these calls are no-ops for non-interpatch ghost zones - min_rho_ghost_zone().assert_fully_setup(); - max_rho_ghost_zone().assert_fully_setup(); - min_sigma_ghost_zone().assert_fully_setup(); - max_sigma_ghost_zone().assert_fully_setup(); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" + +namespace AHFinderDirect +{ + using jtutil::error_exit; + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function constructs a patch object. + // + patch::patch(patch_system &my_patch_system_in, int patch_number_in, + const char name_in[], bool is_plus_in, char ctype_in, + local_coords::coords_set coords_set_rho_in, + local_coords::coords_set coords_set_sigma_in, + local_coords::coords_set coords_set_tau_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in) + + : fd_grid(grid_array_pars_in, grid_pars_in), + + my_patch_system_(my_patch_system_in), + patch_number_(patch_number_in), + name_(name_in), + is_plus_(is_plus_in), ctype_(ctype_in), + + coords_set_rho_(coords_set_rho_in), + coords_set_sigma_(coords_set_sigma_in), + coords_set_tau_(coords_set_tau_in), + + min_rho_patch_edge_(*new patch_edge(*this, side_is_min, side_is_rho)), + max_rho_patch_edge_(*new patch_edge(*this, side_is_max, side_is_rho)), + min_sigma_patch_edge_(*new patch_edge(*this, side_is_min, side_is_sigma)), + max_sigma_patch_edge_(*new patch_edge(*this, side_is_max, side_is_sigma)), + + min_rho_ghost_zone_(NULL), + max_rho_ghost_zone_(NULL), + min_sigma_ghost_zone_(NULL), + max_sigma_ghost_zone_(NULL) // no comma + + { + } + + //****************************************************************************** + + // + // This function destroys a patch object. + // + patch::~patch() + { + // no need to check for null pointers, since delete NULL is a silent no-op + + delete max_sigma_ghost_zone_; + delete min_sigma_ghost_zone_; + delete max_rho_ghost_zone_; + delete min_rho_ghost_zone_; + + delete &max_sigma_patch_edge_; + delete &min_sigma_patch_edge_; + delete &max_rho_patch_edge_; + delete &min_rho_patch_edge_; + } + + //****************************************************************************** + + // + // This function constructs a z_patch object. + // + z_patch::z_patch(patch_system &my_patch_system_in, int patch_number_in, + const char *name_in, bool is_plus_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in) + : patch(my_patch_system_in, patch_number_in, + name_in, is_plus_in, 'z', + local_coords::coords_set_mu, local_coords::coords_set_nu, + local_coords::coords_set_phi, + grid_array_pars_in, grid_pars_in) + { + } + + //****************************************************************************** + + // + // This function constructs an x_patch object. + // + x_patch::x_patch(patch_system &my_patch_system_in, int patch_number_in, + const char *name_in, bool is_plus_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in) + : patch(my_patch_system_in, patch_number_in, + name_in, is_plus_in, 'x', + local_coords::coords_set_nu, local_coords::coords_set_phi, + local_coords::coords_set_mu, + grid_array_pars_in, grid_pars_in) + { + } + + //****************************************************************************** + + // + // This function constructs a y_patch object. + // + y_patch::y_patch(patch_system &my_patch_system_in, int patch_number_in, + const char *name_in, bool is_plus_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in) + : patch(my_patch_system_in, patch_number_in, + name_in, is_plus_in, 'y', + local_coords::coords_set_mu, local_coords::coords_set_phi, + local_coords::coords_set_nu, + grid_array_pars_in, grid_pars_in) + { + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function computes the (rho,sigma) induced 2-D metric from the + // 3-D (x,y,z) metric of the space containing the patch, as per p.33 of + // my apparent horizon finding notes. + // + // Arguments: + // (r,rho,sigma) = The coordinates where the Jacobian is wanted. + // partial_surface_r_wrt_(rho,sigma) + // = The partial derivatives of the surface radius with respect to + // the (rho,sigma) coordinates. + // g_{xx,xy,xz,yy,yz,zz} = The xyz 3-metric components $g_{ij}$. + // g_{rho_rho,rho_sigma,sigma_sigma} = The (rho,sigma) induced 2-D metric. + // + // Results: + // This function returns the Jacobian of the (rho,sigma) induced 2-D metric. + // + fp patch::rho_sigma_metric(fp r, fp rho, fp sigma, + fp partial_surface_r_wrt_rho, + fp partial_surface_r_wrt_sigma, + fp g_xx, fp g_xy, fp g_xz, + fp g_yy, fp g_yz, + fp g_zz, + fp &g_rho_rho, fp &g_rho_sigma, + fp &g_sigma_sigma) + const + { + fp partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma; + fp partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma; + fp partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma; + partial_xyz_wrt_r_rho_sigma(r, rho, sigma, + partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, + partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, + partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); + + const fp dx_wrt_rho = partial_x_wrt_rho + partial_x_wrt_r * partial_surface_r_wrt_rho; + const fp dx_wrt_sigma = partial_x_wrt_sigma + partial_x_wrt_r * partial_surface_r_wrt_sigma; + const fp dy_wrt_rho = partial_y_wrt_rho + partial_y_wrt_r * partial_surface_r_wrt_rho; + const fp dy_wrt_sigma = partial_y_wrt_sigma + partial_y_wrt_r * partial_surface_r_wrt_sigma; + const fp dz_wrt_rho = partial_z_wrt_rho + partial_z_wrt_r * partial_surface_r_wrt_rho; + const fp dz_wrt_sigma = partial_z_wrt_sigma + partial_z_wrt_r * partial_surface_r_wrt_sigma; + + g_rho_rho = +dx_wrt_rho * dx_wrt_rho * g_xx + 2.0 * dx_wrt_rho * dy_wrt_rho * g_xy + 2.0 * dx_wrt_rho * dz_wrt_rho * g_xz + dy_wrt_rho * dy_wrt_rho * g_yy + 2.0 * dy_wrt_rho * dz_wrt_rho * g_yz + dz_wrt_rho * dz_wrt_rho * g_zz; + g_rho_sigma = +dx_wrt_rho * dx_wrt_sigma * g_xx + (dx_wrt_rho * dy_wrt_sigma + dy_wrt_rho * dx_wrt_sigma) * g_xy + (dx_wrt_rho * dz_wrt_sigma + dz_wrt_rho * dx_wrt_sigma) * g_xz + dy_wrt_rho * dy_wrt_sigma * g_yy + (dy_wrt_rho * dz_wrt_sigma + dz_wrt_rho * dy_wrt_sigma) * g_yz + dz_wrt_rho * dz_wrt_sigma * g_zz; + g_sigma_sigma = +dx_wrt_sigma * dx_wrt_sigma * g_xx + 2.0 * dx_wrt_sigma * dy_wrt_sigma * g_xy + 2.0 * dx_wrt_sigma * dz_wrt_sigma * g_xz + dy_wrt_sigma * dy_wrt_sigma * g_yy + 2.0 * dy_wrt_sigma * dz_wrt_sigma * g_yz + dz_wrt_sigma * dz_wrt_sigma * g_zz; + + return g_rho_rho * g_sigma_sigma - jtutil::pow2(g_rho_sigma); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function decodes the character-string name of an integration method + // into an enum integration_method . See the comments in "patch.hh" on the + // declaration of enum integration_method for details on the methods and + // their character-string names. + // + // static + enum patch::integration_method + patch::decode_integration_method(const char method_string[]) + { + if ((strcmp(method_string, "trapezoid") == 0) || (strcmp(method_string, "trapezoid rule") == 0)) + return integration_method__trapezoid; + else if ((strcmp(method_string, "Simpson") == 0) || (strcmp(method_string, "Simpson's rule") == 0)) + return integration_method__Simpson; + else if ((strcmp(method_string, "Simpson (variant)") == 0) || (strcmp(method_string, "Simpson's rule (variant)") == 0)) + return integration_method__Simpson_variant; + else if (strcmp(method_string, "automatic choice") == 0) + return integration_method__automatic_choice; + else + error_exit(ERROR_EXIT, + "***** patch::decode_integration_method():\n" + " unknown method_string=\"%s\"!\n", + method_string); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function computes an approximation to the arc length of a surface + // over the patch's nominal bounds along the rho direction (i.e. in a + // dsigma=constant plane where dsigma is a multiple of 90 degrees) + // + // Arguments: + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp patch::rho_arc_length(int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const + { + fp dsigma; + if (is_valid_dsigma(0.0)) + then dsigma = 0.0; + else if (is_valid_dsigma(90.0)) + then dsigma = 90.0; + else if (is_valid_dsigma(180.0)) + then dsigma = 180.0; + else if (is_valid_dsigma(-90.0)) + then dsigma = -90.0; + else + error_exit(PANIC_EXIT, + "***** patch::rho_arc_length(): can't find valid dsigma\n" + " which is a multiple of 90 degrees!\n" + " %s patch: [min,max]_dsigma()=[%g,%g]\n", + name(), min_dsigma(), max_dsigma()); + const fp sigma = sigma_of_dsigma(dsigma); + const int isigma = isigma_of_sigma(sigma); + + fp sum = 0.0; + + for (int irho = min_irho(); irho <= max_irho(); ++irho) + { + const fp rho = rho_of_irho(irho); + const fp r = ghosted_gridfn(ghosted_radius_gfn, irho, isigma); + const fp partial_surface_r_wrt_rho = partial_rho(ghosted_radius_gfn, irho, isigma); + const fp partial_surface_r_wrt_sigma = partial_sigma(ghosted_radius_gfn, irho, isigma); + + const fp g_xx = gridfn(g_xx_gfn, irho, isigma); + const fp g_xy = gridfn(g_xy_gfn, irho, isigma); + const fp g_xz = gridfn(g_xz_gfn, irho, isigma); + const fp g_yy = gridfn(g_yy_gfn, irho, isigma); + const fp g_yz = gridfn(g_yz_gfn, irho, isigma); + const fp g_zz = gridfn(g_zz_gfn, irho, isigma); + + fp g_rho_rho, g_rho_sigma, g_sigma_sigma; + rho_sigma_metric(r, rho, sigma, + partial_surface_r_wrt_rho, + partial_surface_r_wrt_sigma, + g_xx, g_xy, g_xz, + g_yy, g_yz, + g_zz, + g_rho_rho, g_rho_sigma, + g_sigma_sigma); + + const fp coeff = integration_coeff(method, + max_irho() - min_irho(), + irho - min_irho()); + + sum += coeff * sqrt(g_rho_rho); + } + + return delta_rho() * sum; + } + + //****************************************************************************** + + // + // This function computes an approximation to the arc length of a surface + // over the patch's nominal bounds along the sigma direction (i.e. in a + // drho=constant plane where drho is a multiple of 90 degrees) + // + // Arguments: + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp patch::sigma_arc_length(int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const + { + fp drho; + if (is_valid_drho(0.0)) + then drho = 0.0; + else if (is_valid_drho(90.0)) + then drho = 90.0; + else if (is_valid_drho(180.0)) + then drho = 180.0; + else if (is_valid_drho(-90.0)) + then drho = -90.0; + else + error_exit(PANIC_EXIT, + "***** patch::sigma_arc_length(): can't find valid drho\n" + " which is a multiple of 90 degrees!\n" + " %s patch: [min,max]_drho()=[%g,%g]\n", + name(), min_drho(), max_drho()); + const fp rho = rho_of_drho(drho); + const int irho = irho_of_rho(rho); + + fp sum = 0.0; + + for (int isigma = min_isigma(); isigma <= max_isigma(); ++isigma) + { + const fp sigma = sigma_of_isigma(isigma); + const fp r = ghosted_gridfn(ghosted_radius_gfn, irho, isigma); + const fp partial_surface_r_wrt_rho = partial_rho(ghosted_radius_gfn, irho, isigma); + const fp partial_surface_r_wrt_sigma = partial_sigma(ghosted_radius_gfn, irho, isigma); + + const fp g_xx = gridfn(g_xx_gfn, irho, isigma); + const fp g_xy = gridfn(g_xy_gfn, irho, isigma); + const fp g_xz = gridfn(g_xz_gfn, irho, isigma); + const fp g_yy = gridfn(g_yy_gfn, irho, isigma); + const fp g_yz = gridfn(g_yz_gfn, irho, isigma); + const fp g_zz = gridfn(g_zz_gfn, irho, isigma); + + fp g_rho_rho, g_rho_sigma, g_sigma_sigma; + rho_sigma_metric(r, rho, sigma, + partial_surface_r_wrt_rho, + partial_surface_r_wrt_sigma, + g_xx, g_xy, g_xz, + g_yy, g_yz, + g_zz, + g_rho_rho, g_rho_sigma, + g_sigma_sigma); + + const fp coeff = integration_coeff(method, + max_isigma() - min_isigma(), + isigma - min_isigma()); + + sum += coeff * sqrt(g_sigma_sigma); + } + + return delta_sigma() * sum; + } + + //****************************************************************************** + + // + // This function computes the arc length of a surface in the specified + // plane ("xz" or "yz") over the patch's nominal bounds. + // + // Arguments: + // plane[] = (in) "xz" or "yz" to specify the plane. + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp z_patch::plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const + { + if ((plane[0] == 'x') && (plane[1] == 'z')) + then // xz-plane = rotation about y = nu arc = sigma sigma + return sigma_arc_length(ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + else if ((plane[0] == 'y') && (plane[1] == 'z')) + then // yz-plane = rotation about x = mu arc = rho arc + return rho_arc_length(ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + else + error_exit(ERROR_EXIT, + "***** z_patch::plane_arc_length(): %s patch, plane=\"%s\", but\n" + " this patch doesn't contain that plane!\n", + name(), plane); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function computes the arc length of a surface in the specified + // plane ("xy" or "xz") over the patch's nominal bounds. + // + // Arguments: + // plane[] = (in) "xy" or "xz" to specify the plane. + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp x_patch::plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const + { + if ((plane[0] == 'x') && (plane[1] == 'y')) + then // xy-plane = rotation about z = phi arc = sigma arc + return sigma_arc_length(ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + else if ((plane[0] == 'x') && (plane[1] == 'z')) + then // xz-plane = rotation about y = nu arc = rho arc + return rho_arc_length(ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + else + error_exit(ERROR_EXIT, + "***** x_patch::plane_arc_length(): %s patch, plane=\"%s\", but\n" + " this patch doesn't contain that plane!\n", + name(), plane); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function computes the arc length of a surface in the specified + // plane ("xy" or "yz") over the patch's nominal bounds. + // + // Arguments: + // plane[] = (in) "xy" or "yz" to specify the plane. + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp y_patch::plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const + { + if ((plane[0] == 'x') && (plane[1] == 'y')) + then // xy-plane = rotation about z = phi arc = sigma arc + return sigma_arc_length(ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + else if ((plane[0] == 'y') && (plane[1] == 'z')) + then // yz-plane = rotation about x = mu arc = rho arc + return rho_arc_length(ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + else + error_exit(ERROR_EXIT, + "***** y_patch::plane_arc_length(): %s patch, plane=\"%s\", but\n" + " this patch doesn't contain that plane!\n", + name(), plane); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function computes an approximation to the (surface) integral of + // a gridfn over the patch's nominal area, + // $\int f(\rho,\sigma) \, dA$ + // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ + // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma). + // + // Arguments: + // unknown_src_gfn = (in) The gridfn to be integrated. This may be + // either nominal-grid or ghosted-grid; n.b. in + // the latter case the integral is still done only + // over the patch's nominal area. + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp patch::integrate_gridfn(int unknown_src_gfn, + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const + { + const bool src_is_ghosted = is_valid_ghosted_gfn(unknown_src_gfn); + + fp sum = 0.0; + for (int irho = min_irho(); irho <= max_irho(); ++irho) + { + for (int isigma = min_isigma(); isigma <= max_isigma(); ++isigma) + { + const fp fn = unknown_gridfn(src_is_ghosted, + unknown_src_gfn, irho, isigma); + + const fp rho = rho_of_irho(irho); + const fp sigma = sigma_of_isigma(isigma); + const fp r = ghosted_gridfn(ghosted_radius_gfn, irho, isigma); + const fp partial_surface_r_wrt_rho = partial_rho(ghosted_radius_gfn, irho, isigma); + const fp partial_surface_r_wrt_sigma = partial_sigma(ghosted_radius_gfn, irho, isigma); + + const fp g_xx = gridfn(g_xx_gfn, irho, isigma); + const fp g_xy = gridfn(g_xy_gfn, irho, isigma); + const fp g_xz = gridfn(g_xz_gfn, irho, isigma); + const fp g_yy = gridfn(g_yy_gfn, irho, isigma); + const fp g_yz = gridfn(g_yz_gfn, irho, isigma); + const fp g_zz = gridfn(g_zz_gfn, irho, isigma); + + fp g_rho_rho, g_rho_sigma, g_sigma_sigma; + const fp Jac = rho_sigma_metric(r, rho, sigma, + partial_surface_r_wrt_rho, + partial_surface_r_wrt_sigma, + g_xx, g_xy, g_xz, + g_yy, g_yz, + g_zz, + g_rho_rho, g_rho_sigma, + g_sigma_sigma); + + const fp coeff_rho = integration_coeff(method, + max_irho() - min_irho(), + irho - min_irho()); + const fp coeff_sigma = integration_coeff(method, + max_isigma() - min_isigma(), + isigma - min_isigma()); + + sum += coeff_rho * coeff_sigma * fn * sqrt(jtutil::abs(Jac)); + } + } + + return delta_rho() * delta_sigma() * sum; + } + + //****************************************************************************** + + // + // This function computes the integration coefficients for + // integrate_gridfn() . That is, if we write + // $\int_{x_0}^{x_N} f(x) \, dx + // \approx \Delta x \, \sum_{i=0}^N c_i f(x_i)$ + // then this function computes $c_i$. + // + // For method == integration_method__automatic_choice the choices are + // N=1 trapezoid + // N=2 Simpson + // N=3 trapezoid + // N=4 Simpson + // N=5 trapezoid + // N=6 Simpson + // N=7 and up Simpson variant + // + // Arguments: + // method = Specifies the integration method. + // N = The number of integration *intervals*. (The number of integration + // *points* is N+1.) + // i = Specifies the point at which the coefficient is desired. + // + // static + fp patch::integration_coeff(enum integration_method method, int N, int i) + { + assert(i >= 0); + assert(i <= N); + + if (method == integration_method__automatic_choice) + then + { + if (N >= 7) + then method = integration_method__Simpson_variant; + else if ((N % 2) == 0) + then method = integration_method__Simpson; + else + method = integration_method__trapezoid; + } + + switch (method) + { + case integration_method__trapezoid: + if ((i == 0) || (i == N)) + then return 0.5; + else + return 1.0; + + case integration_method__Simpson: + if ((N % 2) != 0) + then error_exit(ERROR_EXIT, + "***** patch::integration_coeff():\n" + " Simpson's rule requires N to be even, but N=%d!\n", + N); /*NOTREACHED*/ + if ((i == 0) || (i == N)) + then return 1.0 / 3.0; + else if ((i % 2) == 0) + then return 2.0 / 3.0; + else + return 4.0 / 3.0; + + case integration_method__Simpson_variant: + if (N < 7) + then error_exit(ERROR_EXIT, + "***** patch::integration_coeff():\n" + " Simpson's rule (variant) requires N >= 7, but N=%d!\n", + N); /*NOTREACHED*/ + if ((i == 0) || (i == N)) + then return 17.0 / 48.0; + else if ((i == 1) || (i == N - 1)) + then return 59.0 / 48.0; + else if ((i == 2) || (i == N - 2)) + then return 43.0 / 48.0; + else if ((i == 3) || (i == N - 3)) + then return 49.0 / 48.0; + else + return 1.0; + + default: + error_exit(ERROR_EXIT, + "***** patch::integration_coeff(): unknown method=(int)%d!\n" + " (this should never happen!)\n", + int(method)); /*NOTREACHED*/ + } + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function returns a reference to the ghost zone on a specified + // edge, after first assert()ing that the edge belongs to this patch. + // + // N.b. This function can't be inline in "patch.hh" because it needs + // member functions of class patch_edge, which comes after class patch + // in our #include order. + // + ghost_zone &patch::ghost_zone_on_edge(const patch_edge &e) + const + { + assert(e.my_patch() == *this); + return minmax_ang_ghost_zone(e.is_min(), e.is_rho()); + } + + //****************************************************************************** + + // + // This function determines which of the two adjacent ghost zones meeting + // at a specified corner, contains a specified point. If the point isn't + // in either ghost zone, an error_exit() is done. If the point is in both + // ghost zones, it's arbitrary which one will be chosen. + // + // Arguments: + // {rho,sigma}_is_min = Specify the corner (and implicitly the ghost zones). + // irho,isigma = Specify the point. + // + // Results: + // This function returns (a reference to) the desired ghost zone. + ghost_zone &patch::corner_ghost_zone_containing_point(bool rho_is_min, bool sigma_is_min, + int irho, int isigma) + const + { + ghost_zone &rho_gz = minmax_rho_ghost_zone(rho_is_min); + ghost_zone &sigma_gz = minmax_sigma_ghost_zone(sigma_is_min); + + const patch_edge &rho_edge = rho_gz.my_edge(); + const patch_edge &sigma_edge = sigma_gz.my_edge(); + + const int rho_iperp = rho_edge.iperp_of_irho_isigma(irho, isigma); + const int rho_ipar = rho_edge.ipar_of_irho_isigma(irho, isigma); + const int sigma_iperp = sigma_edge.iperp_of_irho_isigma(irho, isigma); + const int sigma_ipar = sigma_edge.ipar_of_irho_isigma(irho, isigma); + + const bool is_in_rho_ghost_zone = rho_gz.is_in_ghost_zone(rho_iperp, rho_ipar); + const bool is_in_sigma_ghost_zone = sigma_gz.is_in_ghost_zone(sigma_iperp, sigma_ipar); + + // check that point is in at least one ghost zone + if (!is_in_rho_ghost_zone && !is_in_sigma_ghost_zone) + then error_exit(ERROR_EXIT, + "***** patch::corner_ghost_zone_containing_point():\n" + " neither ghost zone contains point (this should never happen)!\n" + " patch=%s rho_is_min=(int)%d sigma_is_min=(int)%d\n" + " irho=%d isigma=%d\n", + name(), int(rho_is_min), int(sigma_is_min), + irho, isigma); /*NOTREACHED*/ + + return is_in_rho_ghost_zone ? rho_gz : sigma_gz; + } + + //****************************************************************************** + + // + // This function determines which ghost zone contains a specified + // noncorner point. + // + // If the point isn't in any ghost zone of this patch, or if the point + // is in the corner of a ghost zone, an error_exit() is done. + // + // Arguments: + // irho,isigma = Specify the point. + // + // Results: + // This function returns (a reference to) the desired ghost zone. + ghost_zone &patch::ghost_zone_containing_noncorner_point(int irho, int isigma) + const + { + // n.b. these loops must use _int_ variables for the loop + // to terminate! + for (int want_min = false; want_min <= true; ++want_min) + { + for (int want_rho = false; want_rho <= true; ++want_rho) + { + const patch_edge &e = minmax_ang_patch_edge(want_min, want_rho); + const int iperp = e.iperp_of_irho_isigma(irho, isigma); + const int ipar = e.ipar_of_irho_isigma(irho, isigma); + + ghost_zone &gz = minmax_ang_ghost_zone(want_min, want_rho); + if (gz.is_in_ghost_zone(iperp, ipar) && gz.my_edge().ipar_is_in_noncorner(ipar)) + then return gz; + } + } + + error_exit(ERROR_EXIT, + "***** patch::ghost_zone_containing_noncorner_point():\n" + " no ghost zone contains point (this should never happen)!\n" + " patch=%s irho=%d isigma=%d\n", + name(), irho, isigma); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function assert()s that a specified ghost zone of this patch + // hasn't already been set up, then constructs it as a mirror-symmetry + // ghost zone and properly links this to/from the patch. + // + void patch::create_mirror_symmetry_ghost_zone(const patch_edge &my_edge) + { + // make sure we belong to the right patch + assert(my_edge.my_patch() == *this); + + symmetry_ghost_zone *temp = new symmetry_ghost_zone(my_edge); + set_ghost_zone(my_edge, temp); + } + + //****************************************************************************** + + // + // This function assert()s that a specified ghost zone of this patch + // hasn't already been set up, then creates it as a periodic-symmetry + // ghost zone and properly links this to/from the patch. + // + void patch::create_periodic_symmetry_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, + bool is_ipar_map_plus) + { + // make sure we belong to the right patch + assert(my_edge.my_patch() == *this); + + int my_sample_ipar = my_edge.min_ipar_without_corners(); + int other_sample_ipar = is_ipar_map_plus + ? other_edge.min_ipar_without_corners() + : other_edge.max_ipar_without_corners(); + + symmetry_ghost_zone *temp = new symmetry_ghost_zone(my_edge, other_edge, + my_sample_ipar, other_sample_ipar, + is_ipar_map_plus); + set_ghost_zone(my_edge, temp); + } + + //****************************************************************************** + + // + // This function assert()s that a specified ghost zone of this patch + // hasn't already been set up, then creates it as an interpatch ghost + // zone (with lots of NULL pointers for info we can't compute yet) + // and properly links this to/from the patch. + // + void patch::create_interpatch_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, + int patch_overlap_width) + { + // make sure we belong to the right patch + assert(my_edge.my_patch() == *this); + + interpatch_ghost_zone *temp = new interpatch_ghost_zone(my_edge, other_edge, + patch_overlap_width); + set_ghost_zone(my_edge, temp); + } + + //****************************************************************************** + + // + // This is a helper function for setup_*_ghost_zone(). This function + // assert()s that one of the ghost zone pointers (which one is selected + // by edge ) is NULL, then stores a value in it. + // + void patch::set_ghost_zone(const patch_edge &edge, ghost_zone *gzp) + { + ghost_zone *&ghost_zone_ptr_to_set = edge.is_min() + ? (edge.is_rho() ? min_rho_ghost_zone_ : min_sigma_ghost_zone_) + : (edge.is_rho() ? max_rho_ghost_zone_ : max_sigma_ghost_zone_); + + assert(ghost_zone_ptr_to_set == NULL); + ghost_zone_ptr_to_set = gzp; + } + + //****************************************************************************** + + // + // This function finds which patch edge is adjacent to a neighboring + // patch q, or does an error_exit() if q isn't actually a neighboring patch. + // The computation is done using only (rho,sigma) coordinate sets and + // min/max dang bounds ==> it's ok to use this function in setting up + // interpatch ghost zones. + // + // Arguments: + // q = The (supposedly) neighboring patch. + // patch_overlap_width = The number of grid points these patches overlap. + // If this is nonzero, then these patches must have the + // same grid spacing in the perpendicular direction. + // + const patch_edge &patch::edge_adjacent_to_patch(const patch &q, + int patch_overlap_width /* = 0 */) + const + { + const patch &p = *this; + + // which (rho,sigma) coordinate do the patches have in common? + // ... this is the perp coordinate for the border + const local_coords::coords_set common_coord_set = p.coords_set_rho_sigma() & q.coords_set_rho_sigma(); + + // is this coordinate rho or sigma in each patch? + const bool common_is_p_rho = (common_coord_set == p.coords_set_rho()); + const bool common_is_p_sigma = (common_coord_set == p.coords_set_sigma()); + if ((common_is_p_rho ^ common_is_p_sigma) != 0x1) + then error_exit(ERROR_EXIT, + "***** patch::edge_adjacent_to_patch():\n" + " common coordinate isn't exactly one of p.{rho,sigma}!\n" + " p.name()=\"%s\" q.name()=\"%s\"\n" + " common_coord_set=%s\n" + " common_is_p_rho=%d common_is_p_sigma=%d\n", + p.name(), q.name(), + local_coords::name_of_coords_set(common_coord_set), + int(common_is_p_rho), int(common_is_p_sigma)); + /*NOTREACHED*/ + const bool common_is_q_rho = (common_coord_set == q.coords_set_rho()); + const bool common_is_q_sigma = (common_coord_set == q.coords_set_sigma()); + if ((common_is_q_rho ^ common_is_q_sigma) != 0x1) + then error_exit(ERROR_EXIT, + "***** patch::edge_adjacent_to_patch():\n" + " common coordinate isn't exactly one of q.{rho,sigma}!\n" + " p.name()=\"%s\" q.name()=\"%s\"\n" + " common_coord_set=%s\n" + " common_is_q_rho=%d common_is_q_sigma=%d\n", + p.name(), q.name(), + local_coords::name_of_coords_set(common_coord_set), + int(common_is_q_rho), int(common_is_q_sigma)); + /*NOTREACHED*/ + + // how much do the patches overlap? + // ... eg patch_overlap_width = 3 would be + // p p p p p + // q q q q q + // so the overlap would be (patch_overlap_width-1) * delta = 2 * delta + if ((patch_overlap_width - 1 != 0) && jtutil::fuzzy::NE(p.delta_dang(common_is_p_rho), + q.delta_dang(common_is_q_rho))) + then error_exit(ERROR_EXIT, + "***** patch::edge_adjacent_to_patch():\n" + " patch_overlap_width != 0 must have same perp grid spacing in both patches!\n" + " p.name()=\"%s\" q.name()=\"%s\"\n" + " common_coord_set=%s\n" + " common_is_p_rho=%d common_is_q_rho=%d\n" + " p.delta_dang(common_is_p_rho)=%g\n" + " q.delta_dang(common_is_q_rho)=%g\n", + p.name(), q.name(), + local_coords::name_of_coords_set(common_coord_set), + int(common_is_p_rho), int(common_is_q_rho), + double(p.delta_dang(common_is_p_rho)), + double(q.delta_dang(common_is_q_rho))); /*NOTREACHED*/ + + const fp doverlap = fp(patch_overlap_width - 1) * p.delta_dang(common_is_p_rho); + + // where is the common boundary relative to the min/max sides of each patch? + const bool common_is_p_min_q_max = local_coords::fuzzy_EQ_dang(p.min_dang(common_is_p_rho), + q.max_dang(common_is_q_rho) - doverlap); + const bool common_is_p_max_q_min = local_coords::fuzzy_EQ_dang(p.max_dang(common_is_p_rho), + q.min_dang(common_is_q_rho) + doverlap); + if ((common_is_p_min_q_max ^ common_is_p_max_q_min) != 0x1) + then error_exit(ERROR_EXIT, + "***** patch::edge_adjacent_to_patch():\n" + " common coordinate isn't exactly one of {pmax/qmin, pmin/qmax}!\n" + " p.name()=\"%s\" q.name()=\"%s\"\n" + " common_coord_set=%s\n" + " common_is_p_rho=%d common_is_q_rho=%d\n" + " p.delta_dang(common_is_p_rho)=%g\n" + " q.delta_dang(common_is_q_rho)=%g\n" + " patch_overlap_width=%d doverlap=%g\n" + " common_is_p_min_q_max=%d common_is_p_max_q_min=%d\n", + p.name(), q.name(), + local_coords::name_of_coords_set(common_coord_set), + int(common_is_p_rho), int(common_is_q_rho), + double(p.delta_dang(common_is_p_rho)), + double(q.delta_dang(common_is_q_rho)), + patch_overlap_width, double(doverlap), + int(common_is_p_min_q_max), int(common_is_p_max_q_min)); + /*NOTREACHED*/ + + return p.minmax_ang_patch_edge(common_is_p_min_q_max, common_is_p_rho); + } + + //****************************************************************************** + + // + // This function verifies (via assert()) that all ghost zones of this + // patch have been fully set up. + // + void patch::assert_all_ghost_zones_fully_setup() const + { + assert(min_rho_ghost_zone_ != NULL); + assert(max_rho_ghost_zone_ != NULL); + assert(min_sigma_ghost_zone_ != NULL); + assert(max_sigma_ghost_zone_ != NULL); + + // these calls are no-ops for non-interpatch ghost zones + min_rho_ghost_zone().assert_fully_setup(); + max_rho_ghost_zone().assert_fully_setup(); + min_sigma_ghost_zone().assert_fully_setup(); + max_sigma_ghost_zone().assert_fully_setup(); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/patch.h b/AMSS_NCKU_source/AHF_Direct/patch.h similarity index 97% rename from AMSS_NCKU_source/patch.h rename to AMSS_NCKU_source/AHF_Direct/patch.h index 36833bc..1440d0b 100644 --- a/AMSS_NCKU_source/patch.h +++ b/AMSS_NCKU_source/AHF_Direct/patch.h @@ -1,1150 +1,1150 @@ -#ifndef TPATCH_H -#define TPATCH_H -namespace AHFinderDirect -{ - - //***************************************************************************** - //***************************************************************************** - //***************************************************************************** - - // - // ***** how patch boundaries are handled ***** - // - - // - // Basically, we handle patch boundaries using the usual "ghost zone" - // technique, interpolating values from neighboring patches as necessary. - // - // In more detail, we use the following interrelated types of objects - // to handle patch boundaries: - // - // A patch_edge object represents the basic geometry of a min/max - // rho/sigma side of a patch, i.e. it provides which-side-am-I predicates, - // coordinate conversions between (perp,par) and (rho,sigma), etc. - // Every patch has (points to) 4 patch_edge objects, one for each of - // the patch's sides. - // - // A ghost_zone object describes a patch's ghost zone, and knows how - // to fill in gridfns there based on either the patch system's symmetry - // or interpolation from a neighboring patch. ghost_zone is an abstract - // base class, from which we derive two classes: - // * A symmetry_ghost_zone object describes a ghost zone which is a - // (discrete) symmetry of spacetime, either mirror-image or periodic. - // Such an object knows how to fill in ghost-zone gridfn data from - // the "other side" of the symmetry. - // * An interpatch_ghost_zone object describes a ghost zone which - // overlaps another patch. Such an object knows how to get ghost - // zone gridfn data from the other patch. More accurately, it gets - // the data by asking (calling) the appropriate one of the other - // patch's patch_interp objects. - // Every patch has (points to) 4 ghost_zone objects, one for each of - // the patch's sides. - // - // A patch_interp object does the actual interpolation of data from - // within a patch (for filling in data in another patch's ghost zone). - // A patch_interp object points to the patch and patch_edge where it - // will be interpolating. - // - // For example, suppose we have two patches p and q with a common - // angular boundary. Then the desired network of pointers looks like - // this (omitting the patch_edge objects for simplicity): - // - // +-----+ +-----+ - // | | <--> p.interpatch_ghost_zone ---> q.patch_interp ---> | | - // | p | | q | - // | | <--- p.patch_interp <--- q.interpatch_ghost_zone <--> | | - // +-----+ +-----+ - // - // Because of the mutual pointers, we can't easily construct (say) p's - // interpatch_ghost_zone until after q itself has been constructed, and - // vice versa. Moreover, the patch_interp:: constructor needs the - // adjacent-side ghost_zone objects to already exist, and it needs to - // know the iperp range of the interpolation region, which can only be - // computed from the adjacent-patch interpatch_ghost_zone object. - // - // The solution adopted here is to use a 3-phase algorithm, ultimately - // driven by the patch_system constructor: - // * The patch constructors themselves construct the patch_edge objects - // and links them to/from the patches. - // * The patch_system constructor calls the appropriate functions - // patch::create_mirror_symmetry_ghost_zone() - // patch::create_periodic_symmetry_ghost_zone() - // patch::create_interpatch_ghost_zone() - // to construct the ghost_zone objects and link them to/from the - // patches. - // * The patch_system constructor calls the functions - // interpatch_ghost_zone::finish_setup() - // to finish setting up the interpatch_ghost_zone objects, construct - // the other patch's patch_interp objects, and finish linking the - // interpatch_ghost_zone objects to the patch_interp objects. - // - - //***************************************************************************** - //***************************************************************************** - //***************************************************************************** - - // - // patch - abstract base class to describe a generic coordinate/grid patch - // - - // - // There are 3 types of patches, z, x, and y. Each type uses two of - // (mu,nu,phi) as its angular coordinates (rho,sigma); the remaining - // "unused" one of (mu,nu,phi) is tau. - // - // z patch ==> (rho,sigma) = (mu,nu) tau = phi - // x patch ==> (rho,sigma) = (nu,phi) tau = mu - // y patch ==> (rho,sigma) = (mu,phi) tau = nu - // - - // forward declarations - class patch_edge; - class ghost_zone; - class symmetry_ghost_zone; - class interpatch_ghost_zone; - class patch_interp; - class patch_system; - - // - // const qualifiers refer to the gridfn values - // - class patch - : public fd_grid - { - // - // ***** patch system, type, and coordinate metadata ***** - // - public: - // to which patch system do we belong? - patch_system &my_patch_system() const - { - return my_patch_system_; - } - - // each patch has a unique 0-origin small-integer patch number, - // usually denoted pn - int patch_number() const { return patch_number_; } - - // each patch has a unique human-readable patch name for debugging etc - const char *name() const { return name_; } // typically "+z" etc - - // are we a +[xyz] or -[xyz] patch? - bool is_plus() const { return is_plus_; } - - // ... values for the is_plus_in constructor argument - // FIXME: these should really be bool, but then we couldn't - // use the "enum hack" for in-class constants - enum - { - patch_is_plus = true, - patch_is_minus = false - }; - - // are we a (+/-) x or y or z patch? - // ... n.b. type is `char' because this is handy for both - // switch() and human-readable printing - char ctype() const { return ctype_; } // 'z' or 'x' or 'y' - - // are two patches really the same patch? - // n.b. this does *not* compare any of the gridfn data! - bool operator==(const patch &other_patch) const - { - return this == &other_patch; - } - bool operator!=(const patch &other_patch) const - { - return !operator==(other_patch); - } - - // (rho,sigma,tau) coordinates as singleton coordinate sets - local_coords::coords_set coords_set_rho() const - { - return coords_set_rho_; - } - local_coords::coords_set coords_set_sigma() const - { - return coords_set_sigma_; - } - local_coords::coords_set coords_set_tau() const - { - return coords_set_tau_; - } - - // {rho,sigma} coordinate set - local_coords::coords_set coords_set_rho_sigma() const - { - return coords_set_rho() | coords_set_sigma(); - } - - // (rho,sigma) coordinates as human-readable character strings - // (for labelling output files etc) - virtual const char *name_of_rho() const = 0; - virtual const char *name_of_sigma() const = 0; - - // - // ***** (rho,sigma,tau) coordinates ***** - // - public: - // convert (rho,sigma) --> tau - virtual fp tau_of_rho_sigma(fp rho, fp sigma) const = 0; - - // convert (rho,sigma) --> (mu,nu,phi) - virtual fp mu_of_rho_sigma(fp rho, fp sigma) const = 0; - virtual fp nu_of_rho_sigma(fp rho, fp sigma) const = 0; - virtual fp phi_of_rho_sigma(fp rho, fp sigma) const = 0; - - // convert (rho,sigma) <--> usual polar spherical (theta,phi) - virtual void theta_phi_of_rho_sigma(fp rho, fp sigma, - fp &ps_theta, fp &ps_phi) - const = 0; - virtual void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, - fp &rho, fp &sigma) - const = 0; - - // convert (r,rho,sigma) <--> local (x,y,z) - virtual void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, - fp &x, fp &y, fp &z) - const = 0; - virtual fp rho_of_xyz(fp x, fp y, fp z) const = 0; - virtual fp sigma_of_xyz(fp x, fp y, fp z) const = 0; - - // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) - // with respect to the local coordinate system - virtual void xyzcos_of_rho_sigma(fp rho, fp sigma, - fp &xcos, fp &ycos, fp &zcos) - const = 0; - - // partial (x,y,z) / partial (rho,sigma) - virtual void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, - fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, - fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, - fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) - const = 0; - - // partial (rho,sigma) / partial (x,y,z) - virtual fp partial_rho_wrt_x(fp x, fp y, fp z) const = 0; - virtual fp partial_rho_wrt_y(fp x, fp y, fp z) const = 0; - virtual fp partial_rho_wrt_z(fp x, fp y, fp z) const = 0; - virtual fp partial_sigma_wrt_x(fp x, fp y, fp z) const = 0; - virtual fp partial_sigma_wrt_y(fp x, fp y, fp z) const = 0; - virtual fp partial_sigma_wrt_z(fp x, fp y, fp z) const = 0; - - // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) - virtual fp partial2_rho_wrt_xx(fp x, fp y, fp z) const = 0; - virtual fp partial2_rho_wrt_xy(fp x, fp y, fp z) const = 0; - virtual fp partial2_rho_wrt_xz(fp x, fp y, fp z) const = 0; - virtual fp partial2_rho_wrt_yy(fp x, fp y, fp z) const = 0; - virtual fp partial2_rho_wrt_yz(fp x, fp y, fp z) const = 0; - virtual fp partial2_rho_wrt_zz(fp x, fp y, fp z) const = 0; - virtual fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const = 0; - virtual fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const = 0; - virtual fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const = 0; - virtual fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const = 0; - virtual fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const = 0; - virtual fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const = 0; - - // compute (rho,sigma) 2-D induced metric from 3-D xyz metric - // as per p.33 of my apparent horizon finding notes - // ... returns Jacobian of (rho,sigma) 2-D induced metric - fp rho_sigma_metric(fp r, fp rho, fp sigma, - fp partial_surface_r_wrt_rho, - fp partial_surface_r_wrt_sigma, - fp g_xx, fp g_xy, fp g_xz, - fp g_yy, fp g_yz, - fp g_zz, - fp &g_rho_rho, fp &g_rho_sigma, - fp &g_sigma_sigma) - const; - - // plotting coordinates (dpx,dpy) - // ... character string describing how (dpx,dpy) are - // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" - // (used for labelling output files) - virtual const char *name_of_dpx() const = 0; - virtual const char *name_of_dpy() const = 0; - // ... (irho,isimga) --> (px,py) - virtual fp dpx_of_rho_sigma(fp rho, fp sigma) const = 0; - virtual fp dpy_of_rho_sigma(fp rho, fp sigma) const = 0; - - // - // ***** line/surface integrals ***** - // - public: - // - // The following enum describes the integration methods supported - // by integrate_gridfn() . - // - // For convenience of exposition we describe the methods as if for - // 1-D integration, but integrate_gridfn() actually does 2-D - // (surface) integration over the patch. - // - // Suppose we're computing $\int_{x_0}^{x^N} f(x) \, dx$, using the - // equally spaced integration points $f_0$, $f_1$, \dots, $f_N$, - // spaced $\Delta x$ apart. Then the integration methods are as - // follows, with the convention that $\langle X \rangle$ denotes - // indefinite repetition of the "X" terms, depending on N: - // - enum integration_method - { - // Trapezoid rule - // ... character-string name "trapezoid" or "trapezoid rule" - // ... 2nd order accurate for smooth functions - // ... requires N >= 1 - // $$ - // \Delta x \left[ - // \half f_0 - // + \langle - // f_k - // \rangle - // + \half f_N - // \right] - // $$ - integration_method__trapezoid, - - // Simpson's rule - // ... character-string name "Simpson" or "Simpson's rule" - // ... 4th order accurate for smooth functions - // ... requires N >= 2 and N even - // $$ - // \Delta x \left[ - // \frac{1}{3} f_0 - // + \frac{4}{3} f_1 - // + \langle - // \frac{2}{3} f_{2k} + \frac{4}{3} f_{2k+1} - // \rangle - // + \frac{1}{3} f_N - // \right] - // $$ - integration_method__Simpson, - - // Simpson's rule, variant form - // ... characgter-string name "Simpson (variant)" - // or "Simpson's rule (variant)" - // ... described in Numerical Recipes 1st edition (4.1.14) - // ... 4th order accurate for smooth functions - // ... requires N >= 7 - // $$ - // \Delta x \left[ - // \frac{17}{48} f_0 - // + \frac{59}{48} f_1 - // + \frac{43}{48} f_2 - // + \frac{49}{48} f_3 - // + \langle - // f_k - // \rangle - // + \frac{49}{48} f_{N-3} - // + \frac{43}{48} f_{N-2} - // + \frac{59}{48} f_{N-1} - // + \frac{17}{48} f_N - // \right] - // $$ - integration_method__Simpson_variant, - - // automatic choice of the "best" one of the above methods: - // ... i.e. choose Simpson's rule or variant if applicable, - // otherwise trapezoid rule - // N == 2 Simpson's rule - // N == 3 trapezoid rule - // N == 4 Simpson's rule - // N == 5 trapezoid rule - // N == 6 Simpson's rule - // N >= 7 Simpson's rule, variant form - integration_method__automatic_choice // no comma here! - }; - - // decode character string name into internal enum - static enum integration_method - decode_integration_method(const char method_string[]); - - // compute the arc length of a surface in the specified plane - // (must be one of "xy", "xz", or "yz") over the patch's nominal bounds - // ... error_exit() if plane is invalid and/or - // the patch doesn't contain that coordinate plane - virtual fp plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const = 0; - - // ... along the rho direction (i.e. in a dsigma=constant plane - // where dsigma is a multiple of 90 degrees) - fp rho_arc_length(int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const; - // ... along the sigma direction (i.e. in a drho=constant plane - // where drho is a multiple of 90 degrees) - fp sigma_arc_length(int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const; - - // compute the surface integral of a gridfn over the patch's - // nominal area, - // $\int f(\rho,\sigma) \, dA$ - // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ - // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma) - // ... integration method selected by method argument - // ... src gridfn may be either nominal-grid or ghosted-grid - // (n.b. in the latter case the integral is still done - // only over the patch's nominal area) - fp integrate_gridfn(int unknown_src_gfn, - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const; - - // compute integration coefficient $c_i$ where - // $\int_{x_0}^{x_N} f(x) \, dx - // \approx \Delta x \, \sum_{i=0}^N c_i f(x_i)$ - private: - static fp integration_coeff(enum integration_method method, int N, int i); - - // - // ***** patch edges **** - // - public: - const patch_edge &min_rho_patch_edge() const - { - return min_rho_patch_edge_; - } - const patch_edge &max_rho_patch_edge() const - { - return max_rho_patch_edge_; - } - const patch_edge &min_sigma_patch_edge() const - { - return min_sigma_patch_edge_; - } - const patch_edge &max_sigma_patch_edge() const - { - return max_sigma_patch_edge_; - } - const patch_edge &minmax_ang_patch_edge(bool want_min, bool want_rho) - const - { - return want_min ? (want_rho ? min_rho_patch_edge() - : min_sigma_patch_edge()) - : (want_rho ? max_rho_patch_edge() - : max_sigma_patch_edge()); - } - - // find which patch edge is adjacent to neighboring patch q, - // or error_exit() if it's not actually a neighboring patch - // ... computation done using only (rho,sigma) coordinate sets - // and min/max dang bounds ==> ok to use in setting up ghost zones - // ... patch_overlap_width = number of grid points (grid spacings - // in the perpendicular direction) these patches' nominal grids - // overlap, - // ... if this is nonzero, then these patches must have - // the *same* grid spacing in the perpendicular direction - // ... e.g. delta_dang = 5, this patch max_dang = 50, - // other patch min_dang = 40 ==> patch_overlap_width = 3 - // p p p p p - // q q q q q - const patch_edge &edge_adjacent_to_patch(const patch &q, - int patch_overlap_width = 0) - const; - - // - // ***** ghost zones ***** - // - public: - ghost_zone &min_rho_ghost_zone() const - { - assert(min_rho_ghost_zone_ != NULL); - return *min_rho_ghost_zone_; - } - ghost_zone &max_rho_ghost_zone() const - { - assert(max_rho_ghost_zone_ != NULL); - return *max_rho_ghost_zone_; - } - ghost_zone &min_sigma_ghost_zone() const - { - assert(min_sigma_ghost_zone_ != NULL); - return *min_sigma_ghost_zone_; - } - ghost_zone &max_sigma_ghost_zone() const - { - assert(max_sigma_ghost_zone_ != NULL); - return *max_sigma_ghost_zone_; - } - ghost_zone &minmax_rho_ghost_zone(bool want_min) - const - { - return want_min ? min_rho_ghost_zone() - : max_rho_ghost_zone(); - } - ghost_zone &minmax_sigma_ghost_zone(bool want_min) - const - { - return want_min ? min_sigma_ghost_zone() - : max_sigma_ghost_zone(); - } - - ghost_zone &minmax_ang_ghost_zone(bool want_min, bool want_rho) - const - { - return want_rho ? minmax_rho_ghost_zone(want_min) - : minmax_sigma_ghost_zone(want_min); - } - - ghost_zone &ghost_zone_on_edge(const patch_edge &e) const; - - // which of the two ghost zones at a specified corner, - // contains a specified point? - ghost_zone &corner_ghost_zone_containing_point(bool rho_is_min, bool sigma_is_min, // specifies corner - int irho, int isigma) // specifies point - const; - - // which ghost zone contains a specified noncorner point? - ghost_zone &ghost_zone_containing_noncorner_point(int irho, int isigma) - const; - - // - // ***** set up ghost zones - // - public: - // assert() that this ghost zone hasn't been set up yet, - // then set it up as mirror-symmetry - void create_mirror_symmetry_ghost_zone(const patch_edge &edge); - - // assert() that this ghost zone hasn't been set up yet, - // then set it up as periodic-symmetry - void create_periodic_symmetry_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, - bool ipar_map_is_plus); - - // assert() that this ghost zone hasn't been set up yet, - // then set it up as interpatch - // ... this only sets up ghost zone in skeletal form; use - // interpatch_ghost_zone::finish_setup() to complete - // the setup process - void create_interpatch_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, - int patch_overlap_width); - - // assert() that all ghost zones - // are fully setup - void assert_all_ghost_zones_fully_setup() const; - - private: - // helper function for setup_*_ghost_zone(): - // assert() that ghost zone pointer on specified edge is NULL - // (i.e. that we haven't already setup this ghost zone), - // then assign new value to it - void set_ghost_zone(const patch_edge &edge, ghost_zone *gzp); - - // - // ***** constructor, destructor, et al ***** - // - protected: - // ... used only from derived classes - // ... doesn't set up ghost zone info, since this depends on - // knowing our neighbouring patches, which might not exist yet - // ... saves a pointer to name_in[], so this should have a - // lifetime at least as long as that of this object - patch(patch_system &my_patch_system_in, int patch_number_in, - const char name_in[], bool is_plus_in, char ctype_in, - local_coords::coords_set coords_set_rho_in, - local_coords::coords_set coords_set_sigma_in, - local_coords::coords_set coords_set_tau_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in); - - public: - // destructor must be virtual to allow destruction - // of derived classes via ptr/ref to this class - virtual ~patch(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - patch(const patch &rhs); - patch &operator=(const patch &rhs); - - // - // ***** data members ***** - // - private: - // type/coordinate metadata - patch_system &my_patch_system_; - const int patch_number_; - const char *name_; - const bool is_plus_; - const char ctype_; - const local_coords::coords_set coords_set_rho_, - coords_set_sigma_, - coords_set_tau_; - - // edges - const patch_edge &min_rho_patch_edge_; - const patch_edge &max_rho_patch_edge_; - const patch_edge &min_sigma_patch_edge_; - const patch_edge &max_sigma_patch_edge_; - - // ghost zones - // ... pointers are set to NULL by ctor, - // reset to non-NULL by set_ghost_zone(), which is called by - // create_mirror_symmetry_ghost_zone() - // create_periodic_symmetry_ghost_zone() - // create_interpatch_ghost_zone() - ghost_zone *min_rho_ghost_zone_; - ghost_zone *max_rho_ghost_zone_; - ghost_zone *min_sigma_ghost_zone_; - ghost_zone *max_sigma_ghost_zone_; - }; - - //***************************************************************************** - //***************************************************************************** - //***************************************************************************** - - // - // This class describes a +/- z patch. It doesn't define any new - // functions not already present in class patch ; it "just" defines - // non-virtual versions of all the pure virtual functions defined there. - // - // z patch ==> (rho,sigma) = (mu,nu) tau = phi - // - class z_patch - : public patch - { - public: - // human-readable names of (rho,sigma) - const char *name_of_rho() const { return "mu"; } - const char *name_of_sigma() const { return "nu"; } - - // convert (rho,sigma) --> tau - fp tau_of_rho_sigma(fp rho, fp sigma) const - { - return local_coords::phi_of_mu_nu(rho, sigma); - } - - // convert (rho,sigma) --> (mu,nu,phi) - fp mu_of_rho_sigma(fp rho, fp sigma) const { return rho; } - fp nu_of_rho_sigma(fp rho, fp sigma) const { return sigma; } - fp phi_of_rho_sigma(fp rho, fp sigma) const - { - return local_coords::phi_of_mu_nu(rho, sigma); - } - - // convert (rho,sigma) <--> usual polar spherical (theta,phi) - void theta_phi_of_rho_sigma(fp rho, fp sigma, fp &ps_theta, fp &ps_phi) - const - { - local_coords::theta_phi_of_mu_nu(rho, sigma, ps_theta, ps_phi); - } - void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, fp &rho, fp &sigma) - const - { - local_coords::mu_nu_of_theta_phi(ps_theta, ps_phi, rho, sigma); - } - - // convert (r,rho,sigma) <--> (x,y,z) - void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, fp &x, fp &y, fp &z) - const - { - local_coords::xyz_of_r_mu_nu(r, rho, sigma, x, y, z); - } - fp rho_of_xyz(fp x, fp y, fp z) const - { - return modulo_reduce_rho(local_coords::mu_of_yz(y, z)); - } - fp sigma_of_xyz(fp x, fp y, fp z) const - { - return modulo_reduce_sigma(local_coords::nu_of_xz(x, z)); - } - - // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) - // with respect to the local coordinate system - void xyzcos_of_rho_sigma(fp rho, fp sigma, - fp &xcos, fp &ycos, fp &zcos) - const - { - local_coords::xyzcos_of_mu_nu(rho, sigma, xcos, ycos, zcos); - } - - // partial (x,y,z) / partial (rho,sigma) - void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, - fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, - fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, - fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) - const - { - local_coords::partial_xyz_wrt_r_mu_nu(r, rho, sigma, - partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, - partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, - partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); - } - - // partial (rho,sigma) / partial (x,y,z) - fp partial_rho_wrt_x(fp x, fp y, fp z) const { return 0.0; } - fp partial_rho_wrt_y(fp x, fp y, fp z) const - { - return local_coords::partial_mu_wrt_y(y, z); - } - fp partial_rho_wrt_z(fp x, fp y, fp z) const - { - return local_coords::partial_mu_wrt_z(y, z); - } - fp partial_sigma_wrt_x(fp x, fp y, fp z) const - { - return local_coords::partial_nu_wrt_x(x, z); - } - fp partial_sigma_wrt_y(fp x, fp y, fp z) const { return 0.0; } - fp partial_sigma_wrt_z(fp x, fp y, fp z) const - { - return local_coords::partial_nu_wrt_z(x, z); - } - - // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) - fp partial2_rho_wrt_xx(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_xy(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_xz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_yy(fp x, fp y, fp z) const - { - return local_coords::partial2_mu_wrt_yy(y, z); - } - fp partial2_rho_wrt_yz(fp x, fp y, fp z) const - { - return local_coords::partial2_mu_wrt_yz(y, z); - } - fp partial2_rho_wrt_zz(fp x, fp y, fp z) const - { - return local_coords::partial2_mu_wrt_zz(y, z); - } - fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const - { - return local_coords::partial2_nu_wrt_xx(x, z); - } - fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const - { - return local_coords::partial2_nu_wrt_xz(x, z); - } - fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const - { - return local_coords::partial2_nu_wrt_zz(x, z); - } - - // plotting coordinates (px,py) - // ... character string describing how (dpx,dpy) are - // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" - // (used for labelling output files) - const char *name_of_dpx() const - { - return "dsigma = dnu"; - } - const char *name_of_dpy() const - { - return is_plus() ? "drho = dmu" : "180 - drho = 180 - dmu"; - } - // ... (irho,isimga) --> (px,py) - fp dpx_of_rho_sigma(fp rho, fp sigma) const - { - return jtutil::degrees_of_radians(sigma); - } - fp dpy_of_rho_sigma(fp rho, fp sigma) const - { - const fp drho = jtutil::degrees_of_radians(rho); - return is_plus() ? drho : 180.0 - drho; - } - - // compute the arc length of a surface in the specified plane - // (must be one of "xz" or "yz") over the patch's nominal bounds - // ... error_exit() if plane is invalid - fp plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const; - - // constructor, destructor - z_patch(patch_system &my_patch_system_in, int patch_number_in, - const char *name_in, bool is_plus_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in); - ~z_patch() {} - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - z_patch(const z_patch &rhs); - z_patch &operator=(const z_patch &rhs); - }; - - //***************************************************************************** - - // - // This class describes a +/- x patch. It doesn't define any new - // functions not already present in class patch ; it "just" defines - // non-virtual versions of all the pure virtual functions defined there. - // - // x patch ==> (rho,sigma) = (nu,phi) tau = mu - // - class x_patch - : public patch - { - public: - // human-readable names of (rho,sigma) - const char *name_of_rho() const { return "nu"; } - const char *name_of_sigma() const { return "phi"; } - - // convert (rho,sigma) --> tau - fp tau_of_rho_sigma(fp rho, fp sigma) const - { - return local_coords::mu_of_nu_phi(rho, sigma); - } - - // convert (rho,sigma) --> (mu,nu,phi) - fp nu_of_rho_sigma(fp rho, fp sigma) const { return rho; } - fp phi_of_rho_sigma(fp rho, fp sigma) const { return sigma; } - fp mu_of_rho_sigma(fp rho, fp sigma) const - { - return local_coords::mu_of_nu_phi(rho, sigma); - } - - // convert (rho,sigma) <--> usual polar spherical (theta,phi) - void theta_phi_of_rho_sigma(fp rho, fp sigma, fp &ps_theta, fp &ps_phi) - const - { - local_coords::theta_phi_of_nu_phi(rho, sigma, ps_theta, ps_phi); - } - void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, fp &rho, fp &sigma) - const - { - local_coords::nu_phi_of_theta_phi(ps_theta, ps_phi, rho, sigma); - } - - // convert (r,rho,sigma) <--> (x,y,z) - void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, fp &x, fp &y, fp &z) - const - { - local_coords::xyz_of_r_nu_phi(r, rho, sigma, x, y, z); - } - fp rho_of_xyz(fp x, fp y, fp z) const - { - return modulo_reduce_rho(local_coords::nu_of_xz(x, z)); - } - fp sigma_of_xyz(fp x, fp y, fp z) const - { - return modulo_reduce_sigma(local_coords::phi_of_xy(x, y)); - } - - // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) - // with respect to the local coordinate system - void xyzcos_of_rho_sigma(fp rho, fp sigma, - fp &xcos, fp &ycos, fp &zcos) - const - { - local_coords::xyzcos_of_nu_phi(rho, sigma, xcos, ycos, zcos); - } - - // partial (x,y,z) / partial (rho,sigma) - void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, - fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, - fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, - fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) - const - { - local_coords::partial_xyz_wrt_r_nu_phi(r, rho, sigma, - partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, - partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, - partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); - } - - // partial (rho,sigma) / partial (x,y,z) - fp partial_rho_wrt_x(fp x, fp y, fp z) const - { - return local_coords::partial_nu_wrt_x(x, z); - } - fp partial_rho_wrt_y(fp x, fp y, fp z) const { return 0.0; } - fp partial_rho_wrt_z(fp x, fp y, fp z) const - { - return local_coords::partial_nu_wrt_z(x, z); - } - fp partial_sigma_wrt_x(fp x, fp y, fp z) const - { - return local_coords::partial_phi_wrt_x(x, y); - } - fp partial_sigma_wrt_y(fp x, fp y, fp z) const - { - return local_coords::partial_phi_wrt_y(x, y); - } - fp partial_sigma_wrt_z(fp x, fp y, fp z) const { return 0.0; } - - // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) - fp partial2_rho_wrt_xx(fp x, fp y, fp z) const - { - return local_coords::partial2_nu_wrt_xx(x, z); - } - fp partial2_rho_wrt_xy(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_xz(fp x, fp y, fp z) const - { - return local_coords::partial2_nu_wrt_xz(x, z); - } - fp partial2_rho_wrt_yy(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_yz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_zz(fp x, fp y, fp z) const - { - return local_coords::partial2_nu_wrt_zz(x, z); - } - fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const - { - return local_coords::partial2_phi_wrt_xx(x, y); - } - fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const - { - return local_coords::partial2_phi_wrt_xy(x, y); - } - fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const - { - return local_coords::partial2_phi_wrt_yy(x, y); - } - fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const { return 0.0; } - - // plotting coordinates (px,py) - // ... character string describing how (dpx,dpy) are - // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" - // (used for labelling output files) - const char *name_of_dpx() const { return "drho = dnu"; } - const char *name_of_dpy() const - { - return is_plus() ? "dsigma = dphi" - : "180 - dsigma = 180 - dphi"; - } - // ... (irho,isimga) --> (px,py) - fp dpx_of_rho_sigma(fp rho, fp sigma) const - { - return jtutil::degrees_of_radians(rho); - } - fp dpy_of_rho_sigma(fp rho, fp sigma) const - { - const fp dsigma = jtutil::degrees_of_radians(sigma); - return is_plus() ? dsigma : 180.0 - dsigma; - } - - // compute the arc length of a surface in the specified plane - // (must be one of "xy" or "xz") over the patch's nominal bounds - // ... error_exit() if plane is invalid - fp plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const; - - // constructor, destructor - x_patch(patch_system &my_patch_system_in, int patch_number_in, - const char *name_in, bool is_plus_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in); - ~x_patch() {} - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - x_patch(const x_patch &rhs); - x_patch &operator=(const x_patch &rhs); - }; - - //***************************************************************************** - - // - // This class describes a +/- y patch. It doesn't define any new - // functions not already present in class patch ; it "just" defines - // non-virtual versions of all the pure virtual functions defined there. - // - // y patch ==> (rho,sigma) = (mu,phi) tau = nu - // - class y_patch - : public patch - { - public: - // human-readable names of (rho,sigma) - const char *name_of_rho() const { return "mu"; } - const char *name_of_sigma() const { return "phi"; } - - // convert (rho,sigma) --> tau - fp tau_of_rho_sigma(fp rho, fp sigma) const - { - return local_coords::nu_of_mu_phi(rho, sigma); - } - - // convert (rho,sigma) --> (mu,nu,phi) - fp mu_of_rho_sigma(fp rho, fp sigma) const { return rho; } - fp phi_of_rho_sigma(fp rho, fp sigma) const { return sigma; } - fp nu_of_rho_sigma(fp rho, fp sigma) const - { - return local_coords::nu_of_mu_phi(rho, sigma); - } - - // convert (rho,sigma) <--> usual polar spherical (theta,phi) - void theta_phi_of_rho_sigma(fp rho, fp sigma, fp &ps_theta, fp &ps_phi) - const - { - local_coords::theta_phi_of_mu_phi(rho, sigma, ps_theta, ps_phi); - } - void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, fp &rho, fp &sigma) - const - { - local_coords::mu_phi_of_theta_phi(ps_theta, ps_phi, rho, sigma); - } - - // convert (r,rho,sigma) <--> (x,y,z) - void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, fp &x, fp &y, fp &z) - const - { - local_coords::xyz_of_r_mu_phi(r, rho, sigma, x, y, z); - } - fp rho_of_xyz(fp x, fp y, fp z) const - { - return modulo_reduce_rho(local_coords::mu_of_yz(y, z)); - } - fp sigma_of_xyz(fp x, fp y, fp z) const - { - return modulo_reduce_sigma(local_coords::phi_of_xy(x, y)); - } - - // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) - // with respect to the local coordinate system - void xyzcos_of_rho_sigma(fp rho, fp sigma, - fp &xcos, fp &ycos, fp &zcos) - const - { - local_coords::xyzcos_of_mu_phi(rho, sigma, xcos, ycos, zcos); - } - - // partial (x,y,z) / partial (rho,sigma) - void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, - fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, - fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, - fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) - const - { - local_coords::partial_xyz_wrt_r_mu_phi(r, rho, sigma, - partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, - partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, - partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); - } - - // partial (rho,sigma) / partial (x,y,z) - fp partial_rho_wrt_x(fp x, fp y, fp z) const { return 0.0; } - fp partial_rho_wrt_y(fp x, fp y, fp z) const - { - return local_coords::partial_mu_wrt_y(y, z); - } - fp partial_rho_wrt_z(fp x, fp y, fp z) const - { - return local_coords::partial_mu_wrt_z(y, z); - } - fp partial_sigma_wrt_x(fp x, fp y, fp z) const - { - return local_coords::partial_phi_wrt_x(x, y); - } - fp partial_sigma_wrt_y(fp x, fp y, fp z) const - { - return local_coords::partial_phi_wrt_y(x, y); - } - fp partial_sigma_wrt_z(fp x, fp y, fp z) const { return 0.0; } - - // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) - fp partial2_rho_wrt_xx(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_xy(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_xz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_rho_wrt_yy(fp x, fp y, fp z) const - { - return local_coords::partial2_mu_wrt_yy(y, z); - } - fp partial2_rho_wrt_yz(fp x, fp y, fp z) const - { - return local_coords::partial2_mu_wrt_yz(y, z); - } - fp partial2_rho_wrt_zz(fp x, fp y, fp z) const - { - return local_coords::partial2_mu_wrt_zz(y, z); - } - fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const - { - return local_coords::partial2_phi_wrt_xx(x, y); - } - fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const - { - return local_coords::partial2_phi_wrt_xy(x, y); - } - fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const - { - return local_coords::partial2_phi_wrt_yy(x, y); - } - fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const { return 0.0; } - fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const { return 0.0; } - - // plotting coordinates (px,py) - // ... character string describing how (dpx,dpy) are - // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" - // (used for labelling output files) - const char *name_of_dpx() const - { - return is_plus() ? "90 - dsigma = 90 - dphi" - : "90 + dsigma = 90 + dphi"; - } - const char *name_of_dpy() const { return "drho = dmu"; } - // ... (rho,simga) --> (px,py) - fp dpx_of_rho_sigma(fp rho, fp sigma) const - { - const fp dsigma = jtutil::degrees_of_radians(sigma); - return is_plus() ? 90.0 - dsigma : 90.0 + dsigma; - } - fp dpy_of_rho_sigma(fp rho, fp sigma) const - { - return jtutil::degrees_of_radians(rho); - } - - // compute the arc length of a surface in the specified plane - // (must be one of "xy" or "yz") over the patch's nominal bounds - // ... error_exit() if plane is invalid - fp plane_arc_length(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum integration_method method) - const; - - // constructor, destructor - y_patch(patch_system &my_patch_system_in, int patch_number_in, - const char *name_in, bool is_plus_in, - const grid_arrays::grid_array_pars &grid_array_pars_in, - const grid::grid_pars &grid_pars_in); - ~y_patch() {} - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - y_patch(const y_patch &rhs); - y_patch &operator=(const y_patch &rhs); - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* TPATCH_H */ +#ifndef TPATCH_H +#define TPATCH_H +namespace AHFinderDirect +{ + + //***************************************************************************** + //***************************************************************************** + //***************************************************************************** + + // + // ***** how patch boundaries are handled ***** + // + + // + // Basically, we handle patch boundaries using the usual "ghost zone" + // technique, interpolating values from neighboring patches as necessary. + // + // In more detail, we use the following interrelated types of objects + // to handle patch boundaries: + // + // A patch_edge object represents the basic geometry of a min/max + // rho/sigma side of a patch, i.e. it provides which-side-am-I predicates, + // coordinate conversions between (perp,par) and (rho,sigma), etc. + // Every patch has (points to) 4 patch_edge objects, one for each of + // the patch's sides. + // + // A ghost_zone object describes a patch's ghost zone, and knows how + // to fill in gridfns there based on either the patch system's symmetry + // or interpolation from a neighboring patch. ghost_zone is an abstract + // base class, from which we derive two classes: + // * A symmetry_ghost_zone object describes a ghost zone which is a + // (discrete) symmetry of spacetime, either mirror-image or periodic. + // Such an object knows how to fill in ghost-zone gridfn data from + // the "other side" of the symmetry. + // * An interpatch_ghost_zone object describes a ghost zone which + // overlaps another patch. Such an object knows how to get ghost + // zone gridfn data from the other patch. More accurately, it gets + // the data by asking (calling) the appropriate one of the other + // patch's patch_interp objects. + // Every patch has (points to) 4 ghost_zone objects, one for each of + // the patch's sides. + // + // A patch_interp object does the actual interpolation of data from + // within a patch (for filling in data in another patch's ghost zone). + // A patch_interp object points to the patch and patch_edge where it + // will be interpolating. + // + // For example, suppose we have two patches p and q with a common + // angular boundary. Then the desired network of pointers looks like + // this (omitting the patch_edge objects for simplicity): + // + // +-----+ +-----+ + // | | <--> p.interpatch_ghost_zone ---> q.patch_interp ---> | | + // | p | | q | + // | | <--- p.patch_interp <--- q.interpatch_ghost_zone <--> | | + // +-----+ +-----+ + // + // Because of the mutual pointers, we can't easily construct (say) p's + // interpatch_ghost_zone until after q itself has been constructed, and + // vice versa. Moreover, the patch_interp:: constructor needs the + // adjacent-side ghost_zone objects to already exist, and it needs to + // know the iperp range of the interpolation region, which can only be + // computed from the adjacent-patch interpatch_ghost_zone object. + // + // The solution adopted here is to use a 3-phase algorithm, ultimately + // driven by the patch_system constructor: + // * The patch constructors themselves construct the patch_edge objects + // and links them to/from the patches. + // * The patch_system constructor calls the appropriate functions + // patch::create_mirror_symmetry_ghost_zone() + // patch::create_periodic_symmetry_ghost_zone() + // patch::create_interpatch_ghost_zone() + // to construct the ghost_zone objects and link them to/from the + // patches. + // * The patch_system constructor calls the functions + // interpatch_ghost_zone::finish_setup() + // to finish setting up the interpatch_ghost_zone objects, construct + // the other patch's patch_interp objects, and finish linking the + // interpatch_ghost_zone objects to the patch_interp objects. + // + + //***************************************************************************** + //***************************************************************************** + //***************************************************************************** + + // + // patch - abstract base class to describe a generic coordinate/grid patch + // + + // + // There are 3 types of patches, z, x, and y. Each type uses two of + // (mu,nu,phi) as its angular coordinates (rho,sigma); the remaining + // "unused" one of (mu,nu,phi) is tau. + // + // z patch ==> (rho,sigma) = (mu,nu) tau = phi + // x patch ==> (rho,sigma) = (nu,phi) tau = mu + // y patch ==> (rho,sigma) = (mu,phi) tau = nu + // + + // forward declarations + class patch_edge; + class ghost_zone; + class symmetry_ghost_zone; + class interpatch_ghost_zone; + class patch_interp; + class patch_system; + + // + // const qualifiers refer to the gridfn values + // + class patch + : public fd_grid + { + // + // ***** patch system, type, and coordinate metadata ***** + // + public: + // to which patch system do we belong? + patch_system &my_patch_system() const + { + return my_patch_system_; + } + + // each patch has a unique 0-origin small-integer patch number, + // usually denoted pn + int patch_number() const { return patch_number_; } + + // each patch has a unique human-readable patch name for debugging etc + const char *name() const { return name_; } // typically "+z" etc + + // are we a +[xyz] or -[xyz] patch? + bool is_plus() const { return is_plus_; } + + // ... values for the is_plus_in constructor argument + // FIXME: these should really be bool, but then we couldn't + // use the "enum hack" for in-class constants + enum + { + patch_is_plus = true, + patch_is_minus = false + }; + + // are we a (+/-) x or y or z patch? + // ... n.b. type is `char' because this is handy for both + // switch() and human-readable printing + char ctype() const { return ctype_; } // 'z' or 'x' or 'y' + + // are two patches really the same patch? + // n.b. this does *not* compare any of the gridfn data! + bool operator==(const patch &other_patch) const + { + return this == &other_patch; + } + bool operator!=(const patch &other_patch) const + { + return !operator==(other_patch); + } + + // (rho,sigma,tau) coordinates as singleton coordinate sets + local_coords::coords_set coords_set_rho() const + { + return coords_set_rho_; + } + local_coords::coords_set coords_set_sigma() const + { + return coords_set_sigma_; + } + local_coords::coords_set coords_set_tau() const + { + return coords_set_tau_; + } + + // {rho,sigma} coordinate set + local_coords::coords_set coords_set_rho_sigma() const + { + return coords_set_rho() | coords_set_sigma(); + } + + // (rho,sigma) coordinates as human-readable character strings + // (for labelling output files etc) + virtual const char *name_of_rho() const = 0; + virtual const char *name_of_sigma() const = 0; + + // + // ***** (rho,sigma,tau) coordinates ***** + // + public: + // convert (rho,sigma) --> tau + virtual fp tau_of_rho_sigma(fp rho, fp sigma) const = 0; + + // convert (rho,sigma) --> (mu,nu,phi) + virtual fp mu_of_rho_sigma(fp rho, fp sigma) const = 0; + virtual fp nu_of_rho_sigma(fp rho, fp sigma) const = 0; + virtual fp phi_of_rho_sigma(fp rho, fp sigma) const = 0; + + // convert (rho,sigma) <--> usual polar spherical (theta,phi) + virtual void theta_phi_of_rho_sigma(fp rho, fp sigma, + fp &ps_theta, fp &ps_phi) + const = 0; + virtual void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, + fp &rho, fp &sigma) + const = 0; + + // convert (r,rho,sigma) <--> local (x,y,z) + virtual void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, + fp &x, fp &y, fp &z) + const = 0; + virtual fp rho_of_xyz(fp x, fp y, fp z) const = 0; + virtual fp sigma_of_xyz(fp x, fp y, fp z) const = 0; + + // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) + // with respect to the local coordinate system + virtual void xyzcos_of_rho_sigma(fp rho, fp sigma, + fp &xcos, fp &ycos, fp &zcos) + const = 0; + + // partial (x,y,z) / partial (rho,sigma) + virtual void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, + fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, + fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, + fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) + const = 0; + + // partial (rho,sigma) / partial (x,y,z) + virtual fp partial_rho_wrt_x(fp x, fp y, fp z) const = 0; + virtual fp partial_rho_wrt_y(fp x, fp y, fp z) const = 0; + virtual fp partial_rho_wrt_z(fp x, fp y, fp z) const = 0; + virtual fp partial_sigma_wrt_x(fp x, fp y, fp z) const = 0; + virtual fp partial_sigma_wrt_y(fp x, fp y, fp z) const = 0; + virtual fp partial_sigma_wrt_z(fp x, fp y, fp z) const = 0; + + // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) + virtual fp partial2_rho_wrt_xx(fp x, fp y, fp z) const = 0; + virtual fp partial2_rho_wrt_xy(fp x, fp y, fp z) const = 0; + virtual fp partial2_rho_wrt_xz(fp x, fp y, fp z) const = 0; + virtual fp partial2_rho_wrt_yy(fp x, fp y, fp z) const = 0; + virtual fp partial2_rho_wrt_yz(fp x, fp y, fp z) const = 0; + virtual fp partial2_rho_wrt_zz(fp x, fp y, fp z) const = 0; + virtual fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const = 0; + virtual fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const = 0; + virtual fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const = 0; + virtual fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const = 0; + virtual fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const = 0; + virtual fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const = 0; + + // compute (rho,sigma) 2-D induced metric from 3-D xyz metric + // as per p.33 of my apparent horizon finding notes + // ... returns Jacobian of (rho,sigma) 2-D induced metric + fp rho_sigma_metric(fp r, fp rho, fp sigma, + fp partial_surface_r_wrt_rho, + fp partial_surface_r_wrt_sigma, + fp g_xx, fp g_xy, fp g_xz, + fp g_yy, fp g_yz, + fp g_zz, + fp &g_rho_rho, fp &g_rho_sigma, + fp &g_sigma_sigma) + const; + + // plotting coordinates (dpx,dpy) + // ... character string describing how (dpx,dpy) are + // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" + // (used for labelling output files) + virtual const char *name_of_dpx() const = 0; + virtual const char *name_of_dpy() const = 0; + // ... (irho,isimga) --> (px,py) + virtual fp dpx_of_rho_sigma(fp rho, fp sigma) const = 0; + virtual fp dpy_of_rho_sigma(fp rho, fp sigma) const = 0; + + // + // ***** line/surface integrals ***** + // + public: + // + // The following enum describes the integration methods supported + // by integrate_gridfn() . + // + // For convenience of exposition we describe the methods as if for + // 1-D integration, but integrate_gridfn() actually does 2-D + // (surface) integration over the patch. + // + // Suppose we're computing $\int_{x_0}^{x^N} f(x) \, dx$, using the + // equally spaced integration points $f_0$, $f_1$, \dots, $f_N$, + // spaced $\Delta x$ apart. Then the integration methods are as + // follows, with the convention that $\langle X \rangle$ denotes + // indefinite repetition of the "X" terms, depending on N: + // + enum integration_method + { + // Trapezoid rule + // ... character-string name "trapezoid" or "trapezoid rule" + // ... 2nd order accurate for smooth functions + // ... requires N >= 1 + // $$ + // \Delta x \left[ + // \half f_0 + // + \langle + // f_k + // \rangle + // + \half f_N + // \right] + // $$ + integration_method__trapezoid, + + // Simpson's rule + // ... character-string name "Simpson" or "Simpson's rule" + // ... 4th order accurate for smooth functions + // ... requires N >= 2 and N even + // $$ + // \Delta x \left[ + // \frac{1}{3} f_0 + // + \frac{4}{3} f_1 + // + \langle + // \frac{2}{3} f_{2k} + \frac{4}{3} f_{2k+1} + // \rangle + // + \frac{1}{3} f_N + // \right] + // $$ + integration_method__Simpson, + + // Simpson's rule, variant form + // ... characgter-string name "Simpson (variant)" + // or "Simpson's rule (variant)" + // ... described in Numerical Recipes 1st edition (4.1.14) + // ... 4th order accurate for smooth functions + // ... requires N >= 7 + // $$ + // \Delta x \left[ + // \frac{17}{48} f_0 + // + \frac{59}{48} f_1 + // + \frac{43}{48} f_2 + // + \frac{49}{48} f_3 + // + \langle + // f_k + // \rangle + // + \frac{49}{48} f_{N-3} + // + \frac{43}{48} f_{N-2} + // + \frac{59}{48} f_{N-1} + // + \frac{17}{48} f_N + // \right] + // $$ + integration_method__Simpson_variant, + + // automatic choice of the "best" one of the above methods: + // ... i.e. choose Simpson's rule or variant if applicable, + // otherwise trapezoid rule + // N == 2 Simpson's rule + // N == 3 trapezoid rule + // N == 4 Simpson's rule + // N == 5 trapezoid rule + // N == 6 Simpson's rule + // N >= 7 Simpson's rule, variant form + integration_method__automatic_choice // no comma here! + }; + + // decode character string name into internal enum + static enum integration_method + decode_integration_method(const char method_string[]); + + // compute the arc length of a surface in the specified plane + // (must be one of "xy", "xz", or "yz") over the patch's nominal bounds + // ... error_exit() if plane is invalid and/or + // the patch doesn't contain that coordinate plane + virtual fp plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const = 0; + + // ... along the rho direction (i.e. in a dsigma=constant plane + // where dsigma is a multiple of 90 degrees) + fp rho_arc_length(int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const; + // ... along the sigma direction (i.e. in a drho=constant plane + // where drho is a multiple of 90 degrees) + fp sigma_arc_length(int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const; + + // compute the surface integral of a gridfn over the patch's + // nominal area, + // $\int f(\rho,\sigma) \, dA$ + // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ + // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma) + // ... integration method selected by method argument + // ... src gridfn may be either nominal-grid or ghosted-grid + // (n.b. in the latter case the integral is still done + // only over the patch's nominal area) + fp integrate_gridfn(int unknown_src_gfn, + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const; + + // compute integration coefficient $c_i$ where + // $\int_{x_0}^{x_N} f(x) \, dx + // \approx \Delta x \, \sum_{i=0}^N c_i f(x_i)$ + private: + static fp integration_coeff(enum integration_method method, int N, int i); + + // + // ***** patch edges **** + // + public: + const patch_edge &min_rho_patch_edge() const + { + return min_rho_patch_edge_; + } + const patch_edge &max_rho_patch_edge() const + { + return max_rho_patch_edge_; + } + const patch_edge &min_sigma_patch_edge() const + { + return min_sigma_patch_edge_; + } + const patch_edge &max_sigma_patch_edge() const + { + return max_sigma_patch_edge_; + } + const patch_edge &minmax_ang_patch_edge(bool want_min, bool want_rho) + const + { + return want_min ? (want_rho ? min_rho_patch_edge() + : min_sigma_patch_edge()) + : (want_rho ? max_rho_patch_edge() + : max_sigma_patch_edge()); + } + + // find which patch edge is adjacent to neighboring patch q, + // or error_exit() if it's not actually a neighboring patch + // ... computation done using only (rho,sigma) coordinate sets + // and min/max dang bounds ==> ok to use in setting up ghost zones + // ... patch_overlap_width = number of grid points (grid spacings + // in the perpendicular direction) these patches' nominal grids + // overlap, + // ... if this is nonzero, then these patches must have + // the *same* grid spacing in the perpendicular direction + // ... e.g. delta_dang = 5, this patch max_dang = 50, + // other patch min_dang = 40 ==> patch_overlap_width = 3 + // p p p p p + // q q q q q + const patch_edge &edge_adjacent_to_patch(const patch &q, + int patch_overlap_width = 0) + const; + + // + // ***** ghost zones ***** + // + public: + ghost_zone &min_rho_ghost_zone() const + { + assert(min_rho_ghost_zone_ != NULL); + return *min_rho_ghost_zone_; + } + ghost_zone &max_rho_ghost_zone() const + { + assert(max_rho_ghost_zone_ != NULL); + return *max_rho_ghost_zone_; + } + ghost_zone &min_sigma_ghost_zone() const + { + assert(min_sigma_ghost_zone_ != NULL); + return *min_sigma_ghost_zone_; + } + ghost_zone &max_sigma_ghost_zone() const + { + assert(max_sigma_ghost_zone_ != NULL); + return *max_sigma_ghost_zone_; + } + ghost_zone &minmax_rho_ghost_zone(bool want_min) + const + { + return want_min ? min_rho_ghost_zone() + : max_rho_ghost_zone(); + } + ghost_zone &minmax_sigma_ghost_zone(bool want_min) + const + { + return want_min ? min_sigma_ghost_zone() + : max_sigma_ghost_zone(); + } + + ghost_zone &minmax_ang_ghost_zone(bool want_min, bool want_rho) + const + { + return want_rho ? minmax_rho_ghost_zone(want_min) + : minmax_sigma_ghost_zone(want_min); + } + + ghost_zone &ghost_zone_on_edge(const patch_edge &e) const; + + // which of the two ghost zones at a specified corner, + // contains a specified point? + ghost_zone &corner_ghost_zone_containing_point(bool rho_is_min, bool sigma_is_min, // specifies corner + int irho, int isigma) // specifies point + const; + + // which ghost zone contains a specified noncorner point? + ghost_zone &ghost_zone_containing_noncorner_point(int irho, int isigma) + const; + + // + // ***** set up ghost zones + // + public: + // assert() that this ghost zone hasn't been set up yet, + // then set it up as mirror-symmetry + void create_mirror_symmetry_ghost_zone(const patch_edge &edge); + + // assert() that this ghost zone hasn't been set up yet, + // then set it up as periodic-symmetry + void create_periodic_symmetry_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, + bool ipar_map_is_plus); + + // assert() that this ghost zone hasn't been set up yet, + // then set it up as interpatch + // ... this only sets up ghost zone in skeletal form; use + // interpatch_ghost_zone::finish_setup() to complete + // the setup process + void create_interpatch_ghost_zone(const patch_edge &my_edge, const patch_edge &other_edge, + int patch_overlap_width); + + // assert() that all ghost zones + // are fully setup + void assert_all_ghost_zones_fully_setup() const; + + private: + // helper function for setup_*_ghost_zone(): + // assert() that ghost zone pointer on specified edge is NULL + // (i.e. that we haven't already setup this ghost zone), + // then assign new value to it + void set_ghost_zone(const patch_edge &edge, ghost_zone *gzp); + + // + // ***** constructor, destructor, et al ***** + // + protected: + // ... used only from derived classes + // ... doesn't set up ghost zone info, since this depends on + // knowing our neighbouring patches, which might not exist yet + // ... saves a pointer to name_in[], so this should have a + // lifetime at least as long as that of this object + patch(patch_system &my_patch_system_in, int patch_number_in, + const char name_in[], bool is_plus_in, char ctype_in, + local_coords::coords_set coords_set_rho_in, + local_coords::coords_set coords_set_sigma_in, + local_coords::coords_set coords_set_tau_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in); + + public: + // destructor must be virtual to allow destruction + // of derived classes via ptr/ref to this class + virtual ~patch(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + patch(const patch &rhs); + patch &operator=(const patch &rhs); + + // + // ***** data members ***** + // + private: + // type/coordinate metadata + patch_system &my_patch_system_; + const int patch_number_; + const char *name_; + const bool is_plus_; + const char ctype_; + const local_coords::coords_set coords_set_rho_, + coords_set_sigma_, + coords_set_tau_; + + // edges + const patch_edge &min_rho_patch_edge_; + const patch_edge &max_rho_patch_edge_; + const patch_edge &min_sigma_patch_edge_; + const patch_edge &max_sigma_patch_edge_; + + // ghost zones + // ... pointers are set to NULL by ctor, + // reset to non-NULL by set_ghost_zone(), which is called by + // create_mirror_symmetry_ghost_zone() + // create_periodic_symmetry_ghost_zone() + // create_interpatch_ghost_zone() + ghost_zone *min_rho_ghost_zone_; + ghost_zone *max_rho_ghost_zone_; + ghost_zone *min_sigma_ghost_zone_; + ghost_zone *max_sigma_ghost_zone_; + }; + + //***************************************************************************** + //***************************************************************************** + //***************************************************************************** + + // + // This class describes a +/- z patch. It doesn't define any new + // functions not already present in class patch ; it "just" defines + // non-virtual versions of all the pure virtual functions defined there. + // + // z patch ==> (rho,sigma) = (mu,nu) tau = phi + // + class z_patch + : public patch + { + public: + // human-readable names of (rho,sigma) + const char *name_of_rho() const { return "mu"; } + const char *name_of_sigma() const { return "nu"; } + + // convert (rho,sigma) --> tau + fp tau_of_rho_sigma(fp rho, fp sigma) const + { + return local_coords::phi_of_mu_nu(rho, sigma); + } + + // convert (rho,sigma) --> (mu,nu,phi) + fp mu_of_rho_sigma(fp rho, fp sigma) const { return rho; } + fp nu_of_rho_sigma(fp rho, fp sigma) const { return sigma; } + fp phi_of_rho_sigma(fp rho, fp sigma) const + { + return local_coords::phi_of_mu_nu(rho, sigma); + } + + // convert (rho,sigma) <--> usual polar spherical (theta,phi) + void theta_phi_of_rho_sigma(fp rho, fp sigma, fp &ps_theta, fp &ps_phi) + const + { + local_coords::theta_phi_of_mu_nu(rho, sigma, ps_theta, ps_phi); + } + void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, fp &rho, fp &sigma) + const + { + local_coords::mu_nu_of_theta_phi(ps_theta, ps_phi, rho, sigma); + } + + // convert (r,rho,sigma) <--> (x,y,z) + void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, fp &x, fp &y, fp &z) + const + { + local_coords::xyz_of_r_mu_nu(r, rho, sigma, x, y, z); + } + fp rho_of_xyz(fp x, fp y, fp z) const + { + return modulo_reduce_rho(local_coords::mu_of_yz(y, z)); + } + fp sigma_of_xyz(fp x, fp y, fp z) const + { + return modulo_reduce_sigma(local_coords::nu_of_xz(x, z)); + } + + // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) + // with respect to the local coordinate system + void xyzcos_of_rho_sigma(fp rho, fp sigma, + fp &xcos, fp &ycos, fp &zcos) + const + { + local_coords::xyzcos_of_mu_nu(rho, sigma, xcos, ycos, zcos); + } + + // partial (x,y,z) / partial (rho,sigma) + void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, + fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, + fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, + fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) + const + { + local_coords::partial_xyz_wrt_r_mu_nu(r, rho, sigma, + partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, + partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, + partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); + } + + // partial (rho,sigma) / partial (x,y,z) + fp partial_rho_wrt_x(fp x, fp y, fp z) const { return 0.0; } + fp partial_rho_wrt_y(fp x, fp y, fp z) const + { + return local_coords::partial_mu_wrt_y(y, z); + } + fp partial_rho_wrt_z(fp x, fp y, fp z) const + { + return local_coords::partial_mu_wrt_z(y, z); + } + fp partial_sigma_wrt_x(fp x, fp y, fp z) const + { + return local_coords::partial_nu_wrt_x(x, z); + } + fp partial_sigma_wrt_y(fp x, fp y, fp z) const { return 0.0; } + fp partial_sigma_wrt_z(fp x, fp y, fp z) const + { + return local_coords::partial_nu_wrt_z(x, z); + } + + // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) + fp partial2_rho_wrt_xx(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_xy(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_xz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_yy(fp x, fp y, fp z) const + { + return local_coords::partial2_mu_wrt_yy(y, z); + } + fp partial2_rho_wrt_yz(fp x, fp y, fp z) const + { + return local_coords::partial2_mu_wrt_yz(y, z); + } + fp partial2_rho_wrt_zz(fp x, fp y, fp z) const + { + return local_coords::partial2_mu_wrt_zz(y, z); + } + fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const + { + return local_coords::partial2_nu_wrt_xx(x, z); + } + fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const + { + return local_coords::partial2_nu_wrt_xz(x, z); + } + fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const + { + return local_coords::partial2_nu_wrt_zz(x, z); + } + + // plotting coordinates (px,py) + // ... character string describing how (dpx,dpy) are + // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" + // (used for labelling output files) + const char *name_of_dpx() const + { + return "dsigma = dnu"; + } + const char *name_of_dpy() const + { + return is_plus() ? "drho = dmu" : "180 - drho = 180 - dmu"; + } + // ... (irho,isimga) --> (px,py) + fp dpx_of_rho_sigma(fp rho, fp sigma) const + { + return jtutil::degrees_of_radians(sigma); + } + fp dpy_of_rho_sigma(fp rho, fp sigma) const + { + const fp drho = jtutil::degrees_of_radians(rho); + return is_plus() ? drho : 180.0 - drho; + } + + // compute the arc length of a surface in the specified plane + // (must be one of "xz" or "yz") over the patch's nominal bounds + // ... error_exit() if plane is invalid + fp plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const; + + // constructor, destructor + z_patch(patch_system &my_patch_system_in, int patch_number_in, + const char *name_in, bool is_plus_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in); + ~z_patch() {} + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + z_patch(const z_patch &rhs); + z_patch &operator=(const z_patch &rhs); + }; + + //***************************************************************************** + + // + // This class describes a +/- x patch. It doesn't define any new + // functions not already present in class patch ; it "just" defines + // non-virtual versions of all the pure virtual functions defined there. + // + // x patch ==> (rho,sigma) = (nu,phi) tau = mu + // + class x_patch + : public patch + { + public: + // human-readable names of (rho,sigma) + const char *name_of_rho() const { return "nu"; } + const char *name_of_sigma() const { return "phi"; } + + // convert (rho,sigma) --> tau + fp tau_of_rho_sigma(fp rho, fp sigma) const + { + return local_coords::mu_of_nu_phi(rho, sigma); + } + + // convert (rho,sigma) --> (mu,nu,phi) + fp nu_of_rho_sigma(fp rho, fp sigma) const { return rho; } + fp phi_of_rho_sigma(fp rho, fp sigma) const { return sigma; } + fp mu_of_rho_sigma(fp rho, fp sigma) const + { + return local_coords::mu_of_nu_phi(rho, sigma); + } + + // convert (rho,sigma) <--> usual polar spherical (theta,phi) + void theta_phi_of_rho_sigma(fp rho, fp sigma, fp &ps_theta, fp &ps_phi) + const + { + local_coords::theta_phi_of_nu_phi(rho, sigma, ps_theta, ps_phi); + } + void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, fp &rho, fp &sigma) + const + { + local_coords::nu_phi_of_theta_phi(ps_theta, ps_phi, rho, sigma); + } + + // convert (r,rho,sigma) <--> (x,y,z) + void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, fp &x, fp &y, fp &z) + const + { + local_coords::xyz_of_r_nu_phi(r, rho, sigma, x, y, z); + } + fp rho_of_xyz(fp x, fp y, fp z) const + { + return modulo_reduce_rho(local_coords::nu_of_xz(x, z)); + } + fp sigma_of_xyz(fp x, fp y, fp z) const + { + return modulo_reduce_sigma(local_coords::phi_of_xy(x, y)); + } + + // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) + // with respect to the local coordinate system + void xyzcos_of_rho_sigma(fp rho, fp sigma, + fp &xcos, fp &ycos, fp &zcos) + const + { + local_coords::xyzcos_of_nu_phi(rho, sigma, xcos, ycos, zcos); + } + + // partial (x,y,z) / partial (rho,sigma) + void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, + fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, + fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, + fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) + const + { + local_coords::partial_xyz_wrt_r_nu_phi(r, rho, sigma, + partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, + partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, + partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); + } + + // partial (rho,sigma) / partial (x,y,z) + fp partial_rho_wrt_x(fp x, fp y, fp z) const + { + return local_coords::partial_nu_wrt_x(x, z); + } + fp partial_rho_wrt_y(fp x, fp y, fp z) const { return 0.0; } + fp partial_rho_wrt_z(fp x, fp y, fp z) const + { + return local_coords::partial_nu_wrt_z(x, z); + } + fp partial_sigma_wrt_x(fp x, fp y, fp z) const + { + return local_coords::partial_phi_wrt_x(x, y); + } + fp partial_sigma_wrt_y(fp x, fp y, fp z) const + { + return local_coords::partial_phi_wrt_y(x, y); + } + fp partial_sigma_wrt_z(fp x, fp y, fp z) const { return 0.0; } + + // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) + fp partial2_rho_wrt_xx(fp x, fp y, fp z) const + { + return local_coords::partial2_nu_wrt_xx(x, z); + } + fp partial2_rho_wrt_xy(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_xz(fp x, fp y, fp z) const + { + return local_coords::partial2_nu_wrt_xz(x, z); + } + fp partial2_rho_wrt_yy(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_yz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_zz(fp x, fp y, fp z) const + { + return local_coords::partial2_nu_wrt_zz(x, z); + } + fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const + { + return local_coords::partial2_phi_wrt_xx(x, y); + } + fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const + { + return local_coords::partial2_phi_wrt_xy(x, y); + } + fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const + { + return local_coords::partial2_phi_wrt_yy(x, y); + } + fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const { return 0.0; } + + // plotting coordinates (px,py) + // ... character string describing how (dpx,dpy) are + // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" + // (used for labelling output files) + const char *name_of_dpx() const { return "drho = dnu"; } + const char *name_of_dpy() const + { + return is_plus() ? "dsigma = dphi" + : "180 - dsigma = 180 - dphi"; + } + // ... (irho,isimga) --> (px,py) + fp dpx_of_rho_sigma(fp rho, fp sigma) const + { + return jtutil::degrees_of_radians(rho); + } + fp dpy_of_rho_sigma(fp rho, fp sigma) const + { + const fp dsigma = jtutil::degrees_of_radians(sigma); + return is_plus() ? dsigma : 180.0 - dsigma; + } + + // compute the arc length of a surface in the specified plane + // (must be one of "xy" or "xz") over the patch's nominal bounds + // ... error_exit() if plane is invalid + fp plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const; + + // constructor, destructor + x_patch(patch_system &my_patch_system_in, int patch_number_in, + const char *name_in, bool is_plus_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in); + ~x_patch() {} + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + x_patch(const x_patch &rhs); + x_patch &operator=(const x_patch &rhs); + }; + + //***************************************************************************** + + // + // This class describes a +/- y patch. It doesn't define any new + // functions not already present in class patch ; it "just" defines + // non-virtual versions of all the pure virtual functions defined there. + // + // y patch ==> (rho,sigma) = (mu,phi) tau = nu + // + class y_patch + : public patch + { + public: + // human-readable names of (rho,sigma) + const char *name_of_rho() const { return "mu"; } + const char *name_of_sigma() const { return "phi"; } + + // convert (rho,sigma) --> tau + fp tau_of_rho_sigma(fp rho, fp sigma) const + { + return local_coords::nu_of_mu_phi(rho, sigma); + } + + // convert (rho,sigma) --> (mu,nu,phi) + fp mu_of_rho_sigma(fp rho, fp sigma) const { return rho; } + fp phi_of_rho_sigma(fp rho, fp sigma) const { return sigma; } + fp nu_of_rho_sigma(fp rho, fp sigma) const + { + return local_coords::nu_of_mu_phi(rho, sigma); + } + + // convert (rho,sigma) <--> usual polar spherical (theta,phi) + void theta_phi_of_rho_sigma(fp rho, fp sigma, fp &ps_theta, fp &ps_phi) + const + { + local_coords::theta_phi_of_mu_phi(rho, sigma, ps_theta, ps_phi); + } + void rho_sigma_of_theta_phi(fp ps_theta, fp ps_phi, fp &rho, fp &sigma) + const + { + local_coords::mu_phi_of_theta_phi(ps_theta, ps_phi, rho, sigma); + } + + // convert (r,rho,sigma) <--> (x,y,z) + void xyz_of_r_rho_sigma(fp r, fp rho, fp sigma, fp &x, fp &y, fp &z) + const + { + local_coords::xyz_of_r_mu_phi(r, rho, sigma, x, y, z); + } + fp rho_of_xyz(fp x, fp y, fp z) const + { + return modulo_reduce_rho(local_coords::mu_of_yz(y, z)); + } + fp sigma_of_xyz(fp x, fp y, fp z) const + { + return modulo_reduce_sigma(local_coords::phi_of_xy(x, y)); + } + + // convert (rho,sigma) --> direction cosines (xcos,ycos,zcos) + // with respect to the local coordinate system + void xyzcos_of_rho_sigma(fp rho, fp sigma, + fp &xcos, fp &ycos, fp &zcos) + const + { + local_coords::xyzcos_of_mu_phi(rho, sigma, xcos, ycos, zcos); + } + + // partial (x,y,z) / partial (rho,sigma) + void partial_xyz_wrt_r_rho_sigma(fp r, fp rho, fp sigma, + fp &partial_x_wrt_r, fp &partial_x_wrt_rho, fp &partial_x_wrt_sigma, + fp &partial_y_wrt_r, fp &partial_y_wrt_rho, fp &partial_y_wrt_sigma, + fp &partial_z_wrt_r, fp &partial_z_wrt_rho, fp &partial_z_wrt_sigma) + const + { + local_coords::partial_xyz_wrt_r_mu_phi(r, rho, sigma, + partial_x_wrt_r, partial_x_wrt_rho, partial_x_wrt_sigma, + partial_y_wrt_r, partial_y_wrt_rho, partial_y_wrt_sigma, + partial_z_wrt_r, partial_z_wrt_rho, partial_z_wrt_sigma); + } + + // partial (rho,sigma) / partial (x,y,z) + fp partial_rho_wrt_x(fp x, fp y, fp z) const { return 0.0; } + fp partial_rho_wrt_y(fp x, fp y, fp z) const + { + return local_coords::partial_mu_wrt_y(y, z); + } + fp partial_rho_wrt_z(fp x, fp y, fp z) const + { + return local_coords::partial_mu_wrt_z(y, z); + } + fp partial_sigma_wrt_x(fp x, fp y, fp z) const + { + return local_coords::partial_phi_wrt_x(x, y); + } + fp partial_sigma_wrt_y(fp x, fp y, fp z) const + { + return local_coords::partial_phi_wrt_y(x, y); + } + fp partial_sigma_wrt_z(fp x, fp y, fp z) const { return 0.0; } + + // partial^2 (rho,sigma) / partial (xx,xy,xz,yy,yz) + fp partial2_rho_wrt_xx(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_xy(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_xz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_rho_wrt_yy(fp x, fp y, fp z) const + { + return local_coords::partial2_mu_wrt_yy(y, z); + } + fp partial2_rho_wrt_yz(fp x, fp y, fp z) const + { + return local_coords::partial2_mu_wrt_yz(y, z); + } + fp partial2_rho_wrt_zz(fp x, fp y, fp z) const + { + return local_coords::partial2_mu_wrt_zz(y, z); + } + fp partial2_sigma_wrt_xx(fp x, fp y, fp z) const + { + return local_coords::partial2_phi_wrt_xx(x, y); + } + fp partial2_sigma_wrt_xy(fp x, fp y, fp z) const + { + return local_coords::partial2_phi_wrt_xy(x, y); + } + fp partial2_sigma_wrt_xz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_yy(fp x, fp y, fp z) const + { + return local_coords::partial2_phi_wrt_yy(x, y); + } + fp partial2_sigma_wrt_yz(fp x, fp y, fp z) const { return 0.0; } + fp partial2_sigma_wrt_zz(fp x, fp y, fp z) const { return 0.0; } + + // plotting coordinates (px,py) + // ... character string describing how (dpx,dpy) are + // defined in terms of (mu,nu,phi), eg "90 - drho = 90 - dphi" + // (used for labelling output files) + const char *name_of_dpx() const + { + return is_plus() ? "90 - dsigma = 90 - dphi" + : "90 + dsigma = 90 + dphi"; + } + const char *name_of_dpy() const { return "drho = dmu"; } + // ... (rho,simga) --> (px,py) + fp dpx_of_rho_sigma(fp rho, fp sigma) const + { + const fp dsigma = jtutil::degrees_of_radians(sigma); + return is_plus() ? 90.0 - dsigma : 90.0 + dsigma; + } + fp dpy_of_rho_sigma(fp rho, fp sigma) const + { + return jtutil::degrees_of_radians(rho); + } + + // compute the arc length of a surface in the specified plane + // (must be one of "xy" or "yz") over the patch's nominal bounds + // ... error_exit() if plane is invalid + fp plane_arc_length(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum integration_method method) + const; + + // constructor, destructor + y_patch(patch_system &my_patch_system_in, int patch_number_in, + const char *name_in, bool is_plus_in, + const grid_arrays::grid_array_pars &grid_array_pars_in, + const grid::grid_pars &grid_pars_in); + ~y_patch() {} + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + y_patch(const y_patch &rhs); + y_patch &operator=(const y_patch &rhs); + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* TPATCH_H */ diff --git a/AMSS_NCKU_source/patch_edge.h b/AMSS_NCKU_source/AHF_Direct/patch_edge.h similarity index 96% rename from AMSS_NCKU_source/patch_edge.h rename to AMSS_NCKU_source/AHF_Direct/patch_edge.h index 2ec7d04..64c2365 100644 --- a/AMSS_NCKU_source/patch_edge.h +++ b/AMSS_NCKU_source/AHF_Direct/patch_edge.h @@ -1,320 +1,320 @@ -#ifndef TPATCH_EDGE_H -#define TPATCH_EDGE_H -namespace AHFinderDirect -{ - - //***************************************************************************** - - // - // patch_edge -- perpendicular/parallel geometry of one side of a patch - // - // A patch_edge object is a very light-weight object which represents - // the basic geometry of a min/max rho/sigma side of a patch, i.e. it - // provides which-side-am-I predicates, coordinate conversions between - // (perp,par) and (rho,sigma), etc. Every patch has (points to) 4 patch_edge - // objects, one for each of the patch's sides. See the comments in - // "patch.hh" for a "big picture" discussion of patches, patch edges, - // ghost zones, and patch interpolation regions. - // - // Note that since patch_edge has only const member functions - // (and members!), a patch_edge object is effectively always const . - // This means there's no harm in always declaring patch_edge objects - // to be const . - // - - class patch_edge - { - public: - // - // ***** meta-info ***** - // - - // meta-info about patch - patch &my_patch() const { return my_patch_; } - - // meta-info about edge - bool is_rho() const { return is_rho_; } - bool is_min() const { return is_min_; } - bool perp_is_rho() const { return is_rho(); } - bool par_is_rho() const { return !is_rho(); } - - // human-readable {min,max}_{rho,sigma} name (for debugging etc) - const char *name() const - { - return is_min() - ? (is_rho() ? "min_rho" : "min_sigma") - : (is_rho() ? "max_rho" : "max_sigma"); - } - - // are two edges really the same edge? - bool operator==(const patch_edge &other_edge) const - { - return (my_patch() == other_edge.my_patch()) && (is_rho() == other_edge.is_rho()) && (is_min() == other_edge.is_min()); - } - bool operator!=(const patch_edge &other_edge) const - { - return !operator==(other_edge); - } - - // - // ***** adjacent edges ***** - // - - // get adjacent edges to our min/max par corners - const patch_edge &min_par_adjacent_edge() const - { - return my_patch() - .minmax_ang_patch_edge(grid::side_is_min, par_is_rho()); - } - const patch_edge &max_par_adjacent_edge() const - { - return my_patch() - .minmax_ang_patch_edge(grid::side_is_max, par_is_rho()); - } - const patch_edge &minmax_par_adjacent_edge(bool want_min) const - { - return want_min ? min_par_adjacent_edge() - : max_par_adjacent_edge(); - } - - // - // ***** gridfn subscripting and coordinate maps ***** - // - - // gridfn strides perpendicular/parallel to the edge - int perp_stride() const - { - return my_patch().iang_stride(perp_is_rho()); - } - int par_stride() const - { - return my_patch().iang_stride(par_is_rho()); - } - int ghosted_perp_stride() const - { - return my_patch().ghosted_iang_stride(perp_is_rho()); - } - int ghosted_par_stride() const - { - return my_patch().ghosted_iang_stride(par_is_rho()); - } - - // coordinate maps perpendicular/parallel to the edge - // ... range is that of the grid *including* ghost zones - const jtutil::linear_map &perp_map() const - { - return my_patch().ang_map(perp_is_rho()); - } - const jtutil::linear_map &par_map() const - { - return my_patch().ang_map(par_is_rho()); - } - - // meta-info about perp/par coordinates - // ... as (mu,nu,phi) tensor indices - local_coords::coords_set coords_set_perp() const - { - return perp_is_rho() ? my_patch().coords_set_rho() - : my_patch().coords_set_sigma(); - } - local_coords::coords_set coords_set_par() const - { - return par_is_rho() ? my_patch().coords_set_rho() - : my_patch().coords_set_sigma(); - } - - // - // ***** coordinate conversions ***** - // - - // coordinate conversions based on ghost zone direction - // ... (iperp,ipar) <--> (perp,par) - fp perp_of_iperp(int iperp) const - { - return my_patch().ang_of_iang(perp_is_rho(), iperp); - } - fp par_of_ipar(int ipar) const - { - return my_patch().ang_of_iang(par_is_rho(), ipar); - } - fp fp_iperp_of_perp(fp perp) const - { - return my_patch().fp_iang_of_ang(perp_is_rho(), perp); - } - fp fp_ipar_of_par(fp par) const - { - return my_patch().fp_iang_of_ang(par_is_rho(), par); - } - int iperp_of_perp(fp perp, jtutil::linear_map::noninteger_action - nia = jtutil::linear_map::nia_error) - { - return my_patch().iang_of_ang(perp_is_rho(), perp, nia); - } - int ipar_of_par(fp par, jtutil::linear_map::noninteger_action - nia = jtutil::linear_map::nia_error) - { - return my_patch().iang_of_ang(par_is_rho(), par, nia); - } - - // ... (perp,par) --> (rho,sigma) - int irho_of_iperp_ipar(int iperp, int ipar) const - { - return perp_is_rho() ? iperp : ipar; - } - int isigma_of_iperp_ipar(int iperp, int ipar) const - { - return perp_is_rho() ? ipar : iperp; - } - fp rho_of_perp_par(fp perp, fp par) const - { - return perp_is_rho() ? perp : par; - } - fp sigma_of_perp_par(fp perp, fp par) const - { - return perp_is_rho() ? par : perp; - } - // ... (rho,sigma) --> (perp,par) - int iperp_of_irho_isigma(int irho, int isigma) const - { - return perp_is_rho() ? irho : isigma; - } - int ipar_of_irho_isigma(int irho, int isigma) const - { - return par_is_rho() ? irho : isigma; - } - fp perp_of_rho_sigma(fp rho, fp sigma) const - { - return perp_is_rho() ? rho : sigma; - } - fp par_of_rho_sigma(fp rho, fp sigma) const - { - return par_is_rho() ? rho : sigma; - } - - // outer perp of nominal grid on this edge - // ... this is outermost *grid point* - fp grid_outer_iperp() const - { - return my_patch().minmax_iang(is_min(), is_rho()); - } - // ... this is actual outer edge of grid - // (might be halfway between two grid points) - fp grid_outer_perp() const - { - return my_patch().minmax_ang(is_min(), is_rho()); - } - // ... this is grid_outer_perp() converted back to the iperp - // coordinate, but still returned as floating-point; - // it will be either integer or half-integer - fp fp_grid_outer_iperp() const - { - return fp_iperp_of_perp(grid_outer_perp()); - } - - // - // ***** min/max/outer coordinates of edge ***** - // - - // min/max/size ipar of the edge - // (these are exteme limits for any iperp, a given ghost zone - // or interpolation region may have tighter and/or iperp-dependent - // limits) - // ... not including corners - int min_ipar_without_corners() const - { - return my_patch().min_iang(par_is_rho()); - } - int max_ipar_without_corners() const - { - return my_patch().max_iang(par_is_rho()); - } - // ... including corners - int min_ipar_with_corners() const - { - return my_patch().ghosted_min_iang(par_is_rho()); - } - int max_ipar_with_corners() const - { - return my_patch().ghosted_max_iang(par_is_rho()); - } - // ... of the corners themselves - int min_ipar_corner__min_ipar() const - { - return min_ipar_with_corners(); - } - int min_ipar_corner__max_ipar() const - { - return min_ipar_without_corners() - 1; - } - int max_ipar_corner__min_ipar() const - { - return max_ipar_without_corners() + 1; - } - int max_ipar_corner__max_ipar() const - { - return max_ipar_with_corners(); - } - - // membership predicates for ipar corners, non-corners - bool ipar_is_in_min_ipar_corner(int ipar) const - { - return (ipar >= min_ipar_corner__min_ipar()) && (ipar <= min_ipar_corner__max_ipar()); - } - bool ipar_is_in_max_ipar_corner(int ipar) const - { - return (ipar >= max_ipar_corner__min_ipar()) && (ipar <= max_ipar_corner__max_ipar()); - } - bool ipar_is_in_corner(int ipar) const - { - return ipar_is_in_min_ipar_corner(ipar) || ipar_is_in_max_ipar_corner(ipar); - } - bool ipar_is_in_noncorner(int ipar) const - { - return (ipar >= min_ipar_without_corners()) && (ipar <= max_ipar_without_corners()); - } - - // convenience function selecting amongst the above - // membership predicates - bool ipar_is_in_selected_part(bool want_corners, - bool want_noncorner, - int ipar) - const - { - return (want_corners && ipar_is_in_corner(ipar)) || (want_noncorner && ipar_is_in_noncorner(ipar)); - } - - // outer (farthest from patch center) iperp of nominal grid - int nominal_grid_outer_iperp() const - { - return my_patch() - .minmax_iang(is_min(), is_rho()); - } - - // - // ***** constructor, destructor ***** - // - - patch_edge(patch &my_patch_in, - bool is_min_in, bool is_rho_in) - : my_patch_(my_patch_in), - is_min_(is_min_in), is_rho_(is_rho_in) - { - } - // compiler-synthesized (no-op) destructor is fine - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - patch_edge(const patch_edge &rhs); - patch_edge &operator=(const patch_edge &rhs); - - private: - patch &my_patch_; - const bool is_min_, is_rho_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* TPATCH_EDGE_H */ +#ifndef TPATCH_EDGE_H +#define TPATCH_EDGE_H +namespace AHFinderDirect +{ + + //***************************************************************************** + + // + // patch_edge -- perpendicular/parallel geometry of one side of a patch + // + // A patch_edge object is a very light-weight object which represents + // the basic geometry of a min/max rho/sigma side of a patch, i.e. it + // provides which-side-am-I predicates, coordinate conversions between + // (perp,par) and (rho,sigma), etc. Every patch has (points to) 4 patch_edge + // objects, one for each of the patch's sides. See the comments in + // "patch.hh" for a "big picture" discussion of patches, patch edges, + // ghost zones, and patch interpolation regions. + // + // Note that since patch_edge has only const member functions + // (and members!), a patch_edge object is effectively always const . + // This means there's no harm in always declaring patch_edge objects + // to be const . + // + + class patch_edge + { + public: + // + // ***** meta-info ***** + // + + // meta-info about patch + patch &my_patch() const { return my_patch_; } + + // meta-info about edge + bool is_rho() const { return is_rho_; } + bool is_min() const { return is_min_; } + bool perp_is_rho() const { return is_rho(); } + bool par_is_rho() const { return !is_rho(); } + + // human-readable {min,max}_{rho,sigma} name (for debugging etc) + const char *name() const + { + return is_min() + ? (is_rho() ? "min_rho" : "min_sigma") + : (is_rho() ? "max_rho" : "max_sigma"); + } + + // are two edges really the same edge? + bool operator==(const patch_edge &other_edge) const + { + return (my_patch() == other_edge.my_patch()) && (is_rho() == other_edge.is_rho()) && (is_min() == other_edge.is_min()); + } + bool operator!=(const patch_edge &other_edge) const + { + return !operator==(other_edge); + } + + // + // ***** adjacent edges ***** + // + + // get adjacent edges to our min/max par corners + const patch_edge &min_par_adjacent_edge() const + { + return my_patch() + .minmax_ang_patch_edge(grid::side_is_min, par_is_rho()); + } + const patch_edge &max_par_adjacent_edge() const + { + return my_patch() + .minmax_ang_patch_edge(grid::side_is_max, par_is_rho()); + } + const patch_edge &minmax_par_adjacent_edge(bool want_min) const + { + return want_min ? min_par_adjacent_edge() + : max_par_adjacent_edge(); + } + + // + // ***** gridfn subscripting and coordinate maps ***** + // + + // gridfn strides perpendicular/parallel to the edge + int perp_stride() const + { + return my_patch().iang_stride(perp_is_rho()); + } + int par_stride() const + { + return my_patch().iang_stride(par_is_rho()); + } + int ghosted_perp_stride() const + { + return my_patch().ghosted_iang_stride(perp_is_rho()); + } + int ghosted_par_stride() const + { + return my_patch().ghosted_iang_stride(par_is_rho()); + } + + // coordinate maps perpendicular/parallel to the edge + // ... range is that of the grid *including* ghost zones + const jtutil::linear_map &perp_map() const + { + return my_patch().ang_map(perp_is_rho()); + } + const jtutil::linear_map &par_map() const + { + return my_patch().ang_map(par_is_rho()); + } + + // meta-info about perp/par coordinates + // ... as (mu,nu,phi) tensor indices + local_coords::coords_set coords_set_perp() const + { + return perp_is_rho() ? my_patch().coords_set_rho() + : my_patch().coords_set_sigma(); + } + local_coords::coords_set coords_set_par() const + { + return par_is_rho() ? my_patch().coords_set_rho() + : my_patch().coords_set_sigma(); + } + + // + // ***** coordinate conversions ***** + // + + // coordinate conversions based on ghost zone direction + // ... (iperp,ipar) <--> (perp,par) + fp perp_of_iperp(int iperp) const + { + return my_patch().ang_of_iang(perp_is_rho(), iperp); + } + fp par_of_ipar(int ipar) const + { + return my_patch().ang_of_iang(par_is_rho(), ipar); + } + fp fp_iperp_of_perp(fp perp) const + { + return my_patch().fp_iang_of_ang(perp_is_rho(), perp); + } + fp fp_ipar_of_par(fp par) const + { + return my_patch().fp_iang_of_ang(par_is_rho(), par); + } + int iperp_of_perp(fp perp, jtutil::linear_map::noninteger_action + nia = jtutil::linear_map::nia_error) + { + return my_patch().iang_of_ang(perp_is_rho(), perp, nia); + } + int ipar_of_par(fp par, jtutil::linear_map::noninteger_action + nia = jtutil::linear_map::nia_error) + { + return my_patch().iang_of_ang(par_is_rho(), par, nia); + } + + // ... (perp,par) --> (rho,sigma) + int irho_of_iperp_ipar(int iperp, int ipar) const + { + return perp_is_rho() ? iperp : ipar; + } + int isigma_of_iperp_ipar(int iperp, int ipar) const + { + return perp_is_rho() ? ipar : iperp; + } + fp rho_of_perp_par(fp perp, fp par) const + { + return perp_is_rho() ? perp : par; + } + fp sigma_of_perp_par(fp perp, fp par) const + { + return perp_is_rho() ? par : perp; + } + // ... (rho,sigma) --> (perp,par) + int iperp_of_irho_isigma(int irho, int isigma) const + { + return perp_is_rho() ? irho : isigma; + } + int ipar_of_irho_isigma(int irho, int isigma) const + { + return par_is_rho() ? irho : isigma; + } + fp perp_of_rho_sigma(fp rho, fp sigma) const + { + return perp_is_rho() ? rho : sigma; + } + fp par_of_rho_sigma(fp rho, fp sigma) const + { + return par_is_rho() ? rho : sigma; + } + + // outer perp of nominal grid on this edge + // ... this is outermost *grid point* + fp grid_outer_iperp() const + { + return my_patch().minmax_iang(is_min(), is_rho()); + } + // ... this is actual outer edge of grid + // (might be halfway between two grid points) + fp grid_outer_perp() const + { + return my_patch().minmax_ang(is_min(), is_rho()); + } + // ... this is grid_outer_perp() converted back to the iperp + // coordinate, but still returned as floating-point; + // it will be either integer or half-integer + fp fp_grid_outer_iperp() const + { + return fp_iperp_of_perp(grid_outer_perp()); + } + + // + // ***** min/max/outer coordinates of edge ***** + // + + // min/max/size ipar of the edge + // (these are exteme limits for any iperp, a given ghost zone + // or interpolation region may have tighter and/or iperp-dependent + // limits) + // ... not including corners + int min_ipar_without_corners() const + { + return my_patch().min_iang(par_is_rho()); + } + int max_ipar_without_corners() const + { + return my_patch().max_iang(par_is_rho()); + } + // ... including corners + int min_ipar_with_corners() const + { + return my_patch().ghosted_min_iang(par_is_rho()); + } + int max_ipar_with_corners() const + { + return my_patch().ghosted_max_iang(par_is_rho()); + } + // ... of the corners themselves + int min_ipar_corner__min_ipar() const + { + return min_ipar_with_corners(); + } + int min_ipar_corner__max_ipar() const + { + return min_ipar_without_corners() - 1; + } + int max_ipar_corner__min_ipar() const + { + return max_ipar_without_corners() + 1; + } + int max_ipar_corner__max_ipar() const + { + return max_ipar_with_corners(); + } + + // membership predicates for ipar corners, non-corners + bool ipar_is_in_min_ipar_corner(int ipar) const + { + return (ipar >= min_ipar_corner__min_ipar()) && (ipar <= min_ipar_corner__max_ipar()); + } + bool ipar_is_in_max_ipar_corner(int ipar) const + { + return (ipar >= max_ipar_corner__min_ipar()) && (ipar <= max_ipar_corner__max_ipar()); + } + bool ipar_is_in_corner(int ipar) const + { + return ipar_is_in_min_ipar_corner(ipar) || ipar_is_in_max_ipar_corner(ipar); + } + bool ipar_is_in_noncorner(int ipar) const + { + return (ipar >= min_ipar_without_corners()) && (ipar <= max_ipar_without_corners()); + } + + // convenience function selecting amongst the above + // membership predicates + bool ipar_is_in_selected_part(bool want_corners, + bool want_noncorner, + int ipar) + const + { + return (want_corners && ipar_is_in_corner(ipar)) || (want_noncorner && ipar_is_in_noncorner(ipar)); + } + + // outer (farthest from patch center) iperp of nominal grid + int nominal_grid_outer_iperp() const + { + return my_patch() + .minmax_iang(is_min(), is_rho()); + } + + // + // ***** constructor, destructor ***** + // + + patch_edge(patch &my_patch_in, + bool is_min_in, bool is_rho_in) + : my_patch_(my_patch_in), + is_min_(is_min_in), is_rho_(is_rho_in) + { + } + // compiler-synthesized (no-op) destructor is fine + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + patch_edge(const patch_edge &rhs); + patch_edge &operator=(const patch_edge &rhs); + + private: + patch &my_patch_; + const bool is_min_, is_rho_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* TPATCH_EDGE_H */ diff --git a/AMSS_NCKU_source/patch_info.C b/AMSS_NCKU_source/AHF_Direct/patch_info.C similarity index 97% rename from AMSS_NCKU_source/patch_info.C rename to AMSS_NCKU_source/AHF_Direct/patch_info.C index 3503f47..46a416a 100644 --- a/AMSS_NCKU_source/patch_info.C +++ b/AMSS_NCKU_source/AHF_Direct/patch_info.C @@ -1,187 +1,187 @@ -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "patch_info.h" - -namespace AHFinderDirect - { -using jtutil::error_exit; - -//****************************************************************************** -//****************************************************************************** -//****************************************************************************** - -// -// This function computes, and returns a reference to, a -// struct grid_arrays::grid_array_pars from the info in a -// struct patch_info and the additional information in the arguments. -// -// The result refers to an internal static buffer in this function; the -// usual caveats about lifetimes/overwriting apply. -// -// Arguments: -// ghost_zone_width = Width in grid points of all ghost zones. -// patch_extend_width = Number of grid points to extend each patch past -// "just touching" so as to overlap neighboring patches. -// Thus patches overlap by -// patch_overlap_width = 2*patch_extend_width + 1 -// grid points. For example, with patch_extend_width == 2, -// here are the grid points of two neighboring patches: -// x x x x x X X -// | -// O O o o o o o -// Here | marks the "just touching" boundary, -// x and o the grid points before this extension, -// and X and O the extra grid points added by this -// extension. -// N_zones_per_right_angle = This sets the grid spacing (same in both -// directions) to 90.0 / N_zones_per_right_angle. -// It's a fatal error (error_exit()) if this -// doesn't evenly divide the grid sizes in both -// directions. -// -const grid_arrays::grid_array_pars& - patch_info::grid_array_pars(int ghost_zone_width, int patch_extend_width, - int N_zones_per_right_angle) - const -{ -static - struct grid_arrays::grid_array_pars grid_array_pars_buffer; - -// -// the values of min_(irho,isigma) are actually arbitrary, but for -// debugging convenience it's handy to have (irho,isigma) ranges map -// one-to-one with (rho,sigma) ranges across all patches; the assignments -// here have this property -// -const fp delta_drho_dsigma = 90.0 / fp(N_zones_per_right_angle); -grid_array_pars_buffer.min_irho - = jtutil::round::to_integer(min_drho /delta_drho_dsigma); -grid_array_pars_buffer.min_isigma - = jtutil::round::to_integer(min_dsigma/delta_drho_dsigma); - -verify_grid_spacing_ok(N_zones_per_right_angle); -const int N_irho_zones - = jtutil::round::to_integer( - fp(N_zones_per_right_angle) * (max_drho -min_drho ) / 90.0 - ); -const int N_isigma_zones - = jtutil::round::to_integer( - fp(N_zones_per_right_angle) * (max_dsigma-min_dsigma) / 90.0 - ); - -grid_array_pars_buffer.max_irho - = grid_array_pars_buffer.min_irho + N_irho_zones; -grid_array_pars_buffer.max_isigma - = grid_array_pars_buffer.min_isigma + N_isigma_zones; - -grid_array_pars_buffer.min_irho -= patch_extend_width; -grid_array_pars_buffer.min_isigma -= patch_extend_width; -grid_array_pars_buffer.max_irho += patch_extend_width; -grid_array_pars_buffer.max_isigma += patch_extend_width; - -grid_array_pars_buffer.min_rho_ghost_zone_width = ghost_zone_width; -grid_array_pars_buffer.max_rho_ghost_zone_width = ghost_zone_width; -grid_array_pars_buffer.min_sigma_ghost_zone_width = ghost_zone_width; -grid_array_pars_buffer.max_sigma_ghost_zone_width = ghost_zone_width; - -return grid_array_pars_buffer; -} - -//****************************************************************************** -// -// -// This function computes, and returns a reference to, a -// struct grid_arrays::grid_pars from the info in a struct patch_info -// and the additional information in the arguments. -// -// The result refers to an internal static buffer in this function; the -// usual caveats about lifetimes/overwriting apply. -// -// Arguments: -// patch_extend_width = Number of grid points to extend each patch past -// "just touching" so as to overlap neighboring patches. -// Thus patches overlap by 2*patch_extend_width + 1 grid -// points. For example, with patch_extend_width == 2, here -// are the grid points of two neighboring patches: -// x x x x x X X -// | -// O O o o o o o -// Here | marks the "just touching" boundary, -// x and o the grid points before this extension, -// and X and O the extra grid points added by this -// extension. -// N_zones_per_right_angle = This sets the grid spacing (same in both -// directions) to 90.0 / N_zones_per_right_angle. -// It's a fatal error (error_exit()) if this -// doesn't evenly divide the grid sizes in both -// directions. -// -const grid::grid_pars& patch_info::grid_pars(int patch_extend_width, - int N_zones_per_right_angle) - const -{ -static - struct grid::grid_pars grid_pars_buffer; - -verify_grid_spacing_ok(N_zones_per_right_angle); -const fp delta_drho_dsigma = 90.0 / fp(N_zones_per_right_angle); -const fp extend_drho_dsigma = fp(patch_extend_width) * delta_drho_dsigma; - -grid_pars_buffer. min_drho = min_drho - extend_drho_dsigma; -grid_pars_buffer.delta_drho = delta_drho_dsigma; -grid_pars_buffer. max_drho = max_drho + extend_drho_dsigma; -grid_pars_buffer. min_dsigma = min_dsigma - extend_drho_dsigma; -grid_pars_buffer.delta_dsigma = delta_drho_dsigma; -grid_pars_buffer. max_dsigma = max_dsigma + extend_drho_dsigma; - -return grid_pars_buffer; -} - -//****************************************************************************** - -// -// This function verifies that the grid spacing evenly divides the -// grid sizes in both directions, and does an error_exit() if not. -// -// Arguments: -// N_zones_per_right_angle = This sets the grid spacing (same in both -// directions) to 90.0 / N_zones_per_right_angle. -// -void patch_info::verify_grid_spacing_ok(int N_zones_per_right_angle) - const -{ -const fp N_irho_zones_fp - = fp(N_zones_per_right_angle) * (max_drho -min_drho ) / 90.0; -const fp N_isigma_zones_fp - = fp(N_zones_per_right_angle) * (max_dsigma-min_dsigma) / 90.0; - -if (! ( jtutil::fuzzy::is_integer(N_irho_zones_fp) - && jtutil::fuzzy::is_integer(N_isigma_zones_fp) ) ) - then error_exit(ERROR_EXIT, -"***** patch_info::verify_grid_spacing_ok():\n" -" N_zones_per_right_angle=%d gives grid spacing which\n" -" doesn't evenly divide grid sizes!\n" -" [min,max]_drho=[%g,%g] [min,max]_dsigma=[%g,%g]\n" -" ==> N_irho_zones_fp=%g N_isigma_zones_fp=%g\n" - , - N_zones_per_right_angle, - double(min_drho), double(max_drho), - double(min_dsigma), double(max_dsigma), - double(N_irho_zones_fp), double(N_isigma_zones_fp)); - /*NOTREACHED*/ -} - - } // namespace AHFinderDirect +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "patch_info.h" + +namespace AHFinderDirect + { +using jtutil::error_exit; + +//****************************************************************************** +//****************************************************************************** +//****************************************************************************** + +// +// This function computes, and returns a reference to, a +// struct grid_arrays::grid_array_pars from the info in a +// struct patch_info and the additional information in the arguments. +// +// The result refers to an internal static buffer in this function; the +// usual caveats about lifetimes/overwriting apply. +// +// Arguments: +// ghost_zone_width = Width in grid points of all ghost zones. +// patch_extend_width = Number of grid points to extend each patch past +// "just touching" so as to overlap neighboring patches. +// Thus patches overlap by +// patch_overlap_width = 2*patch_extend_width + 1 +// grid points. For example, with patch_extend_width == 2, +// here are the grid points of two neighboring patches: +// x x x x x X X +// | +// O O o o o o o +// Here | marks the "just touching" boundary, +// x and o the grid points before this extension, +// and X and O the extra grid points added by this +// extension. +// N_zones_per_right_angle = This sets the grid spacing (same in both +// directions) to 90.0 / N_zones_per_right_angle. +// It's a fatal error (error_exit()) if this +// doesn't evenly divide the grid sizes in both +// directions. +// +const grid_arrays::grid_array_pars& + patch_info::grid_array_pars(int ghost_zone_width, int patch_extend_width, + int N_zones_per_right_angle) + const +{ +static + struct grid_arrays::grid_array_pars grid_array_pars_buffer; + +// +// the values of min_(irho,isigma) are actually arbitrary, but for +// debugging convenience it's handy to have (irho,isigma) ranges map +// one-to-one with (rho,sigma) ranges across all patches; the assignments +// here have this property +// +const fp delta_drho_dsigma = 90.0 / fp(N_zones_per_right_angle); +grid_array_pars_buffer.min_irho + = jtutil::round::to_integer(min_drho /delta_drho_dsigma); +grid_array_pars_buffer.min_isigma + = jtutil::round::to_integer(min_dsigma/delta_drho_dsigma); + +verify_grid_spacing_ok(N_zones_per_right_angle); +const int N_irho_zones + = jtutil::round::to_integer( + fp(N_zones_per_right_angle) * (max_drho -min_drho ) / 90.0 + ); +const int N_isigma_zones + = jtutil::round::to_integer( + fp(N_zones_per_right_angle) * (max_dsigma-min_dsigma) / 90.0 + ); + +grid_array_pars_buffer.max_irho + = grid_array_pars_buffer.min_irho + N_irho_zones; +grid_array_pars_buffer.max_isigma + = grid_array_pars_buffer.min_isigma + N_isigma_zones; + +grid_array_pars_buffer.min_irho -= patch_extend_width; +grid_array_pars_buffer.min_isigma -= patch_extend_width; +grid_array_pars_buffer.max_irho += patch_extend_width; +grid_array_pars_buffer.max_isigma += patch_extend_width; + +grid_array_pars_buffer.min_rho_ghost_zone_width = ghost_zone_width; +grid_array_pars_buffer.max_rho_ghost_zone_width = ghost_zone_width; +grid_array_pars_buffer.min_sigma_ghost_zone_width = ghost_zone_width; +grid_array_pars_buffer.max_sigma_ghost_zone_width = ghost_zone_width; + +return grid_array_pars_buffer; +} + +//****************************************************************************** +// +// +// This function computes, and returns a reference to, a +// struct grid_arrays::grid_pars from the info in a struct patch_info +// and the additional information in the arguments. +// +// The result refers to an internal static buffer in this function; the +// usual caveats about lifetimes/overwriting apply. +// +// Arguments: +// patch_extend_width = Number of grid points to extend each patch past +// "just touching" so as to overlap neighboring patches. +// Thus patches overlap by 2*patch_extend_width + 1 grid +// points. For example, with patch_extend_width == 2, here +// are the grid points of two neighboring patches: +// x x x x x X X +// | +// O O o o o o o +// Here | marks the "just touching" boundary, +// x and o the grid points before this extension, +// and X and O the extra grid points added by this +// extension. +// N_zones_per_right_angle = This sets the grid spacing (same in both +// directions) to 90.0 / N_zones_per_right_angle. +// It's a fatal error (error_exit()) if this +// doesn't evenly divide the grid sizes in both +// directions. +// +const grid::grid_pars& patch_info::grid_pars(int patch_extend_width, + int N_zones_per_right_angle) + const +{ +static + struct grid::grid_pars grid_pars_buffer; + +verify_grid_spacing_ok(N_zones_per_right_angle); +const fp delta_drho_dsigma = 90.0 / fp(N_zones_per_right_angle); +const fp extend_drho_dsigma = fp(patch_extend_width) * delta_drho_dsigma; + +grid_pars_buffer. min_drho = min_drho - extend_drho_dsigma; +grid_pars_buffer.delta_drho = delta_drho_dsigma; +grid_pars_buffer. max_drho = max_drho + extend_drho_dsigma; +grid_pars_buffer. min_dsigma = min_dsigma - extend_drho_dsigma; +grid_pars_buffer.delta_dsigma = delta_drho_dsigma; +grid_pars_buffer. max_dsigma = max_dsigma + extend_drho_dsigma; + +return grid_pars_buffer; +} + +//****************************************************************************** + +// +// This function verifies that the grid spacing evenly divides the +// grid sizes in both directions, and does an error_exit() if not. +// +// Arguments: +// N_zones_per_right_angle = This sets the grid spacing (same in both +// directions) to 90.0 / N_zones_per_right_angle. +// +void patch_info::verify_grid_spacing_ok(int N_zones_per_right_angle) + const +{ +const fp N_irho_zones_fp + = fp(N_zones_per_right_angle) * (max_drho -min_drho ) / 90.0; +const fp N_isigma_zones_fp + = fp(N_zones_per_right_angle) * (max_dsigma-min_dsigma) / 90.0; + +if (! ( jtutil::fuzzy::is_integer(N_irho_zones_fp) + && jtutil::fuzzy::is_integer(N_isigma_zones_fp) ) ) + then error_exit(ERROR_EXIT, +"***** patch_info::verify_grid_spacing_ok():\n" +" N_zones_per_right_angle=%d gives grid spacing which\n" +" doesn't evenly divide grid sizes!\n" +" [min,max]_drho=[%g,%g] [min,max]_dsigma=[%g,%g]\n" +" ==> N_irho_zones_fp=%g N_isigma_zones_fp=%g\n" + , + N_zones_per_right_angle, + double(min_drho), double(max_drho), + double(min_dsigma), double(max_dsigma), + double(N_irho_zones_fp), double(N_isigma_zones_fp)); + /*NOTREACHED*/ +} + + } // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/patch_info.h b/AMSS_NCKU_source/AHF_Direct/patch_info.h similarity index 97% rename from AMSS_NCKU_source/patch_info.h rename to AMSS_NCKU_source/AHF_Direct/patch_info.h index 9af436f..6cb7ce6 100644 --- a/AMSS_NCKU_source/patch_info.h +++ b/AMSS_NCKU_source/AHF_Direct/patch_info.h @@ -1,70 +1,70 @@ -namespace AHFinderDirect -{ - - //***************************************************************************** - - // - // This (POD, and hence static-initializable) struct gives a minimal - // set of information which varies from one patch to another. - // - // The member functions allow computing all the grid:: constructor - // arguments; with these in hand it's fairly easy to construct the - // patch itself. This scheme doesn't allow the most general possible - // type of patch (eg it constrains all ghost zones to have the same width, - // and it requires the grid spacing to evenly divide 90 degrees), but - // it does cover all the cases that seem to come up in practice. - // - // Arguments for member functions: - // ghost_zone_width = Width in grid points of all ghost zones. - // patch_extend_width = Number of grid points to extend each patch past - // "just touching" so as to overlap neighboring patches. - // Thus patches overlap by - // patch_overlap_width = 2*patch_extend_width + 1 - // grid points. For example, with patch_extend_width == 2, - // here are the grid points of two neighboring patches: - // x x x x x X X - // | - // O O o o o o o - // Here | marks the "just touching" boundary, - // x and o the grid points before this extension, - // and X and O the extra grid points added by this - // extension. - // N_zones_per_right_angle = This sets the grid spacing (same in both - // directions) to 90.0 / N_zones_per_right_angle. - // It's a fatal error (error_exit()) if this - // doesn't evenly divide the grid sizes in both - // directions. - // - struct patch_info - { - const char *name; - bool is_plus; - char ctype; - fp min_drho, max_drho; - fp min_dsigma, max_dsigma; - - // compute and return reference to struct grid_arrays::grid_array_pars - // ... result refers to internal static buffer; - // the usual caveats about lifetimes/overwriting apply - const grid_arrays::grid_array_pars & - grid_array_pars(int ghost_zone_width, int patch_extend_width, - int N_zones_per_right_angle) - const; - - // compute and return reference to struct grid::grid_pars - // ... result refers to internal static buffer; - // the usual caveats about lifetimes/overwriting apply - const grid::grid_pars &grid_pars(int patch_extend_width, - int N_zones_per_right_angle) - const; - - private: - // verify that grid spacing evenly divides grid sizes - // in both directions; no-op if ok, error_exit() if not ok - void verify_grid_spacing_ok(int N_zones_per_right_angle) - const; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect +namespace AHFinderDirect +{ + + //***************************************************************************** + + // + // This (POD, and hence static-initializable) struct gives a minimal + // set of information which varies from one patch to another. + // + // The member functions allow computing all the grid:: constructor + // arguments; with these in hand it's fairly easy to construct the + // patch itself. This scheme doesn't allow the most general possible + // type of patch (eg it constrains all ghost zones to have the same width, + // and it requires the grid spacing to evenly divide 90 degrees), but + // it does cover all the cases that seem to come up in practice. + // + // Arguments for member functions: + // ghost_zone_width = Width in grid points of all ghost zones. + // patch_extend_width = Number of grid points to extend each patch past + // "just touching" so as to overlap neighboring patches. + // Thus patches overlap by + // patch_overlap_width = 2*patch_extend_width + 1 + // grid points. For example, with patch_extend_width == 2, + // here are the grid points of two neighboring patches: + // x x x x x X X + // | + // O O o o o o o + // Here | marks the "just touching" boundary, + // x and o the grid points before this extension, + // and X and O the extra grid points added by this + // extension. + // N_zones_per_right_angle = This sets the grid spacing (same in both + // directions) to 90.0 / N_zones_per_right_angle. + // It's a fatal error (error_exit()) if this + // doesn't evenly divide the grid sizes in both + // directions. + // + struct patch_info + { + const char *name; + bool is_plus; + char ctype; + fp min_drho, max_drho; + fp min_dsigma, max_dsigma; + + // compute and return reference to struct grid_arrays::grid_array_pars + // ... result refers to internal static buffer; + // the usual caveats about lifetimes/overwriting apply + const grid_arrays::grid_array_pars & + grid_array_pars(int ghost_zone_width, int patch_extend_width, + int N_zones_per_right_angle) + const; + + // compute and return reference to struct grid::grid_pars + // ... result refers to internal static buffer; + // the usual caveats about lifetimes/overwriting apply + const grid::grid_pars &grid_pars(int patch_extend_width, + int N_zones_per_right_angle) + const; + + private: + // verify that grid spacing evenly divides grid sizes + // in both directions; no-op if ok, error_exit() if not ok + void verify_grid_spacing_ok(int N_zones_per_right_angle) + const; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/patch_interp.C b/AMSS_NCKU_source/AHF_Direct/patch_interp.C similarity index 96% rename from AMSS_NCKU_source/patch_interp.C rename to AMSS_NCKU_source/AHF_Direct/patch_interp.C index b2a5624..bb17095 100644 --- a/AMSS_NCKU_source/patch_interp.C +++ b/AMSS_NCKU_source/AHF_Direct/patch_interp.C @@ -1,360 +1,360 @@ -#include -#include -#include - -#include "util_Table.h" -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" - -namespace AHFinderDirect -{ - int lagrange_interp(double coor_orin, double dx, double *gf, - int PTS, double ipx, double *out, int *mposn, double *Jac, - int ORD) // ORD-1 order lagrange interpolation - { - assert(PTS >= ORD); - int mi, mf; - - double *L, *x; - L = new double[PTS]; - x = new double[PTS]; - int i, j, k; - - //-- Determine molecular range - // for odd points, say 5, the molecular is - // | - // +-----+---x-+-----+-----+ - // - mi = jtutil::round::ceiling((ipx - coor_orin) / dx) - ORD / 2; - mf = mi + ORD; - if (mi < 0) - { - mi = 0; - mf = ORD; - } - else if (mf > PTS) - { - mf = PTS; - mi = PTS - ORD; - } - - //-- Setup coordinate by input origin, dx - for (j = mi; j < mf; j++) - x[j] = coor_orin + j * dx; - - //-- Lagrange basis function - *out = 0; - for (i = mi; i < mf; i++) - { - L[i] = 1.0; - for (k = mi; k < mf; k++) - if (k != i) - { - L[i] *= (ipx - x[k]) / (x[i] - x[k]); - } - *out += *(gf + i) * L[i]; - *Jac = L[i]; - Jac++; - } - - *mposn = mi; - - delete[] L; - delete[] x; - - return 0; // Normal retrun - } - - using jtutil::error_exit; - - patch_interp::patch_interp(const patch_edge &my_edge_in, - int min_iperp_in, int max_iperp_in, - const jtutil::array1d &min_parindex_array_in, - const jtutil::array1d &max_parindex_array_in, - const jtutil::array2d &interp_par_in, - bool ok_to_use_min_par_ghost_zone, - bool ok_to_use_max_par_ghost_zone, - int interp_handle_in, int interp_par_table_handle_in) - : my_patch_(my_edge_in.my_patch()), - my_edge_(my_edge_in), - min_gfn_(my_patch().ghosted_min_gfn()), - max_gfn_(my_patch().ghosted_max_gfn()), - ok_to_use_min_par_ghost_zone_(ok_to_use_min_par_ghost_zone), - ok_to_use_max_par_ghost_zone_(ok_to_use_max_par_ghost_zone), - min_iperp_(min_iperp_in), max_iperp_(max_iperp_in), - min_ipar_(ok_to_use_min_par_ghost_zone - ? my_edge_in.min_ipar_with_corners() - : my_edge_in.min_ipar_without_corners()), - max_ipar_(ok_to_use_max_par_ghost_zone - ? my_edge_in.max_ipar_with_corners() - : my_edge_in.max_ipar_without_corners()), - min_parindex_array_(min_parindex_array_in), - max_parindex_array_(max_parindex_array_in), - interp_par_(interp_par_in), - interp_handle_(interp_handle_in), - interp_par_table_handle_(1), - gridfn_coord_origin_(my_edge().par_map().fp_of_int(min_ipar_)), - gridfn_coord_delta_(my_edge().par_map().delta_fp()), - gridfn_data_ptrs_(min_gfn_, max_gfn_), - interp_data_buffer_ptrs_(min_gfn_, max_gfn_) // no comma - { - int status; - - const CCTK_INT stride = my_edge().ghosted_par_stride(); - - status = 0; - if (status < 0) - then error_exit(ERROR_EXIT, - "***** patch_interp::patch_interp():\n" - " can't set gridfn stride in interpolator parmameter table!\n" - " error status=%d\n", - status); /*NOTREACHED*/ - } - - patch_interp::~patch_interp() - { - } - - void patch_interp::interpolate(int ghosted_min_gfn_to_interp, - int ghosted_max_gfn_to_interp, - jtutil::array3d &data_buffer, - jtutil::array2d &posn_buffer, - jtutil::array3d &Jacobian_buffer) - const - - { - int status; - - const int N_dims = 1; - const int N_gridfns = jtutil::how_many_in_range(ghosted_min_gfn_to_interp, - ghosted_max_gfn_to_interp); - const CCTK_INT N_gridfn_data_points = jtutil::how_many_in_range(min_ipar(), max_ipar()); - - //-- Jacobian - const int Jacobian_interp_point_stride = Jacobian_buffer.subscript_stride_j(); - - // - // do the interpolations at each iperp - // - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - // - // interpolation-point coordinates - // - const int min_parindex = min_parindex_array_(iperp); - const int max_parindex = max_parindex_array_(iperp); - const CCTK_INT N_interp_points = jtutil::how_many_in_range(min_parindex, max_parindex); - const fp *const interp_coords_ptr = &interp_par_(iperp, min_parindex); - const void *const interp_coords[N_dims] = {static_cast(interp_coords_ptr)}; - - // - // pointers to gridfn data to interpolate, and to result buffer - // - for (int ghosted_gfn = ghosted_min_gfn_to_interp; - ghosted_gfn <= ghosted_max_gfn_to_interp; - ++ghosted_gfn) - { - // set up data pointer to --> (iperp,min_ipar) gridfn - const int start_irho = my_edge().irho_of_iperp_ipar(iperp, min_ipar()); - const int start_isigma = my_edge().isigma_of_iperp_ipar(iperp, min_ipar()); - gridfn_data_ptrs_(ghosted_gfn) = static_cast( - &my_patch() - .ghosted_gridfn(ghosted_gfn, - start_irho, start_isigma)); - interp_data_buffer_ptrs_(ghosted_gfn) = static_cast( - &data_buffer(ghosted_gfn, iperp, min_parindex)); - } - const void *const *const gridfn_data = &gridfn_data_ptrs_(ghosted_min_gfn_to_interp); - void *const *const interp_buffer = &interp_data_buffer_ptrs_(ghosted_min_gfn_to_interp); - - //-- molecule position - CCTK_POINTER molecule_posn_ptrs[N_dims] = {static_cast(&posn_buffer(iperp, min_parindex))}; - //-- Jacobian - CCTK_POINTER const Jacobian_ptrs[1] //[N_gridfns] - = {static_cast( - &Jacobian_buffer(iperp, min_parindex, 0))}; - // Jacobian_buffer has continuous memory allocation. - - const CCTK_INT stride = my_edge().ghosted_par_stride(); - double y[N_gridfn_data_points]; - - for (int i = 0; i < N_gridfn_data_points; i++) - { - y[i] = *((double *)(*gridfn_data) + stride * i); - } - - const int ORD = 6; - double Jac[ORD]; - int posn; // of molecular, starting from 0 - for (int i = 0; i < N_interp_points; i++) - { - status = lagrange_interp(gridfn_coord_origin_, gridfn_coord_delta_, - y, N_gridfn_data_points, - *((double *)interp_coords[0] + i), ((double *)(*interp_buffer) + i), - &posn, Jac, ORD); - - *((int *)molecule_posn_ptrs[0] + i) = posn + 2; - - memcpy((double *)(Jacobian_ptrs[0]) + Jacobian_buffer.min_k() + - Jacobian_interp_point_stride * i, - Jac, sizeof(Jac)); - } - - // convert the molecule positions from parindex-min_ipar - // to parindex values (again, cf comments on array subscripting - // at the start of "patch_interp.hh") - for (int parindex = min_parindex; - parindex <= max_parindex; - ++parindex) - { - posn_buffer(iperp, parindex) += min_ipar(); - } - - if (status < 0) - then error_exit(ERROR_EXIT, - "***** patch_interp::interpolate():\n" - " error return %d from interpolator at iperp=%d of [%d,%d]!\n" - " my_patch()=\"%s\" my_edge()=\"%s\"\n", - status, iperp, min_iperp(), max_iperp(), - my_patch().name(), my_edge().name()); /*NOTREACHED*/ - - } // end for iperp - } - - void patch_interp::verify_Jacobian_sparsity_pattern_ok() - const - { - CCTK_INT MSS_is_fn_of_interp_coords = 0, MSS_is_fn_of_input_array_values = 0; - CCTK_INT Jacobian_is_fn_of_input_array_values = 0; - - // - // verify that we grok the Jacobian sparsity pattern - // - if (MSS_is_fn_of_interp_coords || MSS_is_fn_of_input_array_values || Jacobian_is_fn_of_input_array_values) - then error_exit(ERROR_EXIT, - "***** patch_interp::verify_Jacobian_sparsity_pattern_ok():\n" - " implementation restriction: we only grok Jacobians with\n" - " fixed-sized hypercube-shaped molecules, independent of\n" - " the interpolation coordinates and the floating-point values!\n" - " MSS_is_fn_of_interp_coords=(int)%d (we only grok 0)\n" - " MSS_is_fn_of_input_array_values=(int)%d (we only grok 0)\n" - " Jacobian_is_fn_of_input_array_values=(int)%d (we only grok 0)\n", - MSS_is_fn_of_interp_coords, - MSS_is_fn_of_input_array_values, - Jacobian_is_fn_of_input_array_values); - } - - //****************************************************************************** - - // - // This function queries the interpolator to get the [min,max] ipar m - // coordinates of the interpolation molecules. - // - // (This API implicitly assumes that the Jacobian sparsity is one which - // is "ok" as verified by verify_Jacobian_sparsity_pattern_ok() .) - // - void patch_interp::molecule_minmax_ipar_m(int &min_ipar_m, int &max_ipar_m) - const - { - min_ipar_m = -2; - max_ipar_m = 3; - } - - //****************************************************************************** - - // - // This function queries the interpolator at each iperp to find out the - // molecule ipar positions (which we implicitly assume to be independent - // of ghosted_gfn), and stores these in posn_buffer(iperp, parindex) . - // - // (This API implicitly assumes that the Jacobian sparsity is one which - // is "ok" as verified by verify_Jacobian_sparsity_pattern_ok() .) - // - void patch_interp::molecule_posn(jtutil::array2d &posn_buffer) - const - { - const int N_dims = 1; - int status; - - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - const int min_parindex = min_parindex_array_(iperp); - const int max_parindex = max_parindex_array_(iperp); - - // set up the molecule-position query in the parameter table - CCTK_POINTER molecule_posn_ptrs[N_dims] = {static_cast(&posn_buffer(iperp, min_parindex))}; - status = 0; // Util_TableSetPointerArray(interp_par_table_handle_, N_dims, - // molecule_posn_ptrs, "molecule_positions"); - - if (status < 0) - then error_exit(ERROR_EXIT, - "***** patch_interp::molecule_posn():\n" - " can't set molecule position query\n" - " in interpolator parmameter table at iperp=%d of [%d,%d]!\n" - " error status=%d\n", - iperp, min_iperp(), max_iperp(), - status); /*NOTREACHED*/ - - for (int parindex = min_parindex; - parindex <= max_parindex; - ++parindex) - { - posn_buffer(iperp, parindex) += min_ipar(); - } - } - } - - void patch_interp::Jacobian(jtutil::array3d &Jacobian_buffer) - const - { - const int N_dims = 1; - const int N_gridfns = 1; - - int status1, status2; - - // - // set Jacobian stride info in parameter table - // - const int Jacobian_interp_point_stride = Jacobian_buffer.subscript_stride_j(); - - status1 = 0; - - status2 = 0; - - if ((status1 < 0) || (status2 < 0)) - then error_exit(ERROR_EXIT, - "***** patch_interp::Jacobian():\n" - " can't set Jacobian stride info in interpolator parmameter table!\n" - " error status1=%d status2=%d\n", - status1, status2); - - // - // query the Jacobians at each iperp - // - for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) - { - const int min_parindex = min_parindex_array_(iperp); - const int max_parindex = max_parindex_array_(iperp); - - // - // set up the Jacobian query in the parameter table - // - CCTK_POINTER const Jacobian_ptrs[N_gridfns] = {static_cast( - &Jacobian_buffer(iperp, min_parindex, 0))}; - } - } -} // namespace AHFinderDirect +#include +#include +#include + +#include "util_Table.h" +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" + +namespace AHFinderDirect +{ + int lagrange_interp(double coor_orin, double dx, double *gf, + int PTS, double ipx, double *out, int *mposn, double *Jac, + int ORD) // ORD-1 order lagrange interpolation + { + assert(PTS >= ORD); + int mi, mf; + + double *L, *x; + L = new double[PTS]; + x = new double[PTS]; + int i, j, k; + + //-- Determine molecular range + // for odd points, say 5, the molecular is + // | + // +-----+---x-+-----+-----+ + // + mi = jtutil::round::ceiling((ipx - coor_orin) / dx) - ORD / 2; + mf = mi + ORD; + if (mi < 0) + { + mi = 0; + mf = ORD; + } + else if (mf > PTS) + { + mf = PTS; + mi = PTS - ORD; + } + + //-- Setup coordinate by input origin, dx + for (j = mi; j < mf; j++) + x[j] = coor_orin + j * dx; + + //-- Lagrange basis function + *out = 0; + for (i = mi; i < mf; i++) + { + L[i] = 1.0; + for (k = mi; k < mf; k++) + if (k != i) + { + L[i] *= (ipx - x[k]) / (x[i] - x[k]); + } + *out += *(gf + i) * L[i]; + *Jac = L[i]; + Jac++; + } + + *mposn = mi; + + delete[] L; + delete[] x; + + return 0; // Normal retrun + } + + using jtutil::error_exit; + + patch_interp::patch_interp(const patch_edge &my_edge_in, + int min_iperp_in, int max_iperp_in, + const jtutil::array1d &min_parindex_array_in, + const jtutil::array1d &max_parindex_array_in, + const jtutil::array2d &interp_par_in, + bool ok_to_use_min_par_ghost_zone, + bool ok_to_use_max_par_ghost_zone, + int interp_handle_in, int interp_par_table_handle_in) + : my_patch_(my_edge_in.my_patch()), + my_edge_(my_edge_in), + min_gfn_(my_patch().ghosted_min_gfn()), + max_gfn_(my_patch().ghosted_max_gfn()), + ok_to_use_min_par_ghost_zone_(ok_to_use_min_par_ghost_zone), + ok_to_use_max_par_ghost_zone_(ok_to_use_max_par_ghost_zone), + min_iperp_(min_iperp_in), max_iperp_(max_iperp_in), + min_ipar_(ok_to_use_min_par_ghost_zone + ? my_edge_in.min_ipar_with_corners() + : my_edge_in.min_ipar_without_corners()), + max_ipar_(ok_to_use_max_par_ghost_zone + ? my_edge_in.max_ipar_with_corners() + : my_edge_in.max_ipar_without_corners()), + min_parindex_array_(min_parindex_array_in), + max_parindex_array_(max_parindex_array_in), + interp_par_(interp_par_in), + interp_handle_(interp_handle_in), + interp_par_table_handle_(1), + gridfn_coord_origin_(my_edge().par_map().fp_of_int(min_ipar_)), + gridfn_coord_delta_(my_edge().par_map().delta_fp()), + gridfn_data_ptrs_(min_gfn_, max_gfn_), + interp_data_buffer_ptrs_(min_gfn_, max_gfn_) // no comma + { + int status; + + const CCTK_INT stride = my_edge().ghosted_par_stride(); + + status = 0; + if (status < 0) + then error_exit(ERROR_EXIT, + "***** patch_interp::patch_interp():\n" + " can't set gridfn stride in interpolator parmameter table!\n" + " error status=%d\n", + status); /*NOTREACHED*/ + } + + patch_interp::~patch_interp() + { + } + + void patch_interp::interpolate(int ghosted_min_gfn_to_interp, + int ghosted_max_gfn_to_interp, + jtutil::array3d &data_buffer, + jtutil::array2d &posn_buffer, + jtutil::array3d &Jacobian_buffer) + const + + { + int status; + + const int N_dims = 1; + const int N_gridfns = jtutil::how_many_in_range(ghosted_min_gfn_to_interp, + ghosted_max_gfn_to_interp); + const CCTK_INT N_gridfn_data_points = jtutil::how_many_in_range(min_ipar(), max_ipar()); + + //-- Jacobian + const int Jacobian_interp_point_stride = Jacobian_buffer.subscript_stride_j(); + + // + // do the interpolations at each iperp + // + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + // + // interpolation-point coordinates + // + const int min_parindex = min_parindex_array_(iperp); + const int max_parindex = max_parindex_array_(iperp); + const CCTK_INT N_interp_points = jtutil::how_many_in_range(min_parindex, max_parindex); + const fp *const interp_coords_ptr = &interp_par_(iperp, min_parindex); + const void *const interp_coords[N_dims] = {static_cast(interp_coords_ptr)}; + + // + // pointers to gridfn data to interpolate, and to result buffer + // + for (int ghosted_gfn = ghosted_min_gfn_to_interp; + ghosted_gfn <= ghosted_max_gfn_to_interp; + ++ghosted_gfn) + { + // set up data pointer to --> (iperp,min_ipar) gridfn + const int start_irho = my_edge().irho_of_iperp_ipar(iperp, min_ipar()); + const int start_isigma = my_edge().isigma_of_iperp_ipar(iperp, min_ipar()); + gridfn_data_ptrs_(ghosted_gfn) = static_cast( + &my_patch() + .ghosted_gridfn(ghosted_gfn, + start_irho, start_isigma)); + interp_data_buffer_ptrs_(ghosted_gfn) = static_cast( + &data_buffer(ghosted_gfn, iperp, min_parindex)); + } + const void *const *const gridfn_data = &gridfn_data_ptrs_(ghosted_min_gfn_to_interp); + void *const *const interp_buffer = &interp_data_buffer_ptrs_(ghosted_min_gfn_to_interp); + + //-- molecule position + CCTK_POINTER molecule_posn_ptrs[N_dims] = {static_cast(&posn_buffer(iperp, min_parindex))}; + //-- Jacobian + CCTK_POINTER const Jacobian_ptrs[1] //[N_gridfns] + = {static_cast( + &Jacobian_buffer(iperp, min_parindex, 0))}; + // Jacobian_buffer has continuous memory allocation. + + const CCTK_INT stride = my_edge().ghosted_par_stride(); + double y[N_gridfn_data_points]; + + for (int i = 0; i < N_gridfn_data_points; i++) + { + y[i] = *((double *)(*gridfn_data) + stride * i); + } + + const int ORD = 6; + double Jac[ORD]; + int posn; // of molecular, starting from 0 + for (int i = 0; i < N_interp_points; i++) + { + status = lagrange_interp(gridfn_coord_origin_, gridfn_coord_delta_, + y, N_gridfn_data_points, + *((double *)interp_coords[0] + i), ((double *)(*interp_buffer) + i), + &posn, Jac, ORD); + + *((int *)molecule_posn_ptrs[0] + i) = posn + 2; + + memcpy((double *)(Jacobian_ptrs[0]) + Jacobian_buffer.min_k() + + Jacobian_interp_point_stride * i, + Jac, sizeof(Jac)); + } + + // convert the molecule positions from parindex-min_ipar + // to parindex values (again, cf comments on array subscripting + // at the start of "patch_interp.hh") + for (int parindex = min_parindex; + parindex <= max_parindex; + ++parindex) + { + posn_buffer(iperp, parindex) += min_ipar(); + } + + if (status < 0) + then error_exit(ERROR_EXIT, + "***** patch_interp::interpolate():\n" + " error return %d from interpolator at iperp=%d of [%d,%d]!\n" + " my_patch()=\"%s\" my_edge()=\"%s\"\n", + status, iperp, min_iperp(), max_iperp(), + my_patch().name(), my_edge().name()); /*NOTREACHED*/ + + } // end for iperp + } + + void patch_interp::verify_Jacobian_sparsity_pattern_ok() + const + { + CCTK_INT MSS_is_fn_of_interp_coords = 0, MSS_is_fn_of_input_array_values = 0; + CCTK_INT Jacobian_is_fn_of_input_array_values = 0; + + // + // verify that we grok the Jacobian sparsity pattern + // + if (MSS_is_fn_of_interp_coords || MSS_is_fn_of_input_array_values || Jacobian_is_fn_of_input_array_values) + then error_exit(ERROR_EXIT, + "***** patch_interp::verify_Jacobian_sparsity_pattern_ok():\n" + " implementation restriction: we only grok Jacobians with\n" + " fixed-sized hypercube-shaped molecules, independent of\n" + " the interpolation coordinates and the floating-point values!\n" + " MSS_is_fn_of_interp_coords=(int)%d (we only grok 0)\n" + " MSS_is_fn_of_input_array_values=(int)%d (we only grok 0)\n" + " Jacobian_is_fn_of_input_array_values=(int)%d (we only grok 0)\n", + MSS_is_fn_of_interp_coords, + MSS_is_fn_of_input_array_values, + Jacobian_is_fn_of_input_array_values); + } + + //****************************************************************************** + + // + // This function queries the interpolator to get the [min,max] ipar m + // coordinates of the interpolation molecules. + // + // (This API implicitly assumes that the Jacobian sparsity is one which + // is "ok" as verified by verify_Jacobian_sparsity_pattern_ok() .) + // + void patch_interp::molecule_minmax_ipar_m(int &min_ipar_m, int &max_ipar_m) + const + { + min_ipar_m = -2; + max_ipar_m = 3; + } + + //****************************************************************************** + + // + // This function queries the interpolator at each iperp to find out the + // molecule ipar positions (which we implicitly assume to be independent + // of ghosted_gfn), and stores these in posn_buffer(iperp, parindex) . + // + // (This API implicitly assumes that the Jacobian sparsity is one which + // is "ok" as verified by verify_Jacobian_sparsity_pattern_ok() .) + // + void patch_interp::molecule_posn(jtutil::array2d &posn_buffer) + const + { + const int N_dims = 1; + int status; + + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + const int min_parindex = min_parindex_array_(iperp); + const int max_parindex = max_parindex_array_(iperp); + + // set up the molecule-position query in the parameter table + CCTK_POINTER molecule_posn_ptrs[N_dims] = {static_cast(&posn_buffer(iperp, min_parindex))}; + status = 0; // Util_TableSetPointerArray(interp_par_table_handle_, N_dims, + // molecule_posn_ptrs, "molecule_positions"); + + if (status < 0) + then error_exit(ERROR_EXIT, + "***** patch_interp::molecule_posn():\n" + " can't set molecule position query\n" + " in interpolator parmameter table at iperp=%d of [%d,%d]!\n" + " error status=%d\n", + iperp, min_iperp(), max_iperp(), + status); /*NOTREACHED*/ + + for (int parindex = min_parindex; + parindex <= max_parindex; + ++parindex) + { + posn_buffer(iperp, parindex) += min_ipar(); + } + } + } + + void patch_interp::Jacobian(jtutil::array3d &Jacobian_buffer) + const + { + const int N_dims = 1; + const int N_gridfns = 1; + + int status1, status2; + + // + // set Jacobian stride info in parameter table + // + const int Jacobian_interp_point_stride = Jacobian_buffer.subscript_stride_j(); + + status1 = 0; + + status2 = 0; + + if ((status1 < 0) || (status2 < 0)) + then error_exit(ERROR_EXIT, + "***** patch_interp::Jacobian():\n" + " can't set Jacobian stride info in interpolator parmameter table!\n" + " error status1=%d status2=%d\n", + status1, status2); + + // + // query the Jacobians at each iperp + // + for (int iperp = min_iperp(); iperp <= max_iperp(); ++iperp) + { + const int min_parindex = min_parindex_array_(iperp); + const int max_parindex = max_parindex_array_(iperp); + + // + // set up the Jacobian query in the parameter table + // + CCTK_POINTER const Jacobian_ptrs[N_gridfns] = {static_cast( + &Jacobian_buffer(iperp, min_parindex, 0))}; + } + } +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/patch_interp.h b/AMSS_NCKU_source/AHF_Direct/patch_interp.h similarity index 97% rename from AMSS_NCKU_source/patch_interp.h rename to AMSS_NCKU_source/AHF_Direct/patch_interp.h index 3bb550c..df02fc0 100644 --- a/AMSS_NCKU_source/patch_interp.h +++ b/AMSS_NCKU_source/AHF_Direct/patch_interp.h @@ -1,293 +1,293 @@ -#ifndef TPATCH_INTERP_H -#define TPATCH_INTERP_H -namespace AHFinderDirect - { - -// -// patch_interp - interpolation from a patch -// - -// -// A patch_interp object is responsible for interpolating gridfn data -// from its owning patch for use by another patch's ghost_zone object -// (in setting up the gridfn in the other ghost zone). A patch_interp -// object deals only in its own patch's coordinates; other code elsewhere -// (in practice in interpatch_ghost_zone::) is responsible for translating -// other patch's coordinates into our coordinates. -// - -// -// A patch_interp defines a "patch interpolation region", the region of -// its owning patch from which this interpolation will use gridfn data. -// - -// -// The way the patch coordnates are constructed, any two adjacent patches -// share a common (perpendicular) coordinate. Thus we only have to do -// 1-dimensional interpolation here (in the parallel direction). In -// other words, for each iperp we interpolate in par. -// -// In general we interpolate each gridfn at a number of distinct par -// for each iperp; the integer "parindex" indexes these points. We -// attach no particular semantics to parindex, and it need not be -// 0-origin or have the same range for each iperp. [In practice, -// parindex will be the other patch's ipar coordinate.] However, -// we assume that the range of parindex is roughly similar for each -// iperp, so it's ok to use (iperp,parindex) as a 2-D rectangular -// index space. -// -// For example, we might interpolate at the points -// ipar ipar ipar ipar ipar ipar ipar ipar ipar -// 1 2 3 4 5 6 7 8 9 -// iperp=10 (2a) (3b) (4c) -// iperp=11 (2d) (3e) (4f) (5g) -// where the (2a)-(5g) are the interpolation points, with 2-5 being the -// parindex values and a-g being unique identifiers used in our description -// below. In terms of our member data, this interpolation region would -// be described by -// [min,max]_iperp_=[10,11] -// [min,max]_ipar_=[1,9] -// [min,max]_parindex_array_(10)=[2,5] -// [min,max]_parindex_array_(11)=[2,6] -// interp_par_(10,2) = x[a] -// interp_par_(10,3) = x[b] -// interp_par_(10,4) = x[c] -// interp_par_(11,2) = x[d] -// interp_par_(11,3) = x[e] -// interp_par_(11,4) = x[f] -// interp_par_(11,5) = x[g] -// - -// -// We use the Cactus local interpolator CCTK_InterpLocalUniform() -// to do the interpolation. To minimize interpolator overheads, we -// interpolate all the gridfns at each iperp in a single interpolator -// call. [Different iperp values involve different sets of (1-D) -// gridfn data, and so inherently require distinct interpolator calls.] -// -// Setting up the array subscripting for the interpolator to access -// the gridfn data is a bit tricky: The interpolator accesses the -// gridfn data using the generic (1-D) subscripting expression -// data[offset + i*stride] -// where i is the data array index. However, we'd rather not use -// offset , because it has to be supplied in the parameter table as -// an array subscripted by gfn , and so would require changing the -// parameter table for each call on interpolate() (with potentially -// different numbers of gridfns being interpolated). Instead, at each -// iperp we use i = ipar-min_ipar , so the default offset=0 makes -// the subscripting expression zero for ipar = min_ipar . This also -// makes the interpolator's min_i = 0 and max_i be dims-1 (both -// the defaults), so those also don't have to be set in the parameter -// table either. We set the interpolator's data coordinate origin to -// the par coordinate for min_ipar , so it correctly maps i --> par . -// With this strategy we can share the interpolator parameter table -// across all the iperp values, and we don't need to modify the -// parameter table at all after the initial setup in our constructor. -// However, we do have to adjust the molecule positions in -// patch_interp::molecule_posn() , since the interpolator will return -// i values, while molecule_posn() needs ipar values. -// - -class patch_interp - { -public: - // to which patch/edge do we belong? - const patch& my_patch() const { return my_patch_; } - const patch_edge& my_edge() const { return my_edge_; } - - -public: - // - // ***** main client interface ***** - // - // interpolate specified range of ghosted gridfns - // at all the coordinates specified when we were constructed, - // store interpolated data in - // data_buffer(ghosted_gfn, iperp, parindex) - void interpolate(int ghosted_min_gfn_to_interp, - int ghosted_max_gfn_to_interp, - jtutil::array3d& data_buffer) - const; - void interpolate(int ghosted_min_gfn_to_interp, - int ghosted_max_gfn_to_interp, - jtutil::array3d& data_buffer, - jtutil::array2d& posn_buffer, - jtutil::array3d& Jacobian_buffe) - const; - -public: - // - // ***** Jacobian of interpolate() ***** - // - - // verify (no-op if ok, error_exit() if not) that interpolator - // has a Jacobian sparsity pattern which we grok: at present this - // means molecules are fixed-sized hypercubes, with size/shape - // independent of interpolation coordinates and the floating-point - // values in the input arrays - void verify_Jacobian_sparsity_pattern_ok() const; - - // - // The API for the remaining Jacobian functions implicitly - // assumes that the Jacobian sparsity pattern is "ok" as - // verified by verify_Jacobian_sparsity_pattern_ok() , - // and in particular that [min,max]_ipar_m are independent - // of iperp and parindex. - // - - // get [min,max] ipar m coordinates of interpolation molecules - void molecule_minmax_ipar_m(int& min_ipar_m, int& max_ipar_m) const; - - // get interpolation molecule ipar positions in - // molecule_posn_buffer(iperp, parindex) - // ... array type is CCTK_INT so we can pass by reference - // to interpolator - void molecule_posn(jtutil::array2d& posn_buffer) const; - - // get Jacobian of interpolated data with respect to this patch's - // ghosted gridfns, - // partial interpolate() data_buffer(ghosted_gfn, iperp, parindex) - // --------------------------------------------------------------- - // partial ghosted_gridfn(ghosted_gfn, iperp, posn+ipar_m) - // store Jacobian in - // Jacobian_buffer(iperp, parindex, ipar_m) - // where we implicitly assume the Jacobian to be independent of - // ghosted_gfn, and where - // posn = posn_buffer(iperp, parindex) - // as returned by molecule_posn() - void Jacobian(jtutil::array3d& Jacobian_buffer) const; - - // - // ***** internal functions ***** - // -private: - // [min,max] iperp for interpolation and gridfn data - int min_iperp() const { return min_iperp_; } - int max_iperp() const { return max_iperp_; } - - // min/max (iperp,ipar) of the gridfn data to use for interpolation - int min_ipar() const { return min_ipar_; } - int max_ipar() const { return max_ipar_; } - - // - // ***** constructor, destructor, et al ***** - // -public: - // - // Constructor arguments: - // my_edge_in = Identifies the patch/edge to which this - // interpolation region is to belong. - // [min,max]_iperp_in = The range of iperp for this interpolation - // region - // [min,max]_parindex_array_in(iperp) - // = [min,max] range of parindex actually used at each iperp. - // We keep references to these arrays, so they should have - // lifetimes at last as long as that of this object. - // interp_par_in(iperp,parindex) - // = Gives the par coordinates at which we will interpolate; - // array entries outside the range [min,max]_parindex_in - // are unused. We keep a reference to this array, so it - // should have a lifetime at last as long as that of this - // object. - // ok_to_use_[min,max]_par_ghost_zone - // = Boolean flags saying whether or not we should use gridfn - // data from the [min,max]_par ghost zones in the interpolation. - // interp_handle_in = Cactus handle to the interpatch interpolation - // operator. - // interp_par_table_handle_in - // = Cactus handle to a Cactus key/value table giving - // parameters (eg order) for the interpatch interpolation - // operator. This class internally clones this table and - // modifies the clone, so the original table is not modified - // by any actions of this class. - // - // This constructor requires that this patch's gridfns already - // exist, since we size various arrays based on the patch's min/max - // ghosted gfn. - // - patch_interp(const patch_edge& my_edge_in, - int min_iperp_in, int max_iperp_in, - const jtutil::array1d& min_parindex_array_in, - const jtutil::array1d& max_parindex_array_in, - const jtutil::array2d& interp_par_in, - bool ok_to_use_min_par_ghost_zone, - bool ok_to_use_max_par_ghost_zone, - int interp_handle_in, int interp_par_table_handle_in); - ~patch_interp(); - -private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - patch_interp(const patch_interp& rhs); - patch_interp& operator=(const patch_interp& rhs); - - - // - // ***** data members ***** - // -private: - const patch& my_patch_; - const patch_edge& my_edge_; - - // range of gfn we can handle - // (any given interpolate() call may specify a subrange) - const int min_gfn_, max_gfn_; - - // these are strictly speaking redundant - // but we keep them for use in debugging - bool ok_to_use_min_par_ghost_zone_, ok_to_use_max_par_ghost_zone_; - - // patch interpolation region, - // i.e. range of (iperp,ipar) in this patch from which - // we will use gridfn data in interpolation - const int min_iperp_, max_iperp_; - const int min_ipar_, max_ipar_; - - // [min,max] parindex at each iperp - // ... these are references to arrays passed in to our constructor - // ==> we do *not* own them! - // ... indices are (iperp) - const jtutil::array1d& min_parindex_array_; - const jtutil::array1d& max_parindex_array_; - - // interp_par_(iperp,parindex) - // = Gives the par coordinates at which we will interpolate; - // array entries outside the range [min,max]_parindex_in - // are unused (n.b. this interface implicitly takes the - // par coordinates to be independent of ghosted_gfn). - // ... this is a reference to an array passed in to our constructor - // ==> we do *not* own this! - const jtutil::array2d& interp_par_; // indices (iperp,parindex) - - // Cactus handle to the interpolation operator - int interp_handle_; - - // Cactus handle to our private Cactus key/value table - // giving parameters for the interpolation operator - // ... this starts out as a copy of the passed-in table, - // then gets extra stuff added to it specific to this - // interpolation region; it's shared across all iperp - // ... we own this table - const int interp_par_table_handle_; - - // (par) origin and delta values of the gridfn data - const fp gridfn_coord_origin_, gridfn_coord_delta_; - - // --> start of gridfn data to use for interpolation - // (reset for each iperp) - // ... we do *not* own the pointed-to data! - // ... index is (gfn) - mutable jtutil::array1d gridfn_data_ptrs_; - - // --> start of interpolation data buffer for each gridfn - // (reset for each iperp) - // ... we do *not* own the pointed-to data! - // ... index is (gfn) - mutable jtutil::array1d interp_data_buffer_ptrs_; - }; - -//****************************************************************************** - - } // namespace AHFinderDirect -#endif /* TPATCH_INTERP_H */ +#ifndef TPATCH_INTERP_H +#define TPATCH_INTERP_H +namespace AHFinderDirect + { + +// +// patch_interp - interpolation from a patch +// + +// +// A patch_interp object is responsible for interpolating gridfn data +// from its owning patch for use by another patch's ghost_zone object +// (in setting up the gridfn in the other ghost zone). A patch_interp +// object deals only in its own patch's coordinates; other code elsewhere +// (in practice in interpatch_ghost_zone::) is responsible for translating +// other patch's coordinates into our coordinates. +// + +// +// A patch_interp defines a "patch interpolation region", the region of +// its owning patch from which this interpolation will use gridfn data. +// + +// +// The way the patch coordnates are constructed, any two adjacent patches +// share a common (perpendicular) coordinate. Thus we only have to do +// 1-dimensional interpolation here (in the parallel direction). In +// other words, for each iperp we interpolate in par. +// +// In general we interpolate each gridfn at a number of distinct par +// for each iperp; the integer "parindex" indexes these points. We +// attach no particular semantics to parindex, and it need not be +// 0-origin or have the same range for each iperp. [In practice, +// parindex will be the other patch's ipar coordinate.] However, +// we assume that the range of parindex is roughly similar for each +// iperp, so it's ok to use (iperp,parindex) as a 2-D rectangular +// index space. +// +// For example, we might interpolate at the points +// ipar ipar ipar ipar ipar ipar ipar ipar ipar +// 1 2 3 4 5 6 7 8 9 +// iperp=10 (2a) (3b) (4c) +// iperp=11 (2d) (3e) (4f) (5g) +// where the (2a)-(5g) are the interpolation points, with 2-5 being the +// parindex values and a-g being unique identifiers used in our description +// below. In terms of our member data, this interpolation region would +// be described by +// [min,max]_iperp_=[10,11] +// [min,max]_ipar_=[1,9] +// [min,max]_parindex_array_(10)=[2,5] +// [min,max]_parindex_array_(11)=[2,6] +// interp_par_(10,2) = x[a] +// interp_par_(10,3) = x[b] +// interp_par_(10,4) = x[c] +// interp_par_(11,2) = x[d] +// interp_par_(11,3) = x[e] +// interp_par_(11,4) = x[f] +// interp_par_(11,5) = x[g] +// + +// +// We use the Cactus local interpolator CCTK_InterpLocalUniform() +// to do the interpolation. To minimize interpolator overheads, we +// interpolate all the gridfns at each iperp in a single interpolator +// call. [Different iperp values involve different sets of (1-D) +// gridfn data, and so inherently require distinct interpolator calls.] +// +// Setting up the array subscripting for the interpolator to access +// the gridfn data is a bit tricky: The interpolator accesses the +// gridfn data using the generic (1-D) subscripting expression +// data[offset + i*stride] +// where i is the data array index. However, we'd rather not use +// offset , because it has to be supplied in the parameter table as +// an array subscripted by gfn , and so would require changing the +// parameter table for each call on interpolate() (with potentially +// different numbers of gridfns being interpolated). Instead, at each +// iperp we use i = ipar-min_ipar , so the default offset=0 makes +// the subscripting expression zero for ipar = min_ipar . This also +// makes the interpolator's min_i = 0 and max_i be dims-1 (both +// the defaults), so those also don't have to be set in the parameter +// table either. We set the interpolator's data coordinate origin to +// the par coordinate for min_ipar , so it correctly maps i --> par . +// With this strategy we can share the interpolator parameter table +// across all the iperp values, and we don't need to modify the +// parameter table at all after the initial setup in our constructor. +// However, we do have to adjust the molecule positions in +// patch_interp::molecule_posn() , since the interpolator will return +// i values, while molecule_posn() needs ipar values. +// + +class patch_interp + { +public: + // to which patch/edge do we belong? + const patch& my_patch() const { return my_patch_; } + const patch_edge& my_edge() const { return my_edge_; } + + +public: + // + // ***** main client interface ***** + // + // interpolate specified range of ghosted gridfns + // at all the coordinates specified when we were constructed, + // store interpolated data in + // data_buffer(ghosted_gfn, iperp, parindex) + void interpolate(int ghosted_min_gfn_to_interp, + int ghosted_max_gfn_to_interp, + jtutil::array3d& data_buffer) + const; + void interpolate(int ghosted_min_gfn_to_interp, + int ghosted_max_gfn_to_interp, + jtutil::array3d& data_buffer, + jtutil::array2d& posn_buffer, + jtutil::array3d& Jacobian_buffe) + const; + +public: + // + // ***** Jacobian of interpolate() ***** + // + + // verify (no-op if ok, error_exit() if not) that interpolator + // has a Jacobian sparsity pattern which we grok: at present this + // means molecules are fixed-sized hypercubes, with size/shape + // independent of interpolation coordinates and the floating-point + // values in the input arrays + void verify_Jacobian_sparsity_pattern_ok() const; + + // + // The API for the remaining Jacobian functions implicitly + // assumes that the Jacobian sparsity pattern is "ok" as + // verified by verify_Jacobian_sparsity_pattern_ok() , + // and in particular that [min,max]_ipar_m are independent + // of iperp and parindex. + // + + // get [min,max] ipar m coordinates of interpolation molecules + void molecule_minmax_ipar_m(int& min_ipar_m, int& max_ipar_m) const; + + // get interpolation molecule ipar positions in + // molecule_posn_buffer(iperp, parindex) + // ... array type is CCTK_INT so we can pass by reference + // to interpolator + void molecule_posn(jtutil::array2d& posn_buffer) const; + + // get Jacobian of interpolated data with respect to this patch's + // ghosted gridfns, + // partial interpolate() data_buffer(ghosted_gfn, iperp, parindex) + // --------------------------------------------------------------- + // partial ghosted_gridfn(ghosted_gfn, iperp, posn+ipar_m) + // store Jacobian in + // Jacobian_buffer(iperp, parindex, ipar_m) + // where we implicitly assume the Jacobian to be independent of + // ghosted_gfn, and where + // posn = posn_buffer(iperp, parindex) + // as returned by molecule_posn() + void Jacobian(jtutil::array3d& Jacobian_buffer) const; + + // + // ***** internal functions ***** + // +private: + // [min,max] iperp for interpolation and gridfn data + int min_iperp() const { return min_iperp_; } + int max_iperp() const { return max_iperp_; } + + // min/max (iperp,ipar) of the gridfn data to use for interpolation + int min_ipar() const { return min_ipar_; } + int max_ipar() const { return max_ipar_; } + + // + // ***** constructor, destructor, et al ***** + // +public: + // + // Constructor arguments: + // my_edge_in = Identifies the patch/edge to which this + // interpolation region is to belong. + // [min,max]_iperp_in = The range of iperp for this interpolation + // region + // [min,max]_parindex_array_in(iperp) + // = [min,max] range of parindex actually used at each iperp. + // We keep references to these arrays, so they should have + // lifetimes at last as long as that of this object. + // interp_par_in(iperp,parindex) + // = Gives the par coordinates at which we will interpolate; + // array entries outside the range [min,max]_parindex_in + // are unused. We keep a reference to this array, so it + // should have a lifetime at last as long as that of this + // object. + // ok_to_use_[min,max]_par_ghost_zone + // = Boolean flags saying whether or not we should use gridfn + // data from the [min,max]_par ghost zones in the interpolation. + // interp_handle_in = Cactus handle to the interpatch interpolation + // operator. + // interp_par_table_handle_in + // = Cactus handle to a Cactus key/value table giving + // parameters (eg order) for the interpatch interpolation + // operator. This class internally clones this table and + // modifies the clone, so the original table is not modified + // by any actions of this class. + // + // This constructor requires that this patch's gridfns already + // exist, since we size various arrays based on the patch's min/max + // ghosted gfn. + // + patch_interp(const patch_edge& my_edge_in, + int min_iperp_in, int max_iperp_in, + const jtutil::array1d& min_parindex_array_in, + const jtutil::array1d& max_parindex_array_in, + const jtutil::array2d& interp_par_in, + bool ok_to_use_min_par_ghost_zone, + bool ok_to_use_max_par_ghost_zone, + int interp_handle_in, int interp_par_table_handle_in); + ~patch_interp(); + +private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + patch_interp(const patch_interp& rhs); + patch_interp& operator=(const patch_interp& rhs); + + + // + // ***** data members ***** + // +private: + const patch& my_patch_; + const patch_edge& my_edge_; + + // range of gfn we can handle + // (any given interpolate() call may specify a subrange) + const int min_gfn_, max_gfn_; + + // these are strictly speaking redundant + // but we keep them for use in debugging + bool ok_to_use_min_par_ghost_zone_, ok_to_use_max_par_ghost_zone_; + + // patch interpolation region, + // i.e. range of (iperp,ipar) in this patch from which + // we will use gridfn data in interpolation + const int min_iperp_, max_iperp_; + const int min_ipar_, max_ipar_; + + // [min,max] parindex at each iperp + // ... these are references to arrays passed in to our constructor + // ==> we do *not* own them! + // ... indices are (iperp) + const jtutil::array1d& min_parindex_array_; + const jtutil::array1d& max_parindex_array_; + + // interp_par_(iperp,parindex) + // = Gives the par coordinates at which we will interpolate; + // array entries outside the range [min,max]_parindex_in + // are unused (n.b. this interface implicitly takes the + // par coordinates to be independent of ghosted_gfn). + // ... this is a reference to an array passed in to our constructor + // ==> we do *not* own this! + const jtutil::array2d& interp_par_; // indices (iperp,parindex) + + // Cactus handle to the interpolation operator + int interp_handle_; + + // Cactus handle to our private Cactus key/value table + // giving parameters for the interpolation operator + // ... this starts out as a copy of the passed-in table, + // then gets extra stuff added to it specific to this + // interpolation region; it's shared across all iperp + // ... we own this table + const int interp_par_table_handle_; + + // (par) origin and delta values of the gridfn data + const fp gridfn_coord_origin_, gridfn_coord_delta_; + + // --> start of gridfn data to use for interpolation + // (reset for each iperp) + // ... we do *not* own the pointed-to data! + // ... index is (gfn) + mutable jtutil::array1d gridfn_data_ptrs_; + + // --> start of interpolation data buffer for each gridfn + // (reset for each iperp) + // ... we do *not* own the pointed-to data! + // ... index is (gfn) + mutable jtutil::array1d interp_data_buffer_ptrs_; + }; + +//****************************************************************************** + + } // namespace AHFinderDirect +#endif /* TPATCH_INTERP_H */ diff --git a/AMSS_NCKU_source/patch_system.C b/AMSS_NCKU_source/AHF_Direct/patch_system.C similarity index 97% rename from AMSS_NCKU_source/patch_system.C rename to AMSS_NCKU_source/AHF_Direct/patch_system.C index f31f5de..844f646 100644 --- a/AMSS_NCKU_source/patch_system.C +++ b/AMSS_NCKU_source/AHF_Direct/patch_system.C @@ -1,2522 +1,2522 @@ -#include -#include -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_info.h" -#include "patch_system.h" -#include "patch_system_info.h" - -namespace AHFinderDirect -{ - using jtutil::error_exit; - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function constructs a patch_system object. - // - // Constructor arguments: - // ghost_zone_width = Width in grid points of all ghost zones. - // patch_overlap_width = Number of grid points that adjacent - // nominally-just-touching patches should overlap. - // For example, with patch_overlap_width == 3, here - // are the grid points of two neighboring patches: - // x x x x x X - // | - // O o o o o o - // Here | marks the "just touching" boundary, - // x and o the grid points before this extension, - // and X and O the extra grid points added by this - // extension. For this example, the patch_extend_width - // parameter used by some other functions would - // be 1; in general - // patch_overlap_width = 2*patch_extend_width + 1 - // N_zones_per_right_angle = This sets the grid spacing (same in both - // directions) to 90.0 / N_zones_per_right_angle. - // It's a fatal error (error_exit()) if this - // doesn't evenly divide the grid sizes in both - // directions. - // ip_interp_handle = Cactus handle to the interpatch interpolation operator; - // this must be a 1-D interpolator - // ip_interp_par_table_handle = Cactus handle to the parameter table for the - // interpatch interpolation operator - // surface_interp_handle = Cactus handle to the surface interpolation - // operator; this is optional, and is only used by - // radius_in_{local,global}_xyz_direction() - // If this is used, it must be a 2-D interpolator - // surface_interp_par_table_handle = Cactus handle to the parameter table - // for the surface interpolation operator; - // this is optional, and is only used by - // radius_in_local_xyz_direction() - // print_summary_msg_flag = true to print 2 lines of CCTK_VInfo messages - // giving the patch system type and origin - // false to skip this - // print_detailed_msg_flag = true to print extensive messages tracing the - // creation and initialization of various - // data structures - // false to skip this - // - patch_system::patch_system(fp origin_x_in, fp origin_y_in, fp origin_z_in, - enum patch_system_type type_in, - int ghost_zone_width, int patch_overlap_width, - int N_zones_per_right_angle, - int min_gfn_in, int max_gfn_in, - int ghosted_min_gfn_in, int ghosted_max_gfn_in, - int ip_interp_handle, int ip_interp_par_table_handle, - int surface_interp_handle_in, - int surface_interp_par_table_handle_in, - bool print_summary_msg_flag, - bool print_detailed_msg_flag) - - : global_coords_(origin_x_in, origin_y_in, origin_z_in), - type_(type_in), - N_patches_(N_patches_of_type(type_in)), - all_patches_(new patch *[N_patches_]), - starting_gpn_(new int[N_patches_ + 1]), - ghosted_starting_gpn_(new int[N_patches_ + 1]), - gridfn_storage_(NULL), // set in setup_gridfn_storage() - ghosted_gridfn_storage_(NULL), // set in setup_gridfn_storage() - global_min_ym_(0), global_max_ym_(0), - // set in compute_synchronize_Jacobian() - surface_interp_handle_(surface_interp_handle_in), - surface_interp_par_table_handle_(surface_interp_par_table_handle_in) - { - if (!jtutil::is_odd(patch_overlap_width)) - then error_exit(ERROR_EXIT, - "***** patch_system::patch_system(): implementation restriction:\n" - " patch_overlap_width=%d, but we only support odd values!\n", - patch_overlap_width); /*NOTREACHED*/ - const int patch_extend_width = patch_overlap_width >> 1; - - if (ghost_zone_width < fd_grid::molecule_radius()) - { - cout << "***** patch_system::patch_system():" << endl - << " must have ghost_zone_width >= fd_grid::molecule_radius()" << endl - << " but got ghost_zone_width=" << ghost_zone_width << " fd_grid::molecule_radius()=" << fd_grid::molecule_radius() << "!" << endl - << " finite difference order=4" << endl; - abort(); - } - - if (print_summary_msg_flag) - then - { - CCTK_VInfo(CCTK_THORNSTRING, - " constructing %s patch system", - name_of_type(type())); - CCTK_VInfo(CCTK_THORNSTRING, - " with %d angular zones per right angle", - N_zones_per_right_angle); - } - - // construct/interlink the patches and ghost zones - switch (type_in) - { - case patch_system__full_sphere: - create_patches(patch_system_info::full_sphere::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__full_sphere(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_z_hemisphere: - create_patches(patch_system_info::plus_z_hemisphere::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_z_hemisphere(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_xy_quadrant_mirrored: - create_patches(patch_system_info::plus_xy_quadrant::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_xy_quadrant_mirrored(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_xy_quadrant_rotating: - create_patches(patch_system_info::plus_xy_quadrant::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_xy_quadrant_rotating(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_xz_quadrant_mirrored: - create_patches(patch_system_info::plus_xz_quadrant::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_xz_quadrant_mirrored(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_xz_quadrant_rotating: - create_patches(patch_system_info::plus_xz_quadrant::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_xz_quadrant_rotating(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_xyz_octant_mirrored: - create_patches(patch_system_info::plus_xyz_octant::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_xyz_octant_mirrored(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - case patch_system__plus_xyz_octant_rotating: - create_patches(patch_system_info::plus_xyz_octant::patch_info_array, - ghost_zone_width, patch_extend_width, - N_zones_per_right_angle, - print_detailed_msg_flag); - setup_gridfn_storage(min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in, - print_detailed_msg_flag); - setup_ghost_zones__plus_xyz_octant_rotating(patch_overlap_width, - ip_interp_handle, - ip_interp_par_table_handle, - print_detailed_msg_flag); - break; - - default: - error_exit(ERROR_EXIT, - "***** patch_system::patch_system(): bad type_in=(int)%d!\n", - int(type_in)); /*NOTREACHED*/ - } - - if (print_summary_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " ==> %d nominal, %d ghosted angular grid points", - N_grid_points(), ghosted_N_grid_points()); - } - - //****************************************************************************** - - // - // This function destroys a patch_system object. - // - patch_system::~patch_system() - { - for (int pn = N_patches() - 1; pn >= 0; --pn) - { - if (&ith_patch(pn)) - delete &ith_patch(pn); - } - - if (ghosted_gridfn_storage_) - delete[] ghosted_gridfn_storage_; - if (gridfn_storage_) - delete[] gridfn_storage_; - if (ghosted_starting_gpn_) - delete[] ghosted_starting_gpn_; - if (starting_gpn_) - delete[] starting_gpn_; - if (all_patches_) - delete[] all_patches_; - } - - //****************************************************************************** - - // - // This function is called from the patch_system:: constructor to - // construct a set of patches as described by an array of patch_info - // structures and associated arguments, and make these patches members - // of this patch system. This function also correctly sets - // N_grid_points_ - // N_ghosted_grid_points_ - // all_patches_[] - // starting_gpn_[] - // ghosted_starting_gpn_[] - // This function does *NOT* create any of the ghost zones, and does - // *NOT* set up any gridfns. - // - void patch_system::create_patches(const struct patch_info patch_info_in[], - int ghost_zone_width, int patch_extend_width, - int N_zones_per_right_angle, - bool print_msg_flag) - { - N_grid_points_ = 0; - ghosted_N_grid_points_ = 0; - for (int pn = 0; pn < N_patches(); ++pn) - { - const struct patch_info &pi = patch_info_in[pn]; - const struct grid::grid_array_pars &grid_array_pars = pi.grid_array_pars(ghost_zone_width, - patch_extend_width, - N_zones_per_right_angle); - const struct grid::grid_pars &grid_pars = pi.grid_pars(patch_extend_width, - N_zones_per_right_angle); - - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " constructing %s patch (%d x %d grid points)", - pi.name, - jtutil::how_many_in_range(grid_array_pars.min_irho, - grid_array_pars.max_irho), - jtutil::how_many_in_range(grid_array_pars.min_isigma, - grid_array_pars.max_isigma)); - - struct patch *p; - switch (pi.ctype) - { - case 'z': - p = new z_patch(*this, pn, - pi.name, pi.is_plus, - grid_array_pars, grid_pars); - break; - case 'x': - p = new x_patch(*this, pn, - pi.name, pi.is_plus, - grid_array_pars, grid_pars); - break; - case 'y': - p = new y_patch(*this, pn, - pi.name, pi.is_plus, - grid_array_pars, grid_pars); - break; - default: - error_exit(ERROR_EXIT, - "***** patch_system::create_patches():\n" - " unknown patch_info_in[pn=%d].ctype=0x%02d='%c'!\n", - pn, pi.ctype, pi.ctype); /*NOTREACHED*/ - } - - // these record number of grid points in *previous* patches, - // i.e. they do *not* include the number of grid points in this patch - starting_gpn_[pn] = N_grid_points_; - ghosted_starting_gpn_[pn] = ghosted_N_grid_points_; - - N_grid_points_ += p->N_grid_points(); - ghosted_N_grid_points_ += p->ghosted_N_grid_points(); - - all_patches_[pn] = p; - } - - starting_gpn_[N_patches_] = N_grid_points_; - ghosted_starting_gpn_[N_patches_] = ghosted_N_grid_points_; - } - - //****************************************************************************** - - // - // This function is called from the patch_system:: constructor to set - // up the storage for all gridfns in all patches, giving each gridfn a - // contiguous-across-all-patches storage array. This function also makes - // a number of self-consistency checks to ensure that the gridfn storage - // subscripting is set up properly. - // - // This function assumes that all the patches have already been constructed - // before it is called. - // - // For example, given the patches {x,y,z}, the ghosted gridfns {H,J}, - // and the nominal gridfns {a,b,c}, we might picture the storage like - // this: - // - // xa xa xa ya ya za za za za - // xb xb xb yb yb zb zb zb zb - // xc xc xc yc yc zc zc zc zc - // - // xH xH xH xH yH yH yH zH zH zH zH zH - // xJ xJ xJ xJ yJ yJ yJ zJ zJ zJ zJ zJ - // - // Here the upper/lower blocks are for nominal/ghosted gridfns. - // The storage is taken as being contiguous within each row (in fact - // within each block). Thus the storage for all the nominal gridfns - // (or all the ghosted gridfns) in a single patch is *non*-contiguous. - // - // The creation of patches is done in several phases: first the patches - // are constructed with no gridfn storage, then we are called to set up - // the gridfn storage (taking into account the sizes of the other patches), - // then finally ghost zones are constructed and interlinked. - // - // FIXME: We should pad the gridfn storage as necessary to avoid cache - // conflicts, but we don't do this at present. - // - void patch_system::setup_gridfn_storage(int min_gfn_in, int max_gfn_in, - int ghosted_min_gfn_in, int ghosted_max_gfn_in, - bool print_msg_flag) - { - const int N_gridfns_in = jtutil::how_many_in_range(min_gfn_in, max_gfn_in); - const int ghosted_N_gridfns_in = jtutil::how_many_in_range(ghosted_min_gfn_in, ghosted_max_gfn_in); - - const int gfn_stride = N_grid_points(); - const int ghosted_gfn_stride = ghosted_N_grid_points(); - - const int N_storage = gfn_stride * N_gridfns_in; - const int ghosted_N_storage = ghosted_gfn_stride * ghosted_N_gridfns_in; - - if (print_msg_flag) - then - { - CCTK_VInfo(CCTK_THORNSTRING, - " setting up gridfn storage"); - CCTK_VInfo(CCTK_THORNSTRING, - " gfn=[%d,%d] ghosted_gfn=[%d,%d]", - min_gfn_in, max_gfn_in, - ghosted_min_gfn_in, ghosted_max_gfn_in); - CCTK_VInfo(CCTK_THORNSTRING, - " N_grid_points()=%d ghosted_N_grid_points()=%d", - N_grid_points(), ghosted_N_grid_points()); - } - - // storage arrays for all gridfns - gridfn_storage_ = new fp[N_storage]; - ghosted_gridfn_storage_ = new fp[ghosted_N_storage]; - - // divide up the storage array among the patches - // and set up the storage in the individual patches themselves - { - for (int pn = 0; pn < N_patches(); ++pn) - { - const int posn = starting_gpn_[pn]; - const int ghosted_posn = ghosted_starting_gpn_[pn]; - const struct grid_arrays::gridfn_pars gridfn_pars = { - min_gfn_in, max_gfn_in, - &gridfn_storage_[posn], - gfn_stride, 0, 0}; - const struct grid_arrays::gridfn_pars ghosted_gridfn_pars = { - ghosted_min_gfn_in, ghosted_max_gfn_in, - &ghosted_gridfn_storage_[ghosted_posn], - ghosted_gfn_stride, 0, 0}; - - patch &p = ith_patch(pn); - p.setup_gridfn_storage(gridfn_pars, ghosted_gridfn_pars); - } - } - - if (print_msg_flag) - then - { - CCTK_VInfo(CCTK_THORNSTRING, - " checking that storage is partitioned properly"); - } - - // check to make sure storage for distinct gridfns - // forms a partition of the overall storage array - const patch &pfirst = ith_patch(0); - const patch &plast = ith_patch(N_patches() - 1); - { - for (int gfn = min_gfn(); gfn + 1 < max_gfn(); ++gfn) - { - // range of storage occupied by gridfns: - // gfn --> [gfn_first, gfn_last] - // gfn+1 --> [gfn1_first, gfn1_last] - const fp *const gfn_last_ptr = &plast.gridfn(gfn, plast.max_irho(), - plast.max_isigma()); - const fp *const gfn1_first_ptr = &pfirst.gridfn(gfn + 1, pfirst.min_irho(), - pfirst.min_isigma()); - if (!(gfn1_first_ptr == gfn_last_ptr + 1)) - then error_exit(PANIC_EXIT, - "***** patch_system::setup_gridfn_storage():\n" - " nominal-grid gridfns don't partition overall storage array!" - " (this should never happen!)\n" - " gfn=%d last point at gfn_last_ptr=%p\n" - " gfn+1=%d first point at gfn1_first_ptr=%p\n" - " should have gfn1_first_ptr == gfn_last_ptr+1\n", - gfn, (const void *)gfn_last_ptr, - gfn + 1, (const void *)gfn1_first_ptr); /*NOTREACHED*/ - } - } - - { - for (int ghosted_gfn = ghosted_min_gfn(); - ghosted_gfn + 1 < ghosted_max_gfn(); - ++ghosted_gfn) - { - // range of storage occupied by ghosted gridfns: - // ghosted_gfn --> [gfn_first, gfn_last] - // ghosted_gfn+1 --> [gfn1_first, gfn1_last] - const fp *const ghosted_gfn_last_ptr = &plast.ghosted_gridfn(ghosted_gfn, - plast.ghosted_max_irho(), - plast.ghosted_max_isigma()); - const fp *const ghosted_gfn1_first_ptr = &pfirst.ghosted_gridfn(ghosted_gfn + 1, - pfirst.ghosted_min_irho(), - pfirst.ghosted_min_isigma()); - if (!(ghosted_gfn1_first_ptr == ghosted_gfn_last_ptr + 1)) - then error_exit(PANIC_EXIT, - "***** patch_system::setup_gridfn_storage():\n" - " ghosted-grid gridfns don't partition overall storage array!" - " (this should never happen!)\n" - " ghosted_gfn=%d last point at ghosted_gfn_last_ptr=%p\n" - " ghosted_gfn+1=%d first point at ghosted_gfn1_first_ptr=%p\n" - " should have ghosted_gfn1_first_ptr == ghosted_gfn_last_ptr+1\n", - ghosted_gfn, (const void *)ghosted_gfn_last_ptr, - ghosted_gfn + 1, - (const void *)ghosted_gfn1_first_ptr); - /*NOTREACHED*/ - } - } - - // check to make sure storage for distinct patches - // forms a partition of the storage for each gridfn - { - for (int gfn = min_gfn(); gfn < max_gfn(); ++gfn) - { - for (int pn = 0; pn + 1 < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - const patch &p1 = ith_patch(pn + 1); - - // range of storage occupied by gridfn: - // p --> [p_first, p_last] - // p1 --> [p1_first, p1_last] - const fp *const p_last_ptr = &p.gridfn(gfn, p.max_irho(), p.max_isigma()); - const fp *const p1_first_ptr = &p1.gridfn(gfn, p1.min_irho(), p1.min_isigma()); - if (!(p1_first_ptr == p_last_ptr + 1)) - then error_exit(PANIC_EXIT, - "***** patch_system::setup_gridfn_storage():\n" - " nominal-grid patches gridfns don't partition storage for gfn=%d!\n" - " (this should never happen!)\n" - " gfn=%d %s patch last point at p_last_ptr=%p\n" - " gfn=%d %s patch first point at p1_first_ptr=%p\n" - " should have p1_first_ptr == p_last_ptr+1\n", - gfn, - gfn, p.name(), (const void *)p_last_ptr, - gfn + 1, p1.name(), (const void *)p1_first_ptr); - /*NOTREACHED*/ - } - } - } - - { - for (int ghosted_gfn = ghosted_min_gfn(); - ghosted_gfn < ghosted_max_gfn(); - ++ghosted_gfn) - { - for (int pn = 0; pn + 1 < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - const patch &p1 = ith_patch(pn + 1); - - // range of storage occupied by ghosted gridfn: - // p --> [p_first, p_last] - // p1 --> [p1_first, p1_last] - const fp *const p_last_ptr = &p.ghosted_gridfn(ghosted_gfn, - p.ghosted_max_irho(), - p.ghosted_max_isigma()); - const fp *const p1_first_ptr = &p1.ghosted_gridfn(ghosted_gfn, - p1.ghosted_min_irho(), - p1.ghosted_min_isigma()); - if (!(p1_first_ptr == p_last_ptr + 1)) - then error_exit(PANIC_EXIT, - "***** patch_system::setup_gridfn_storage():\n" - " nominal-grid patches gridfns don't partition storage for gfn=%d!\n" - " (this should never happen!)\n" - " %s patch (pn=%d) last point at p_last_ptr=%p\n" - " %s patch (pn=%d) first point at p1_first_ptr=%p\n" - " should have p1_first_ptr == p_last_ptr+1\n", - ghosted_gfn, - p.name(), pn, (const void *)p_last_ptr, - p1.name(), pn + 1, (const void *)p1_first_ptr); - /*NOTREACHED*/ - } - } - } - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a full-sphere patch system. - // - void patch_system::setup_ghost_zones__full_sphere(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " seting up full sphere ghost zones"); - - patch &pz = ith_patch(patch_system_info::full_sphere::patch_number__pz); - patch &px = ith_patch(patch_system_info::full_sphere::patch_number__px); - patch &py = ith_patch(patch_system_info::full_sphere::patch_number__py); - patch &mx = ith_patch(patch_system_info::full_sphere::patch_number__mx); - patch &my = ith_patch(patch_system_info::full_sphere::patch_number__my); - patch &mz = ith_patch(patch_system_info::full_sphere::patch_number__mz); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(pz, mx, patch_overlap_width); - create_interpatch_ghost_zones(pz, my, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - create_interpatch_ghost_zones(py, mx, patch_overlap_width); - create_interpatch_ghost_zones(mx, my, patch_overlap_width); - create_interpatch_ghost_zones(my, px, patch_overlap_width); - create_interpatch_ghost_zones(mz, px, patch_overlap_width); - create_interpatch_ghost_zones(mz, py, patch_overlap_width); - create_interpatch_ghost_zones(mz, mx, patch_overlap_width); - create_interpatch_ghost_zones(mz, my, patch_overlap_width); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, mx, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(py, mx, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mx, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(my, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, mx, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +z hemisphere patch system. - // - void patch_system::setup_ghost_zones__plus_z_hemisphere(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +z hemisphere ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__py); - patch &mx = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__mx); - patch &my = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__my); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(pz, mx, patch_overlap_width); - create_interpatch_ghost_zones(pz, my, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - create_interpatch_ghost_zones(py, mx, patch_overlap_width); - create_interpatch_ghost_zones(mx, my, patch_overlap_width); - create_interpatch_ghost_zones(my, px, patch_overlap_width); - px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); - mx.create_mirror_symmetry_ghost_zone(mx.min_rho_patch_edge()); - my.create_mirror_symmetry_ghost_zone(my.min_rho_patch_edge()); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, mx, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(py, mx, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mx, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(my, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +xy quadrant (mirrored) patch system. - // - void patch_system::setup_ghost_zones__plus_xy_quadrant_mirrored(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +xy quadrant (mirrored) ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__py); - patch &mz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__mz); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - create_interpatch_ghost_zones(mz, px, patch_overlap_width); - create_interpatch_ghost_zones(mz, py, patch_overlap_width); - pz.create_mirror_symmetry_ghost_zone(pz.min_rho_patch_edge()); - pz.create_mirror_symmetry_ghost_zone(pz.min_sigma_patch_edge()); - px.create_mirror_symmetry_ghost_zone(px.min_sigma_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_sigma_patch_edge()); - mz.create_mirror_symmetry_ghost_zone(mz.max_rho_patch_edge()); - mz.create_mirror_symmetry_ghost_zone(mz.max_sigma_patch_edge()); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +xy quadrant (rotating) patch system. - // - void patch_system::setup_ghost_zones__plus_xy_quadrant_rotating(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +xy quadrant (rotating) ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__py); - patch &mz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__mz); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - create_interpatch_ghost_zones(mz, px, patch_overlap_width); - create_interpatch_ghost_zones(mz, py, patch_overlap_width); - create_periodic_symmetry_ghost_zones(pz.min_rho_patch_edge(), - pz.min_sigma_patch_edge(), - true); - create_periodic_symmetry_ghost_zones(px.min_sigma_patch_edge(), - py.max_sigma_patch_edge(), - true); - create_periodic_symmetry_ghost_zones(mz.max_rho_patch_edge(), - mz.max_sigma_patch_edge(), - true); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(mz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +xz quadrant (mirrored) patch system. - // - void patch_system::setup_ghost_zones__plus_xz_quadrant_mirrored(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +xz quadrant (mirrored) ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__py); - patch &my = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__my); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(pz, my, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - create_interpatch_ghost_zones(px, my, patch_overlap_width); - pz.create_mirror_symmetry_ghost_zone(pz.min_sigma_patch_edge()); - px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_sigma_patch_edge()); - my.create_mirror_symmetry_ghost_zone(my.min_rho_patch_edge()); - my.create_mirror_symmetry_ghost_zone(my.min_sigma_patch_edge()); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +xz quadrant (rotating) patch system. - // - void patch_system::setup_ghost_zones__plus_xz_quadrant_rotating(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +xz quadrant (rotating) ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__py); - patch &my = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__my); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(pz, my, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - create_interpatch_ghost_zones(px, my, patch_overlap_width); - px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); - my.create_mirror_symmetry_ghost_zone(my.min_rho_patch_edge()); - create_periodic_symmetry_ghost_zones(pz.min_sigma_patch_edge(), - pz.min_sigma_patch_edge(), - false); - create_periodic_symmetry_ghost_zones(py.max_sigma_patch_edge(), - my.min_sigma_patch_edge(), - false); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, my, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +xyz octant (mirrored) patch system. - // - void patch_system::setup_ghost_zones__plus_xyz_octant_mirrored(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +xyz octant (mirrored) ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_xyz_octant::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_xyz_octant::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_xyz_octant::patch_number__py); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - pz.create_mirror_symmetry_ghost_zone(pz.min_rho_patch_edge()); - pz.create_mirror_symmetry_ghost_zone(pz.min_sigma_patch_edge()); - px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); - px.create_mirror_symmetry_ghost_zone(px.min_sigma_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_sigma_patch_edge()); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - - // - // This function sets up (constructs and interlinks) the ghost zones - // for a +xyz octant (rotating) patch system. - // - void patch_system::setup_ghost_zones__plus_xyz_octant_rotating(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag) - { - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " setting up +xyz octant (rotating) ghost zones"); - - patch &pz = ith_patch(patch_system_info::plus_xyz_octant::patch_number__pz); - patch &px = ith_patch(patch_system_info::plus_xyz_octant::patch_number__px); - patch &py = ith_patch(patch_system_info::plus_xyz_octant::patch_number__py); - - // create the ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " creating ghost zones"); - create_interpatch_ghost_zones(pz, px, patch_overlap_width); - create_interpatch_ghost_zones(pz, py, patch_overlap_width); - create_interpatch_ghost_zones(px, py, patch_overlap_width); - px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); - py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); - create_periodic_symmetry_ghost_zones(pz.min_rho_patch_edge(), - pz.min_sigma_patch_edge(), - true); - create_periodic_symmetry_ghost_zones(px.min_sigma_patch_edge(), - py.max_sigma_patch_edge(), - true); - - // finish setting up the interpatch ghost zones - if (print_msg_flag) - then CCTK_VInfo(CCTK_THORNSTRING, - " finishing interpatch setup"); - finish_interpatch_setup(pz, px, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(pz, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - finish_interpatch_setup(px, py, - patch_overlap_width, - ip_interp_handle, ip_interp_par_table_handle); - - assert_all_ghost_zones_fully_setup(); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function creates a pair of periodic-symmetry ghost zones. - // - // static - void patch_system::create_periodic_symmetry_ghost_zones(const patch_edge &ex, const patch_edge &ey, - bool ipar_map_is_plus) - { - ex.my_patch() - .create_periodic_symmetry_ghost_zone(ex, ey, ipar_map_is_plus); - - if (ex == ey) - then - { - // ex and ey are the same edge (i.e. the symmetry maps the edge - // back to itself), so we only want to set up the edge once - // ==> no-op here - } - else - ey.my_patch() - .create_periodic_symmetry_ghost_zone(ey, ex, ipar_map_is_plus); - } - - //****************************************************************************** - - // - // This function automagically figures out which edges of two adjacent - // patches are adjacent, then creates both patches' ghost zones on those - // edges and interlinks them with their respective patches. - // - // static - void patch_system::create_interpatch_ghost_zones(patch &px, patch &py, - int patch_overlap_width) - { - const patch_edge &ex = px.edge_adjacent_to_patch(py, patch_overlap_width); - const patch_edge &ey = py.edge_adjacent_to_patch(px, patch_overlap_width); - - px.create_interpatch_ghost_zone(ex, ey, patch_overlap_width); - py.create_interpatch_ghost_zone(ey, ex, patch_overlap_width); - } - - //****************************************************************************** - - // - // This function automagically figures out which edges of two adjacent - // patches are adjacent, then finishes setting up both ghost zones. - // - // static - void patch_system::finish_interpatch_setup(patch &px, patch &py, - int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle) - { - const patch_edge &ex = px.edge_adjacent_to_patch(py, patch_overlap_width); - const patch_edge &ey = py.edge_adjacent_to_patch(px, patch_overlap_width); - px.ghost_zone_on_edge(ex) - .cast_to_interpatch_ghost_zone() - .finish_setup(ip_interp_handle, ip_interp_par_table_handle); - py.ghost_zone_on_edge(ey) - .cast_to_interpatch_ghost_zone() - .finish_setup(ip_interp_handle, ip_interp_par_table_handle); - } - - //****************************************************************************** - - // - // This function assert()s that all ghost zones of all patches have - // been fully set up. - // - void patch_system::assert_all_ghost_zones_fully_setup() const - { - for (int pn = 0; pn < N_patches(); ++pn) - { - ith_patch(pn).assert_all_ghost_zones_fully_setup(); - } - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function decodes a patch system's type into N_patches. - // - // static - int patch_system::N_patches_of_type(enum patch_system_type type_in) - { - switch (type_in) - { - case patch_system__full_sphere: - return patch_system_info::full_sphere::N_patches; - case patch_system__plus_z_hemisphere: - return patch_system_info::plus_z_hemisphere::N_patches; - case patch_system__plus_xy_quadrant_mirrored: - case patch_system__plus_xy_quadrant_rotating: - return patch_system_info::plus_xy_quadrant::N_patches; - case patch_system__plus_xz_quadrant_mirrored: - case patch_system__plus_xz_quadrant_rotating: - return patch_system_info::plus_xz_quadrant::N_patches; - case patch_system__plus_xyz_octant_mirrored: - case patch_system__plus_xyz_octant_rotating: - return patch_system_info::plus_xyz_octant::N_patches; - default: - error_exit(PANIC_EXIT, - "***** patch_system::N_patches_of_type(): bad type=(int)%d!\n" - " (this should never happen!)\n", - int(type_in)); /*NOTREACHED*/ - } - } - - //****************************************************************************** - - // - // This function decodes a patch system's type into a human-readable - // type name (a C string). - // - // static - const char *patch_system::name_of_type(enum patch_system_type type_in) - { - switch (type_in) - { - case patch_system__full_sphere: - return "full sphere"; - case patch_system__plus_z_hemisphere: - return "+z hemisphere"; - case patch_system__plus_xy_quadrant_mirrored: - return "+xy quadrant (mirrored)"; - case patch_system__plus_xy_quadrant_rotating: - return "+xy quadrant (rotating)"; - case patch_system__plus_xz_quadrant_mirrored: - return "+xz quadrant (mirrored)"; - case patch_system__plus_xz_quadrant_rotating: - return "+xz quadrant (rotating)"; - case patch_system__plus_xyz_octant_mirrored: - return "+xyz octant (mirrored)"; - case patch_system__plus_xyz_octant_rotating: - return "+xyz octant (rotating)"; - default: - error_exit(PANIC_EXIT, - "***** patch_system::name_of_type(): bad type=(int)%d!\n" - " (this should never happen!)\n", - int(type_in)); /*NOTREACHED*/ - } - } - - //****************************************************************************** - - // - // This function encodes a human-readable type name (a C string) into - // a patch system's type into. - // - // static - enum patch_system::patch_system_type - patch_system::type_of_name(const char *name_in) - { - if (strcmp(name_in, "full sphere") == 0) - return patch_system__full_sphere; - else if (strcmp(name_in, "+z hemisphere") == 0) - return patch_system__plus_z_hemisphere; - else if (strcmp(name_in, "+xy quadrant (mirrored)") == 0) - return patch_system__plus_xy_quadrant_mirrored; - else if (strcmp(name_in, "+xy quadrant (rotating)") == 0) - return patch_system__plus_xy_quadrant_rotating; - else if (strcmp(name_in, "+xz quadrant (mirrored)") == 0) - return patch_system__plus_xz_quadrant_mirrored; - else if (strcmp(name_in, "+xz quadrant (rotating)") == 0) - return patch_system__plus_xz_quadrant_rotating; - else if (strcmp(name_in, "+xyz octant (mirrored)") == 0) - return patch_system__plus_xyz_octant_mirrored; - else if (strcmp(name_in, "+xyz octant (rotating)") == 0) - return patch_system__plus_xyz_octant_rotating; - else - error_exit(PANIC_EXIT, - "***** patch_system::type_of_name(): unknown name=\"%s\"!", - name_in); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function finds a (the) patch with a specified sign and xyz ctype. - // If no such patch exists, it does an error_exit() (and doesn't return - // to the caller). - // - // FIXME: - // - This function could be implemented to be very fast (using the - // patch numbers in patch_system_info::), but right now it just does - // a sequential search through all the patches, so it's pretty slow :( - // - const patch &patch_system::plus_or_minus_xyz_patch(bool is_plus, char ctype) - const - { - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - if ((p.is_plus() == is_plus) && (p.ctype() == ctype)) - then return p; - } - - error_exit(ERROR_EXIT, - "***** patch_system::plus_or_minus_xyz_patch():\n" - " can't find any %c%c patch!", - (is_plus ? '+' : '-'), ctype); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function finds a patch from its human-readable name, and returns - // the patch number, or does an error_exit() if no patch is found with - // the specified name. - // - int patch_system::patch_number_of_name(const char *name) const - { - for (int pn = 0; pn < N_patches(); ++pn) - { - if (strcmp(ith_patch(pn).name(), name) == 0) - return pn; - } - - error_exit(ERROR_EXIT, - "***** patch_system::patch_number_of_name():\n" - " no patch with name \"%s\"!\n", - name); /*NOTREACHED*/ - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function decodes a 0-origin grid point number into a - // (patch,irho,isigma) triple. - // - // Arguments: - // gpn = The grid point number to decode. - // (irho,isigma) = (out) The decoded patch coordinates. - // - // Results: - // This function returns a reference to the decoded patch. (An alternative - // design would be to return this via a patch*& argument, but the design - // used here seems slightly cleaner to use in practice.) - // - const patch & - patch_system::patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) - const - { - assert(gpn >= 0); - assert(gpn < N_grid_points()); - - for (int pn = 0; pn < N_patches(); ++pn) - { - // n.b. [pn+1] is ok since starting_gpn_[] has size N_patches()+1 - if ((gpn >= starting_gpn_[pn]) && (gpn < starting_gpn_[pn + 1])) - then - { - const patch &p = ith_patch(pn); - const int gpn_in_patch = gpn - starting_gpn_[pn]; - assert(gpn_in_patch >= 0); - assert(gpn_in_patch < p.N_grid_points()); - p.irho_isigma_of_gpn(gpn_in_patch, irho, isigma); - return p; - } - } - - error_exit(PANIC_EXIT, - "***** patch_system::patch_irho_isigma_of_gpn(gpn=%d):\n" - " couldn't find any patch! (this should never happen!)\n" - " N_grid_points()=%d\n", - gpn, - N_grid_points()); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function decodes a 0-origin grid point number into a *ghosted* - // (patch,irho,isigma) triple. - // - // Arguments: - // gpn = The grid point number to decode. - // (irho,isigma) = (out) The decoded patch coordinates. - // - // Results: - // This function returns a reference to the decoded patch. (An alternative - // design would be to return this via a patch*& argument, but the design - // used here seems slightly cleaner to use in practice.) - // - const patch & - patch_system::ghosted_patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) - const - { - assert(gpn >= 0); - assert(gpn < ghosted_N_grid_points()); - - for (int pn = 0; pn < N_patches(); ++pn) - { - // n.b. [pn+1] is ok since ghosted_starting_gpn_[] - // has size N_patches()+1 - if ((gpn >= ghosted_starting_gpn_[pn]) && (gpn < ghosted_starting_gpn_[pn + 1])) - then - { - const patch &p = ith_patch(pn); - const int gpn_in_patch = gpn - ghosted_starting_gpn_[pn]; - assert(gpn_in_patch >= 0); - assert(gpn_in_patch < p.ghosted_N_grid_points()); - p.ghosted_irho_isigma_of_gpn(gpn_in_patch, irho, isigma); - return p; - } - } - - error_exit(PANIC_EXIT, - "***** patch_system::ghosted_patch_irho_isigma_of_gpn(gpn=%d):\n" - " couldn't find any patch! (this should never happen!)\n" - " ghosted_N_grid_points()=%d\n", - gpn, - ghosted_N_grid_points()); /*NOTREACHED*/ - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function sets a (nominal-grid) gridfn to a constant value. - // - void patch_system::set_gridfn_to_constant(fp a, int dst_gfn) - { - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - p.gridfn(dst_gfn, irho, isigma) = a; - } - } - } - } - - //****************************************************************************** - - // - // This function copies one (nominal-grid) gridfn to another. - // - void patch_system::gridfn_copy(int src_gfn, int dst_gfn) - { - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - p.gridfn(dst_gfn, irho, isigma) = p.gridfn(src_gfn, irho, isigma); - } - } - } - } - - //****************************************************************************** - - // - // This function adds a scalar to a ghosted gridfn. - // - void patch_system::add_to_ghosted_gridfn(fp delta, int ghosted_dst_gfn) - { - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - for (int irho = p.ghosted_min_irho(); - irho <= p.ghosted_max_irho(); - ++irho) - { - for (int isigma = p.ghosted_min_isigma(); - isigma <= p.ghosted_max_isigma(); - ++isigma) - { - p.ghosted_gridfn(ghosted_dst_gfn, irho, isigma) += delta; - } - } - } - } - - //****************************************************************************** - - // - // Recentering - // - void patch_system::recentering(fp x, fp y, fp z) - { - global_coords_.recentering(x, y, z); - } - - //****************************************************************************** - - // - // This function computes norms of a nominal-grid gridfn. - // - void patch_system::gridfn_norms(int src_gfn, jtutil::norm &norms) - const - { - if (!is_valid_gfn(src_gfn)) - then error_exit(ERROR_EXIT, - "***** patch_system::gridfn_norms(): invalid src_gfn=%d!\n", - src_gfn); /*NOTREACHED*/ - - norms.reset(); - - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - norms.data(p.gridfn(src_gfn, irho, isigma)); - } - } - } - } - - //****************************************************************************** - - // - // This function computes norms of a ghosted-grid gridfn over the - // nominal grid. - // - void patch_system::ghosted_gridfn_norms(int ghosted_src_gfn, - jtutil::norm &norms) - const - { - if (!is_valid_ghosted_gfn(ghosted_src_gfn)) - then error_exit(ERROR_EXIT, - "***** patch_system::gridfn_norms(): invalid ghosted_src_gfn=%d!\n", - ghosted_src_gfn); /*NOTREACHED*/ - norms.reset(); - - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) - { - for (int isigma = p.min_isigma(); - isigma <= p.max_isigma(); - ++isigma) - { - norms.data(p.ghosted_gridfn(ghosted_src_gfn, irho, isigma)); - } - } - } - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function computes an approximation to the circumference of a - // surface in the xy, xz, or yz plane. Note that we compute the full - // circumference all around the sphere, even if the patch system only - // covers a proper subset of this. - // - // We assume that adjacent patches are butt-joined, i.e. that their - // nominal boundaries just touch. - // - // Arguments: - // plane[] = (in) "xy", "xz", or "yz" to specify the integration plane. - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp patch_system::circumference(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum patch::integration_method method) - const - { - // - // compute arc length around the patch system - // - fp arc_length = 0.0; - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - if ((p.ctype() == plane[0]) || (p.ctype() == plane[1])) - then arc_length += p.plane_arc_length(plane, - ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - } - - // - // correct the arc length - // for the fact that the patch system may not cover the full 2-sphere - // - switch (type()) - { - case patch_system__full_sphere: - break; - case patch_system__plus_z_hemisphere: - arc_length *= ((plane[0] == 'x') && (plane[1] == 'y')) ? 1.0 : 2.0; - break; - case patch_system__plus_xy_quadrant_mirrored: - case patch_system__plus_xy_quadrant_rotating: - arc_length *= ((plane[0] == 'x') && (plane[1] == 'y')) ? 4.0 : 2.0; - break; - case patch_system__plus_xz_quadrant_mirrored: - case patch_system__plus_xz_quadrant_rotating: - arc_length *= ((plane[0] == 'x') && (plane[1] == 'z')) ? 4.0 : 2.0; - break; - case patch_system__plus_xyz_octant_mirrored: - case patch_system__plus_xyz_octant_rotating: - arc_length *= 4.0; - break; - default: - error_exit(PANIC_EXIT, - "***** patch_system::circumference(): unknown patch system type()=(int)%d!\n" - " (this should never happen!)\n", - int(type())); /*NOTREACHED*/ - } - - return arc_length; - } - - //****************************************************************************** - - // - // This function computes an approximation to the (surface) integral of - // a gridfn over the 2-sphere - // $\int f(\rho,\sigma) \, dA$ - // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ - // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma). - // - // We assume that adjacent patches are butt-joined, i.e. that their - // nominal boundaries just touch. - // - // Arguments: - // unknown_src_gfn = (in) The gridfn to be integrated. This may be - // either nominal-grid or ghosted-grid. - // src_gfn_is_even_across_{xy,xz,yz}_plane - // = (in) Boolean flags specifying whether the gridfn to be integrated - // is even (true) or odd (false) across the corresponding planes. - // Only the flags corresponding to boundaries of the patch system - // are used. For example, for a plus_z_hemisphere patch system, - // only the src_gfn_is_even_across_xy_plane flag is used. - // ghosted_radius_gfn = (in) The surface radius. - // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. - // method = (in) Selects the integration scheme. - // - fp patch_system::integrate_gridfn(int unknown_src_gfn, - bool src_gfn_is_even_across_xy_plane, - bool src_gfn_is_even_across_xz_plane, - bool src_gfn_is_even_across_yz_plane, - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum patch::integration_method method) - const - { - // - // compute integral over patch system - // - fp integral = 0.0; - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - integral += p.integrate_gridfn(unknown_src_gfn, - ghosted_radius_gfn, - g_xx_gfn, g_xy_gfn, g_xz_gfn, - g_yy_gfn, g_yz_gfn, - g_zz_gfn, - method); - } - - // - // correct the integral - // for the fact that the patch system may not cover the full 2-sphere - // - switch (type()) - { - case patch_system__full_sphere: - break; - case patch_system__plus_z_hemisphere: - integral *= src_gfn_is_even_across_xy_plane ? 2.0 : 0.0; - break; - case patch_system__plus_xy_quadrant_mirrored: - case patch_system__plus_xy_quadrant_rotating: - integral *= src_gfn_is_even_across_xz_plane ? 2.0 : 0.0; - integral *= src_gfn_is_even_across_yz_plane ? 2.0 : 0.0; - break; - case patch_system__plus_xz_quadrant_mirrored: - case patch_system__plus_xz_quadrant_rotating: - integral *= src_gfn_is_even_across_xy_plane ? 2.0 : 0.0; - integral *= src_gfn_is_even_across_yz_plane ? 2.0 : 0.0; - break; - case patch_system__plus_xyz_octant_mirrored: - case patch_system__plus_xyz_octant_rotating: - integral *= src_gfn_is_even_across_xy_plane ? 2.0 : 0.0; - integral *= src_gfn_is_even_across_xz_plane ? 2.0 : 0.0; - integral *= src_gfn_is_even_across_yz_plane ? 2.0 : 0.0; - break; - default: - error_exit(PANIC_EXIT, - "***** patch_system::integrate_gridfn(): bad patch system type()=(int)%d!\n" - " (this should never happen!)\n", - int(type())); /*NOTREACHED*/ - } - - return integral; - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function finds what patch contains (the ray from the origin to) - // a given local (x,y,z) position. - // - // If there are multiple patches containing the position, we return the - // one which would still contain it if patches didn't overlap; if multiple - // patches satisfy this criterion then it's arbitrary which one we return. - // - // If no patch contains the position (this can only if the point as at - // the local coordinate origin, or for a non--full-sphere patch system), - // then we return a NULL pointer. - // - // Arguments: - // (x,y,z) = The local coordinates to be converted. - // - // Results: - // This function returns a reference to the containing patch. - // - const patch *patch_system::patch_containing_local_xyz(fp x, fp y, fp z) - const - { - if ((x == 0.0) && (y == 0.0) && (z == 0.0)) - then return NULL; - - // to which axis is (x,y,z) closest? - // ... or equivalently, which of |x|, |y|, and |z| is largest? - const fp abs_x = jtutil::abs(x); - const fp abs_y = jtutil::abs(y); - const fp abs_z = jtutil::abs(z); - - if ((abs_z >= abs_x) && (abs_z >= abs_y)) - then return &plus_or_minus_xyz_patch(z > 0.0, 'z'); // +/- z patch - else if ((abs_x >= abs_y) && (abs_x >= abs_z)) - then return &plus_or_minus_xyz_patch(x > 0.0, 'x'); // +/- x patch - else if ((abs_y >= abs_x) && (abs_y >= abs_z)) - then return &plus_or_minus_xyz_patch(y > 0.0, 'y'); // +/- y patch - else - error_exit(ERROR_EXIT, - "***** patch_system::patch_containing_local_xyz():\n" - " unknown (wierd!) ordering of |x|, |y|, and |z|!\n" - " (this should never happen!)\n" - " [local] (x,y,z)=(%g,%g,%g)\n", - double(x), double(y), double(z)); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function computes the radius of a patch-system 2-surface in the - // direction of a specified local (x,y,z) point, taking into account any - // patch-system symmetries. If the point coincides with the local origin, - // we return the dummy value 1.0. - // - // Bugs: - // Due to the surface-interpolator overhead, repeatedly calling this - // function is rather inefficient. - // - fp patch_system::radius_in_local_xyz_direction(int ghosted_radius_gfn, - fp x, fp y, fp z) - const - { - if ((x == 0.0) && (y == 0.0) && (z == 0.0)) - then return 1.0; - - // - // apply symmetries to map (x,y,z) into that part of the 2-sphere - // which is covered by the patch system - // - switch (type()) - { - case patch_system__full_sphere: - break; - case patch_system__plus_z_hemisphere: - z = fabs(z); - break; - case patch_system__plus_xy_quadrant_mirrored: - case patch_system__plus_xy_quadrant_rotating: - x = fabs(x); - y = fabs(y); - break; - case patch_system__plus_xz_quadrant_mirrored: - case patch_system__plus_xz_quadrant_rotating: - x = fabs(x); - z = fabs(z); - break; - case patch_system__plus_xyz_octant_mirrored: - case patch_system__plus_xyz_octant_rotating: - x = fabs(x); - y = fabs(y); - z = fabs(z); - break; - default: - error_exit(PANIC_EXIT, - "***** patch_system::radius_in_local_xyz_direction():\n" - " unknown patch system type()=(int)%d!\n" - " (this should never happen!)\n", - int(type())); /*NOTREACHED*/ - } - - const patch *p_ptr = patch_containing_local_xyz(x, y, z); - if (p_ptr == NULL) - then error_exit(ERROR_EXIT, - "***** patch_system::radius_in_local_xyz_direction():\n" - " can't find containing patch!\n" - " (this should never happen!)\n" - " [local] (x,y,z)=(%g,%g,%g)\n", - double(x), double(y), double(z)); /*NOTREACHED*/ - - const patch &p = *p_ptr; - const fp rho = p.rho_of_xyz(x, y, z); - const fp sigma = p.sigma_of_xyz(x, y, z); - - // - // Set up the surface interpolator to interpolate the surface radius - // gridfn to the (rho,sigma) coordinates: - // - // Notes on the interpolator setup: - // * The interpolator assumes Fortran subscripting, so we take the - // coordinates in the order (sigma,rho) to match our C subscripting - // in the patch system. - // * To avoid having to set up min/max array subscripts in the parameter - // table, we treat the patch as using 0-origin (integer) array subscripts - // (irho - ghosted_min_irho(), isigma - ghosted_min_isigma()). However, - // we use the usual floating-point coordinates. - // - - const int N_dims = 2; - const CCTK_REAL coord_origin[N_dims] = {p.ghosted_min_sigma(), p.ghosted_min_rho()}; - const CCTK_REAL coord_delta[N_dims] = {p.delta_sigma(), p.delta_rho()}; - - const int N_interp_points = 1; - const int interp_coords_type_code = CCTK_VARIABLE_REAL; - const void *const interp_coords[N_dims] = {static_cast(&sigma), static_cast(&rho)}; - - const int N_input_arrays = 1; - const CCTK_INT input_array_dims[N_dims] = {p.ghosted_N_isigma(), p.ghosted_N_irho()}; - const CCTK_INT input_array_type_codes[N_input_arrays] = {CCTK_VARIABLE_REAL}; - const void *const input_arrays[N_input_arrays] = { - static_cast( - p.ghosted_gridfn_data_array(ghosted_radius_gfn))}; - - const int N_output_arrays = 1; - const CCTK_INT output_array_type_codes[N_output_arrays] = {CCTK_VARIABLE_REAL}; - fp xyz_radius; - void *const output_arrays[N_output_arrays] = {static_cast(&xyz_radius)}; - - return xyz_radius; - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function prints an unknown-grid gridfn in ASCII format to a - // named output file. The output format is suitable for a gnuplot - // 'splot' command. (Individual patches may be selected with the - // select.patch program (perl script).) The output format is either - // # print_xyz_flag == false - // dpx dpy gridfn - // or - // # print_xyz_flag == true - // dpx dpy gridfn global_x global_y global_z - // where global_[xyz} are derived from the angular position and a - // specified (unknown-grid) radius gridfn. - // - void patch_system::print_unknown_gridfn(bool ghosted_flag, int unknown_gfn, - bool print_xyz_flag, bool radius_is_ghosted_flag, - int unknown_radius_gfn, - const char output_file_name[], bool want_ghost_zones) - const - { - if (want_ghost_zones && !ghosted_flag) - then error_exit(PANIC_EXIT, - "***** patch_system::print_unknown_gridfn(unknown_gfn=%d):\n" - " can't have want_ghost_zones && !ghosted_flag !\n", - unknown_gfn); /*NOTREACHED*/ - if (want_ghost_zones && print_xyz_flag && !radius_is_ghosted_flag) - then error_exit(PANIC_EXIT, - "***** patch_system::print_unknown_gridfn(unknown_gfn=%d):\n" - " can't have want_ghost_zones && print_xyz_flag\n" - " && !radius_is_ghosted_flag!\n" - " unknown_radius_gfn=%d\n", - unknown_gfn, - unknown_radius_gfn); /*NOTREACHED*/ - - FILE *output_fp = fopen(output_file_name, "w"); - if (output_fp == NULL) - then error_exit(ERROR_EXIT, - "***** patch_system::print_unknown_gridfn(unknown_gfn=%d):\n" - " can't open output file \"%s\"\n!", - unknown_gfn, - output_file_name); /*NOTREACHED*/ - - fprintf(output_fp, "# N_patches = %d\n", N_patches()); - fprintf(output_fp, "# origin = %.15g %.15g %.15g\n", - double(origin_x()), double(origin_y()), double(origin_z())); - fprintf(output_fp, "\n"); - - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - - fprintf(output_fp, "### %s patch\n", p.name()); - fprintf(output_fp, "# N_rho = %d\n", - p.effective_N_irho(want_ghost_zones)); - fprintf(output_fp, "# N_sigma = %d\n", - p.effective_N_isigma(want_ghost_zones)); - fprintf(output_fp, "# %s_gfn=%d\n", - (ghosted_flag ? "ghosted" : "nominal"), unknown_gfn); - fprintf(output_fp, "# dpx = %s\n", p.name_of_dpx()); - fprintf(output_fp, "# dpy = %s\n", p.name_of_dpy()); - fprintf(output_fp, "#\n"); - fprintf(output_fp, - print_xyz_flag - ? "# dpx\tdpy\tgridfn\tglobal_x\tglobal_y\tglobal_z\n" - : "# dpx\tdpy\tgridfn\n"); - - for (int irho = p.effective_min_irho(want_ghost_zones); - irho <= p.effective_max_irho(want_ghost_zones); - ++irho) - { - for (int isigma = p.effective_min_isigma(want_ghost_zones); - isigma <= p.effective_max_isigma(want_ghost_zones); - ++isigma) - { - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - const fp dpx = p.dpx_of_rho_sigma(rho, sigma); - const fp dpy = p.dpy_of_rho_sigma(rho, sigma); - fprintf(output_fp, - "%g\t%g\t%#.15g", - dpx, dpy, p.unknown_gridfn(ghosted_flag, unknown_gfn, irho, isigma)); - if (print_xyz_flag) - then - { - const fp r = p.unknown_gridfn(radius_is_ghosted_flag, - unknown_radius_gfn, - irho, isigma); - fp local_x, local_y, local_z; - p.xyz_of_r_rho_sigma(r, rho, sigma, - local_x, local_y, local_z); - const fp global_x = origin_x() + local_x; - const fp global_y = origin_y() + local_y; - const fp global_z = origin_z() + local_z; - fprintf(output_fp, - "\t%#.10g\t%#.10g\t%#.10g", - global_x, global_y, global_z); - } - fprintf(output_fp, "\n"); - } - fprintf(output_fp, "\n"); - } - fprintf(output_fp, "\n"); - } - - fclose(output_fp); - } - - //****************************************************************************** - - // - // This function reads an unknown-grid gridfn in ASCII format from - // a named input file. Comments ('#' in column 1) and blank lines - // are ignored, otherwise the input format matches that written by - // print_unknown_gridfn(): the first 3 numbers on each line are taken - // to be dpx, dpy, and the gridfn value; anything else on the line is - // ignored. - // - void patch_system::read_unknown_gridfn(bool ghosted_flag, int unknown_gfn, - const char input_file_name[], - bool want_ghost_zones) - { - if (want_ghost_zones && !ghosted_flag) - then error_exit(PANIC_EXIT, - "***** patch_system::read_unknown_gridfn(unknown_gfn=%d):\n" - " can't have want_ghost_zones && !ghosted_flag !\n", - unknown_gfn); /*NOTREACHED*/ - - FILE *input_fp = fopen(input_file_name, "r"); - if (input_fp == NULL) - then error_exit(ERROR_EXIT, - "***** patch_system::read_unknown_gridfn(unknown_gfn=%d):\n" - " can't open input file \"%s\"\n!", - unknown_gfn, - input_file_name); /*NOTREACHED*/ - - int line_number = 1; - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - - for (int irho = p.effective_min_irho(want_ghost_zones); - irho <= p.effective_max_irho(want_ghost_zones); - ++irho) - { - for (int isigma = p.effective_min_isigma(want_ghost_zones); - isigma <= p.effective_max_isigma(want_ghost_zones); - ++isigma) - { - const fp rho = p.rho_of_irho(irho); - const fp sigma = p.sigma_of_isigma(isigma); - const fp dpx = p.dpx_of_rho_sigma(rho, sigma); - const fp dpy = p.dpy_of_rho_sigma(rho, sigma); - - const int buffer_size = 250; - char buffer[buffer_size]; - // read/discard comments and blank lines - do - { - if (fgets(buffer, buffer_size, input_fp) == NULL) - then error_exit(ERROR_EXIT, - "***** patch::read_unknown_gridfn(%s patch, unknown_gfn=%d):\n" - " I/O error or unexpected end-of-file on input!\n" - " at irho=%d of [%d,%d], isigma=%d of [%d,%d]\n" - " dpx=%g dpy=%g\n", - p.name(), unknown_gfn, - irho, p.effective_min_irho(want_ghost_zones), - p.effective_max_irho(want_ghost_zones), - isigma, - p.effective_min_isigma(want_ghost_zones), - p.effective_max_isigma(want_ghost_zones), - dpx, dpy); /*NOTREACHED*/ - ++line_number; - } while ((buffer[0] == '#') || (buffer[0] == '\n')); - - double read_dpx, read_dpy, read_gridfn_value; - if (sscanf(buffer, "%lf %lf %lf", - &read_dpx, &read_dpy, &read_gridfn_value) != 3) - then error_exit(ERROR_EXIT, - "***** patch::read_unknown_gridfn(%s patch, unknown_gfn=%d):\n" - " bad input data at input line %d!\n", - p.name(), unknown_gfn, - line_number); /*NOTREACHED*/ - if (!(jtutil::fuzzy::EQ(read_dpx, dpx) && jtutil::fuzzy::EQ(read_dpy, dpy))) - then error_exit(ERROR_EXIT, - "***** patch::read_unknown_gridfn(%s patch, unknown_gfn=%d):\n" - " wrong (dpx,dpy) at input line %d!\n" - " expected (%g,%g)\n" - " read (%g,%g)\n", - p.name(), unknown_gfn, - line_number, - dpx, dpy, - read_dpx, read_dpy); /*NOTREACHED*/ - - p.unknown_gridfn(ghosted_flag, - unknown_gfn, irho, isigma) = read_gridfn_value; - } - } - } - - fclose(input_fp); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - - // - // This function "synchronizes" all ghost zones of all patches, i.e. it - // update the ghost-zone values of the specified gridfns via the appropriate - // sequence of symmetry operations and interpatch interpolations. This - // process is described in detail in the header comments in "ghost_zone.hh". - // - void patch_system::synchronize(int ghosted_min_gfn_to_sync, - int ghosted_max_gfn_to_sync) - { - // - // Phase 1: - // Fill in gridfn data at all the non-corner points of symmetry ghost - // zones, using the symmetries to get this data from its "home patch" - // nominal grids. - // - { - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - // n.b. these loops must use _int_ variables for the loop - // to terminate! - for (int want_min = false; want_min <= true; ++want_min) - { - for (int want_rho = false; want_rho <= true; ++want_rho) - { - ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); - if (gz.is_symmetry()) - then gz.synchronize(ghosted_min_gfn_to_sync, - ghosted_max_gfn_to_sync, - false, // want corners? - true); // want non-corner? - } - } - } - } - - // - // Phase 2: - // Fill in gridfn data in all the interpatch ghost zones, using interpatch - // interpolation from neighboring patches as described above. - // - { - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - // n.b. these loops must use _int_ variables for the loop - // to terminate! - for (int want_min = false; want_min <= true; ++want_min) - { - for (int want_rho = false; want_rho <= true; ++want_rho) - { - ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); - if (gz.is_interpatch()) - then gz.synchronize(ghosted_min_gfn_to_sync, - ghosted_max_gfn_to_sync); - } - } - } - } - - // - // Phase 3: - // Fill in gridfn data at all the corner points of symmetry ghost zones, - // using the symmetries to get this data from its "home patch" nominal - // grids or ghost zones. - // - { - for (int pn = 0; pn < N_patches(); ++pn) - { - patch &p = ith_patch(pn); - // n.b. these loops must use _int_ variables for the loop - // to terminate! - for (int want_min = false; want_min <= true; ++want_min) - { - for (int want_rho = false; want_rho <= true; ++want_rho) - { - ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); - if (gz.is_symmetry()) - then gz.synchronize(ghosted_min_gfn_to_sync, - ghosted_max_gfn_to_sync, - true, // want corners? - false); // want non-corner? - } - } - } - } - } - - //****************************************************************************** - - // - // This function does any precomputation necessary to compute the Jacobian - // of synchronize() , taking into account synchronize()'s full 3-phase - // algorithm. In practice, this means it computes the individual Jacobian - // of each ghost zone, and sets global_{min,max}_ym_ . - // - void patch_system::compute_synchronize_Jacobian(int ghosted_min_gfn_to_sync, - int ghosted_max_gfn_to_sync) - const - { - global_min_ym_ = +INT_MAX; - global_max_ym_ = -INT_MAX; - for (int pn = 0; pn < N_patches(); ++pn) - { - const patch &p = ith_patch(pn); - // n.b. these loops must use _int_ variables for the loop - // to terminate! - for (int want_min = false; want_min <= true; ++want_min) - { - for (int want_rho = false; want_rho <= true; ++want_rho) - { - ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); - // is dummy//gz.compute_Jacobian(ghosted_min_gfn_to_sync, ghosted_max_gfn_to_sync); - - global_min_ym_ = min(global_min_ym_, - gz.Jacobian_min_y_ipar_m()); - global_max_ym_ = max(global_max_ym_, - gz.Jacobian_max_y_ipar_m()); - } - } - } - } - - //****************************************************************************** - - // - // Given that compute_synchronize_Jacobian() has been called, this - // function computes the global min/max m over all ghost zone points. - // This is useful for sizing the buffer for synchronize_Jacobian(). - // - void patch_system::synchronize_Jacobian_global_minmax_ym(int &min_ym, int &max_ym) - const - { - min_ym = global_min_ym_; - max_ym = global_max_ym_; - } - - //****************************************************************************** - - // - // Given that compute_synchronize_Jacobian() has been called, this - // function computes a single row of the Jacobian, taking into account - // synchronize()'s 3-phase algorithm: - // - It returns the edge to which the y point belongs (the caller can get - // the patch from this edge). - // - It stores y_iperp and y_posn and min/max ym in the named arguments. - // - It stores the Jacobian elements - // partial synchronize() gridfn(ghosted_gfn, px, x_iperp, x_ipar) - // ------------------------------------------------------------- - // partial gridfn(ghosted_gfn, py, y_iperp, y_posn+ym) - // in the caller-supplied buffer - // Jacobian_buffer(ym) - // for each ym in the min/max ym range. - // - // In practice, the main task of this function is taking into account - // synchronize()'s 3-phase algorithm. There are several cases: - // - ghost zone is symmetry && x point is in non-corner - // ==> x value was computed by a phase 1 symmetry operation, - // using (only) nominal-grid data - // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) - // - ghost zone is symmetry && x point is in corner - // --> x value was computed by a phase 3 symmetry operation, - // from some point (call it z), - // ==> overall Jacobian(x,y) = overall Jacobian(z,y) - // ==> call this function recursively to get z's Jacobian - // (z must be in the noncorner part of some ghost zone, - // so this won't lead to infinite recursion) - // - ghost zone is interpatch - // ==> x value was computed by a phase 2 interpatch interpolation - // - using (only) nominal-grid data - // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) - // - using a mixture of nominal-grid data - // and data computed by a phase 1 symmetry operation - // ==> overall Jacobian(x,y) = "fold" ghost zone Jacobian(x,y) - // to take the phase 1 symmetry - // operation into account - // - const patch_edge & - patch_system::synchronize_Jacobian(const ghost_zone &xgz, - int x_iperp, int x_ipar, - int &y_iperp, - int &y_posn, int &min_ym, int &max_ym, - jtutil::array1d &Jacobian_buffer) - const - { - const patch_edge &xe = xgz.my_edge(); - - if (xgz.is_symmetry() && xe.ipar_is_in_noncorner(x_ipar)) - then - { - // ghost zone is symmetry && x point is in non-corner - // ==> x value was computed by a phase 1 symmetry operation, - // using (only) nominal-grid data - // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) - return ghost_zone_Jacobian(xgz, - x_iperp, x_ipar, - y_iperp, - y_posn, min_ym, max_ym, - Jacobian_buffer); - } - - else if (xgz.is_symmetry() && xe.ipar_is_in_corner(x_ipar)) - then - { - // ghost zone is symmetry && x point is in corner - // --> x value was computed by a phase 3 symmetry operation, - // from some point (call it z), - // ==> overall Jacobian(x,y) = overall Jacobian(z,y) - // ==> call this function recursively to get z's Jacobian - // (z must be in the noncorner part of some ghost zone, - // so this won't lead to infinite recursion) - - const patch &zp = xgz.other_patch(); - const patch_edge &ze = xgz.other_edge(); - const symmetry_ghost_zone &xsgz = xgz.cast_to_symmetry_ghost_zone(); - const int z_iperp = xsgz.iperp_map_of_iperp(x_iperp); - const int z_ipar = xsgz.ipar_map_of_ipar(x_ipar); - - // - // Computing z's edge/ghost zone is tricky. For example: - // | - // p1 e3|e4 p2 - // | - // | z - // -----------e1-----------+------------e2--------- - // | x - // | - // Here the point x in the corner of p1's e1 ghost zone, - // is computed by the phase 3 symmetry operation (a reflection - // about e1) from z. Thus zp == p1 and ze == e1. - // - // But we need to "turn the corner" to compute z's "true" edge - // e3 (so we can recursively call this function to compute z's - // Jacobian). Thus we explicitly check which ghost zone of p1 - // (here the e3 ghost zone) contains the point z. - // - const int z_irho = ze.irho_of_iperp_ipar(z_iperp, z_ipar); - const int z_isigma = ze.isigma_of_iperp_ipar(z_iperp, z_ipar); - const ghost_zone &true_zgz = zp.ghost_zone_containing_noncorner_point(z_irho, z_isigma); - const patch_edge &true_ze = true_zgz.my_edge(); - const int true_z_iperp = true_ze.iperp_of_irho_isigma(z_irho, z_isigma); - const int true_z_ipar = true_ze.ipar_of_irho_isigma(z_irho, z_isigma); - - // make sure we have the right ghost zone! - assert(true_zgz.is_in_ghost_zone(true_z_iperp, true_z_ipar)); - - return synchronize_Jacobian(true_zgz, - true_z_iperp, true_z_ipar, - y_iperp, - y_posn, min_ym, max_ym, - Jacobian_buffer); - } - - else if (xgz.is_interpatch()) - then - { - // ghost zone is interpatch - // ==> x value was computed by a phase 2 interpatch interpolation - // - using (only) nominal-grid data - // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) - // - using a mixture of nominal-grid data - // and data computed by a phase 1 symmetry operation - // ==> overall Jacobian(x,y) = "fold" ghost zone Jacobian(x,y) - // to take the phase 1 symmetry - // operation into account - // - // For example, - // | - // xp xe|ye a yp - // | b - // | xc - // ----------xse-----------+---d-------yse---------- - // | e - // | - // here point x is computed by interpatch-interpolating in the - // par direction from the 5 y points abcde. e is outside the - // nominal grid, so its Jacobian must be "folded" over to c. - // Notice that this "folding" must be done about the edge yse, - // *not* about ye itself. - - // Jacobian of the phase 2 interpatch interpolation - const patch_edge &ye = ghost_zone_Jacobian(xgz, - x_iperp, x_ipar, - y_iperp, - y_posn, min_ym, max_ym, - Jacobian_buffer); - const int min_y_ipar = y_posn + min_ym; - const int max_y_ipar = y_posn + max_ym; - - // fold any points in the Jacobian outside the nominal grid - if (ye.ipar_is_in_min_ipar_corner(min_y_ipar)) - then - { - fold_Jacobian(ye, ye.min_par_adjacent_edge(), - y_iperp, - y_posn, min_ym, max_ym, - min_ym, ye.min_ipar_corner__max_ipar() - y_posn, - Jacobian_buffer); - min_ym = ye.min_ipar_without_corners() - y_posn; - } - if (ye.ipar_is_in_max_ipar_corner(max_y_ipar)) - then - { - fold_Jacobian(ye, ye.max_par_adjacent_edge(), - y_iperp, - y_posn, min_ym, max_ym, - ye.max_ipar_corner__min_ipar() - y_posn, max_ym, - Jacobian_buffer); - max_ym = ye.max_ipar_without_corners() - y_posn; - } - - return ye; - } - - else - error_exit(PANIC_EXIT, - "***** patch_system::synchronize_Jacobian():\n" - " don't know what to do with ghost zone (this should never happen)!\n" - " xgz.my_patch()=\"%s\" xe=xgz.my_edge()=\"%s\"\n" - " xgz.other_patch()=\"%s\" xgz.other_edge()=\"%s\"\n" - " xgz.is_symmetry()=(int)%d xgz.is_interpatch()=(int)%d\n" - " x_iperp=%d x_ipar=%d\n" - " xe.ipar_is_in_{min,max}_ipar_corner(x_ipar)=(int){%d,%d}\n" - " xe.ipar_is_in_{corner,noncorner}(x_ipar)=(int){%d,%d}\n", - xgz.my_patch().name(), xe.name(), - xgz.other_patch().name(), xgz.other_edge().name(), - int(xgz.is_symmetry()), int(xgz.is_interpatch()), - x_iperp, x_ipar, - xe.ipar_is_in_min_ipar_corner(x_ipar), - xe.ipar_is_in_max_ipar_corner(x_ipar), - xe.ipar_is_in_corner(x_ipar), - xe.ipar_is_in_noncorner(x_ipar)); /*NOTREACHED*/ - } - - //****************************************************************************** - - // - // This function "folds" part of a(n interpatch) Jacobian row to take - // a symmetry operation into account. For example: - // | - // |e_Jac - // | p - // | a - // | b - // | c=y - // ---------+---d-------e_fold------- - // | e=x sgz_fold - // | - // Here the Jacobian abcde is to be "folded", because e is outside the - // nominal grid (its Jacobian must be "folded" over to c). - // - // Notice that the folding (about the edge e_fold) is in the par direction - // with respect to e_Jac, but the perp direction with respect to e_fold. - // Since e_fold and e_Jac are adjacent edges, - // e_Jac (iperp,ipar) == e_fold (ipar,iperp) - // - // Arguments: - // e_Jac = edge which the Jacobian lies along - // e_fold = edge about which to fold; the corresponding ghost zone must be - // symmetry ghost zone, and at present we only support the case - // where this is a "local" (mirror-image) symmetry ghost zone - // iperp = iperp-wrt-e_Jac coordinate of Jacobian - // posn = ipar-wrt-e_Jac coordinate of Jacobian molecule reference point - // [min,max]_m = range of ipar-wrt-e_Jac molecule m in Jacobian - // [min,max]_fold_m = range of ipar-wrt-e_Jac molecule m which is to folded; - // this must be a subrange of [min,max]_m - // - void patch_system::fold_Jacobian(const patch_edge &e_Jac, - const patch_edge &e_fold, - int iperp, - int posn, int min_m, int max_m, - int min_fold_m, int max_fold_m, - jtutil::array1d &Jacobian_buffer) - const - { - // check that [min,max]_fold_m is a subrange of [min,max]_m - assert(min_fold_m >= min_m); - assert(min_fold_m <= max_m); - assert(max_fold_m >= min_m); - assert(max_fold_m <= max_m); - - const patch &p = e_fold.my_patch(); - assert(e_Jac.my_patch() == p); - - const symmetry_ghost_zone &sgz_fold = p.ghost_zone_on_edge(e_fold) - .cast_to_symmetry_ghost_zone(); - - // - // At present we only handle the case show in the comments above, - // where sgz_fold is a local (mirror-image) symmetry, i.e. where - // y is guaranteed to be within the molecule abcde. - // - if (sgz_fold.other_edge() != e_fold) - then error_exit(ERROR_EXIT, - "***** patch_system::fold_Jacobian()\n" - " implementation restriction: at present we only handle folding\n" - " via \"local\" (mirror-image) symmetries!\n" - " p=\"%s\" e_Jac=\"%s\" e_fold=\"%s\"\n" - " but sgz_fold.other_edge()=\"%s\" != e_fold\n", - p.name(), e_Jac.name(), e_fold.name(), - sgz_fold.other_edge().name()); /*NOTREACHED*/ - - for (int xm = min_fold_m; xm <= max_fold_m; ++xm) - { - const int x_Jac_ipar = posn + xm; // x ipar wrt e_Jac - const int x_fold_iperp = x_Jac_ipar; // ... == iperp wrt e_fold - - const int y_fold_iperp = sgz_fold.iperp_map_of_iperp(x_fold_iperp); - // y iperp wrt e_fold - const int y_Jac_ipar = y_fold_iperp; // ... == ipar wrt e_Jac - const int ym = y_Jac_ipar - posn; - - // check that y is indeed within the molecule - assert(ym >= min_m); - assert(ym <= max_m); - - // actually "fold" the molecule - Jacobian_buffer(ym) += Jacobian_buffer(xm); - } - } - - //****************************************************************************** - - // - // Given that compute_synchronize_Jacobian() has been called, this - // function computes a single row of the Jacobian of a given ghost zone, - // *not* taking into account synchronize()'s 3-phase algorithm: - // - It returns the edge to which the y point belongs (the caller can get - // the patch from this edge). - // - It stores y_iperp and y_posn and min/max ym in the named arguments. - // - It stores the Jacobian elements - // partial synchronize() gridfn(ghosted_gfn, px, x_iperp, x_ipar) - // ------------------------------------------------------------- - // partial gridfn(ghosted_gfn, py, y_iperp, y_posn+ym) - // in the caller-supplied buffer - // Jacobian_buffer(ym) - // for each ym in the min/max ym range - // - const patch_edge & - patch_system::ghost_zone_Jacobian(const ghost_zone &xgz, - int x_iperp, int x_ipar, - int &y_iperp, - int &y_posn, int &min_ym, int &max_ym, - jtutil::array1d &Jacobian_buffer) - const - { - y_iperp = xgz.Jacobian_y_iperp(x_iperp); - - y_posn = xgz.Jacobian_y_ipar_posn(x_iperp, x_ipar); - min_ym = xgz.Jacobian_min_y_ipar_m(); - max_ym = xgz.Jacobian_max_y_ipar_m(); - - for (int ym = min_ym; ym <= max_ym; ++ym) - { - Jacobian_buffer(ym) = xgz.Jacobian(x_iperp, x_ipar, ym); - } - - return xgz.other_edge(); - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_info.h" +#include "patch_system.h" +#include "patch_system_info.h" + +namespace AHFinderDirect +{ + using jtutil::error_exit; + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function constructs a patch_system object. + // + // Constructor arguments: + // ghost_zone_width = Width in grid points of all ghost zones. + // patch_overlap_width = Number of grid points that adjacent + // nominally-just-touching patches should overlap. + // For example, with patch_overlap_width == 3, here + // are the grid points of two neighboring patches: + // x x x x x X + // | + // O o o o o o + // Here | marks the "just touching" boundary, + // x and o the grid points before this extension, + // and X and O the extra grid points added by this + // extension. For this example, the patch_extend_width + // parameter used by some other functions would + // be 1; in general + // patch_overlap_width = 2*patch_extend_width + 1 + // N_zones_per_right_angle = This sets the grid spacing (same in both + // directions) to 90.0 / N_zones_per_right_angle. + // It's a fatal error (error_exit()) if this + // doesn't evenly divide the grid sizes in both + // directions. + // ip_interp_handle = Cactus handle to the interpatch interpolation operator; + // this must be a 1-D interpolator + // ip_interp_par_table_handle = Cactus handle to the parameter table for the + // interpatch interpolation operator + // surface_interp_handle = Cactus handle to the surface interpolation + // operator; this is optional, and is only used by + // radius_in_{local,global}_xyz_direction() + // If this is used, it must be a 2-D interpolator + // surface_interp_par_table_handle = Cactus handle to the parameter table + // for the surface interpolation operator; + // this is optional, and is only used by + // radius_in_local_xyz_direction() + // print_summary_msg_flag = true to print 2 lines of CCTK_VInfo messages + // giving the patch system type and origin + // false to skip this + // print_detailed_msg_flag = true to print extensive messages tracing the + // creation and initialization of various + // data structures + // false to skip this + // + patch_system::patch_system(fp origin_x_in, fp origin_y_in, fp origin_z_in, + enum patch_system_type type_in, + int ghost_zone_width, int patch_overlap_width, + int N_zones_per_right_angle, + int min_gfn_in, int max_gfn_in, + int ghosted_min_gfn_in, int ghosted_max_gfn_in, + int ip_interp_handle, int ip_interp_par_table_handle, + int surface_interp_handle_in, + int surface_interp_par_table_handle_in, + bool print_summary_msg_flag, + bool print_detailed_msg_flag) + + : global_coords_(origin_x_in, origin_y_in, origin_z_in), + type_(type_in), + N_patches_(N_patches_of_type(type_in)), + all_patches_(new patch *[N_patches_]), + starting_gpn_(new int[N_patches_ + 1]), + ghosted_starting_gpn_(new int[N_patches_ + 1]), + gridfn_storage_(NULL), // set in setup_gridfn_storage() + ghosted_gridfn_storage_(NULL), // set in setup_gridfn_storage() + global_min_ym_(0), global_max_ym_(0), + // set in compute_synchronize_Jacobian() + surface_interp_handle_(surface_interp_handle_in), + surface_interp_par_table_handle_(surface_interp_par_table_handle_in) + { + if (!jtutil::is_odd(patch_overlap_width)) + then error_exit(ERROR_EXIT, + "***** patch_system::patch_system(): implementation restriction:\n" + " patch_overlap_width=%d, but we only support odd values!\n", + patch_overlap_width); /*NOTREACHED*/ + const int patch_extend_width = patch_overlap_width >> 1; + + if (ghost_zone_width < fd_grid::molecule_radius()) + { + cout << "***** patch_system::patch_system():" << endl + << " must have ghost_zone_width >= fd_grid::molecule_radius()" << endl + << " but got ghost_zone_width=" << ghost_zone_width << " fd_grid::molecule_radius()=" << fd_grid::molecule_radius() << "!" << endl + << " finite difference order=4" << endl; + abort(); + } + + if (print_summary_msg_flag) + then + { + CCTK_VInfo(CCTK_THORNSTRING, + " constructing %s patch system", + name_of_type(type())); + CCTK_VInfo(CCTK_THORNSTRING, + " with %d angular zones per right angle", + N_zones_per_right_angle); + } + + // construct/interlink the patches and ghost zones + switch (type_in) + { + case patch_system__full_sphere: + create_patches(patch_system_info::full_sphere::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__full_sphere(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_z_hemisphere: + create_patches(patch_system_info::plus_z_hemisphere::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_z_hemisphere(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_xy_quadrant_mirrored: + create_patches(patch_system_info::plus_xy_quadrant::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_xy_quadrant_mirrored(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_xy_quadrant_rotating: + create_patches(patch_system_info::plus_xy_quadrant::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_xy_quadrant_rotating(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_xz_quadrant_mirrored: + create_patches(patch_system_info::plus_xz_quadrant::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_xz_quadrant_mirrored(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_xz_quadrant_rotating: + create_patches(patch_system_info::plus_xz_quadrant::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_xz_quadrant_rotating(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_xyz_octant_mirrored: + create_patches(patch_system_info::plus_xyz_octant::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_xyz_octant_mirrored(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + case patch_system__plus_xyz_octant_rotating: + create_patches(patch_system_info::plus_xyz_octant::patch_info_array, + ghost_zone_width, patch_extend_width, + N_zones_per_right_angle, + print_detailed_msg_flag); + setup_gridfn_storage(min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in, + print_detailed_msg_flag); + setup_ghost_zones__plus_xyz_octant_rotating(patch_overlap_width, + ip_interp_handle, + ip_interp_par_table_handle, + print_detailed_msg_flag); + break; + + default: + error_exit(ERROR_EXIT, + "***** patch_system::patch_system(): bad type_in=(int)%d!\n", + int(type_in)); /*NOTREACHED*/ + } + + if (print_summary_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " ==> %d nominal, %d ghosted angular grid points", + N_grid_points(), ghosted_N_grid_points()); + } + + //****************************************************************************** + + // + // This function destroys a patch_system object. + // + patch_system::~patch_system() + { + for (int pn = N_patches() - 1; pn >= 0; --pn) + { + if (&ith_patch(pn)) + delete &ith_patch(pn); + } + + if (ghosted_gridfn_storage_) + delete[] ghosted_gridfn_storage_; + if (gridfn_storage_) + delete[] gridfn_storage_; + if (ghosted_starting_gpn_) + delete[] ghosted_starting_gpn_; + if (starting_gpn_) + delete[] starting_gpn_; + if (all_patches_) + delete[] all_patches_; + } + + //****************************************************************************** + + // + // This function is called from the patch_system:: constructor to + // construct a set of patches as described by an array of patch_info + // structures and associated arguments, and make these patches members + // of this patch system. This function also correctly sets + // N_grid_points_ + // N_ghosted_grid_points_ + // all_patches_[] + // starting_gpn_[] + // ghosted_starting_gpn_[] + // This function does *NOT* create any of the ghost zones, and does + // *NOT* set up any gridfns. + // + void patch_system::create_patches(const struct patch_info patch_info_in[], + int ghost_zone_width, int patch_extend_width, + int N_zones_per_right_angle, + bool print_msg_flag) + { + N_grid_points_ = 0; + ghosted_N_grid_points_ = 0; + for (int pn = 0; pn < N_patches(); ++pn) + { + const struct patch_info &pi = patch_info_in[pn]; + const struct grid::grid_array_pars &grid_array_pars = pi.grid_array_pars(ghost_zone_width, + patch_extend_width, + N_zones_per_right_angle); + const struct grid::grid_pars &grid_pars = pi.grid_pars(patch_extend_width, + N_zones_per_right_angle); + + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " constructing %s patch (%d x %d grid points)", + pi.name, + jtutil::how_many_in_range(grid_array_pars.min_irho, + grid_array_pars.max_irho), + jtutil::how_many_in_range(grid_array_pars.min_isigma, + grid_array_pars.max_isigma)); + + struct patch *p; + switch (pi.ctype) + { + case 'z': + p = new z_patch(*this, pn, + pi.name, pi.is_plus, + grid_array_pars, grid_pars); + break; + case 'x': + p = new x_patch(*this, pn, + pi.name, pi.is_plus, + grid_array_pars, grid_pars); + break; + case 'y': + p = new y_patch(*this, pn, + pi.name, pi.is_plus, + grid_array_pars, grid_pars); + break; + default: + error_exit(ERROR_EXIT, + "***** patch_system::create_patches():\n" + " unknown patch_info_in[pn=%d].ctype=0x%02d='%c'!\n", + pn, pi.ctype, pi.ctype); /*NOTREACHED*/ + } + + // these record number of grid points in *previous* patches, + // i.e. they do *not* include the number of grid points in this patch + starting_gpn_[pn] = N_grid_points_; + ghosted_starting_gpn_[pn] = ghosted_N_grid_points_; + + N_grid_points_ += p->N_grid_points(); + ghosted_N_grid_points_ += p->ghosted_N_grid_points(); + + all_patches_[pn] = p; + } + + starting_gpn_[N_patches_] = N_grid_points_; + ghosted_starting_gpn_[N_patches_] = ghosted_N_grid_points_; + } + + //****************************************************************************** + + // + // This function is called from the patch_system:: constructor to set + // up the storage for all gridfns in all patches, giving each gridfn a + // contiguous-across-all-patches storage array. This function also makes + // a number of self-consistency checks to ensure that the gridfn storage + // subscripting is set up properly. + // + // This function assumes that all the patches have already been constructed + // before it is called. + // + // For example, given the patches {x,y,z}, the ghosted gridfns {H,J}, + // and the nominal gridfns {a,b,c}, we might picture the storage like + // this: + // + // xa xa xa ya ya za za za za + // xb xb xb yb yb zb zb zb zb + // xc xc xc yc yc zc zc zc zc + // + // xH xH xH xH yH yH yH zH zH zH zH zH + // xJ xJ xJ xJ yJ yJ yJ zJ zJ zJ zJ zJ + // + // Here the upper/lower blocks are for nominal/ghosted gridfns. + // The storage is taken as being contiguous within each row (in fact + // within each block). Thus the storage for all the nominal gridfns + // (or all the ghosted gridfns) in a single patch is *non*-contiguous. + // + // The creation of patches is done in several phases: first the patches + // are constructed with no gridfn storage, then we are called to set up + // the gridfn storage (taking into account the sizes of the other patches), + // then finally ghost zones are constructed and interlinked. + // + // FIXME: We should pad the gridfn storage as necessary to avoid cache + // conflicts, but we don't do this at present. + // + void patch_system::setup_gridfn_storage(int min_gfn_in, int max_gfn_in, + int ghosted_min_gfn_in, int ghosted_max_gfn_in, + bool print_msg_flag) + { + const int N_gridfns_in = jtutil::how_many_in_range(min_gfn_in, max_gfn_in); + const int ghosted_N_gridfns_in = jtutil::how_many_in_range(ghosted_min_gfn_in, ghosted_max_gfn_in); + + const int gfn_stride = N_grid_points(); + const int ghosted_gfn_stride = ghosted_N_grid_points(); + + const int N_storage = gfn_stride * N_gridfns_in; + const int ghosted_N_storage = ghosted_gfn_stride * ghosted_N_gridfns_in; + + if (print_msg_flag) + then + { + CCTK_VInfo(CCTK_THORNSTRING, + " setting up gridfn storage"); + CCTK_VInfo(CCTK_THORNSTRING, + " gfn=[%d,%d] ghosted_gfn=[%d,%d]", + min_gfn_in, max_gfn_in, + ghosted_min_gfn_in, ghosted_max_gfn_in); + CCTK_VInfo(CCTK_THORNSTRING, + " N_grid_points()=%d ghosted_N_grid_points()=%d", + N_grid_points(), ghosted_N_grid_points()); + } + + // storage arrays for all gridfns + gridfn_storage_ = new fp[N_storage]; + ghosted_gridfn_storage_ = new fp[ghosted_N_storage]; + + // divide up the storage array among the patches + // and set up the storage in the individual patches themselves + { + for (int pn = 0; pn < N_patches(); ++pn) + { + const int posn = starting_gpn_[pn]; + const int ghosted_posn = ghosted_starting_gpn_[pn]; + const struct grid_arrays::gridfn_pars gridfn_pars = { + min_gfn_in, max_gfn_in, + &gridfn_storage_[posn], + gfn_stride, 0, 0}; + const struct grid_arrays::gridfn_pars ghosted_gridfn_pars = { + ghosted_min_gfn_in, ghosted_max_gfn_in, + &ghosted_gridfn_storage_[ghosted_posn], + ghosted_gfn_stride, 0, 0}; + + patch &p = ith_patch(pn); + p.setup_gridfn_storage(gridfn_pars, ghosted_gridfn_pars); + } + } + + if (print_msg_flag) + then + { + CCTK_VInfo(CCTK_THORNSTRING, + " checking that storage is partitioned properly"); + } + + // check to make sure storage for distinct gridfns + // forms a partition of the overall storage array + const patch &pfirst = ith_patch(0); + const patch &plast = ith_patch(N_patches() - 1); + { + for (int gfn = min_gfn(); gfn + 1 < max_gfn(); ++gfn) + { + // range of storage occupied by gridfns: + // gfn --> [gfn_first, gfn_last] + // gfn+1 --> [gfn1_first, gfn1_last] + const fp *const gfn_last_ptr = &plast.gridfn(gfn, plast.max_irho(), + plast.max_isigma()); + const fp *const gfn1_first_ptr = &pfirst.gridfn(gfn + 1, pfirst.min_irho(), + pfirst.min_isigma()); + if (!(gfn1_first_ptr == gfn_last_ptr + 1)) + then error_exit(PANIC_EXIT, + "***** patch_system::setup_gridfn_storage():\n" + " nominal-grid gridfns don't partition overall storage array!" + " (this should never happen!)\n" + " gfn=%d last point at gfn_last_ptr=%p\n" + " gfn+1=%d first point at gfn1_first_ptr=%p\n" + " should have gfn1_first_ptr == gfn_last_ptr+1\n", + gfn, (const void *)gfn_last_ptr, + gfn + 1, (const void *)gfn1_first_ptr); /*NOTREACHED*/ + } + } + + { + for (int ghosted_gfn = ghosted_min_gfn(); + ghosted_gfn + 1 < ghosted_max_gfn(); + ++ghosted_gfn) + { + // range of storage occupied by ghosted gridfns: + // ghosted_gfn --> [gfn_first, gfn_last] + // ghosted_gfn+1 --> [gfn1_first, gfn1_last] + const fp *const ghosted_gfn_last_ptr = &plast.ghosted_gridfn(ghosted_gfn, + plast.ghosted_max_irho(), + plast.ghosted_max_isigma()); + const fp *const ghosted_gfn1_first_ptr = &pfirst.ghosted_gridfn(ghosted_gfn + 1, + pfirst.ghosted_min_irho(), + pfirst.ghosted_min_isigma()); + if (!(ghosted_gfn1_first_ptr == ghosted_gfn_last_ptr + 1)) + then error_exit(PANIC_EXIT, + "***** patch_system::setup_gridfn_storage():\n" + " ghosted-grid gridfns don't partition overall storage array!" + " (this should never happen!)\n" + " ghosted_gfn=%d last point at ghosted_gfn_last_ptr=%p\n" + " ghosted_gfn+1=%d first point at ghosted_gfn1_first_ptr=%p\n" + " should have ghosted_gfn1_first_ptr == ghosted_gfn_last_ptr+1\n", + ghosted_gfn, (const void *)ghosted_gfn_last_ptr, + ghosted_gfn + 1, + (const void *)ghosted_gfn1_first_ptr); + /*NOTREACHED*/ + } + } + + // check to make sure storage for distinct patches + // forms a partition of the storage for each gridfn + { + for (int gfn = min_gfn(); gfn < max_gfn(); ++gfn) + { + for (int pn = 0; pn + 1 < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + const patch &p1 = ith_patch(pn + 1); + + // range of storage occupied by gridfn: + // p --> [p_first, p_last] + // p1 --> [p1_first, p1_last] + const fp *const p_last_ptr = &p.gridfn(gfn, p.max_irho(), p.max_isigma()); + const fp *const p1_first_ptr = &p1.gridfn(gfn, p1.min_irho(), p1.min_isigma()); + if (!(p1_first_ptr == p_last_ptr + 1)) + then error_exit(PANIC_EXIT, + "***** patch_system::setup_gridfn_storage():\n" + " nominal-grid patches gridfns don't partition storage for gfn=%d!\n" + " (this should never happen!)\n" + " gfn=%d %s patch last point at p_last_ptr=%p\n" + " gfn=%d %s patch first point at p1_first_ptr=%p\n" + " should have p1_first_ptr == p_last_ptr+1\n", + gfn, + gfn, p.name(), (const void *)p_last_ptr, + gfn + 1, p1.name(), (const void *)p1_first_ptr); + /*NOTREACHED*/ + } + } + } + + { + for (int ghosted_gfn = ghosted_min_gfn(); + ghosted_gfn < ghosted_max_gfn(); + ++ghosted_gfn) + { + for (int pn = 0; pn + 1 < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + const patch &p1 = ith_patch(pn + 1); + + // range of storage occupied by ghosted gridfn: + // p --> [p_first, p_last] + // p1 --> [p1_first, p1_last] + const fp *const p_last_ptr = &p.ghosted_gridfn(ghosted_gfn, + p.ghosted_max_irho(), + p.ghosted_max_isigma()); + const fp *const p1_first_ptr = &p1.ghosted_gridfn(ghosted_gfn, + p1.ghosted_min_irho(), + p1.ghosted_min_isigma()); + if (!(p1_first_ptr == p_last_ptr + 1)) + then error_exit(PANIC_EXIT, + "***** patch_system::setup_gridfn_storage():\n" + " nominal-grid patches gridfns don't partition storage for gfn=%d!\n" + " (this should never happen!)\n" + " %s patch (pn=%d) last point at p_last_ptr=%p\n" + " %s patch (pn=%d) first point at p1_first_ptr=%p\n" + " should have p1_first_ptr == p_last_ptr+1\n", + ghosted_gfn, + p.name(), pn, (const void *)p_last_ptr, + p1.name(), pn + 1, (const void *)p1_first_ptr); + /*NOTREACHED*/ + } + } + } + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a full-sphere patch system. + // + void patch_system::setup_ghost_zones__full_sphere(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " seting up full sphere ghost zones"); + + patch &pz = ith_patch(patch_system_info::full_sphere::patch_number__pz); + patch &px = ith_patch(patch_system_info::full_sphere::patch_number__px); + patch &py = ith_patch(patch_system_info::full_sphere::patch_number__py); + patch &mx = ith_patch(patch_system_info::full_sphere::patch_number__mx); + patch &my = ith_patch(patch_system_info::full_sphere::patch_number__my); + patch &mz = ith_patch(patch_system_info::full_sphere::patch_number__mz); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(pz, mx, patch_overlap_width); + create_interpatch_ghost_zones(pz, my, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + create_interpatch_ghost_zones(py, mx, patch_overlap_width); + create_interpatch_ghost_zones(mx, my, patch_overlap_width); + create_interpatch_ghost_zones(my, px, patch_overlap_width); + create_interpatch_ghost_zones(mz, px, patch_overlap_width); + create_interpatch_ghost_zones(mz, py, patch_overlap_width); + create_interpatch_ghost_zones(mz, mx, patch_overlap_width); + create_interpatch_ghost_zones(mz, my, patch_overlap_width); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, mx, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(py, mx, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mx, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(my, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, mx, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +z hemisphere patch system. + // + void patch_system::setup_ghost_zones__plus_z_hemisphere(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +z hemisphere ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__py); + patch &mx = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__mx); + patch &my = ith_patch(patch_system_info::plus_z_hemisphere::patch_number__my); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(pz, mx, patch_overlap_width); + create_interpatch_ghost_zones(pz, my, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + create_interpatch_ghost_zones(py, mx, patch_overlap_width); + create_interpatch_ghost_zones(mx, my, patch_overlap_width); + create_interpatch_ghost_zones(my, px, patch_overlap_width); + px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); + mx.create_mirror_symmetry_ghost_zone(mx.min_rho_patch_edge()); + my.create_mirror_symmetry_ghost_zone(my.min_rho_patch_edge()); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, mx, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(py, mx, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mx, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(my, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +xy quadrant (mirrored) patch system. + // + void patch_system::setup_ghost_zones__plus_xy_quadrant_mirrored(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +xy quadrant (mirrored) ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__py); + patch &mz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__mz); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + create_interpatch_ghost_zones(mz, px, patch_overlap_width); + create_interpatch_ghost_zones(mz, py, patch_overlap_width); + pz.create_mirror_symmetry_ghost_zone(pz.min_rho_patch_edge()); + pz.create_mirror_symmetry_ghost_zone(pz.min_sigma_patch_edge()); + px.create_mirror_symmetry_ghost_zone(px.min_sigma_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_sigma_patch_edge()); + mz.create_mirror_symmetry_ghost_zone(mz.max_rho_patch_edge()); + mz.create_mirror_symmetry_ghost_zone(mz.max_sigma_patch_edge()); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +xy quadrant (rotating) patch system. + // + void patch_system::setup_ghost_zones__plus_xy_quadrant_rotating(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +xy quadrant (rotating) ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__py); + patch &mz = ith_patch(patch_system_info::plus_xy_quadrant::patch_number__mz); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + create_interpatch_ghost_zones(mz, px, patch_overlap_width); + create_interpatch_ghost_zones(mz, py, patch_overlap_width); + create_periodic_symmetry_ghost_zones(pz.min_rho_patch_edge(), + pz.min_sigma_patch_edge(), + true); + create_periodic_symmetry_ghost_zones(px.min_sigma_patch_edge(), + py.max_sigma_patch_edge(), + true); + create_periodic_symmetry_ghost_zones(mz.max_rho_patch_edge(), + mz.max_sigma_patch_edge(), + true); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(mz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +xz quadrant (mirrored) patch system. + // + void patch_system::setup_ghost_zones__plus_xz_quadrant_mirrored(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +xz quadrant (mirrored) ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__py); + patch &my = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__my); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(pz, my, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + create_interpatch_ghost_zones(px, my, patch_overlap_width); + pz.create_mirror_symmetry_ghost_zone(pz.min_sigma_patch_edge()); + px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_sigma_patch_edge()); + my.create_mirror_symmetry_ghost_zone(my.min_rho_patch_edge()); + my.create_mirror_symmetry_ghost_zone(my.min_sigma_patch_edge()); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +xz quadrant (rotating) patch system. + // + void patch_system::setup_ghost_zones__plus_xz_quadrant_rotating(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +xz quadrant (rotating) ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__py); + patch &my = ith_patch(patch_system_info::plus_xz_quadrant::patch_number__my); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(pz, my, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + create_interpatch_ghost_zones(px, my, patch_overlap_width); + px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); + my.create_mirror_symmetry_ghost_zone(my.min_rho_patch_edge()); + create_periodic_symmetry_ghost_zones(pz.min_sigma_patch_edge(), + pz.min_sigma_patch_edge(), + false); + create_periodic_symmetry_ghost_zones(py.max_sigma_patch_edge(), + my.min_sigma_patch_edge(), + false); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, my, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +xyz octant (mirrored) patch system. + // + void patch_system::setup_ghost_zones__plus_xyz_octant_mirrored(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +xyz octant (mirrored) ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_xyz_octant::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_xyz_octant::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_xyz_octant::patch_number__py); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + pz.create_mirror_symmetry_ghost_zone(pz.min_rho_patch_edge()); + pz.create_mirror_symmetry_ghost_zone(pz.min_sigma_patch_edge()); + px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); + px.create_mirror_symmetry_ghost_zone(px.min_sigma_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_sigma_patch_edge()); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + + // + // This function sets up (constructs and interlinks) the ghost zones + // for a +xyz octant (rotating) patch system. + // + void patch_system::setup_ghost_zones__plus_xyz_octant_rotating(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag) + { + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " setting up +xyz octant (rotating) ghost zones"); + + patch &pz = ith_patch(patch_system_info::plus_xyz_octant::patch_number__pz); + patch &px = ith_patch(patch_system_info::plus_xyz_octant::patch_number__px); + patch &py = ith_patch(patch_system_info::plus_xyz_octant::patch_number__py); + + // create the ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " creating ghost zones"); + create_interpatch_ghost_zones(pz, px, patch_overlap_width); + create_interpatch_ghost_zones(pz, py, patch_overlap_width); + create_interpatch_ghost_zones(px, py, patch_overlap_width); + px.create_mirror_symmetry_ghost_zone(px.max_rho_patch_edge()); + py.create_mirror_symmetry_ghost_zone(py.max_rho_patch_edge()); + create_periodic_symmetry_ghost_zones(pz.min_rho_patch_edge(), + pz.min_sigma_patch_edge(), + true); + create_periodic_symmetry_ghost_zones(px.min_sigma_patch_edge(), + py.max_sigma_patch_edge(), + true); + + // finish setting up the interpatch ghost zones + if (print_msg_flag) + then CCTK_VInfo(CCTK_THORNSTRING, + " finishing interpatch setup"); + finish_interpatch_setup(pz, px, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(pz, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + finish_interpatch_setup(px, py, + patch_overlap_width, + ip_interp_handle, ip_interp_par_table_handle); + + assert_all_ghost_zones_fully_setup(); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function creates a pair of periodic-symmetry ghost zones. + // + // static + void patch_system::create_periodic_symmetry_ghost_zones(const patch_edge &ex, const patch_edge &ey, + bool ipar_map_is_plus) + { + ex.my_patch() + .create_periodic_symmetry_ghost_zone(ex, ey, ipar_map_is_plus); + + if (ex == ey) + then + { + // ex and ey are the same edge (i.e. the symmetry maps the edge + // back to itself), so we only want to set up the edge once + // ==> no-op here + } + else + ey.my_patch() + .create_periodic_symmetry_ghost_zone(ey, ex, ipar_map_is_plus); + } + + //****************************************************************************** + + // + // This function automagically figures out which edges of two adjacent + // patches are adjacent, then creates both patches' ghost zones on those + // edges and interlinks them with their respective patches. + // + // static + void patch_system::create_interpatch_ghost_zones(patch &px, patch &py, + int patch_overlap_width) + { + const patch_edge &ex = px.edge_adjacent_to_patch(py, patch_overlap_width); + const patch_edge &ey = py.edge_adjacent_to_patch(px, patch_overlap_width); + + px.create_interpatch_ghost_zone(ex, ey, patch_overlap_width); + py.create_interpatch_ghost_zone(ey, ex, patch_overlap_width); + } + + //****************************************************************************** + + // + // This function automagically figures out which edges of two adjacent + // patches are adjacent, then finishes setting up both ghost zones. + // + // static + void patch_system::finish_interpatch_setup(patch &px, patch &py, + int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle) + { + const patch_edge &ex = px.edge_adjacent_to_patch(py, patch_overlap_width); + const patch_edge &ey = py.edge_adjacent_to_patch(px, patch_overlap_width); + px.ghost_zone_on_edge(ex) + .cast_to_interpatch_ghost_zone() + .finish_setup(ip_interp_handle, ip_interp_par_table_handle); + py.ghost_zone_on_edge(ey) + .cast_to_interpatch_ghost_zone() + .finish_setup(ip_interp_handle, ip_interp_par_table_handle); + } + + //****************************************************************************** + + // + // This function assert()s that all ghost zones of all patches have + // been fully set up. + // + void patch_system::assert_all_ghost_zones_fully_setup() const + { + for (int pn = 0; pn < N_patches(); ++pn) + { + ith_patch(pn).assert_all_ghost_zones_fully_setup(); + } + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function decodes a patch system's type into N_patches. + // + // static + int patch_system::N_patches_of_type(enum patch_system_type type_in) + { + switch (type_in) + { + case patch_system__full_sphere: + return patch_system_info::full_sphere::N_patches; + case patch_system__plus_z_hemisphere: + return patch_system_info::plus_z_hemisphere::N_patches; + case patch_system__plus_xy_quadrant_mirrored: + case patch_system__plus_xy_quadrant_rotating: + return patch_system_info::plus_xy_quadrant::N_patches; + case patch_system__plus_xz_quadrant_mirrored: + case patch_system__plus_xz_quadrant_rotating: + return patch_system_info::plus_xz_quadrant::N_patches; + case patch_system__plus_xyz_octant_mirrored: + case patch_system__plus_xyz_octant_rotating: + return patch_system_info::plus_xyz_octant::N_patches; + default: + error_exit(PANIC_EXIT, + "***** patch_system::N_patches_of_type(): bad type=(int)%d!\n" + " (this should never happen!)\n", + int(type_in)); /*NOTREACHED*/ + } + } + + //****************************************************************************** + + // + // This function decodes a patch system's type into a human-readable + // type name (a C string). + // + // static + const char *patch_system::name_of_type(enum patch_system_type type_in) + { + switch (type_in) + { + case patch_system__full_sphere: + return "full sphere"; + case patch_system__plus_z_hemisphere: + return "+z hemisphere"; + case patch_system__plus_xy_quadrant_mirrored: + return "+xy quadrant (mirrored)"; + case patch_system__plus_xy_quadrant_rotating: + return "+xy quadrant (rotating)"; + case patch_system__plus_xz_quadrant_mirrored: + return "+xz quadrant (mirrored)"; + case patch_system__plus_xz_quadrant_rotating: + return "+xz quadrant (rotating)"; + case patch_system__plus_xyz_octant_mirrored: + return "+xyz octant (mirrored)"; + case patch_system__plus_xyz_octant_rotating: + return "+xyz octant (rotating)"; + default: + error_exit(PANIC_EXIT, + "***** patch_system::name_of_type(): bad type=(int)%d!\n" + " (this should never happen!)\n", + int(type_in)); /*NOTREACHED*/ + } + } + + //****************************************************************************** + + // + // This function encodes a human-readable type name (a C string) into + // a patch system's type into. + // + // static + enum patch_system::patch_system_type + patch_system::type_of_name(const char *name_in) + { + if (strcmp(name_in, "full sphere") == 0) + return patch_system__full_sphere; + else if (strcmp(name_in, "+z hemisphere") == 0) + return patch_system__plus_z_hemisphere; + else if (strcmp(name_in, "+xy quadrant (mirrored)") == 0) + return patch_system__plus_xy_quadrant_mirrored; + else if (strcmp(name_in, "+xy quadrant (rotating)") == 0) + return patch_system__plus_xy_quadrant_rotating; + else if (strcmp(name_in, "+xz quadrant (mirrored)") == 0) + return patch_system__plus_xz_quadrant_mirrored; + else if (strcmp(name_in, "+xz quadrant (rotating)") == 0) + return patch_system__plus_xz_quadrant_rotating; + else if (strcmp(name_in, "+xyz octant (mirrored)") == 0) + return patch_system__plus_xyz_octant_mirrored; + else if (strcmp(name_in, "+xyz octant (rotating)") == 0) + return patch_system__plus_xyz_octant_rotating; + else + error_exit(PANIC_EXIT, + "***** patch_system::type_of_name(): unknown name=\"%s\"!", + name_in); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function finds a (the) patch with a specified sign and xyz ctype. + // If no such patch exists, it does an error_exit() (and doesn't return + // to the caller). + // + // FIXME: + // - This function could be implemented to be very fast (using the + // patch numbers in patch_system_info::), but right now it just does + // a sequential search through all the patches, so it's pretty slow :( + // + const patch &patch_system::plus_or_minus_xyz_patch(bool is_plus, char ctype) + const + { + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + if ((p.is_plus() == is_plus) && (p.ctype() == ctype)) + then return p; + } + + error_exit(ERROR_EXIT, + "***** patch_system::plus_or_minus_xyz_patch():\n" + " can't find any %c%c patch!", + (is_plus ? '+' : '-'), ctype); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function finds a patch from its human-readable name, and returns + // the patch number, or does an error_exit() if no patch is found with + // the specified name. + // + int patch_system::patch_number_of_name(const char *name) const + { + for (int pn = 0; pn < N_patches(); ++pn) + { + if (strcmp(ith_patch(pn).name(), name) == 0) + return pn; + } + + error_exit(ERROR_EXIT, + "***** patch_system::patch_number_of_name():\n" + " no patch with name \"%s\"!\n", + name); /*NOTREACHED*/ + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function decodes a 0-origin grid point number into a + // (patch,irho,isigma) triple. + // + // Arguments: + // gpn = The grid point number to decode. + // (irho,isigma) = (out) The decoded patch coordinates. + // + // Results: + // This function returns a reference to the decoded patch. (An alternative + // design would be to return this via a patch*& argument, but the design + // used here seems slightly cleaner to use in practice.) + // + const patch & + patch_system::patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) + const + { + assert(gpn >= 0); + assert(gpn < N_grid_points()); + + for (int pn = 0; pn < N_patches(); ++pn) + { + // n.b. [pn+1] is ok since starting_gpn_[] has size N_patches()+1 + if ((gpn >= starting_gpn_[pn]) && (gpn < starting_gpn_[pn + 1])) + then + { + const patch &p = ith_patch(pn); + const int gpn_in_patch = gpn - starting_gpn_[pn]; + assert(gpn_in_patch >= 0); + assert(gpn_in_patch < p.N_grid_points()); + p.irho_isigma_of_gpn(gpn_in_patch, irho, isigma); + return p; + } + } + + error_exit(PANIC_EXIT, + "***** patch_system::patch_irho_isigma_of_gpn(gpn=%d):\n" + " couldn't find any patch! (this should never happen!)\n" + " N_grid_points()=%d\n", + gpn, + N_grid_points()); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function decodes a 0-origin grid point number into a *ghosted* + // (patch,irho,isigma) triple. + // + // Arguments: + // gpn = The grid point number to decode. + // (irho,isigma) = (out) The decoded patch coordinates. + // + // Results: + // This function returns a reference to the decoded patch. (An alternative + // design would be to return this via a patch*& argument, but the design + // used here seems slightly cleaner to use in practice.) + // + const patch & + patch_system::ghosted_patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) + const + { + assert(gpn >= 0); + assert(gpn < ghosted_N_grid_points()); + + for (int pn = 0; pn < N_patches(); ++pn) + { + // n.b. [pn+1] is ok since ghosted_starting_gpn_[] + // has size N_patches()+1 + if ((gpn >= ghosted_starting_gpn_[pn]) && (gpn < ghosted_starting_gpn_[pn + 1])) + then + { + const patch &p = ith_patch(pn); + const int gpn_in_patch = gpn - ghosted_starting_gpn_[pn]; + assert(gpn_in_patch >= 0); + assert(gpn_in_patch < p.ghosted_N_grid_points()); + p.ghosted_irho_isigma_of_gpn(gpn_in_patch, irho, isigma); + return p; + } + } + + error_exit(PANIC_EXIT, + "***** patch_system::ghosted_patch_irho_isigma_of_gpn(gpn=%d):\n" + " couldn't find any patch! (this should never happen!)\n" + " ghosted_N_grid_points()=%d\n", + gpn, + ghosted_N_grid_points()); /*NOTREACHED*/ + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function sets a (nominal-grid) gridfn to a constant value. + // + void patch_system::set_gridfn_to_constant(fp a, int dst_gfn) + { + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + p.gridfn(dst_gfn, irho, isigma) = a; + } + } + } + } + + //****************************************************************************** + + // + // This function copies one (nominal-grid) gridfn to another. + // + void patch_system::gridfn_copy(int src_gfn, int dst_gfn) + { + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + p.gridfn(dst_gfn, irho, isigma) = p.gridfn(src_gfn, irho, isigma); + } + } + } + } + + //****************************************************************************** + + // + // This function adds a scalar to a ghosted gridfn. + // + void patch_system::add_to_ghosted_gridfn(fp delta, int ghosted_dst_gfn) + { + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + for (int irho = p.ghosted_min_irho(); + irho <= p.ghosted_max_irho(); + ++irho) + { + for (int isigma = p.ghosted_min_isigma(); + isigma <= p.ghosted_max_isigma(); + ++isigma) + { + p.ghosted_gridfn(ghosted_dst_gfn, irho, isigma) += delta; + } + } + } + } + + //****************************************************************************** + + // + // Recentering + // + void patch_system::recentering(fp x, fp y, fp z) + { + global_coords_.recentering(x, y, z); + } + + //****************************************************************************** + + // + // This function computes norms of a nominal-grid gridfn. + // + void patch_system::gridfn_norms(int src_gfn, jtutil::norm &norms) + const + { + if (!is_valid_gfn(src_gfn)) + then error_exit(ERROR_EXIT, + "***** patch_system::gridfn_norms(): invalid src_gfn=%d!\n", + src_gfn); /*NOTREACHED*/ + + norms.reset(); + + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + norms.data(p.gridfn(src_gfn, irho, isigma)); + } + } + } + } + + //****************************************************************************** + + // + // This function computes norms of a ghosted-grid gridfn over the + // nominal grid. + // + void patch_system::ghosted_gridfn_norms(int ghosted_src_gfn, + jtutil::norm &norms) + const + { + if (!is_valid_ghosted_gfn(ghosted_src_gfn)) + then error_exit(ERROR_EXIT, + "***** patch_system::gridfn_norms(): invalid ghosted_src_gfn=%d!\n", + ghosted_src_gfn); /*NOTREACHED*/ + norms.reset(); + + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + for (int irho = p.min_irho(); irho <= p.max_irho(); ++irho) + { + for (int isigma = p.min_isigma(); + isigma <= p.max_isigma(); + ++isigma) + { + norms.data(p.ghosted_gridfn(ghosted_src_gfn, irho, isigma)); + } + } + } + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function computes an approximation to the circumference of a + // surface in the xy, xz, or yz plane. Note that we compute the full + // circumference all around the sphere, even if the patch system only + // covers a proper subset of this. + // + // We assume that adjacent patches are butt-joined, i.e. that their + // nominal boundaries just touch. + // + // Arguments: + // plane[] = (in) "xy", "xz", or "yz" to specify the integration plane. + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp patch_system::circumference(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum patch::integration_method method) + const + { + // + // compute arc length around the patch system + // + fp arc_length = 0.0; + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + if ((p.ctype() == plane[0]) || (p.ctype() == plane[1])) + then arc_length += p.plane_arc_length(plane, + ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + } + + // + // correct the arc length + // for the fact that the patch system may not cover the full 2-sphere + // + switch (type()) + { + case patch_system__full_sphere: + break; + case patch_system__plus_z_hemisphere: + arc_length *= ((plane[0] == 'x') && (plane[1] == 'y')) ? 1.0 : 2.0; + break; + case patch_system__plus_xy_quadrant_mirrored: + case patch_system__plus_xy_quadrant_rotating: + arc_length *= ((plane[0] == 'x') && (plane[1] == 'y')) ? 4.0 : 2.0; + break; + case patch_system__plus_xz_quadrant_mirrored: + case patch_system__plus_xz_quadrant_rotating: + arc_length *= ((plane[0] == 'x') && (plane[1] == 'z')) ? 4.0 : 2.0; + break; + case patch_system__plus_xyz_octant_mirrored: + case patch_system__plus_xyz_octant_rotating: + arc_length *= 4.0; + break; + default: + error_exit(PANIC_EXIT, + "***** patch_system::circumference(): unknown patch system type()=(int)%d!\n" + " (this should never happen!)\n", + int(type())); /*NOTREACHED*/ + } + + return arc_length; + } + + //****************************************************************************** + + // + // This function computes an approximation to the (surface) integral of + // a gridfn over the 2-sphere + // $\int f(\rho,\sigma) \, dA$ + // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ + // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma). + // + // We assume that adjacent patches are butt-joined, i.e. that their + // nominal boundaries just touch. + // + // Arguments: + // unknown_src_gfn = (in) The gridfn to be integrated. This may be + // either nominal-grid or ghosted-grid. + // src_gfn_is_even_across_{xy,xz,yz}_plane + // = (in) Boolean flags specifying whether the gridfn to be integrated + // is even (true) or odd (false) across the corresponding planes. + // Only the flags corresponding to boundaries of the patch system + // are used. For example, for a plus_z_hemisphere patch system, + // only the src_gfn_is_even_across_xy_plane flag is used. + // ghosted_radius_gfn = (in) The surface radius. + // g_{xx,xy,xz,yy,yz,zz}_gfn = (in) The xyz 3-metric components. + // method = (in) Selects the integration scheme. + // + fp patch_system::integrate_gridfn(int unknown_src_gfn, + bool src_gfn_is_even_across_xy_plane, + bool src_gfn_is_even_across_xz_plane, + bool src_gfn_is_even_across_yz_plane, + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum patch::integration_method method) + const + { + // + // compute integral over patch system + // + fp integral = 0.0; + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + integral += p.integrate_gridfn(unknown_src_gfn, + ghosted_radius_gfn, + g_xx_gfn, g_xy_gfn, g_xz_gfn, + g_yy_gfn, g_yz_gfn, + g_zz_gfn, + method); + } + + // + // correct the integral + // for the fact that the patch system may not cover the full 2-sphere + // + switch (type()) + { + case patch_system__full_sphere: + break; + case patch_system__plus_z_hemisphere: + integral *= src_gfn_is_even_across_xy_plane ? 2.0 : 0.0; + break; + case patch_system__plus_xy_quadrant_mirrored: + case patch_system__plus_xy_quadrant_rotating: + integral *= src_gfn_is_even_across_xz_plane ? 2.0 : 0.0; + integral *= src_gfn_is_even_across_yz_plane ? 2.0 : 0.0; + break; + case patch_system__plus_xz_quadrant_mirrored: + case patch_system__plus_xz_quadrant_rotating: + integral *= src_gfn_is_even_across_xy_plane ? 2.0 : 0.0; + integral *= src_gfn_is_even_across_yz_plane ? 2.0 : 0.0; + break; + case patch_system__plus_xyz_octant_mirrored: + case patch_system__plus_xyz_octant_rotating: + integral *= src_gfn_is_even_across_xy_plane ? 2.0 : 0.0; + integral *= src_gfn_is_even_across_xz_plane ? 2.0 : 0.0; + integral *= src_gfn_is_even_across_yz_plane ? 2.0 : 0.0; + break; + default: + error_exit(PANIC_EXIT, + "***** patch_system::integrate_gridfn(): bad patch system type()=(int)%d!\n" + " (this should never happen!)\n", + int(type())); /*NOTREACHED*/ + } + + return integral; + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function finds what patch contains (the ray from the origin to) + // a given local (x,y,z) position. + // + // If there are multiple patches containing the position, we return the + // one which would still contain it if patches didn't overlap; if multiple + // patches satisfy this criterion then it's arbitrary which one we return. + // + // If no patch contains the position (this can only if the point as at + // the local coordinate origin, or for a non--full-sphere patch system), + // then we return a NULL pointer. + // + // Arguments: + // (x,y,z) = The local coordinates to be converted. + // + // Results: + // This function returns a reference to the containing patch. + // + const patch *patch_system::patch_containing_local_xyz(fp x, fp y, fp z) + const + { + if ((x == 0.0) && (y == 0.0) && (z == 0.0)) + then return NULL; + + // to which axis is (x,y,z) closest? + // ... or equivalently, which of |x|, |y|, and |z| is largest? + const fp abs_x = jtutil::abs(x); + const fp abs_y = jtutil::abs(y); + const fp abs_z = jtutil::abs(z); + + if ((abs_z >= abs_x) && (abs_z >= abs_y)) + then return &plus_or_minus_xyz_patch(z > 0.0, 'z'); // +/- z patch + else if ((abs_x >= abs_y) && (abs_x >= abs_z)) + then return &plus_or_minus_xyz_patch(x > 0.0, 'x'); // +/- x patch + else if ((abs_y >= abs_x) && (abs_y >= abs_z)) + then return &plus_or_minus_xyz_patch(y > 0.0, 'y'); // +/- y patch + else + error_exit(ERROR_EXIT, + "***** patch_system::patch_containing_local_xyz():\n" + " unknown (wierd!) ordering of |x|, |y|, and |z|!\n" + " (this should never happen!)\n" + " [local] (x,y,z)=(%g,%g,%g)\n", + double(x), double(y), double(z)); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function computes the radius of a patch-system 2-surface in the + // direction of a specified local (x,y,z) point, taking into account any + // patch-system symmetries. If the point coincides with the local origin, + // we return the dummy value 1.0. + // + // Bugs: + // Due to the surface-interpolator overhead, repeatedly calling this + // function is rather inefficient. + // + fp patch_system::radius_in_local_xyz_direction(int ghosted_radius_gfn, + fp x, fp y, fp z) + const + { + if ((x == 0.0) && (y == 0.0) && (z == 0.0)) + then return 1.0; + + // + // apply symmetries to map (x,y,z) into that part of the 2-sphere + // which is covered by the patch system + // + switch (type()) + { + case patch_system__full_sphere: + break; + case patch_system__plus_z_hemisphere: + z = fabs(z); + break; + case patch_system__plus_xy_quadrant_mirrored: + case patch_system__plus_xy_quadrant_rotating: + x = fabs(x); + y = fabs(y); + break; + case patch_system__plus_xz_quadrant_mirrored: + case patch_system__plus_xz_quadrant_rotating: + x = fabs(x); + z = fabs(z); + break; + case patch_system__plus_xyz_octant_mirrored: + case patch_system__plus_xyz_octant_rotating: + x = fabs(x); + y = fabs(y); + z = fabs(z); + break; + default: + error_exit(PANIC_EXIT, + "***** patch_system::radius_in_local_xyz_direction():\n" + " unknown patch system type()=(int)%d!\n" + " (this should never happen!)\n", + int(type())); /*NOTREACHED*/ + } + + const patch *p_ptr = patch_containing_local_xyz(x, y, z); + if (p_ptr == NULL) + then error_exit(ERROR_EXIT, + "***** patch_system::radius_in_local_xyz_direction():\n" + " can't find containing patch!\n" + " (this should never happen!)\n" + " [local] (x,y,z)=(%g,%g,%g)\n", + double(x), double(y), double(z)); /*NOTREACHED*/ + + const patch &p = *p_ptr; + const fp rho = p.rho_of_xyz(x, y, z); + const fp sigma = p.sigma_of_xyz(x, y, z); + + // + // Set up the surface interpolator to interpolate the surface radius + // gridfn to the (rho,sigma) coordinates: + // + // Notes on the interpolator setup: + // * The interpolator assumes Fortran subscripting, so we take the + // coordinates in the order (sigma,rho) to match our C subscripting + // in the patch system. + // * To avoid having to set up min/max array subscripts in the parameter + // table, we treat the patch as using 0-origin (integer) array subscripts + // (irho - ghosted_min_irho(), isigma - ghosted_min_isigma()). However, + // we use the usual floating-point coordinates. + // + + const int N_dims = 2; + const CCTK_REAL coord_origin[N_dims] = {p.ghosted_min_sigma(), p.ghosted_min_rho()}; + const CCTK_REAL coord_delta[N_dims] = {p.delta_sigma(), p.delta_rho()}; + + const int N_interp_points = 1; + const int interp_coords_type_code = CCTK_VARIABLE_REAL; + const void *const interp_coords[N_dims] = {static_cast(&sigma), static_cast(&rho)}; + + const int N_input_arrays = 1; + const CCTK_INT input_array_dims[N_dims] = {p.ghosted_N_isigma(), p.ghosted_N_irho()}; + const CCTK_INT input_array_type_codes[N_input_arrays] = {CCTK_VARIABLE_REAL}; + const void *const input_arrays[N_input_arrays] = { + static_cast( + p.ghosted_gridfn_data_array(ghosted_radius_gfn))}; + + const int N_output_arrays = 1; + const CCTK_INT output_array_type_codes[N_output_arrays] = {CCTK_VARIABLE_REAL}; + fp xyz_radius; + void *const output_arrays[N_output_arrays] = {static_cast(&xyz_radius)}; + + return xyz_radius; + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function prints an unknown-grid gridfn in ASCII format to a + // named output file. The output format is suitable for a gnuplot + // 'splot' command. (Individual patches may be selected with the + // select.patch program (perl script).) The output format is either + // # print_xyz_flag == false + // dpx dpy gridfn + // or + // # print_xyz_flag == true + // dpx dpy gridfn global_x global_y global_z + // where global_[xyz} are derived from the angular position and a + // specified (unknown-grid) radius gridfn. + // + void patch_system::print_unknown_gridfn(bool ghosted_flag, int unknown_gfn, + bool print_xyz_flag, bool radius_is_ghosted_flag, + int unknown_radius_gfn, + const char output_file_name[], bool want_ghost_zones) + const + { + if (want_ghost_zones && !ghosted_flag) + then error_exit(PANIC_EXIT, + "***** patch_system::print_unknown_gridfn(unknown_gfn=%d):\n" + " can't have want_ghost_zones && !ghosted_flag !\n", + unknown_gfn); /*NOTREACHED*/ + if (want_ghost_zones && print_xyz_flag && !radius_is_ghosted_flag) + then error_exit(PANIC_EXIT, + "***** patch_system::print_unknown_gridfn(unknown_gfn=%d):\n" + " can't have want_ghost_zones && print_xyz_flag\n" + " && !radius_is_ghosted_flag!\n" + " unknown_radius_gfn=%d\n", + unknown_gfn, + unknown_radius_gfn); /*NOTREACHED*/ + + FILE *output_fp = fopen(output_file_name, "w"); + if (output_fp == NULL) + then error_exit(ERROR_EXIT, + "***** patch_system::print_unknown_gridfn(unknown_gfn=%d):\n" + " can't open output file \"%s\"\n!", + unknown_gfn, + output_file_name); /*NOTREACHED*/ + + fprintf(output_fp, "# N_patches = %d\n", N_patches()); + fprintf(output_fp, "# origin = %.15g %.15g %.15g\n", + double(origin_x()), double(origin_y()), double(origin_z())); + fprintf(output_fp, "\n"); + + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + + fprintf(output_fp, "### %s patch\n", p.name()); + fprintf(output_fp, "# N_rho = %d\n", + p.effective_N_irho(want_ghost_zones)); + fprintf(output_fp, "# N_sigma = %d\n", + p.effective_N_isigma(want_ghost_zones)); + fprintf(output_fp, "# %s_gfn=%d\n", + (ghosted_flag ? "ghosted" : "nominal"), unknown_gfn); + fprintf(output_fp, "# dpx = %s\n", p.name_of_dpx()); + fprintf(output_fp, "# dpy = %s\n", p.name_of_dpy()); + fprintf(output_fp, "#\n"); + fprintf(output_fp, + print_xyz_flag + ? "# dpx\tdpy\tgridfn\tglobal_x\tglobal_y\tglobal_z\n" + : "# dpx\tdpy\tgridfn\n"); + + for (int irho = p.effective_min_irho(want_ghost_zones); + irho <= p.effective_max_irho(want_ghost_zones); + ++irho) + { + for (int isigma = p.effective_min_isigma(want_ghost_zones); + isigma <= p.effective_max_isigma(want_ghost_zones); + ++isigma) + { + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + const fp dpx = p.dpx_of_rho_sigma(rho, sigma); + const fp dpy = p.dpy_of_rho_sigma(rho, sigma); + fprintf(output_fp, + "%g\t%g\t%#.15g", + dpx, dpy, p.unknown_gridfn(ghosted_flag, unknown_gfn, irho, isigma)); + if (print_xyz_flag) + then + { + const fp r = p.unknown_gridfn(radius_is_ghosted_flag, + unknown_radius_gfn, + irho, isigma); + fp local_x, local_y, local_z; + p.xyz_of_r_rho_sigma(r, rho, sigma, + local_x, local_y, local_z); + const fp global_x = origin_x() + local_x; + const fp global_y = origin_y() + local_y; + const fp global_z = origin_z() + local_z; + fprintf(output_fp, + "\t%#.10g\t%#.10g\t%#.10g", + global_x, global_y, global_z); + } + fprintf(output_fp, "\n"); + } + fprintf(output_fp, "\n"); + } + fprintf(output_fp, "\n"); + } + + fclose(output_fp); + } + + //****************************************************************************** + + // + // This function reads an unknown-grid gridfn in ASCII format from + // a named input file. Comments ('#' in column 1) and blank lines + // are ignored, otherwise the input format matches that written by + // print_unknown_gridfn(): the first 3 numbers on each line are taken + // to be dpx, dpy, and the gridfn value; anything else on the line is + // ignored. + // + void patch_system::read_unknown_gridfn(bool ghosted_flag, int unknown_gfn, + const char input_file_name[], + bool want_ghost_zones) + { + if (want_ghost_zones && !ghosted_flag) + then error_exit(PANIC_EXIT, + "***** patch_system::read_unknown_gridfn(unknown_gfn=%d):\n" + " can't have want_ghost_zones && !ghosted_flag !\n", + unknown_gfn); /*NOTREACHED*/ + + FILE *input_fp = fopen(input_file_name, "r"); + if (input_fp == NULL) + then error_exit(ERROR_EXIT, + "***** patch_system::read_unknown_gridfn(unknown_gfn=%d):\n" + " can't open input file \"%s\"\n!", + unknown_gfn, + input_file_name); /*NOTREACHED*/ + + int line_number = 1; + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + + for (int irho = p.effective_min_irho(want_ghost_zones); + irho <= p.effective_max_irho(want_ghost_zones); + ++irho) + { + for (int isigma = p.effective_min_isigma(want_ghost_zones); + isigma <= p.effective_max_isigma(want_ghost_zones); + ++isigma) + { + const fp rho = p.rho_of_irho(irho); + const fp sigma = p.sigma_of_isigma(isigma); + const fp dpx = p.dpx_of_rho_sigma(rho, sigma); + const fp dpy = p.dpy_of_rho_sigma(rho, sigma); + + const int buffer_size = 250; + char buffer[buffer_size]; + // read/discard comments and blank lines + do + { + if (fgets(buffer, buffer_size, input_fp) == NULL) + then error_exit(ERROR_EXIT, + "***** patch::read_unknown_gridfn(%s patch, unknown_gfn=%d):\n" + " I/O error or unexpected end-of-file on input!\n" + " at irho=%d of [%d,%d], isigma=%d of [%d,%d]\n" + " dpx=%g dpy=%g\n", + p.name(), unknown_gfn, + irho, p.effective_min_irho(want_ghost_zones), + p.effective_max_irho(want_ghost_zones), + isigma, + p.effective_min_isigma(want_ghost_zones), + p.effective_max_isigma(want_ghost_zones), + dpx, dpy); /*NOTREACHED*/ + ++line_number; + } while ((buffer[0] == '#') || (buffer[0] == '\n')); + + double read_dpx, read_dpy, read_gridfn_value; + if (sscanf(buffer, "%lf %lf %lf", + &read_dpx, &read_dpy, &read_gridfn_value) != 3) + then error_exit(ERROR_EXIT, + "***** patch::read_unknown_gridfn(%s patch, unknown_gfn=%d):\n" + " bad input data at input line %d!\n", + p.name(), unknown_gfn, + line_number); /*NOTREACHED*/ + if (!(jtutil::fuzzy::EQ(read_dpx, dpx) && jtutil::fuzzy::EQ(read_dpy, dpy))) + then error_exit(ERROR_EXIT, + "***** patch::read_unknown_gridfn(%s patch, unknown_gfn=%d):\n" + " wrong (dpx,dpy) at input line %d!\n" + " expected (%g,%g)\n" + " read (%g,%g)\n", + p.name(), unknown_gfn, + line_number, + dpx, dpy, + read_dpx, read_dpy); /*NOTREACHED*/ + + p.unknown_gridfn(ghosted_flag, + unknown_gfn, irho, isigma) = read_gridfn_value; + } + } + } + + fclose(input_fp); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + + // + // This function "synchronizes" all ghost zones of all patches, i.e. it + // update the ghost-zone values of the specified gridfns via the appropriate + // sequence of symmetry operations and interpatch interpolations. This + // process is described in detail in the header comments in "ghost_zone.hh". + // + void patch_system::synchronize(int ghosted_min_gfn_to_sync, + int ghosted_max_gfn_to_sync) + { + // + // Phase 1: + // Fill in gridfn data at all the non-corner points of symmetry ghost + // zones, using the symmetries to get this data from its "home patch" + // nominal grids. + // + { + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + // n.b. these loops must use _int_ variables for the loop + // to terminate! + for (int want_min = false; want_min <= true; ++want_min) + { + for (int want_rho = false; want_rho <= true; ++want_rho) + { + ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); + if (gz.is_symmetry()) + then gz.synchronize(ghosted_min_gfn_to_sync, + ghosted_max_gfn_to_sync, + false, // want corners? + true); // want non-corner? + } + } + } + } + + // + // Phase 2: + // Fill in gridfn data in all the interpatch ghost zones, using interpatch + // interpolation from neighboring patches as described above. + // + { + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + // n.b. these loops must use _int_ variables for the loop + // to terminate! + for (int want_min = false; want_min <= true; ++want_min) + { + for (int want_rho = false; want_rho <= true; ++want_rho) + { + ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); + if (gz.is_interpatch()) + then gz.synchronize(ghosted_min_gfn_to_sync, + ghosted_max_gfn_to_sync); + } + } + } + } + + // + // Phase 3: + // Fill in gridfn data at all the corner points of symmetry ghost zones, + // using the symmetries to get this data from its "home patch" nominal + // grids or ghost zones. + // + { + for (int pn = 0; pn < N_patches(); ++pn) + { + patch &p = ith_patch(pn); + // n.b. these loops must use _int_ variables for the loop + // to terminate! + for (int want_min = false; want_min <= true; ++want_min) + { + for (int want_rho = false; want_rho <= true; ++want_rho) + { + ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); + if (gz.is_symmetry()) + then gz.synchronize(ghosted_min_gfn_to_sync, + ghosted_max_gfn_to_sync, + true, // want corners? + false); // want non-corner? + } + } + } + } + } + + //****************************************************************************** + + // + // This function does any precomputation necessary to compute the Jacobian + // of synchronize() , taking into account synchronize()'s full 3-phase + // algorithm. In practice, this means it computes the individual Jacobian + // of each ghost zone, and sets global_{min,max}_ym_ . + // + void patch_system::compute_synchronize_Jacobian(int ghosted_min_gfn_to_sync, + int ghosted_max_gfn_to_sync) + const + { + global_min_ym_ = +INT_MAX; + global_max_ym_ = -INT_MAX; + for (int pn = 0; pn < N_patches(); ++pn) + { + const patch &p = ith_patch(pn); + // n.b. these loops must use _int_ variables for the loop + // to terminate! + for (int want_min = false; want_min <= true; ++want_min) + { + for (int want_rho = false; want_rho <= true; ++want_rho) + { + ghost_zone &gz = p.minmax_ang_ghost_zone(want_min, want_rho); + // is dummy//gz.compute_Jacobian(ghosted_min_gfn_to_sync, ghosted_max_gfn_to_sync); + + global_min_ym_ = min(global_min_ym_, + gz.Jacobian_min_y_ipar_m()); + global_max_ym_ = max(global_max_ym_, + gz.Jacobian_max_y_ipar_m()); + } + } + } + } + + //****************************************************************************** + + // + // Given that compute_synchronize_Jacobian() has been called, this + // function computes the global min/max m over all ghost zone points. + // This is useful for sizing the buffer for synchronize_Jacobian(). + // + void patch_system::synchronize_Jacobian_global_minmax_ym(int &min_ym, int &max_ym) + const + { + min_ym = global_min_ym_; + max_ym = global_max_ym_; + } + + //****************************************************************************** + + // + // Given that compute_synchronize_Jacobian() has been called, this + // function computes a single row of the Jacobian, taking into account + // synchronize()'s 3-phase algorithm: + // - It returns the edge to which the y point belongs (the caller can get + // the patch from this edge). + // - It stores y_iperp and y_posn and min/max ym in the named arguments. + // - It stores the Jacobian elements + // partial synchronize() gridfn(ghosted_gfn, px, x_iperp, x_ipar) + // ------------------------------------------------------------- + // partial gridfn(ghosted_gfn, py, y_iperp, y_posn+ym) + // in the caller-supplied buffer + // Jacobian_buffer(ym) + // for each ym in the min/max ym range. + // + // In practice, the main task of this function is taking into account + // synchronize()'s 3-phase algorithm. There are several cases: + // - ghost zone is symmetry && x point is in non-corner + // ==> x value was computed by a phase 1 symmetry operation, + // using (only) nominal-grid data + // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) + // - ghost zone is symmetry && x point is in corner + // --> x value was computed by a phase 3 symmetry operation, + // from some point (call it z), + // ==> overall Jacobian(x,y) = overall Jacobian(z,y) + // ==> call this function recursively to get z's Jacobian + // (z must be in the noncorner part of some ghost zone, + // so this won't lead to infinite recursion) + // - ghost zone is interpatch + // ==> x value was computed by a phase 2 interpatch interpolation + // - using (only) nominal-grid data + // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) + // - using a mixture of nominal-grid data + // and data computed by a phase 1 symmetry operation + // ==> overall Jacobian(x,y) = "fold" ghost zone Jacobian(x,y) + // to take the phase 1 symmetry + // operation into account + // + const patch_edge & + patch_system::synchronize_Jacobian(const ghost_zone &xgz, + int x_iperp, int x_ipar, + int &y_iperp, + int &y_posn, int &min_ym, int &max_ym, + jtutil::array1d &Jacobian_buffer) + const + { + const patch_edge &xe = xgz.my_edge(); + + if (xgz.is_symmetry() && xe.ipar_is_in_noncorner(x_ipar)) + then + { + // ghost zone is symmetry && x point is in non-corner + // ==> x value was computed by a phase 1 symmetry operation, + // using (only) nominal-grid data + // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) + return ghost_zone_Jacobian(xgz, + x_iperp, x_ipar, + y_iperp, + y_posn, min_ym, max_ym, + Jacobian_buffer); + } + + else if (xgz.is_symmetry() && xe.ipar_is_in_corner(x_ipar)) + then + { + // ghost zone is symmetry && x point is in corner + // --> x value was computed by a phase 3 symmetry operation, + // from some point (call it z), + // ==> overall Jacobian(x,y) = overall Jacobian(z,y) + // ==> call this function recursively to get z's Jacobian + // (z must be in the noncorner part of some ghost zone, + // so this won't lead to infinite recursion) + + const patch &zp = xgz.other_patch(); + const patch_edge &ze = xgz.other_edge(); + const symmetry_ghost_zone &xsgz = xgz.cast_to_symmetry_ghost_zone(); + const int z_iperp = xsgz.iperp_map_of_iperp(x_iperp); + const int z_ipar = xsgz.ipar_map_of_ipar(x_ipar); + + // + // Computing z's edge/ghost zone is tricky. For example: + // | + // p1 e3|e4 p2 + // | + // | z + // -----------e1-----------+------------e2--------- + // | x + // | + // Here the point x in the corner of p1's e1 ghost zone, + // is computed by the phase 3 symmetry operation (a reflection + // about e1) from z. Thus zp == p1 and ze == e1. + // + // But we need to "turn the corner" to compute z's "true" edge + // e3 (so we can recursively call this function to compute z's + // Jacobian). Thus we explicitly check which ghost zone of p1 + // (here the e3 ghost zone) contains the point z. + // + const int z_irho = ze.irho_of_iperp_ipar(z_iperp, z_ipar); + const int z_isigma = ze.isigma_of_iperp_ipar(z_iperp, z_ipar); + const ghost_zone &true_zgz = zp.ghost_zone_containing_noncorner_point(z_irho, z_isigma); + const patch_edge &true_ze = true_zgz.my_edge(); + const int true_z_iperp = true_ze.iperp_of_irho_isigma(z_irho, z_isigma); + const int true_z_ipar = true_ze.ipar_of_irho_isigma(z_irho, z_isigma); + + // make sure we have the right ghost zone! + assert(true_zgz.is_in_ghost_zone(true_z_iperp, true_z_ipar)); + + return synchronize_Jacobian(true_zgz, + true_z_iperp, true_z_ipar, + y_iperp, + y_posn, min_ym, max_ym, + Jacobian_buffer); + } + + else if (xgz.is_interpatch()) + then + { + // ghost zone is interpatch + // ==> x value was computed by a phase 2 interpatch interpolation + // - using (only) nominal-grid data + // ==> overall Jacobian(x,y) = ghost zone Jacobian(x,y) + // - using a mixture of nominal-grid data + // and data computed by a phase 1 symmetry operation + // ==> overall Jacobian(x,y) = "fold" ghost zone Jacobian(x,y) + // to take the phase 1 symmetry + // operation into account + // + // For example, + // | + // xp xe|ye a yp + // | b + // | xc + // ----------xse-----------+---d-------yse---------- + // | e + // | + // here point x is computed by interpatch-interpolating in the + // par direction from the 5 y points abcde. e is outside the + // nominal grid, so its Jacobian must be "folded" over to c. + // Notice that this "folding" must be done about the edge yse, + // *not* about ye itself. + + // Jacobian of the phase 2 interpatch interpolation + const patch_edge &ye = ghost_zone_Jacobian(xgz, + x_iperp, x_ipar, + y_iperp, + y_posn, min_ym, max_ym, + Jacobian_buffer); + const int min_y_ipar = y_posn + min_ym; + const int max_y_ipar = y_posn + max_ym; + + // fold any points in the Jacobian outside the nominal grid + if (ye.ipar_is_in_min_ipar_corner(min_y_ipar)) + then + { + fold_Jacobian(ye, ye.min_par_adjacent_edge(), + y_iperp, + y_posn, min_ym, max_ym, + min_ym, ye.min_ipar_corner__max_ipar() - y_posn, + Jacobian_buffer); + min_ym = ye.min_ipar_without_corners() - y_posn; + } + if (ye.ipar_is_in_max_ipar_corner(max_y_ipar)) + then + { + fold_Jacobian(ye, ye.max_par_adjacent_edge(), + y_iperp, + y_posn, min_ym, max_ym, + ye.max_ipar_corner__min_ipar() - y_posn, max_ym, + Jacobian_buffer); + max_ym = ye.max_ipar_without_corners() - y_posn; + } + + return ye; + } + + else + error_exit(PANIC_EXIT, + "***** patch_system::synchronize_Jacobian():\n" + " don't know what to do with ghost zone (this should never happen)!\n" + " xgz.my_patch()=\"%s\" xe=xgz.my_edge()=\"%s\"\n" + " xgz.other_patch()=\"%s\" xgz.other_edge()=\"%s\"\n" + " xgz.is_symmetry()=(int)%d xgz.is_interpatch()=(int)%d\n" + " x_iperp=%d x_ipar=%d\n" + " xe.ipar_is_in_{min,max}_ipar_corner(x_ipar)=(int){%d,%d}\n" + " xe.ipar_is_in_{corner,noncorner}(x_ipar)=(int){%d,%d}\n", + xgz.my_patch().name(), xe.name(), + xgz.other_patch().name(), xgz.other_edge().name(), + int(xgz.is_symmetry()), int(xgz.is_interpatch()), + x_iperp, x_ipar, + xe.ipar_is_in_min_ipar_corner(x_ipar), + xe.ipar_is_in_max_ipar_corner(x_ipar), + xe.ipar_is_in_corner(x_ipar), + xe.ipar_is_in_noncorner(x_ipar)); /*NOTREACHED*/ + } + + //****************************************************************************** + + // + // This function "folds" part of a(n interpatch) Jacobian row to take + // a symmetry operation into account. For example: + // | + // |e_Jac + // | p + // | a + // | b + // | c=y + // ---------+---d-------e_fold------- + // | e=x sgz_fold + // | + // Here the Jacobian abcde is to be "folded", because e is outside the + // nominal grid (its Jacobian must be "folded" over to c). + // + // Notice that the folding (about the edge e_fold) is in the par direction + // with respect to e_Jac, but the perp direction with respect to e_fold. + // Since e_fold and e_Jac are adjacent edges, + // e_Jac (iperp,ipar) == e_fold (ipar,iperp) + // + // Arguments: + // e_Jac = edge which the Jacobian lies along + // e_fold = edge about which to fold; the corresponding ghost zone must be + // symmetry ghost zone, and at present we only support the case + // where this is a "local" (mirror-image) symmetry ghost zone + // iperp = iperp-wrt-e_Jac coordinate of Jacobian + // posn = ipar-wrt-e_Jac coordinate of Jacobian molecule reference point + // [min,max]_m = range of ipar-wrt-e_Jac molecule m in Jacobian + // [min,max]_fold_m = range of ipar-wrt-e_Jac molecule m which is to folded; + // this must be a subrange of [min,max]_m + // + void patch_system::fold_Jacobian(const patch_edge &e_Jac, + const patch_edge &e_fold, + int iperp, + int posn, int min_m, int max_m, + int min_fold_m, int max_fold_m, + jtutil::array1d &Jacobian_buffer) + const + { + // check that [min,max]_fold_m is a subrange of [min,max]_m + assert(min_fold_m >= min_m); + assert(min_fold_m <= max_m); + assert(max_fold_m >= min_m); + assert(max_fold_m <= max_m); + + const patch &p = e_fold.my_patch(); + assert(e_Jac.my_patch() == p); + + const symmetry_ghost_zone &sgz_fold = p.ghost_zone_on_edge(e_fold) + .cast_to_symmetry_ghost_zone(); + + // + // At present we only handle the case show in the comments above, + // where sgz_fold is a local (mirror-image) symmetry, i.e. where + // y is guaranteed to be within the molecule abcde. + // + if (sgz_fold.other_edge() != e_fold) + then error_exit(ERROR_EXIT, + "***** patch_system::fold_Jacobian()\n" + " implementation restriction: at present we only handle folding\n" + " via \"local\" (mirror-image) symmetries!\n" + " p=\"%s\" e_Jac=\"%s\" e_fold=\"%s\"\n" + " but sgz_fold.other_edge()=\"%s\" != e_fold\n", + p.name(), e_Jac.name(), e_fold.name(), + sgz_fold.other_edge().name()); /*NOTREACHED*/ + + for (int xm = min_fold_m; xm <= max_fold_m; ++xm) + { + const int x_Jac_ipar = posn + xm; // x ipar wrt e_Jac + const int x_fold_iperp = x_Jac_ipar; // ... == iperp wrt e_fold + + const int y_fold_iperp = sgz_fold.iperp_map_of_iperp(x_fold_iperp); + // y iperp wrt e_fold + const int y_Jac_ipar = y_fold_iperp; // ... == ipar wrt e_Jac + const int ym = y_Jac_ipar - posn; + + // check that y is indeed within the molecule + assert(ym >= min_m); + assert(ym <= max_m); + + // actually "fold" the molecule + Jacobian_buffer(ym) += Jacobian_buffer(xm); + } + } + + //****************************************************************************** + + // + // Given that compute_synchronize_Jacobian() has been called, this + // function computes a single row of the Jacobian of a given ghost zone, + // *not* taking into account synchronize()'s 3-phase algorithm: + // - It returns the edge to which the y point belongs (the caller can get + // the patch from this edge). + // - It stores y_iperp and y_posn and min/max ym in the named arguments. + // - It stores the Jacobian elements + // partial synchronize() gridfn(ghosted_gfn, px, x_iperp, x_ipar) + // ------------------------------------------------------------- + // partial gridfn(ghosted_gfn, py, y_iperp, y_posn+ym) + // in the caller-supplied buffer + // Jacobian_buffer(ym) + // for each ym in the min/max ym range + // + const patch_edge & + patch_system::ghost_zone_Jacobian(const ghost_zone &xgz, + int x_iperp, int x_ipar, + int &y_iperp, + int &y_posn, int &min_ym, int &max_ym, + jtutil::array1d &Jacobian_buffer) + const + { + y_iperp = xgz.Jacobian_y_iperp(x_iperp); + + y_posn = xgz.Jacobian_y_ipar_posn(x_iperp, x_ipar); + min_ym = xgz.Jacobian_min_y_ipar_m(); + max_ym = xgz.Jacobian_max_y_ipar_m(); + + for (int ym = min_ym; ym <= max_ym; ++ym) + { + Jacobian_buffer(ym) = xgz.Jacobian(x_iperp, x_ipar, ym); + } + + return xgz.other_edge(); + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/patch_system.h b/AMSS_NCKU_source/AHF_Direct/patch_system.h similarity index 97% rename from AMSS_NCKU_source/patch_system.h rename to AMSS_NCKU_source/AHF_Direct/patch_system.h index 0d91c1c..8bff634 100644 --- a/AMSS_NCKU_source/patch_system.h +++ b/AMSS_NCKU_source/AHF_Direct/patch_system.h @@ -1,595 +1,595 @@ -#ifndef TPATCH_SYSTEM_H -#define TPATCH_SYSTEM_H -namespace AHFinderDirect -{ - - //****************************************************************************** - - // - // A patch_system object describes a system of interlinked patches. - // - // Its const qualifiers refer (only) to the gridfn data. Notably, this - // means that synchronize() is a non-const function (it modifies gridfn - // data), while synchronize_Jacobian() et al are const functions (they - // don't modify gridfn data) even though they may update other internal - // state in the patch_system object and its subobjects. - // - - class patch_system - { - // - // ***** static data & functions describing patch systems ***** - // - public: - // what patch-system type are supported? - // (see "patch_system_info.hh" for detailed descriptions of these) - enum patch_system_type - { - patch_system__full_sphere, - patch_system__plus_z_hemisphere, - patch_system__plus_xy_quadrant_mirrored, - patch_system__plus_xy_quadrant_rotating, - patch_system__plus_xz_quadrant_mirrored, - patch_system__plus_xz_quadrant_rotating, - patch_system__plus_xyz_octant_mirrored, - patch_system__plus_xyz_octant_rotating - }; - - // maximum number of patches in any patch-system type - static const int max_N_patches = 6; - - // decode patch system type into N_patches - static int N_patches_of_type(enum patch_system_type type_in); - - // patch system type <--> human-readable character-string name - static const char *name_of_type(enum patch_system_type type_in); - static enum patch_system_type type_of_name(const char *name_in); - - // - // ***** coordinates ***** - // - public: -#ifdef NOT_USED - // global (x,y,z) --> local (x,y,z) - fp local_x_of_global_x(fp global_x) const - { - return global_coords_.local_x_of_global_x(global_x); - } - fp local_y_of_global_y(fp global_y) const - { - return global_coords_.local_y_of_global_y(global_y); - } - fp local_z_of_global_z(fp global_z) const - { - return global_coords_.local_z_of_global_z(global_z); - } -#endif /* NOT_USED */ - -#ifdef NOT_USED - // local (x,y,z) --> global (x,y,z) - fp global_x_of_local_x(fp local_x) const - { - return global_coords_.global_x_of_local_x(local_x); - } - fp global_y_of_local_y(fp local_y) const - { - return global_coords_.global_y_of_local_y(local_y); - } - fp global_z_of_local_z(fp local_z) const - { - return global_coords_.global_z_of_local_z(local_z); - } -#endif /* NOT_USED */ - - // get global (x,y,z) coordinates of local origin point - fp origin_x() const { return global_coords_.origin_x(); } - fp origin_y() const { return global_coords_.origin_y(); } - fp origin_z() const { return global_coords_.origin_z(); } - - // - // ***** meta-info about the entire patch system ***** - // - public: - // patch-system type - enum patch_system_type type() const { return type_; } - - // total number of patches - int N_patches() const { return N_patches_; } - - // get patches by patch number - const patch &ith_patch(int pn) const - { - return *all_patches_[pn]; - } - patch &ith_patch(int pn) - { - return *all_patches_[pn]; - } - - // find a patch by +/- xyz "ctype" - // FIXME: the present implementation of this function is quite slow - const patch &plus_or_minus_xyz_patch(bool is_plus, char ctype) - const; - - // find a patch by name, return patch number; error_exit() if not found - int patch_number_of_name(const char *name) const; - - // total number of grid points - int N_grid_points() const { return N_grid_points_; } - int ghosted_N_grid_points() const { return ghosted_N_grid_points_; } - - // - // ***** meta-info about gridfns ***** - // - public: - int min_gfn() const { return ith_patch(0).min_gfn(); } - int max_gfn() const { return ith_patch(0).max_gfn(); } - int N_gridfns() const { return ith_patch(0).N_gridfns(); } - bool is_valid_gfn(int gfn) const - { - return ith_patch(0).is_valid_gfn(gfn); - } - int ghosted_min_gfn() const { return ith_patch(0).ghosted_min_gfn(); } - int ghosted_max_gfn() const { return ith_patch(0).ghosted_max_gfn(); } - int ghosted_N_gridfns() const - { - return ith_patch(0).ghosted_N_gridfns(); - } - bool is_valid_ghosted_gfn(int ghosted_gfn) const - { - return ith_patch(0).is_valid_ghosted_gfn(ghosted_gfn); - } - - // - // ***** synchronize() and its Jacobian ***** - // - public: - // "synchronize" all ghost zones of all patches, - // i.e. update the ghost-zone values of the specified gridfns - // via the appropriate sequence of symmetry operations - // and interpatch interpolations - void synchronize(int ghosted_min_gfn_to_sync, - int ghosted_max_gfn_to_sync); - - // ... do this for all ghosted gridfns - void synchronize() - { - synchronize(ghosted_min_gfn(), - ghosted_max_gfn()); - } - - // - // do any precomputation necessary to compute Jacobian of - // synchronize() , taking into account synchronize()'s - // full 3-phase algorithm - // - void compute_synchronize_Jacobian(int ghosted_min_gfn_to_sync, - int ghosted_max_gfn_to_sync) - const; - - // ... do this for all ghosted gridfns - void compute_synchronize_Jacobian() - const - { - compute_synchronize_Jacobian(ghosted_min_gfn(), - ghosted_max_gfn()); - } - - // - // The following functions access the Jacobian computed by - // compute_synchronize_Jacobian() . Note this API is rather - // different than that of ghost_zone::comute_Jacobian() et al: - // here we must take into account synchronize()'s full 3-phase - // algorithm, and this may lead to a more general Jacobian - // structure. - // - // This API still implicitly assumes that the Jacobian is - // independent of ghosted_gfn , and that the set of y points - // (with nonzero Jacobian values) in a single row of the Jacobian - // matrix (i.e. the set of points on which a single ghost-zone - // point depends), - // - lies entirely within a single y patch - // - has a single yiperp value - // - have a contiguous interval of yipar; we parameterize this - // interval as yipar = posn+m - // - - // what are the global min/max m over all ghost zone points? - // (this is useful for sizing the buffer for synchronize_Jacobian()) - void synchronize_Jacobian_global_minmax_ym(int &min_ym, int &max_ym) - const; - - // compute a single row of the Jacobian: - // - return value is edge to which y point belongs - // (caller can get patch from this edge) - // - store y_iperp and y_posn and min/max ym in named arguments - // - stores the Jacobian elements - // partial synchronize() gridfn(ghosted_gfn, px, x_iperp, x_ipar) - // ------------------------------------------------------------- - // partial gridfn(ghosted_gfn, py, y_iperp, y_posn+ym) - // (taking into account synchronize()'s full 3-phase algorithm) - // in the caller-supplied buffer - // Jacobian_buffer(ym) - // for each ym in the min/max ym range - const patch_edge & - synchronize_Jacobian(const ghost_zone &xgz, - int x_iperp, int x_ipar, - int &y_iperp, - int &y_posn, int &min_ym, int &max_ym, - jtutil::array1d &Jacobian_buffer) - const; - - // helper functions for synchronize_Jacobian(): - private: - // "fold" (part of) a Jacobian row - // to take a symmetry operation into acount - // e_Jac = edge which the Jacobian lies along - // e_fold = edge about which to fold - // [min,max]_m = range of m in the Jacobian - // [min,max]_fold_m = range of m to fold - // (must be a subrange of {min,max}_m) - void fold_Jacobian(const patch_edge &e_Jac, const patch_edge &e_fold, - int iperp, - int posn, int min_m, int max_m, - int min_fold_m, int max_fold_m, - jtutil::array1d &Jacobian_buffer) - const; - - // compute the Jacobian of ghost zone's synchronize() - // *without* taking into account 3-phase algorithm - const patch_edge & - ghost_zone_Jacobian(const ghost_zone &xgz, - int x_iperp, int x_ipar, - int &y_iperp, - int &y_posn, int &min_ym, int &max_ym, - jtutil::array1d &Jacobian_buffer) - const; - - // - // ***** gridfn operations ***** - // - public: - // dst = a - void set_gridfn_to_constant(fp a, int dst_gfn); - - // dst = src - void gridfn_copy(int src_gfn, int dst_gfn); - - // dst += delta - void add_to_ghosted_gridfn(fp delta, int ghosted_dst_gfn); - - void recentering(fp x, fp y, fp z); - - // compute norms of gridfn (only over nominal grid) - void gridfn_norms(int src_gfn, jtutil::norm &norms) - const; - void ghosted_gridfn_norms(int ghosted_src_gfn, jtutil::norm &norms) - const; - - // - // ***** testing (x,y,z) point position versus a surface ***** - // - - // find patch containing (ray from origin to) given local (x,y,z) - // ... if there are multiple patches containing the position, - // we return the one which would still contain it if patches - // didn't overlap; if multiple patches satisfy this criterion - // then it's arbitrary which one we return - // ... if no patch contains the position (for a non--full-sphere - // patch system), or the position is at the origin, then - // we return a NULL pointer - const patch *patch_containing_local_xyz(fp x, fp y, fp z) - const; - - // radius of surface in direction of an (x,y,z) point, - // taking into account any patch-system symmetries; - // or dummy value 1.0 if point is identical to local origin - // - // FIXME: - // We should provide another API to compute this for a whole - // batch of points at once, since this would be more efficient - // (the interpolator overhead would be amortized over the whole batch) - fp radius_in_local_xyz_direction(int ghosted_radius_gfn, - fp x, fp y, fp z) - const; - - // - // ***** line/surface operations ***** - // - - // compute the circumference of a surface in the {xy, xz, yz} plane - // ... note this is the full circumference all around the sphere, - // even if the patch system only covers a proper subset of this - // ... the implementation assumes adjacent patches are butt-joined - // ... plane must be one of "xy", "xz", or "yz" - fp circumference(const char plane[], - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum patch::integration_method method) - const; - - // compute the surface integral of a gridfn over the 2-sphere - // $\int f(\rho,\sigma) \, dA$ - // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ - // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma) - // ... integration method selected by method argument - // ... src gridfn may be either nominal-grid or ghosted-grid - // ... Boolean flags src_gfn_is_even_across_{xy,xz,yz}_planes - // specify whether the gridfn to be integrated is even (true) - // or odd (false) across the corresponding planes. Only the - // flags corresponding to boundaries of the patch system are - // used. For example, for a plus_z_hemisphere patch system, - // only the src_gfn_is_even_across_xy_plane flag is used. - // ... note integral is over the full 2-sphere, - // even if the patch system only covers a proper subset of this - // ... the implementation assumes adjacent patches are butt-joined - fp integrate_gridfn(int unknown_src_gfn, - bool src_gfn_is_even_across_xy_plane, - bool src_gfn_is_even_across_xz_plane, - bool src_gfn_is_even_across_yz_plane, - int ghosted_radius_gfn, - int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, - int g_yy_gfn, int g_yz_gfn, - int g_zz_gfn, - enum patch::integration_method method) - const; - - // - // ***** I/O ***** - // - public: - // print to a named file (newly (re)created) - // output format is - // dpx dpy gridfn - void print_gridfn(int gfn, const char output_file_name[]) const - { - print_unknown_gridfn(false, gfn, - false, false, 0, - output_file_name, false); - } - void print_ghosted_gridfn(int ghosted_gfn, - const char output_file_name[], - bool want_ghost_zones = true) - const - { - print_unknown_gridfn(true, ghosted_gfn, - false, false, 0, - output_file_name, want_ghost_zones); - } - - // print to a named file (newly (re)created) - // output format is - // dpx dpy gridfn global_x global_y global_z - // where global_[xyz} are derived from the angular position - // and a specified (unknown-grid) radius gridfn - void print_gridfn_with_xyz(int gfn, - bool radius_is_ghosted_flag, int unknown_radius_gfn, - const char output_file_name[]) - const - { - print_unknown_gridfn(false, gfn, - true, radius_is_ghosted_flag, - unknown_radius_gfn, - output_file_name, false); - } - void print_ghosted_gridfn_with_xyz(int ghosted_gfn, - bool radius_is_ghosted_flag, int unknown_radius_gfn, - const char output_file_name[], - bool want_ghost_zones = true) - const - { - print_unknown_gridfn(true, ghosted_gfn, - true, radius_is_ghosted_flag, - unknown_radius_gfn, - output_file_name, want_ghost_zones); - } - - public: - // read from a named file - void read_gridfn(int gfn, const char input_file_name[]) - { - read_unknown_gridfn(false, gfn, input_file_name, false); - } - void read_ghosted_gridfn(int ghosted_gfn, - const char input_file_name[], - bool want_ghost_zones = true) - { - read_unknown_gridfn(true, ghosted_gfn, - input_file_name, want_ghost_zones); - } - - private: - // ... internal worker functions - void print_unknown_gridfn(bool ghosted_flag, int unknown_gfn, - bool print_xyz_flag, bool radius_is_ghosted_flag, - int unknown_radius_gfn, - const char output_file_name[], bool want_ghost_zones) - const; - void read_unknown_gridfn(bool ghosted_flag, int unknown_gfn, - const char input_file_name[], - bool want_ghost_zones); - - // - // ***** access to gridfns as 1-D arrays ***** - // - // ... n.b. this interface implicitly assumes that gridfn data - // arrays are contiguous across patches; this is ensured by - // setup_gridfn_storage() (called by our constructor) - // - public: - // convert (patch,irho,isigma) <--> 1-D 0-origin grid point number (gpn) - int gpn_of_patch_irho_isigma(const patch &p, int irho, int isigma) - const - { -#ifdef DEBUG_AHFD - printf(" <%d> ", isigma); -#endif - return starting_gpn_[p.patch_number()] + p.gpn_of_irho_isigma(irho, isigma); - } - int ghosted_gpn_of_patch_irho_isigma(const patch &p, - int irho, int isigma) - const - { - return ghosted_starting_gpn_[p.patch_number()] + p.ghosted_gpn_of_irho_isigma(irho, isigma); - } - // ... n.b. we return patch as a reference via the function result; - // an alternative would be to have a patch*& argument - const patch & - patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) - const; - const patch & - ghosted_patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) - const; - - // access actual gridfn data arrays - // (low-level, dangerous, use with caution) - const fp *gridfn_data(int gfn) const - { - return ith_patch(0).gridfn_data_array(gfn); - } - fp *gridfn_data(int gfn) - { - return ith_patch(0).gridfn_data_array(gfn); - } - const fp *ghosted_gridfn_data(int ghosted_gfn) const - { - return ith_patch(0).ghosted_gridfn_data_array(ghosted_gfn); - } - fp *ghosted_gridfn_data(int ghosted_gfn) - { - return ith_patch(0).ghosted_gridfn_data_array(ghosted_gfn); - } - - // - // ***** constructor, destructor ***** - // - // This constructor doesn't support the full generality of the - // patch data structures (which would, eg, allow ghost_zone_width - // and patch_extend_width and the interpolator parameters to vary - // from ghost zone to ghost zone, and the grid spacings to vary - // from patch to patch. But in practice we'd probably never - // use that generality... - // - public: - patch_system(fp origin_x_in, fp origin_y_in, fp origin_z_in, - enum patch_system_type type_in, - int ghost_zone_width, int patch_overlap_width, - int N_zones_per_right_angle, - int min_gfn_in, int max_gfn_in, - int ghosted_min_gfn_in, int ghosted_max_gfn_in, - int ip_interp_handle_in, int ip_interp_par_table_handle_in, - int surface_interp_handle_in, - int surface_interp_par_table_handle_in, - bool print_summary_msg_flag, bool print_detailed_msg_flag); - ~patch_system(); - - // - // ***** helper functions for constructor ***** - // - private: - // construct patches as described by patch_info[] array, - // and link them into the patch system - // does *NOT* create ghost zones - // does *NOT* set up gridfns - void create_patches(const struct patch_info patch_info_in[], - int ghost_zone_width, int patch_extend_width, - int N_zones_per_right_angle, - bool print_msg_flag); - - // setup all gridfns with contiguous-across-patches storage - void setup_gridfn_storage(int min_gfn_in, int max_gfn_in, - int ghosted_min_gfn_in, int ghosted_max_gfn_in, - bool print_msg_flag); - - // setup (create/interlink) all ghost zones - void setup_ghost_zones__full_sphere(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_z_hemisphere(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_xy_quadrant_mirrored(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_xy_quadrant_rotating(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_xz_quadrant_mirrored(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_xz_quadrant_rotating(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_xyz_octant_mirrored(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - void setup_ghost_zones__plus_xyz_octant_rotating(int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle, - bool print_msg_flag); - - // create/interlink a pair of periodic-symmetry ghost zones - static void create_periodic_symmetry_ghost_zones(const patch_edge &ex, const patch_edge &ey, - bool ipar_map_is_plus); - - // construct a pair of interpatch ghost zones - // ... automagically figures out which edges are adjacent - static void create_interpatch_ghost_zones(patch &px, patch &py, - int patch_overlap_width); - - // finish setup of a pair of interpatch ghost zones - // ... automagically figures out which edges are adjacent - static void finish_interpatch_setup(patch &px, patch &py, - int patch_overlap_width, - int ip_interp_handle, int ip_interp_par_table_handle); - - // assert() that all ghost zones of all patches are fully setup - void assert_all_ghost_zones_fully_setup() const; - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - patch_system(const patch_system &rhs); - patch_system &operator=(const patch_system &rhs); - - private: - // local <--> global coordinate mapping - global_coords global_coords_; - - // meta-info about patch system - enum patch_system_type type_; - int N_patches_; - int N_grid_points_, ghosted_N_grid_points_; - - // [pn] = --> individual patches - // *** constructor initialization list ordering: - // *** this must be declared after N_patches_ - patch **all_patches_; - - // [pn] = starting grid point number of individual patches - // ... arrays are actually of size N_patches_+1, the [N_patches_] - // entries are == N_grid_points_ and ghosted_N_grid_points_ - // *** constructor initialization list ordering: - // *** these must be declared after N_patches_ - int *starting_gpn_; - int *ghosted_starting_gpn_; - - // pointers to storage blocks for all gridfns - // ... patches point into these, but we own the storage blocks - fp *gridfn_storage_; - fp *ghosted_gridfn_storage_; - - // min/max m over all ghost zone points - mutable int global_min_ym_, global_max_ym_; - - // info about the surface interpolator - // ... used only by radius_in_local_xyz_direction() - int surface_interp_handle_, surface_interp_par_table_handle_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* TPATCH_SYSTEM_H */ +#ifndef TPATCH_SYSTEM_H +#define TPATCH_SYSTEM_H +namespace AHFinderDirect +{ + + //****************************************************************************** + + // + // A patch_system object describes a system of interlinked patches. + // + // Its const qualifiers refer (only) to the gridfn data. Notably, this + // means that synchronize() is a non-const function (it modifies gridfn + // data), while synchronize_Jacobian() et al are const functions (they + // don't modify gridfn data) even though they may update other internal + // state in the patch_system object and its subobjects. + // + + class patch_system + { + // + // ***** static data & functions describing patch systems ***** + // + public: + // what patch-system type are supported? + // (see "patch_system_info.hh" for detailed descriptions of these) + enum patch_system_type + { + patch_system__full_sphere, + patch_system__plus_z_hemisphere, + patch_system__plus_xy_quadrant_mirrored, + patch_system__plus_xy_quadrant_rotating, + patch_system__plus_xz_quadrant_mirrored, + patch_system__plus_xz_quadrant_rotating, + patch_system__plus_xyz_octant_mirrored, + patch_system__plus_xyz_octant_rotating + }; + + // maximum number of patches in any patch-system type + static const int max_N_patches = 6; + + // decode patch system type into N_patches + static int N_patches_of_type(enum patch_system_type type_in); + + // patch system type <--> human-readable character-string name + static const char *name_of_type(enum patch_system_type type_in); + static enum patch_system_type type_of_name(const char *name_in); + + // + // ***** coordinates ***** + // + public: +#ifdef NOT_USED + // global (x,y,z) --> local (x,y,z) + fp local_x_of_global_x(fp global_x) const + { + return global_coords_.local_x_of_global_x(global_x); + } + fp local_y_of_global_y(fp global_y) const + { + return global_coords_.local_y_of_global_y(global_y); + } + fp local_z_of_global_z(fp global_z) const + { + return global_coords_.local_z_of_global_z(global_z); + } +#endif /* NOT_USED */ + +#ifdef NOT_USED + // local (x,y,z) --> global (x,y,z) + fp global_x_of_local_x(fp local_x) const + { + return global_coords_.global_x_of_local_x(local_x); + } + fp global_y_of_local_y(fp local_y) const + { + return global_coords_.global_y_of_local_y(local_y); + } + fp global_z_of_local_z(fp local_z) const + { + return global_coords_.global_z_of_local_z(local_z); + } +#endif /* NOT_USED */ + + // get global (x,y,z) coordinates of local origin point + fp origin_x() const { return global_coords_.origin_x(); } + fp origin_y() const { return global_coords_.origin_y(); } + fp origin_z() const { return global_coords_.origin_z(); } + + // + // ***** meta-info about the entire patch system ***** + // + public: + // patch-system type + enum patch_system_type type() const { return type_; } + + // total number of patches + int N_patches() const { return N_patches_; } + + // get patches by patch number + const patch &ith_patch(int pn) const + { + return *all_patches_[pn]; + } + patch &ith_patch(int pn) + { + return *all_patches_[pn]; + } + + // find a patch by +/- xyz "ctype" + // FIXME: the present implementation of this function is quite slow + const patch &plus_or_minus_xyz_patch(bool is_plus, char ctype) + const; + + // find a patch by name, return patch number; error_exit() if not found + int patch_number_of_name(const char *name) const; + + // total number of grid points + int N_grid_points() const { return N_grid_points_; } + int ghosted_N_grid_points() const { return ghosted_N_grid_points_; } + + // + // ***** meta-info about gridfns ***** + // + public: + int min_gfn() const { return ith_patch(0).min_gfn(); } + int max_gfn() const { return ith_patch(0).max_gfn(); } + int N_gridfns() const { return ith_patch(0).N_gridfns(); } + bool is_valid_gfn(int gfn) const + { + return ith_patch(0).is_valid_gfn(gfn); + } + int ghosted_min_gfn() const { return ith_patch(0).ghosted_min_gfn(); } + int ghosted_max_gfn() const { return ith_patch(0).ghosted_max_gfn(); } + int ghosted_N_gridfns() const + { + return ith_patch(0).ghosted_N_gridfns(); + } + bool is_valid_ghosted_gfn(int ghosted_gfn) const + { + return ith_patch(0).is_valid_ghosted_gfn(ghosted_gfn); + } + + // + // ***** synchronize() and its Jacobian ***** + // + public: + // "synchronize" all ghost zones of all patches, + // i.e. update the ghost-zone values of the specified gridfns + // via the appropriate sequence of symmetry operations + // and interpatch interpolations + void synchronize(int ghosted_min_gfn_to_sync, + int ghosted_max_gfn_to_sync); + + // ... do this for all ghosted gridfns + void synchronize() + { + synchronize(ghosted_min_gfn(), + ghosted_max_gfn()); + } + + // + // do any precomputation necessary to compute Jacobian of + // synchronize() , taking into account synchronize()'s + // full 3-phase algorithm + // + void compute_synchronize_Jacobian(int ghosted_min_gfn_to_sync, + int ghosted_max_gfn_to_sync) + const; + + // ... do this for all ghosted gridfns + void compute_synchronize_Jacobian() + const + { + compute_synchronize_Jacobian(ghosted_min_gfn(), + ghosted_max_gfn()); + } + + // + // The following functions access the Jacobian computed by + // compute_synchronize_Jacobian() . Note this API is rather + // different than that of ghost_zone::comute_Jacobian() et al: + // here we must take into account synchronize()'s full 3-phase + // algorithm, and this may lead to a more general Jacobian + // structure. + // + // This API still implicitly assumes that the Jacobian is + // independent of ghosted_gfn , and that the set of y points + // (with nonzero Jacobian values) in a single row of the Jacobian + // matrix (i.e. the set of points on which a single ghost-zone + // point depends), + // - lies entirely within a single y patch + // - has a single yiperp value + // - have a contiguous interval of yipar; we parameterize this + // interval as yipar = posn+m + // + + // what are the global min/max m over all ghost zone points? + // (this is useful for sizing the buffer for synchronize_Jacobian()) + void synchronize_Jacobian_global_minmax_ym(int &min_ym, int &max_ym) + const; + + // compute a single row of the Jacobian: + // - return value is edge to which y point belongs + // (caller can get patch from this edge) + // - store y_iperp and y_posn and min/max ym in named arguments + // - stores the Jacobian elements + // partial synchronize() gridfn(ghosted_gfn, px, x_iperp, x_ipar) + // ------------------------------------------------------------- + // partial gridfn(ghosted_gfn, py, y_iperp, y_posn+ym) + // (taking into account synchronize()'s full 3-phase algorithm) + // in the caller-supplied buffer + // Jacobian_buffer(ym) + // for each ym in the min/max ym range + const patch_edge & + synchronize_Jacobian(const ghost_zone &xgz, + int x_iperp, int x_ipar, + int &y_iperp, + int &y_posn, int &min_ym, int &max_ym, + jtutil::array1d &Jacobian_buffer) + const; + + // helper functions for synchronize_Jacobian(): + private: + // "fold" (part of) a Jacobian row + // to take a symmetry operation into acount + // e_Jac = edge which the Jacobian lies along + // e_fold = edge about which to fold + // [min,max]_m = range of m in the Jacobian + // [min,max]_fold_m = range of m to fold + // (must be a subrange of {min,max}_m) + void fold_Jacobian(const patch_edge &e_Jac, const patch_edge &e_fold, + int iperp, + int posn, int min_m, int max_m, + int min_fold_m, int max_fold_m, + jtutil::array1d &Jacobian_buffer) + const; + + // compute the Jacobian of ghost zone's synchronize() + // *without* taking into account 3-phase algorithm + const patch_edge & + ghost_zone_Jacobian(const ghost_zone &xgz, + int x_iperp, int x_ipar, + int &y_iperp, + int &y_posn, int &min_ym, int &max_ym, + jtutil::array1d &Jacobian_buffer) + const; + + // + // ***** gridfn operations ***** + // + public: + // dst = a + void set_gridfn_to_constant(fp a, int dst_gfn); + + // dst = src + void gridfn_copy(int src_gfn, int dst_gfn); + + // dst += delta + void add_to_ghosted_gridfn(fp delta, int ghosted_dst_gfn); + + void recentering(fp x, fp y, fp z); + + // compute norms of gridfn (only over nominal grid) + void gridfn_norms(int src_gfn, jtutil::norm &norms) + const; + void ghosted_gridfn_norms(int ghosted_src_gfn, jtutil::norm &norms) + const; + + // + // ***** testing (x,y,z) point position versus a surface ***** + // + + // find patch containing (ray from origin to) given local (x,y,z) + // ... if there are multiple patches containing the position, + // we return the one which would still contain it if patches + // didn't overlap; if multiple patches satisfy this criterion + // then it's arbitrary which one we return + // ... if no patch contains the position (for a non--full-sphere + // patch system), or the position is at the origin, then + // we return a NULL pointer + const patch *patch_containing_local_xyz(fp x, fp y, fp z) + const; + + // radius of surface in direction of an (x,y,z) point, + // taking into account any patch-system symmetries; + // or dummy value 1.0 if point is identical to local origin + // + // FIXME: + // We should provide another API to compute this for a whole + // batch of points at once, since this would be more efficient + // (the interpolator overhead would be amortized over the whole batch) + fp radius_in_local_xyz_direction(int ghosted_radius_gfn, + fp x, fp y, fp z) + const; + + // + // ***** line/surface operations ***** + // + + // compute the circumference of a surface in the {xy, xz, yz} plane + // ... note this is the full circumference all around the sphere, + // even if the patch system only covers a proper subset of this + // ... the implementation assumes adjacent patches are butt-joined + // ... plane must be one of "xy", "xz", or "yz" + fp circumference(const char plane[], + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum patch::integration_method method) + const; + + // compute the surface integral of a gridfn over the 2-sphere + // $\int f(\rho,\sigma) \, dA$ + // = \int f(\rho,\sigma) \sqrt{|J|} \, d\rho \, d\sigma$ + // where $J$ is the Jacobian of $(x,y,z)$ with respect to $(rho,sigma) + // ... integration method selected by method argument + // ... src gridfn may be either nominal-grid or ghosted-grid + // ... Boolean flags src_gfn_is_even_across_{xy,xz,yz}_planes + // specify whether the gridfn to be integrated is even (true) + // or odd (false) across the corresponding planes. Only the + // flags corresponding to boundaries of the patch system are + // used. For example, for a plus_z_hemisphere patch system, + // only the src_gfn_is_even_across_xy_plane flag is used. + // ... note integral is over the full 2-sphere, + // even if the patch system only covers a proper subset of this + // ... the implementation assumes adjacent patches are butt-joined + fp integrate_gridfn(int unknown_src_gfn, + bool src_gfn_is_even_across_xy_plane, + bool src_gfn_is_even_across_xz_plane, + bool src_gfn_is_even_across_yz_plane, + int ghosted_radius_gfn, + int g_xx_gfn, int g_xy_gfn, int g_xz_gfn, + int g_yy_gfn, int g_yz_gfn, + int g_zz_gfn, + enum patch::integration_method method) + const; + + // + // ***** I/O ***** + // + public: + // print to a named file (newly (re)created) + // output format is + // dpx dpy gridfn + void print_gridfn(int gfn, const char output_file_name[]) const + { + print_unknown_gridfn(false, gfn, + false, false, 0, + output_file_name, false); + } + void print_ghosted_gridfn(int ghosted_gfn, + const char output_file_name[], + bool want_ghost_zones = true) + const + { + print_unknown_gridfn(true, ghosted_gfn, + false, false, 0, + output_file_name, want_ghost_zones); + } + + // print to a named file (newly (re)created) + // output format is + // dpx dpy gridfn global_x global_y global_z + // where global_[xyz} are derived from the angular position + // and a specified (unknown-grid) radius gridfn + void print_gridfn_with_xyz(int gfn, + bool radius_is_ghosted_flag, int unknown_radius_gfn, + const char output_file_name[]) + const + { + print_unknown_gridfn(false, gfn, + true, radius_is_ghosted_flag, + unknown_radius_gfn, + output_file_name, false); + } + void print_ghosted_gridfn_with_xyz(int ghosted_gfn, + bool radius_is_ghosted_flag, int unknown_radius_gfn, + const char output_file_name[], + bool want_ghost_zones = true) + const + { + print_unknown_gridfn(true, ghosted_gfn, + true, radius_is_ghosted_flag, + unknown_radius_gfn, + output_file_name, want_ghost_zones); + } + + public: + // read from a named file + void read_gridfn(int gfn, const char input_file_name[]) + { + read_unknown_gridfn(false, gfn, input_file_name, false); + } + void read_ghosted_gridfn(int ghosted_gfn, + const char input_file_name[], + bool want_ghost_zones = true) + { + read_unknown_gridfn(true, ghosted_gfn, + input_file_name, want_ghost_zones); + } + + private: + // ... internal worker functions + void print_unknown_gridfn(bool ghosted_flag, int unknown_gfn, + bool print_xyz_flag, bool radius_is_ghosted_flag, + int unknown_radius_gfn, + const char output_file_name[], bool want_ghost_zones) + const; + void read_unknown_gridfn(bool ghosted_flag, int unknown_gfn, + const char input_file_name[], + bool want_ghost_zones); + + // + // ***** access to gridfns as 1-D arrays ***** + // + // ... n.b. this interface implicitly assumes that gridfn data + // arrays are contiguous across patches; this is ensured by + // setup_gridfn_storage() (called by our constructor) + // + public: + // convert (patch,irho,isigma) <--> 1-D 0-origin grid point number (gpn) + int gpn_of_patch_irho_isigma(const patch &p, int irho, int isigma) + const + { +#ifdef DEBUG_AHFD + printf(" <%d> ", isigma); +#endif + return starting_gpn_[p.patch_number()] + p.gpn_of_irho_isigma(irho, isigma); + } + int ghosted_gpn_of_patch_irho_isigma(const patch &p, + int irho, int isigma) + const + { + return ghosted_starting_gpn_[p.patch_number()] + p.ghosted_gpn_of_irho_isigma(irho, isigma); + } + // ... n.b. we return patch as a reference via the function result; + // an alternative would be to have a patch*& argument + const patch & + patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) + const; + const patch & + ghosted_patch_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) + const; + + // access actual gridfn data arrays + // (low-level, dangerous, use with caution) + const fp *gridfn_data(int gfn) const + { + return ith_patch(0).gridfn_data_array(gfn); + } + fp *gridfn_data(int gfn) + { + return ith_patch(0).gridfn_data_array(gfn); + } + const fp *ghosted_gridfn_data(int ghosted_gfn) const + { + return ith_patch(0).ghosted_gridfn_data_array(ghosted_gfn); + } + fp *ghosted_gridfn_data(int ghosted_gfn) + { + return ith_patch(0).ghosted_gridfn_data_array(ghosted_gfn); + } + + // + // ***** constructor, destructor ***** + // + // This constructor doesn't support the full generality of the + // patch data structures (which would, eg, allow ghost_zone_width + // and patch_extend_width and the interpolator parameters to vary + // from ghost zone to ghost zone, and the grid spacings to vary + // from patch to patch. But in practice we'd probably never + // use that generality... + // + public: + patch_system(fp origin_x_in, fp origin_y_in, fp origin_z_in, + enum patch_system_type type_in, + int ghost_zone_width, int patch_overlap_width, + int N_zones_per_right_angle, + int min_gfn_in, int max_gfn_in, + int ghosted_min_gfn_in, int ghosted_max_gfn_in, + int ip_interp_handle_in, int ip_interp_par_table_handle_in, + int surface_interp_handle_in, + int surface_interp_par_table_handle_in, + bool print_summary_msg_flag, bool print_detailed_msg_flag); + ~patch_system(); + + // + // ***** helper functions for constructor ***** + // + private: + // construct patches as described by patch_info[] array, + // and link them into the patch system + // does *NOT* create ghost zones + // does *NOT* set up gridfns + void create_patches(const struct patch_info patch_info_in[], + int ghost_zone_width, int patch_extend_width, + int N_zones_per_right_angle, + bool print_msg_flag); + + // setup all gridfns with contiguous-across-patches storage + void setup_gridfn_storage(int min_gfn_in, int max_gfn_in, + int ghosted_min_gfn_in, int ghosted_max_gfn_in, + bool print_msg_flag); + + // setup (create/interlink) all ghost zones + void setup_ghost_zones__full_sphere(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_z_hemisphere(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_xy_quadrant_mirrored(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_xy_quadrant_rotating(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_xz_quadrant_mirrored(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_xz_quadrant_rotating(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_xyz_octant_mirrored(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + void setup_ghost_zones__plus_xyz_octant_rotating(int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle, + bool print_msg_flag); + + // create/interlink a pair of periodic-symmetry ghost zones + static void create_periodic_symmetry_ghost_zones(const patch_edge &ex, const patch_edge &ey, + bool ipar_map_is_plus); + + // construct a pair of interpatch ghost zones + // ... automagically figures out which edges are adjacent + static void create_interpatch_ghost_zones(patch &px, patch &py, + int patch_overlap_width); + + // finish setup of a pair of interpatch ghost zones + // ... automagically figures out which edges are adjacent + static void finish_interpatch_setup(patch &px, patch &py, + int patch_overlap_width, + int ip_interp_handle, int ip_interp_par_table_handle); + + // assert() that all ghost zones of all patches are fully setup + void assert_all_ghost_zones_fully_setup() const; + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + patch_system(const patch_system &rhs); + patch_system &operator=(const patch_system &rhs); + + private: + // local <--> global coordinate mapping + global_coords global_coords_; + + // meta-info about patch system + enum patch_system_type type_; + int N_patches_; + int N_grid_points_, ghosted_N_grid_points_; + + // [pn] = --> individual patches + // *** constructor initialization list ordering: + // *** this must be declared after N_patches_ + patch **all_patches_; + + // [pn] = starting grid point number of individual patches + // ... arrays are actually of size N_patches_+1, the [N_patches_] + // entries are == N_grid_points_ and ghosted_N_grid_points_ + // *** constructor initialization list ordering: + // *** these must be declared after N_patches_ + int *starting_gpn_; + int *ghosted_starting_gpn_; + + // pointers to storage blocks for all gridfns + // ... patches point into these, but we own the storage blocks + fp *gridfn_storage_; + fp *ghosted_gridfn_storage_; + + // min/max m over all ghost zone points + mutable int global_min_ym_, global_max_ym_; + + // info about the surface interpolator + // ... used only by radius_in_local_xyz_direction() + int surface_interp_handle_, surface_interp_par_table_handle_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* TPATCH_SYSTEM_H */ diff --git a/AMSS_NCKU_source/patch_system_info.h b/AMSS_NCKU_source/AHF_Direct/patch_system_info.h similarity index 97% rename from AMSS_NCKU_source/patch_system_info.h rename to AMSS_NCKU_source/AHF_Direct/patch_system_info.h index 6404805..a1bc8b8 100644 --- a/AMSS_NCKU_source/patch_system_info.h +++ b/AMSS_NCKU_source/AHF_Direct/patch_system_info.h @@ -1,183 +1,183 @@ -#ifndef TPATCH_SYSTEM_INFO_H -#define TPATCH_SYSTEM_INFO_H -namespace AHFinderDirect -{ - - //****************************************************************************** - - // - // This namespace contains static data describing the patch sizes and - // shapes for each type of patch system. Since this data only describes - // the patch sizes/shapes, we don't distinguish between the different - // boundary conditions. - // - - namespace patch_system_info - { - // - // full-sphere patch system - // ... covers all 4pi steradians - // - namespace full_sphere - { - enum - { - patch_number__pz = 0, - patch_number__px, - patch_number__py, - patch_number__mx, - patch_number__my, - patch_number__mz, - N_patches // no comma - }; - static const struct patch_info patch_info_array[N_patches] = { - // +z patch (90 x 90 degrees): dmu [ -45, 45], dnu [ -45, 45] - {"+z", patch::patch_is_plus, 'z', -45.0, 45.0, -45.0, 45.0}, - - // +x patch (90 x 90 degrees): dnu [ 45, 135], dphi [ -45, 45] - {"+x", patch::patch_is_plus, 'x', 45.0, 135.0, -45.0, 45.0}, - - // +y patch (90 x 90 degrees): dmu [ 45, 135], dphi [ 45, 135] - {"+y", patch::patch_is_plus, 'y', 45.0, 135.0, 45.0, 135.0}, - - // -x patch (90 x 90 degrees): dnu [-135, -45], dphi [ 135, 225] - {"-x", patch::patch_is_minus, 'x', -135.0, -45.0, 135.0, 225.0}, - - // -y patch (90 x 90 degrees): dmu [-135, -45], dphi [-135, -45] - {"-y", patch::patch_is_minus, 'y', -135.0, -45.0, -135.0, -45.0}, - - // -z patch (90 x 90 degrees): dmu [ 135, 225], dnu [ 135, 225] - {"-z", patch::patch_is_minus, 'z', 135.0, 225.0, 135.0, 225.0}, - }; - } // namespace patch_system_info::full_sphere - - // - // +z hemisphere (half) patch system - // ... mirror symmetry across z=0 plane - // - namespace plus_z_hemisphere - { - enum - { - patch_number__pz = 0, - patch_number__px, - patch_number__py, - patch_number__mx, - patch_number__my, - N_patches // no comma - }; - static const struct patch_info patch_info_array[N_patches] = { - // +z patch (90 x 90 degrees): dmu [ -45, 45], dnu [ -45, 45] - {"+z", patch::patch_is_plus, 'z', -45.0, 45.0, -45.0, 45.0}, - - // +x patch (45 x 90 degrees): dnu [ 45, 90], dphi [ -45, 45] - {"+x", patch::patch_is_plus, 'x', 45.0, 90.0, -45.0, 45.0}, - - // +y patch (45 x 90 degrees): dmu [ 45, 90], dphi [ 45, 135] - {"+y", patch::patch_is_plus, 'y', 45.0, 90.0, 45.0, 135.0}, - - // -x patch (45 x 90 degrees): dnu [ -90, -45], dphi [ 135, 225] - {"-x", patch::patch_is_minus, 'x', -90.0, -45.0, 135.0, 225.0}, - - // -y patch (45 x 90 degrees): dmu [ -90, -45], dphi [-135, -45] - {"-y", patch::patch_is_minus, 'y', -90.0, -45.0, -135.0, -45.0}, - }; - } // namespace patch_system_info::plus_z_hemisphere - - // - // +[xy] "vertical" quarter-grid (quadrant) patch system - // two types of boundary conditions: - // ... mirror symmetry across x=0 and y=0 planes - // ... 90 degree periodic rotation symmetry about z axis - // - namespace plus_xy_quadrant - { - enum - { - patch_number__pz = 0, - patch_number__px, - patch_number__py, - patch_number__mz, - N_patches // no comma - }; - static const struct patch_info patch_info_array[N_patches] = { - // +z patch (45 x 45 degrees): dmu [ 0, 45], dnu [ 0, 45] - {"+z", patch::patch_is_plus, 'z', 0.0, 45.0, 0.0, 45.0}, - - // +x patch (90 x 45 degrees): dnu [ 45, 135], dphi [ 0, 45] - {"+x", patch::patch_is_plus, 'x', 45.0, 135.0, 0.0, 45.0}, - - // +y patch (90 x 45 degrees): dmu [ 45, 135], dphi [ 45, 90] - {"+y", patch::patch_is_plus, 'y', 45.0, 135.0, 45.0, 90.0}, - - // -z patch (45 x 45 degrees): dmu [ 135, 180], dnu [ 135, 180] - {"-z", patch::patch_is_minus, 'z', 135.0, 180.0, 135.0, 180.0}, - }; - } // namespace patch_system_info::plus_xy_quadrant - - // - // +[xz] "horizontal" quarter-grid (quadrant) patch system - // two types of boundary conditions - // ... mirror symmetry across x=0 plane, z=0 plane - // ... 180 degree periodic rotation symmetry about z axis, - // mirror symmetry across z=0 plane - // - namespace plus_xz_quadrant - { - enum - { - patch_number__pz = 0, - patch_number__px, - patch_number__py, - patch_number__my, - N_patches // no comma - }; - static const struct patch_info patch_info_array[N_patches] = { - // +z patch (90 x 45 degrees): dmu [ -45, 45], dnu [ 0, 45] - {"+z", patch::patch_is_plus, 'z', -45.0, 45.0, 0.0, 45.0}, - - // +x patch (45 x 90 degrees): dnu [ 45, 90], dphi [ -45, 45] - {"+x", patch::patch_is_plus, 'x', 45.0, 90.0, -45.0, 45.0}, - - // +y patch (45 x 45 degrees): dmu [ 45, 90], dphi [ 45, 90] - {"+y", patch::patch_is_plus, 'y', 45.0, 90.0, 45.0, 90.0}, - - // -y patch (45 x 45 degrees): dmu [ -90, -45], dphi [ -90, -45] - {"-y", patch::patch_is_minus, 'y', -90.0, -45.0, -90.0, -45.0}, - }; - } // namespace patch_system_info::plus_xz_quadrant_rotating - - // - // +[xyz] (octant) patch system - // two types of boundary conditions: - // ... mirror symmetry across x=0 plane, y=0 plane, z=0 plane - // ... 90 degree periodic rotation symmetry about z axis, - // mirror symmetry across z=0 plane - // - namespace plus_xyz_octant - { - enum - { - patch_number__pz = 0, - patch_number__px, - patch_number__py, - N_patches // no comma - }; - static const struct patch_info patch_info_array[N_patches] = { - // +z patch (45 x 45 degrees): dmu [ 0, 45], dnu [ 0, 45] - {"+z", patch::patch_is_plus, 'z', 0.0, 45.0, 0.0, 45.0}, - - // +x patch (45 x 45 degrees): dnu [ 45, 90], dphi [ 0, 45] - {"+x", patch::patch_is_plus, 'x', 45.0, 90.0, 0.0, 45.0}, - - // +y patch (45 x 45 degrees): dmu [ 45, 90], dphi [ 45, 90] - {"+y", patch::patch_is_plus, 'y', 45.0, 90.0, 45.0, 90.0}, - }; - } // namespace patch_system_info::octant_mirrored - - } // namespace patch_system_info:: - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* TPATCH_SYSTEM_INFO_H */ +#ifndef TPATCH_SYSTEM_INFO_H +#define TPATCH_SYSTEM_INFO_H +namespace AHFinderDirect +{ + + //****************************************************************************** + + // + // This namespace contains static data describing the patch sizes and + // shapes for each type of patch system. Since this data only describes + // the patch sizes/shapes, we don't distinguish between the different + // boundary conditions. + // + + namespace patch_system_info + { + // + // full-sphere patch system + // ... covers all 4pi steradians + // + namespace full_sphere + { + enum + { + patch_number__pz = 0, + patch_number__px, + patch_number__py, + patch_number__mx, + patch_number__my, + patch_number__mz, + N_patches // no comma + }; + static const struct patch_info patch_info_array[N_patches] = { + // +z patch (90 x 90 degrees): dmu [ -45, 45], dnu [ -45, 45] + {"+z", patch::patch_is_plus, 'z', -45.0, 45.0, -45.0, 45.0}, + + // +x patch (90 x 90 degrees): dnu [ 45, 135], dphi [ -45, 45] + {"+x", patch::patch_is_plus, 'x', 45.0, 135.0, -45.0, 45.0}, + + // +y patch (90 x 90 degrees): dmu [ 45, 135], dphi [ 45, 135] + {"+y", patch::patch_is_plus, 'y', 45.0, 135.0, 45.0, 135.0}, + + // -x patch (90 x 90 degrees): dnu [-135, -45], dphi [ 135, 225] + {"-x", patch::patch_is_minus, 'x', -135.0, -45.0, 135.0, 225.0}, + + // -y patch (90 x 90 degrees): dmu [-135, -45], dphi [-135, -45] + {"-y", patch::patch_is_minus, 'y', -135.0, -45.0, -135.0, -45.0}, + + // -z patch (90 x 90 degrees): dmu [ 135, 225], dnu [ 135, 225] + {"-z", patch::patch_is_minus, 'z', 135.0, 225.0, 135.0, 225.0}, + }; + } // namespace patch_system_info::full_sphere + + // + // +z hemisphere (half) patch system + // ... mirror symmetry across z=0 plane + // + namespace plus_z_hemisphere + { + enum + { + patch_number__pz = 0, + patch_number__px, + patch_number__py, + patch_number__mx, + patch_number__my, + N_patches // no comma + }; + static const struct patch_info patch_info_array[N_patches] = { + // +z patch (90 x 90 degrees): dmu [ -45, 45], dnu [ -45, 45] + {"+z", patch::patch_is_plus, 'z', -45.0, 45.0, -45.0, 45.0}, + + // +x patch (45 x 90 degrees): dnu [ 45, 90], dphi [ -45, 45] + {"+x", patch::patch_is_plus, 'x', 45.0, 90.0, -45.0, 45.0}, + + // +y patch (45 x 90 degrees): dmu [ 45, 90], dphi [ 45, 135] + {"+y", patch::patch_is_plus, 'y', 45.0, 90.0, 45.0, 135.0}, + + // -x patch (45 x 90 degrees): dnu [ -90, -45], dphi [ 135, 225] + {"-x", patch::patch_is_minus, 'x', -90.0, -45.0, 135.0, 225.0}, + + // -y patch (45 x 90 degrees): dmu [ -90, -45], dphi [-135, -45] + {"-y", patch::patch_is_minus, 'y', -90.0, -45.0, -135.0, -45.0}, + }; + } // namespace patch_system_info::plus_z_hemisphere + + // + // +[xy] "vertical" quarter-grid (quadrant) patch system + // two types of boundary conditions: + // ... mirror symmetry across x=0 and y=0 planes + // ... 90 degree periodic rotation symmetry about z axis + // + namespace plus_xy_quadrant + { + enum + { + patch_number__pz = 0, + patch_number__px, + patch_number__py, + patch_number__mz, + N_patches // no comma + }; + static const struct patch_info patch_info_array[N_patches] = { + // +z patch (45 x 45 degrees): dmu [ 0, 45], dnu [ 0, 45] + {"+z", patch::patch_is_plus, 'z', 0.0, 45.0, 0.0, 45.0}, + + // +x patch (90 x 45 degrees): dnu [ 45, 135], dphi [ 0, 45] + {"+x", patch::patch_is_plus, 'x', 45.0, 135.0, 0.0, 45.0}, + + // +y patch (90 x 45 degrees): dmu [ 45, 135], dphi [ 45, 90] + {"+y", patch::patch_is_plus, 'y', 45.0, 135.0, 45.0, 90.0}, + + // -z patch (45 x 45 degrees): dmu [ 135, 180], dnu [ 135, 180] + {"-z", patch::patch_is_minus, 'z', 135.0, 180.0, 135.0, 180.0}, + }; + } // namespace patch_system_info::plus_xy_quadrant + + // + // +[xz] "horizontal" quarter-grid (quadrant) patch system + // two types of boundary conditions + // ... mirror symmetry across x=0 plane, z=0 plane + // ... 180 degree periodic rotation symmetry about z axis, + // mirror symmetry across z=0 plane + // + namespace plus_xz_quadrant + { + enum + { + patch_number__pz = 0, + patch_number__px, + patch_number__py, + patch_number__my, + N_patches // no comma + }; + static const struct patch_info patch_info_array[N_patches] = { + // +z patch (90 x 45 degrees): dmu [ -45, 45], dnu [ 0, 45] + {"+z", patch::patch_is_plus, 'z', -45.0, 45.0, 0.0, 45.0}, + + // +x patch (45 x 90 degrees): dnu [ 45, 90], dphi [ -45, 45] + {"+x", patch::patch_is_plus, 'x', 45.0, 90.0, -45.0, 45.0}, + + // +y patch (45 x 45 degrees): dmu [ 45, 90], dphi [ 45, 90] + {"+y", patch::patch_is_plus, 'y', 45.0, 90.0, 45.0, 90.0}, + + // -y patch (45 x 45 degrees): dmu [ -90, -45], dphi [ -90, -45] + {"-y", patch::patch_is_minus, 'y', -90.0, -45.0, -90.0, -45.0}, + }; + } // namespace patch_system_info::plus_xz_quadrant_rotating + + // + // +[xyz] (octant) patch system + // two types of boundary conditions: + // ... mirror symmetry across x=0 plane, y=0 plane, z=0 plane + // ... 90 degree periodic rotation symmetry about z axis, + // mirror symmetry across z=0 plane + // + namespace plus_xyz_octant + { + enum + { + patch_number__pz = 0, + patch_number__px, + patch_number__py, + N_patches // no comma + }; + static const struct patch_info patch_info_array[N_patches] = { + // +z patch (45 x 45 degrees): dmu [ 0, 45], dnu [ 0, 45] + {"+z", patch::patch_is_plus, 'z', 0.0, 45.0, 0.0, 45.0}, + + // +x patch (45 x 45 degrees): dnu [ 45, 90], dphi [ 0, 45] + {"+x", patch::patch_is_plus, 'x', 45.0, 90.0, 0.0, 45.0}, + + // +y patch (45 x 45 degrees): dmu [ 45, 90], dphi [ 45, 90] + {"+y", patch::patch_is_plus, 'y', 45.0, 90.0, 45.0, 90.0}, + }; + } // namespace patch_system_info::octant_mirrored + + } // namespace patch_system_info:: + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* TPATCH_SYSTEM_INFO_H */ diff --git a/AMSS_NCKU_source/round.C b/AMSS_NCKU_source/AHF_Direct/round.C similarity index 96% rename from AMSS_NCKU_source/round.C rename to AMSS_NCKU_source/AHF_Direct/round.C index 1c21ee4..79fedb2 100644 --- a/AMSS_NCKU_source/round.C +++ b/AMSS_NCKU_source/AHF_Direct/round.C @@ -1,38 +1,38 @@ -#include - -#include "stdc.h" -#include "util.h" - -namespace AHFinderDirect -{ - namespace jtutil - { - template - int round::to_integer(fp_t x) - { - return (x >= 0.0) - ? int(x + 0.5) // eg 3.6 --> int(4.1) = 4 - : -int((-x) + 0.5); // eg -3.6 --> - int(4.1) = -4 - } - - template - int round::floor(fp_t x) - { - return (x >= 0.0) - ? int(x) - : -ceiling(-x); - } - - template - int round::ceiling(fp_t x) - { - return (x >= 0.0) - ? int(x) + (x != fp_t(int(x))) - : -floor(-x); - } - - template class round; - template class round; - - } // namespace jtutil -} // namespace AHFinderDirect +#include + +#include "stdc.h" +#include "util.h" + +namespace AHFinderDirect +{ + namespace jtutil + { + template + int round::to_integer(fp_t x) + { + return (x >= 0.0) + ? int(x + 0.5) // eg 3.6 --> int(4.1) = 4 + : -int((-x) + 0.5); // eg -3.6 --> - int(4.1) = -4 + } + + template + int round::floor(fp_t x) + { + return (x >= 0.0) + ? int(x) + : -ceiling(-x); + } + + template + int round::ceiling(fp_t x) + { + return (x >= 0.0) + ? int(x) + (x != fp_t(int(x))) + : -floor(-x); + } + + template class round; + template class round; + + } // namespace jtutil +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/setup.C b/AMSS_NCKU_source/AHF_Direct/setup.C similarity index 96% rename from AMSS_NCKU_source/setup.C rename to AMSS_NCKU_source/AHF_Direct/setup.C index e760067..02eecc4 100644 --- a/AMSS_NCKU_source/setup.C +++ b/AMSS_NCKU_source/AHF_Direct/setup.C @@ -1,188 +1,188 @@ -#include -#include -#include -#include - -#include - -#include "util_Table.h" -#include "cctk.h" -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "cpm_map.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" -#include "fd_grid.h" -#include "patch.h" -#include "patch_edge.h" -#include "patch_interp.h" -#include "ghost_zone.h" -#include "patch_system.h" - -#include "Jacobian.h" - -#include "gfns.h" -#include "gr.h" - -#include "horizon_sequence.h" -#include "BH_diagnostics.h" -#include "driver.h" -using namespace std; - -#include "myglobal.h" -#include "bssn_class.h" - -namespace AHFinderDirect -{ - struct state state; - - using jtutil::error_exit; - - namespace - { - int allocate_horizons_to_processor(int N_procs, int my_proc, - int N_horizons, bool multiproc_flag, - horizon_sequence &my_hs) - { - const int N_active_procs = multiproc_flag ? Mymin(N_procs, N_horizons) - : 1; - // Implementation note: - // We allocate the horizons to active processors in round-robin order. - // - int proc = 0; - for (int hn = 1; hn <= N_horizons; ++hn) - { - if (proc == my_proc) - my_hs.append_hn(hn); - if (++proc >= N_active_procs) - proc = 0; - } - - return N_active_procs; - } - } - - extern struct state state; - - void AHFinderDirect_setup(MyList *AHList, MyList *GaugeList, bssn_class *ADM, - int Symmetry, int HN, double *PhysTime) - { - enum patch_system::patch_system_type ps_type; - - switch (Symmetry) - { - case 2: - ps_type = patch_system::patch_system__plus_xyz_octant_mirrored; - break; - case 1: - ps_type = patch_system::patch_system__plus_z_hemisphere; - break; - case 0: - ps_type = patch_system::patch_system__full_sphere; - break; - default: - jtutil::error_exit(ERROR_EXIT, "** Symmetry=%d is not support by AHFD yet.", Symmetry); - } - - int nprocs = 1, myrank = 0; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - state.PhysTime = PhysTime; // Synchonize the PhysTime - state.Symmetry = Symmetry; - state.AHList = AHList; - state.GaugeList = GaugeList; - state.ADM = ADM; - state.N_procs = nprocs; - state.my_proc = myrank; - - state.N_horizons = HN; - - // - // (genuine) horizon sequence for this processor - // - state.my_hs = new horizon_sequence(state.N_horizons); - horizon_sequence &hs = *state.my_hs; - - const bool multiproc_flag = true; - state.N_active_procs = allocate_horizons_to_processor(state.N_procs, state.my_proc, - state.N_horizons, multiproc_flag, - hs); - - // ... horizon numbers run from 1 to N_horizons inclusive - // so the array size is N_horizons+1 - state.AH_data_array = new AH_data *[HN + 1]; - for (int hn = 0; hn <= HN; ++hn) - { - state.AH_data_array[hn] = NULL; - } - - int NNP = 0, NNP_out; - for (int hn = 1; hn <= hs.N_horizons(); ++hn) - { - const bool genuine_flag = hs.is_hn_genuine(hn); - state.AH_data_array[hn] = new AH_data; - struct AH_data &AH_data = *state.AH_data_array[hn]; - - AH_data.recentering_flag = false; - AH_data.stop_finding = false; - - // create the patch system - AH_data.ps_ptr = new patch_system(0, 0, 0, // just dummy set, we will recenter it when setting initial guess - ps_type, 2, 1, - 20, 1, - // (genuine_flag ? 53 : 0), - (genuine_flag ? gfns::nominal_max_gfn - : gfns::skeletal_nominal_max_gfn), - -1, -1, - 1, 1, - 1, 1, - true, false); - patch_system &ps = *AH_data.ps_ptr; - - if (genuine_flag) - ps.set_gridfn_to_constant(1.0, gfns::gfn__one); - - AH_data.Jac_ptr = genuine_flag ? new Jacobian(ps) : NULL; - - AH_data.surface_expansion = 0; - - AH_data.initial_find_flag = genuine_flag; - - AH_data.found_flag = false; - AH_data.BH_diagnostics_fileptr = NULL; - - NNP = Mymax(NNP, AH_data.ps_ptr->N_grid_points()); - } // end of for hn - - MPI_Allreduce(&NNP, &NNP_out, 1, MPI_INT, MPI_MAX, MPI_COMM_WORLD); - - state.Data = new double[NNP_out * 35]; - state.oX = new double[NNP_out]; - state.oY = new double[NNP_out]; - state.oZ = new double[NNP_out]; - } - void AHFinderDirect_cleanup() - { - horizon_sequence &hs = *state.my_hs; - for (int hn = 1; hn <= hs.N_horizons(); ++hn) - { - struct AH_data &AH_data = *state.AH_data_array[hn]; - if (AH_data.ps_ptr) - delete AH_data.ps_ptr; - if (AH_data.Jac_ptr) - delete AH_data.Jac_ptr; - delete state.AH_data_array[hn]; - } // end of for hn - delete[] state.AH_data_array; - delete state.my_hs; - delete[] state.oX; - delete[] state.oY; - delete[] state.oZ; - delete[] state.Data; - } -} // namespace AHFinderDirect +#include +#include +#include +#include + +#include + +#include "util_Table.h" +#include "cctk.h" +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "cpm_map.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" +#include "fd_grid.h" +#include "patch.h" +#include "patch_edge.h" +#include "patch_interp.h" +#include "ghost_zone.h" +#include "patch_system.h" + +#include "Jacobian.h" + +#include "gfns.h" +#include "gr.h" + +#include "horizon_sequence.h" +#include "BH_diagnostics.h" +#include "driver.h" +using namespace std; + +#include "myglobal.h" +#include "bssn_class.h" + +namespace AHFinderDirect +{ + struct state state; + + using jtutil::error_exit; + + namespace + { + int allocate_horizons_to_processor(int N_procs, int my_proc, + int N_horizons, bool multiproc_flag, + horizon_sequence &my_hs) + { + const int N_active_procs = multiproc_flag ? Mymin(N_procs, N_horizons) + : 1; + // Implementation note: + // We allocate the horizons to active processors in round-robin order. + // + int proc = 0; + for (int hn = 1; hn <= N_horizons; ++hn) + { + if (proc == my_proc) + my_hs.append_hn(hn); + if (++proc >= N_active_procs) + proc = 0; + } + + return N_active_procs; + } + } + + extern struct state state; + + void AHFinderDirect_setup(MyList *AHList, MyList *GaugeList, bssn_class *ADM, + int Symmetry, int HN, double *PhysTime) + { + enum patch_system::patch_system_type ps_type; + + switch (Symmetry) + { + case 2: + ps_type = patch_system::patch_system__plus_xyz_octant_mirrored; + break; + case 1: + ps_type = patch_system::patch_system__plus_z_hemisphere; + break; + case 0: + ps_type = patch_system::patch_system__full_sphere; + break; + default: + jtutil::error_exit(ERROR_EXIT, "** Symmetry=%d is not support by AHFD yet.", Symmetry); + } + + int nprocs = 1, myrank = 0; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + state.PhysTime = PhysTime; // Synchonize the PhysTime + state.Symmetry = Symmetry; + state.AHList = AHList; + state.GaugeList = GaugeList; + state.ADM = ADM; + state.N_procs = nprocs; + state.my_proc = myrank; + + state.N_horizons = HN; + + // + // (genuine) horizon sequence for this processor + // + state.my_hs = new horizon_sequence(state.N_horizons); + horizon_sequence &hs = *state.my_hs; + + const bool multiproc_flag = true; + state.N_active_procs = allocate_horizons_to_processor(state.N_procs, state.my_proc, + state.N_horizons, multiproc_flag, + hs); + + // ... horizon numbers run from 1 to N_horizons inclusive + // so the array size is N_horizons+1 + state.AH_data_array = new AH_data *[HN + 1]; + for (int hn = 0; hn <= HN; ++hn) + { + state.AH_data_array[hn] = NULL; + } + + int NNP = 0, NNP_out; + for (int hn = 1; hn <= hs.N_horizons(); ++hn) + { + const bool genuine_flag = hs.is_hn_genuine(hn); + state.AH_data_array[hn] = new AH_data; + struct AH_data &AH_data = *state.AH_data_array[hn]; + + AH_data.recentering_flag = false; + AH_data.stop_finding = false; + + // create the patch system + AH_data.ps_ptr = new patch_system(0, 0, 0, // just dummy set, we will recenter it when setting initial guess + ps_type, 2, 1, + 20, 1, + // (genuine_flag ? 53 : 0), + (genuine_flag ? gfns::nominal_max_gfn + : gfns::skeletal_nominal_max_gfn), + -1, -1, + 1, 1, + 1, 1, + true, false); + patch_system &ps = *AH_data.ps_ptr; + + if (genuine_flag) + ps.set_gridfn_to_constant(1.0, gfns::gfn__one); + + AH_data.Jac_ptr = genuine_flag ? new Jacobian(ps) : NULL; + + AH_data.surface_expansion = 0; + + AH_data.initial_find_flag = genuine_flag; + + AH_data.found_flag = false; + AH_data.BH_diagnostics_fileptr = NULL; + + NNP = Mymax(NNP, AH_data.ps_ptr->N_grid_points()); + } // end of for hn + + MPI_Allreduce(&NNP, &NNP_out, 1, MPI_INT, MPI_MAX, MPI_COMM_WORLD); + + state.Data = new double[NNP_out * 35]; + state.oX = new double[NNP_out]; + state.oY = new double[NNP_out]; + state.oZ = new double[NNP_out]; + } + void AHFinderDirect_cleanup() + { + horizon_sequence &hs = *state.my_hs; + for (int hn = 1; hn <= hs.N_horizons(); ++hn) + { + struct AH_data &AH_data = *state.AH_data_array[hn]; + if (AH_data.ps_ptr) + delete AH_data.ps_ptr; + if (AH_data.Jac_ptr) + delete AH_data.Jac_ptr; + delete state.AH_data_array[hn]; + } // end of for hn + delete[] state.AH_data_array; + delete state.my_hs; + delete[] state.oX; + delete[] state.oY; + delete[] state.oZ; + delete[] state.Data; + } +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/stdc.h b/AMSS_NCKU_source/AHF_Direct/stdc.h similarity index 93% rename from AMSS_NCKU_source/stdc.h rename to AMSS_NCKU_source/AHF_Direct/stdc.h index 745e75c..3ec106a 100644 --- a/AMSS_NCKU_source/stdc.h +++ b/AMSS_NCKU_source/AHF_Direct/stdc.h @@ -1,24 +1,24 @@ -#ifndef AHFINDERDIRECT__STDC_H -#define AHFINDERDIRECT__STDC_H - -#define then /* empty */ - -#ifdef M_PI -#define PI M_PI -#endif - -#define iabs(x_) abs(x_) - -namespace AHFinderDirect -{ - namespace jtutil - { - - int error_exit(int msg_level, const char *format, ...); - -#define ERROR_EXIT (-1) -#define PANIC_EXIT (-2) - } -} - -#endif /* AHFINDERDIRECT__STDC_H */ +#ifndef AHFINDERDIRECT__STDC_H +#define AHFINDERDIRECT__STDC_H + +#define then /* empty */ + +#ifdef M_PI +#define PI M_PI +#endif + +#define iabs(x_) abs(x_) + +namespace AHFinderDirect +{ + namespace jtutil + { + + int error_exit(int msg_level, const char *format, ...); + +#define ERROR_EXIT (-1) +#define PANIC_EXIT (-2) + } +} + +#endif /* AHFINDERDIRECT__STDC_H */ diff --git a/AMSS_NCKU_source/tgrid.C b/AMSS_NCKU_source/AHF_Direct/tgrid.C similarity index 97% rename from AMSS_NCKU_source/tgrid.C rename to AMSS_NCKU_source/AHF_Direct/tgrid.C index 1f3415e..10681e5 100644 --- a/AMSS_NCKU_source/tgrid.C +++ b/AMSS_NCKU_source/AHF_Direct/tgrid.C @@ -1,128 +1,128 @@ -#include -#include -#include - -#include "cctk.h" - -#include "config.h" -#include "stdc.h" -#include "util.h" -#include "array.h" -#include "linear_map.h" - -#include "coords.h" -#include "tgrid.h" - -namespace AHFinderDirect -{ - - //***************************************************************************** - //***************************************************************************** - //***************************************************************************** - - // - // This function constructs a grid_arrays object. - // - grid_arrays::grid_arrays(const grid_array_pars &grid_array_pars_in) - - : gridfn_data_(NULL), - ghosted_gridfn_data_(NULL), - - // these are all set properly by setup_gridfn_storage() - min_gfn_(0), max_gfn_(0), - ghosted_min_gfn_(0), ghosted_max_gfn_(0), - - min_irho_(grid_array_pars_in.min_irho), - max_irho_(grid_array_pars_in.max_irho), - min_isigma_(grid_array_pars_in.min_isigma), - max_isigma_(grid_array_pars_in.max_isigma), - - ghosted_min_irho_(grid_array_pars_in.min_irho - grid_array_pars_in.min_rho_ghost_zone_width), - ghosted_max_irho_(grid_array_pars_in.max_irho + grid_array_pars_in.max_rho_ghost_zone_width), - ghosted_min_isigma_(grid_array_pars_in.min_isigma - grid_array_pars_in.min_sigma_ghost_zone_width), - ghosted_max_isigma_(grid_array_pars_in.max_isigma + grid_array_pars_in.max_sigma_ghost_zone_width) - // no comma - { - } - - //***************************************************************************** - - // - // This function sets up the gridfn storage arrays in a grid_arrays object. - // - void grid_arrays::setup_gridfn_storage(const gridfn_pars &gridfn_pars_in, - const gridfn_pars &ghosted_gridfn_pars_in) - { - assert(gridfn_data_ == NULL); - gridfn_data_ = new jtutil::array3d(gridfn_pars_in.min_gfn, - gridfn_pars_in.max_gfn, - min_irho(), max_irho(), - min_isigma(), max_isigma(), - gridfn_pars_in.storage_array, - gridfn_pars_in.gfn_stride, - gridfn_pars_in.irho_stride, - gridfn_pars_in.isigma_stride); - - assert(ghosted_gridfn_data_ == NULL); - ghosted_gridfn_data_ = new jtutil::array3d(ghosted_gridfn_pars_in.min_gfn, - ghosted_gridfn_pars_in.max_gfn, - ghosted_min_irho(), ghosted_max_irho(), - ghosted_min_isigma(), ghosted_max_isigma(), - ghosted_gridfn_pars_in.storage_array, - ghosted_gridfn_pars_in.gfn_stride, - ghosted_gridfn_pars_in.irho_stride, - ghosted_gridfn_pars_in.isigma_stride); - } - - //****************************************************************************** - - // - // This function destroys a grid_arrays object. - // - grid_arrays::~grid_arrays() - { - delete ghosted_gridfn_data_; - delete gridfn_data_; - } - - //***************************************************************************** - //***************************************************************************** - //***************************************************************************** - - // - // This function constructs a grid object. - // - grid::grid(const grid_array_pars &grid_array_pars_in, - const grid_pars &grid_pars_in) - - : grid_arrays(grid_array_pars_in), - - rho_map_(grid_array_pars_in.min_irho - grid_array_pars_in.min_rho_ghost_zone_width, - grid_array_pars_in.max_irho + grid_array_pars_in.max_rho_ghost_zone_width, - jtutil::radians_of_degrees( - grid_pars_in.min_drho - grid_array_pars_in.min_rho_ghost_zone_width * grid_pars_in.delta_drho), - jtutil::radians_of_degrees(grid_pars_in.delta_drho), - jtutil::radians_of_degrees( - grid_pars_in.max_drho + grid_array_pars_in.max_rho_ghost_zone_width * grid_pars_in.delta_drho)), - - sigma_map_(grid_array_pars_in.min_isigma - grid_array_pars_in.min_sigma_ghost_zone_width, - grid_array_pars_in.max_isigma + grid_array_pars_in.max_sigma_ghost_zone_width, - jtutil::radians_of_degrees( - grid_pars_in.min_dsigma - grid_array_pars_in.min_sigma_ghost_zone_width * grid_pars_in.delta_dsigma), - jtutil::radians_of_degrees(grid_pars_in.delta_dsigma), - jtutil::radians_of_degrees( - grid_pars_in.max_dsigma + grid_array_pars_in.max_sigma_ghost_zone_width * grid_pars_in.delta_dsigma)), - - min_rho_(jtutil::radians_of_degrees(grid_pars_in.min_drho)), - max_rho_(jtutil::radians_of_degrees(grid_pars_in.max_drho)), - min_sigma_(jtutil::radians_of_degrees(grid_pars_in.min_dsigma)), - max_sigma_(jtutil::radians_of_degrees(grid_pars_in.max_dsigma)) - // no comma - { - } - - //****************************************************************************** - //****************************************************************************** - //****************************************************************************** - -} // namespace AHFinderDirect +#include +#include +#include + +#include "cctk.h" + +#include "config.h" +#include "stdc.h" +#include "util.h" +#include "array.h" +#include "linear_map.h" + +#include "coords.h" +#include "tgrid.h" + +namespace AHFinderDirect +{ + + //***************************************************************************** + //***************************************************************************** + //***************************************************************************** + + // + // This function constructs a grid_arrays object. + // + grid_arrays::grid_arrays(const grid_array_pars &grid_array_pars_in) + + : gridfn_data_(NULL), + ghosted_gridfn_data_(NULL), + + // these are all set properly by setup_gridfn_storage() + min_gfn_(0), max_gfn_(0), + ghosted_min_gfn_(0), ghosted_max_gfn_(0), + + min_irho_(grid_array_pars_in.min_irho), + max_irho_(grid_array_pars_in.max_irho), + min_isigma_(grid_array_pars_in.min_isigma), + max_isigma_(grid_array_pars_in.max_isigma), + + ghosted_min_irho_(grid_array_pars_in.min_irho - grid_array_pars_in.min_rho_ghost_zone_width), + ghosted_max_irho_(grid_array_pars_in.max_irho + grid_array_pars_in.max_rho_ghost_zone_width), + ghosted_min_isigma_(grid_array_pars_in.min_isigma - grid_array_pars_in.min_sigma_ghost_zone_width), + ghosted_max_isigma_(grid_array_pars_in.max_isigma + grid_array_pars_in.max_sigma_ghost_zone_width) + // no comma + { + } + + //***************************************************************************** + + // + // This function sets up the gridfn storage arrays in a grid_arrays object. + // + void grid_arrays::setup_gridfn_storage(const gridfn_pars &gridfn_pars_in, + const gridfn_pars &ghosted_gridfn_pars_in) + { + assert(gridfn_data_ == NULL); + gridfn_data_ = new jtutil::array3d(gridfn_pars_in.min_gfn, + gridfn_pars_in.max_gfn, + min_irho(), max_irho(), + min_isigma(), max_isigma(), + gridfn_pars_in.storage_array, + gridfn_pars_in.gfn_stride, + gridfn_pars_in.irho_stride, + gridfn_pars_in.isigma_stride); + + assert(ghosted_gridfn_data_ == NULL); + ghosted_gridfn_data_ = new jtutil::array3d(ghosted_gridfn_pars_in.min_gfn, + ghosted_gridfn_pars_in.max_gfn, + ghosted_min_irho(), ghosted_max_irho(), + ghosted_min_isigma(), ghosted_max_isigma(), + ghosted_gridfn_pars_in.storage_array, + ghosted_gridfn_pars_in.gfn_stride, + ghosted_gridfn_pars_in.irho_stride, + ghosted_gridfn_pars_in.isigma_stride); + } + + //****************************************************************************** + + // + // This function destroys a grid_arrays object. + // + grid_arrays::~grid_arrays() + { + delete ghosted_gridfn_data_; + delete gridfn_data_; + } + + //***************************************************************************** + //***************************************************************************** + //***************************************************************************** + + // + // This function constructs a grid object. + // + grid::grid(const grid_array_pars &grid_array_pars_in, + const grid_pars &grid_pars_in) + + : grid_arrays(grid_array_pars_in), + + rho_map_(grid_array_pars_in.min_irho - grid_array_pars_in.min_rho_ghost_zone_width, + grid_array_pars_in.max_irho + grid_array_pars_in.max_rho_ghost_zone_width, + jtutil::radians_of_degrees( + grid_pars_in.min_drho - grid_array_pars_in.min_rho_ghost_zone_width * grid_pars_in.delta_drho), + jtutil::radians_of_degrees(grid_pars_in.delta_drho), + jtutil::radians_of_degrees( + grid_pars_in.max_drho + grid_array_pars_in.max_rho_ghost_zone_width * grid_pars_in.delta_drho)), + + sigma_map_(grid_array_pars_in.min_isigma - grid_array_pars_in.min_sigma_ghost_zone_width, + grid_array_pars_in.max_isigma + grid_array_pars_in.max_sigma_ghost_zone_width, + jtutil::radians_of_degrees( + grid_pars_in.min_dsigma - grid_array_pars_in.min_sigma_ghost_zone_width * grid_pars_in.delta_dsigma), + jtutil::radians_of_degrees(grid_pars_in.delta_dsigma), + jtutil::radians_of_degrees( + grid_pars_in.max_dsigma + grid_array_pars_in.max_sigma_ghost_zone_width * grid_pars_in.delta_dsigma)), + + min_rho_(jtutil::radians_of_degrees(grid_pars_in.min_drho)), + max_rho_(jtutil::radians_of_degrees(grid_pars_in.max_drho)), + min_sigma_(jtutil::radians_of_degrees(grid_pars_in.min_dsigma)), + max_sigma_(jtutil::radians_of_degrees(grid_pars_in.max_dsigma)) + // no comma + { + } + + //****************************************************************************** + //****************************************************************************** + //****************************************************************************** + +} // namespace AHFinderDirect diff --git a/AMSS_NCKU_source/tgrid.h b/AMSS_NCKU_source/AHF_Direct/tgrid.h similarity index 96% rename from AMSS_NCKU_source/tgrid.h rename to AMSS_NCKU_source/AHF_Direct/tgrid.h index bd22a25..114a7be 100644 --- a/AMSS_NCKU_source/tgrid.h +++ b/AMSS_NCKU_source/AHF_Direct/tgrid.h @@ -1,907 +1,907 @@ -#ifndef TGRID_H -#define TGRID_H -namespace AHFinderDirect -{ - - //***************************************************************************** - - // - // grid_arrays - data arrays for a 2D tensor-product grid - // - // This is a helper class for class grid (below). This class stores - // most of the actual grid function (gridfn) data arrays for a uniform - // tensor-product 2D grid. - // - // The integer grid coordinates are (irho,isigma). This class deals - // with the grid solely at the level of arrays with integer subscripts; - // the derived class grid deals with the floating-point coordinates - // related to those subscripts. - // - // The grid has a nominal extent, surrounded by "ghost zones" on each - // side for finite differencing purposes. - // - // There are separate sets of nominal-grid and ghosted-grid gridfns. - // We identify a gridfn by a small-integer "grid function number", a.k.a. - // "gfn". There are separate gfns for nominal and ghosted gridfns. - // In a very few places we refer to "unknown-grid" gridfns; these might - // be either nominal-grid or ghosted-grid. - // - // For our application (apparent horizon finding), it's useful for the - // storage for a single gridfn to be contiguous *across all patches*. - // (Note this means that the set of all our gridfns is *not* contiguous!) - // To accomplish this, we don't allocate the gridfns when we're created, - // but rather later, with a separate call setup_gridfn_storage() . - // This way higher-level code can first create all patches, then count - // the total amount of storage used, allocate it, then finally call each - // patch again to set up its gridfns appropriately. - // - - class grid_arrays - { - public: - // - // ***** {min,max}_{rho,sigma} "sides" of grid ***** - // - - // - // A grid has 4 (angular) "sides", which we identify as - // {min,max}_{rho,sigma}. Given a side, we define coordinates - // (perpendicular,parallel) to it, normally abbreviated to - // (perp,par). - // - // As well as functions directly referring to a specific side, - // we also support referring to one of these chosen at run-time, - // via Boolean flags: - // - // // generic (irho,isigma) coordinate - // iang = want_rho ? irho : isigma - // - // // opposite (irho,isigma) coordinate - // ixang = want_rho ? isigma : irho - // - // // generic (min,max) direction - // minmax = want_min ? min : max - // - // FIXME: This system of Boolean flags works ok, but it requires - // a lot of repetitive code conditional-expression functions - // in this class. Is there a cleaner solution? - - // there are precisely this many possible sides - enum - { - N_sides = 4 - }; - - // we specify {min,max} with a Boolean want_min - // ... values for want_min - // FIXME: these should really be bool, but then we couldn't - // use the "enum hack" for in-class constants - enum - { - side_is_min = true, - side_is_max = false - }; - - // we specify {rho,sigma} with a Boolean want_rho - // ... values for wanr_rho - // FIXME: these should really be bool, but then we couldn't - // use the "enum hack" for in-class constants - enum - { - side_is_rho = true, - side_is_sigma = false - }; - - // human-readable names for the sides (for debugging) - static const char *minmax_name(bool minmax) - { - return minmax ? "min" : "max"; - } - static const char *iang_name(bool want_rho) - { - return want_rho ? "irho" : "isigma"; - } - - // - // ***** array info ***** - // - public: - // nominal-grid min/max/sizes - int min_irho() const { return min_irho_; } - int max_irho() const { return max_irho_; } - int min_isigma() const { return min_isigma_; } - int max_isigma() const { return max_isigma_; } - int min_iang(bool want_rho) const - { - return want_rho ? min_irho() : min_isigma(); - } - int max_iang(bool want_rho) const - { - return want_rho ? max_irho() : max_isigma(); - } - int minmax_iang(bool want_min, bool want_rho) const - { - return want_min ? min_iang(want_rho) : max_iang(want_rho); - } - int N_irho() const - { - return jtutil::how_many_in_range(min_irho(), max_irho()); - } - int N_isigma() const - { - return jtutil::how_many_in_range(min_isigma(), max_isigma()); - } - int N_grid_points() const - { - return N_irho() * N_isigma(); - } - - // ghosted-grid min/max/sizes - int ghosted_min_irho() const { return ghosted_min_irho_; } - int ghosted_max_irho() const { return ghosted_max_irho_; } - int ghosted_min_isigma() const - { - return ghosted_min_isigma_; - } - int ghosted_max_isigma() const - { - return ghosted_max_isigma_; - } - int ghosted_min_iang(bool want_rho) const - { - return want_rho ? ghosted_min_irho() - : ghosted_min_isigma(); - } - int ghosted_max_iang(bool want_rho) const - { - return want_rho ? ghosted_max_irho() - : ghosted_max_isigma(); - } - int ghosted_minmax_iang(bool want_min, bool want_rho) const - { - return want_min ? ghosted_min_iang(want_rho) - : ghosted_max_iang(want_rho); - } - int ghosted_N_irho() const - { - return jtutil::how_many_in_range(ghosted_min_irho(), - ghosted_max_irho()); - } - int ghosted_N_isigma() const - { - return jtutil::how_many_in_range(ghosted_min_isigma(), - ghosted_max_isigma()); - } - int ghosted_N_grid_points() const - { - return ghosted_N_irho() * ghosted_N_isigma(); - } - - // "effective" grid min/max/sizes - // (= dynamic select between nominal and full grids) - int effective_min_irho(bool want_ghost_zones) const - { - return want_ghost_zones ? ghosted_min_irho() : min_irho(); - } - int effective_max_irho(bool want_ghost_zones) const - { - return want_ghost_zones ? ghosted_max_irho() : max_irho(); - } - int effective_min_isigma(bool want_ghost_zones) const - { - return want_ghost_zones ? ghosted_min_isigma() : min_isigma(); - } - int effective_max_isigma(bool want_ghost_zones) const - { - return want_ghost_zones ? ghosted_max_isigma() : max_isigma(); - } - int effective_N_irho(bool want_ghost_zones) const - { - return want_ghost_zones ? ghosted_N_irho() : N_irho(); - } - int effective_N_isigma(bool want_ghost_zones) const - { - return want_ghost_zones ? ghosted_N_isigma() : N_isigma(); - } - - // - // ***** ghost zones ***** - // - public: - // ghost zone min/max perpendicular coordinates - int min_rho_ghost_zone__min_iperp() const - { - return ghosted_min_irho(); - } - int min_rho_ghost_zone__max_iperp() const - { - return min_irho() - 1; - } - int max_rho_ghost_zone__min_iperp() const - { - return max_irho() + 1; - } - int max_rho_ghost_zone__max_iperp() const - { - return ghosted_max_irho(); - } - int min_sigma_ghost_zone__min_iperp() const - { - return ghosted_min_isigma(); - } - int min_sigma_ghost_zone__max_iperp() const - { - return min_isigma() - 1; - } - int max_sigma_ghost_zone__min_iperp() const - { - return max_isigma() + 1; - } - int max_sigma_ghost_zone__max_iperp() const - { - return ghosted_max_isigma(); - } - int minmax_ang_ghost_zone__min_iperp(bool want_min, bool want_rho) const - { - return want_min - ? (want_rho ? min_rho_ghost_zone__min_iperp() - : min_sigma_ghost_zone__min_iperp()) - : (want_rho ? max_rho_ghost_zone__min_iperp() - : max_sigma_ghost_zone__min_iperp()); - } - int minmax_ang_ghost_zone__max_iperp(bool want_min, bool want_rho) const - { - return want_min - ? (want_rho ? min_rho_ghost_zone__max_iperp() - : min_sigma_ghost_zone__max_iperp()) - : (want_rho ? max_rho_ghost_zone__max_iperp() - : max_sigma_ghost_zone__max_iperp()); - } - - // ghost zone min/max parallel coordinates - // ... not including corners - int rho_ghost_zone_without_corners__min_ipar() const - { - return min_isigma(); - } - int rho_ghost_zone_without_corners__max_ipar() const - { - return max_isigma(); - } - int sigma_ghost_zone_without_corners__min_ipar() const - { - return min_irho(); - } - int sigma_ghost_zone_without_corners__max_ipar() const - { - return max_irho(); - } - int ang_ghost_zone_without_corners__min_ipar(bool want_rho) const - { - return want_rho ? rho_ghost_zone_without_corners__min_ipar() - : sigma_ghost_zone_without_corners__min_ipar(); - } - int ang_ghost_zone_without_corners__max_ipar(bool want_rho) const - { - return want_rho ? rho_ghost_zone_without_corners__max_ipar() - : sigma_ghost_zone_without_corners__max_ipar(); - } - // ... including corners - int rho_ghost_zone_with_corners__min_ipar() const - { - return ghosted_min_isigma(); - } - int rho_ghost_zone_with_corners__max_ipar() const - { - return ghosted_max_isigma(); - } - int sigma_ghost_zone_with_corners__min_ipar() const - { - return ghosted_min_irho(); - } - int sigma_ghost_zone_with_corners__max_ipar() const - { - return ghosted_max_irho(); - } - int ang_ghost_zone_with_corners__min_ipar(bool want_rho) const - { - return want_rho ? rho_ghost_zone_with_corners__min_ipar() - : sigma_ghost_zone_with_corners__min_ipar(); - } - int ang_ghost_zone_with_corners__max_ipar(bool want_rho) const - { - return want_rho ? rho_ghost_zone_with_corners__max_ipar() - : sigma_ghost_zone_with_corners__max_ipar(); - } - - // - // ***** grid-point validity and membership predicates ***** - // - public: - bool is_valid_irho(int irho) const - { - return (irho >= min_irho()) && (irho <= max_irho()); - } - bool is_valid_isigma(int isigma) const - { - return (isigma >= min_isigma()) && (isigma <= max_isigma()); - } - bool is_in_nominal_grid(int irho, int isigma) const - { - return is_valid_irho(irho) && is_valid_isigma(isigma); - } - - bool is_valid_ghosted_irho(int irho) const - { - return (irho >= ghosted_min_irho()) && (irho <= ghosted_max_irho()); - } - bool is_valid_ghosted_isigma(int isigma) const - { - return (isigma >= ghosted_min_isigma()) && (isigma <= ghosted_max_isigma()); - } - bool is_in_ghosted_grid(int irho, int isigma) const - { - return is_valid_ghosted_irho(irho) && is_valid_ghosted_isigma(isigma); - } - - bool is_in_ghost_zone(int irho, int isigma) const - { - return is_in_ghosted_grid(irho, isigma) && !is_in_nominal_grid(irho, isigma); - } - - // - // ***** gfn ranges and validity predicates ***** - // - public: - // gfn ranges - int min_gfn() const - { - assert(gridfn_data_ != NULL); - return (*gridfn_data_).min_i(); - } - int max_gfn() const - { - assert(gridfn_data_ != NULL); - return (*gridfn_data_).max_i(); - } - int N_gridfns() const - { - return jtutil::how_many_in_range(min_gfn(), max_gfn()); - } - int ghosted_min_gfn() const - { - assert(ghosted_gridfn_data_ != NULL); - return (*ghosted_gridfn_data_).min_i(); - } - int ghosted_max_gfn() const - { - assert(ghosted_gridfn_data_ != NULL); - return (*ghosted_gridfn_data_).max_i(); - } - int ghosted_N_gridfns() const - { - return jtutil::how_many_in_range(ghosted_min_gfn(), - ghosted_max_gfn()); - } - - // gfn validity predicates - bool is_valid_gfn(int gfn) const - { - return (gfn >= min_gfn()) && (gfn <= max_gfn()); - } - bool is_valid_ghosted_gfn(int gfn) const - { - return (gfn >= ghosted_min_gfn()) && (gfn <= ghosted_max_gfn()); - } - - // - // ***** gridfns ***** - // - // n.b. access to rvalue gridfn data must be via references - // in order to allow using gridfn(...) as the operand - // of a unary & (address-of) operator - // - public: - // access to nominal-grid gridfn data - // ... rvalue - const fp &gridfn(int gfn, int irho, int isigma) const - { - assert(gridfn_data_ != NULL); - return (*gridfn_data_)(gfn, irho, isigma); - } - // ... lvalue - fp &gridfn(int gfn, int irho, int isigma) - { - assert(gridfn_data_ != NULL); - return (*gridfn_data_)(gfn, irho, isigma); - } - - // access to ghosted-grid gridfn data - // ... rvalue - const fp &ghosted_gridfn(int gfn, int irho, int isigma) const - { - assert(gridfn_data_ != NULL); - return (*ghosted_gridfn_data_)(gfn, irho, isigma); - } - // ... lvalue - fp &ghosted_gridfn(int gfn, int irho, int isigma) - { - assert(gridfn_data_ != NULL); - return (*ghosted_gridfn_data_)(gfn, irho, isigma); - } - - // access to unknown-grid gridfn data - // (either nominal or ghosted, depending on Boolean flag) - // ... rvalue - const fp &unknown_gridfn(bool ghosted_flag, - int unknown_gfn, int irho, int isigma) - const - { - return ghosted_flag ? ghosted_gridfn(unknown_gfn, irho, isigma) - : gridfn(unknown_gfn, irho, isigma); - } - // ... lvalue - fp &unknown_gridfn(bool ghosted_flag, - int unknown_gfn, int irho, int isigma) - { - return ghosted_flag ? ghosted_gridfn(unknown_gfn, irho, isigma) - : gridfn(unknown_gfn, irho, isigma); - } - - // subscripting info - int gfn_stride() const - { - assert(gridfn_data_ != NULL); - return gridfn_data_->subscript_stride_i(); - } - int irho_stride() const - { - assert(gridfn_data_ != NULL); - return gridfn_data_->subscript_stride_j(); - } - int isigma_stride() const - { - assert(gridfn_data_ != NULL); - return gridfn_data_->subscript_stride_k(); - } - int iang_stride(bool want_rho) const - { - return want_rho ? irho_stride() : isigma_stride(); - } - int ghosted_gfn_stride() const - { - assert(ghosted_gridfn_data_ != NULL); - return ghosted_gridfn_data_->subscript_stride_i(); - } - int ghosted_irho_stride() const - { - assert(ghosted_gridfn_data_ != NULL); - return ghosted_gridfn_data_->subscript_stride_j(); - } - int ghosted_isigma_stride() const - { - assert(ghosted_gridfn_data_ != NULL); - return ghosted_gridfn_data_->subscript_stride_k(); - } - int ghosted_iang_stride(bool want_rho) const - { - return want_rho ? ghosted_irho_stride() - : ghosted_isigma_stride(); - } - - // validity predicates for 1-D 0-origin grid point number (gpn) - bool is_valid_gpn(int gpn) const - { - return (gpn >= 0) && (gpn < N_grid_points()); - } - bool is_valid_ghosted_gpn(int gpn) const - { - return (gpn >= 0) && (gpn < ghosted_N_grid_points()); - } - - // convert (irho,isigma) <--> 1-D 0-origin grid point number (gpn) - int gpn_of_irho_isigma(int irho, int isigma) const - { - assert(is_valid_irho(irho)); - assert(is_valid_isigma(isigma)); - - return (irho - min_irho()) * irho_stride() + (isigma - min_isigma()) * isigma_stride(); - } - int ghosted_gpn_of_irho_isigma(int irho, int isigma) const - { - assert(is_valid_ghosted_irho(irho)); - assert(is_valid_ghosted_isigma(isigma)); - return (irho - ghosted_min_irho()) * ghosted_irho_stride() + (isigma - ghosted_min_isigma()) * ghosted_isigma_stride(); - } - // ... current implementation assumes (& verifies) isigma is contiguous - void irho_isigma_of_gpn(int gpn, int &irho, int &isigma) const - { - assert(is_valid_gpn(gpn)); - assert(isigma_stride() == 1); // implementation restriction - irho = min_irho() + gpn / N_isigma(); - isigma = min_isigma() + gpn % N_isigma(); - assert(is_valid_irho(irho)); - assert(is_valid_isigma(isigma)); - } - // ... current implementation assumes (& verifies) isigma is contiguous - void ghosted_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) const - { - assert(is_valid_ghosted_gpn(gpn)); - assert(ghosted_isigma_stride() == 1); // implementation - // restriction - irho = ghosted_min_irho() + gpn / ghosted_N_isigma(); - isigma = ghosted_min_isigma() + gpn % ghosted_N_isigma(); - assert(is_valid_ghosted_irho(irho)); - assert(is_valid_ghosted_isigma(isigma)); - } - - // low-level access to data arrays (!!dangerous!!) - const fp *gridfn_data_array(int gfn) const - { - return &gridfn(gfn, min_irho(), min_isigma()); - } - fp *gridfn_data_array(int gfn) - { - return &gridfn(gfn, min_irho(), min_isigma()); - } - const fp *ghosted_gridfn_data_array(int ghosted_gfn) const - { - return &ghosted_gridfn(ghosted_gfn, ghosted_min_irho(), - ghosted_min_isigma()); - } - fp *ghosted_gridfn_data_array(int ghosted_gfn) - { - return &ghosted_gridfn(ghosted_gfn, ghosted_min_irho(), - ghosted_min_isigma()); - } - - // - // ***** argument structures for constructor et al ***** - // - public: - // these structures bundle related arguments together so we don't - // have 20+ (!) separate arguments to our top-level constructors - struct grid_array_pars - { - int min_irho, max_irho; - int min_isigma, max_isigma; - int min_rho_ghost_zone_width, max_rho_ghost_zone_width; - int min_sigma_ghost_zone_width, max_sigma_ghost_zone_width; - }; - struct gridfn_pars - { - int min_gfn, max_gfn; - - // gridfn storage will be automatically allocated - // if pointer is NULL; any 0 strides are automatically - // set to C-style row-major subscripting - fp *storage_array; - int gfn_stride, irho_stride, isigma_stride; - }; - - // - // ***** constructor, gridfn setup, destructor ***** - // - public: - // construct with no gridfns - grid_arrays(const grid_array_pars &grid_array_pars_in); - - // set up storage for gridfns - void setup_gridfn_storage(const gridfn_pars &gridfn_pars_in, - const gridfn_pars &ghosted_gridfn_pars_in); - - ~grid_arrays(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - grid_arrays(const grid_arrays &rhs); - grid_arrays &operator=(const grid_arrays &rhs); - - private: - // - // ***** the actual gridfn storage arrays ***** - // - // n.b. these pointers are *first* data member in this class - // ==> possibly slightly faster access (0 offset from pointer) - // ... indices are (gfn, irho, isigma) - jtutil::array3d *gridfn_data_; - jtutil::array3d *ghosted_gridfn_data_; - - // gfn bounds - const int min_gfn_, max_gfn_; - const int ghosted_min_gfn_, ghosted_max_gfn_; - - // nominal grid min/max bounds - const int min_irho_, max_irho_; - const int min_isigma_, max_isigma_; - - // full grid min/max bounds - const int ghosted_min_irho_, ghosted_max_irho_; - const int ghosted_min_isigma_, ghosted_max_isigma_; - }; - - //****************************************************************************** - - // - // grid - uniform 2D tensor-product grid - // - // The grid is uniform in the floating point grid coordinates (rho,sigma). - // There is also some (limited) support for expressing these coordinates - // in degrees (drho,dsigma); this is useful for humans trying to specify - // things in parameter files. - // - // The nominal (not including the ghost zones) angular grid boundaries - // may coincide with grid points, or they may be at "half-integer" grid - // coordinates. That is, suppose we have a unit grid spacing, and a boundary - // at an angular coordinate of 0; then the grid may be either 0, 1, 2, ..., - // or 0.5, 1.5, 2.5, ... . - // - - class grid - : public grid_arrays - { - // - // ***** low-level access to coordinate maps ***** - // - public: - // direct (read-only) access to the underlying linear_map objects - // ... useful for (eg) passing to interpolators - const jtutil::linear_map &rho_map() const { return rho_map_; } - const jtutil::linear_map &sigma_map() const { return sigma_map_; } - const jtutil::linear_map &ang_map(bool want_rho) const - { - return want_rho ? rho_map() : sigma_map(); - } - - // - // ***** single-axis coordinate conversions ***** - // - public: - // ... angles in radians - fp rho_of_irho(int irho) const { return rho_map().fp_of_int(irho); } - fp sigma_of_isigma(int isigma) const - { - return sigma_map().fp_of_int(isigma); - } - fp ang_of_iang(bool want_rho, int iang) const - { - return want_rho ? rho_of_irho(iang) - : sigma_of_isigma(iang); - } - - fp fp_irho_of_rho(fp rho) const - { - return rho_map().fp_int_of_fp(rho); - } - int irho_of_rho(fp rho, jtutil::linear_map::noninteger_action - nia = jtutil::linear_map::nia_error) - const - { - return rho_map().int_of_fp(rho, nia); - } - fp fp_isigma_of_sigma(fp sigma) const - { - return sigma_map().fp_int_of_fp(sigma); - } - int isigma_of_sigma(fp sigma, jtutil::linear_map::noninteger_action - nia = jtutil::linear_map::nia_error) - const - { - return sigma_map().int_of_fp(sigma, nia); - } - fp fp_iang_of_ang(bool want_rho, fp ang) - const - { - return want_rho ? fp_irho_of_rho(ang) - : fp_isigma_of_sigma(ang); - } - int iang_of_ang(bool want_rho, - fp ang, jtutil::linear_map::noninteger_action nia = jtutil::linear_map::nia_error) - const - { - return want_rho ? irho_of_rho(ang, nia) - : isigma_of_sigma(ang, nia); - } - - // ... angles in degrees - fp rho_of_drho(fp drho) const - { - return jtutil::radians_of_degrees(drho); - } - fp sigma_of_dsigma(fp dsigma) const - { - return jtutil::radians_of_degrees(dsigma); - } - fp drho_of_rho(fp rho) const - { - return jtutil::degrees_of_radians(rho); - } - fp dsigma_of_sigma(fp sigma) const - { - return jtutil::degrees_of_radians(sigma); - } - fp drho_of_irho(int irho) const - { - return jtutil::degrees_of_radians(rho_of_irho(irho)); - } - fp dsigma_of_isigma(int isigma) const - { - return jtutil::degrees_of_radians(sigma_of_isigma(isigma)); - } - - int irho_of_drho(fp drho, jtutil::linear_map::noninteger_action - nia = jtutil::linear_map::nia_error) - const - { - return irho_of_rho(jtutil::radians_of_degrees(drho), nia); - } - int isigma_of_dsigma(fp dsigma, - jtutil::linear_map::noninteger_action - nia = jtutil::linear_map::nia_error) - const - { - return isigma_of_sigma(jtutil::radians_of_degrees(dsigma), nia); - } - - // - // ***** grid info ***** - // - public: - // grid spacings - fp delta_rho() const { return rho_map().delta_fp(); } - fp delta_sigma() const { return sigma_map().delta_fp(); } - fp delta_drho() const - { - return jtutil::degrees_of_radians(delta_rho()); - } - fp delta_dsigma() const - { - return jtutil::degrees_of_radians(delta_sigma()); - } - fp delta_ang(bool want_rho) const - { - return want_rho ? delta_rho() : delta_sigma(); - } - fp delta_dang(bool want_rho) const - { - return want_rho ? delta_drho() : delta_dsigma(); - } - - // inverse grid spacings - fp inverse_delta_rho() const { return rho_map().inverse_delta_fp(); } - fp inverse_delta_sigma() const - { - return sigma_map().inverse_delta_fp(); - } - - // nominal grid min/max - fp min_rho() const { return min_rho_; } - fp max_rho() const { return max_rho_; } - fp min_sigma() const { return min_sigma_; } - fp max_sigma() const { return max_sigma_; } - fp minmax_ang(bool want_min, bool want_rho) const - { - return want_min ? (want_rho ? min_rho() : min_sigma()) - : (want_rho ? max_rho() : max_sigma()); - } - fp min_drho() const { return jtutil::degrees_of_radians(min_rho()); } - fp max_drho() const { return jtutil::degrees_of_radians(max_rho()); } - fp min_dsigma() const - { - return jtutil::degrees_of_radians(min_sigma()); - } - fp max_dsigma() const - { - return jtutil::degrees_of_radians(max_sigma()); - } - fp min_dang(bool want_rho) const - { - return want_rho ? min_drho() : min_dsigma(); - } - fp max_dang(bool want_rho) const - { - return want_rho ? max_drho() : max_dsigma(); - } - - // ghosted-grid min/max - fp ghosted_min_rho() const - { - return rho_of_irho(ghosted_min_irho()); - } - fp ghosted_max_rho() const - { - return rho_of_irho(ghosted_max_irho()); - } - fp ghosted_min_sigma() const - { - return sigma_of_isigma(ghosted_min_isigma()); - } - fp ghosted_max_sigma() const - { - return sigma_of_isigma(ghosted_max_isigma()); - } - - // is a given (drho,dsigma) within the grid? - bool is_valid_drho(fp drho) const - { - return jtutil::fuzzy::GE(drho, min_drho()) && jtutil::fuzzy::LE(drho, max_drho()); - } - bool is_valid_dsigma(fp dsigma) const - { - return jtutil::fuzzy::GE(dsigma, min_dsigma()) && jtutil::fuzzy::LE(dsigma, max_dsigma()); - } - - // reduce a rho/sigma coordinate modulo 2*pi radians (360 degrees) - // to be within the ghosted grid, - // or error_exit() if no such value exists - fp modulo_reduce_rho(fp rho_in) const - { - return local_coords ::modulo_reduce_ang(rho_in, ghosted_min_rho(), - ghosted_max_rho()); - } - fp modulo_reduce_sigma(fp sigma_in) const - { - return local_coords ::modulo_reduce_ang(sigma_in, ghosted_min_sigma(), - ghosted_max_sigma()); - } - fp modulo_reduce_ang(bool want_rho, fp ang_in) const - { - return want_rho ? modulo_reduce_rho(ang_in) - : modulo_reduce_sigma(ang_in); - } - - // - // ***** misc stuff ***** - // - public: - // human-readable names for the sides (for debugging) - static const char *ang_name(bool want_rho) - { - return want_rho ? "rho" : "sigma"; - } - static const char *dang_name(bool want_rho) - { - return want_rho ? "drho" : "dsigma"; - } - - // - // ***** argument structure for constructor ***** - // - - // this structure bundles related arguments together so we don't - // have 20+ (!) separate arguments to our top-level constructors - struct grid_pars // *** note angles in degrees *** - { - fp min_drho, delta_drho, max_drho; - fp min_dsigma, delta_dsigma, max_dsigma; - }; - - // - // ***** constructor, destructor ***** - // - grid(const grid_array_pars &grid_array_pars_in, - const grid_pars &grid_pars_in); - // compiler-generated default destructor is ok - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - grid(const grid &rhs); - grid &operator=(const grid &rhs); - - private: - // range of these is the full grid (including ghost zones) - const jtutil::linear_map rho_map_, sigma_map_; - - // angular boundaries of nominal grid - const fp min_rho_, max_rho_; - const fp min_sigma_, max_sigma_; - }; - - //****************************************************************************** - -} // namespace AHFinderDirect -#endif /* TGRID_H */ +#ifndef TGRID_H +#define TGRID_H +namespace AHFinderDirect +{ + + //***************************************************************************** + + // + // grid_arrays - data arrays for a 2D tensor-product grid + // + // This is a helper class for class grid (below). This class stores + // most of the actual grid function (gridfn) data arrays for a uniform + // tensor-product 2D grid. + // + // The integer grid coordinates are (irho,isigma). This class deals + // with the grid solely at the level of arrays with integer subscripts; + // the derived class grid deals with the floating-point coordinates + // related to those subscripts. + // + // The grid has a nominal extent, surrounded by "ghost zones" on each + // side for finite differencing purposes. + // + // There are separate sets of nominal-grid and ghosted-grid gridfns. + // We identify a gridfn by a small-integer "grid function number", a.k.a. + // "gfn". There are separate gfns for nominal and ghosted gridfns. + // In a very few places we refer to "unknown-grid" gridfns; these might + // be either nominal-grid or ghosted-grid. + // + // For our application (apparent horizon finding), it's useful for the + // storage for a single gridfn to be contiguous *across all patches*. + // (Note this means that the set of all our gridfns is *not* contiguous!) + // To accomplish this, we don't allocate the gridfns when we're created, + // but rather later, with a separate call setup_gridfn_storage() . + // This way higher-level code can first create all patches, then count + // the total amount of storage used, allocate it, then finally call each + // patch again to set up its gridfns appropriately. + // + + class grid_arrays + { + public: + // + // ***** {min,max}_{rho,sigma} "sides" of grid ***** + // + + // + // A grid has 4 (angular) "sides", which we identify as + // {min,max}_{rho,sigma}. Given a side, we define coordinates + // (perpendicular,parallel) to it, normally abbreviated to + // (perp,par). + // + // As well as functions directly referring to a specific side, + // we also support referring to one of these chosen at run-time, + // via Boolean flags: + // + // // generic (irho,isigma) coordinate + // iang = want_rho ? irho : isigma + // + // // opposite (irho,isigma) coordinate + // ixang = want_rho ? isigma : irho + // + // // generic (min,max) direction + // minmax = want_min ? min : max + // + // FIXME: This system of Boolean flags works ok, but it requires + // a lot of repetitive code conditional-expression functions + // in this class. Is there a cleaner solution? + + // there are precisely this many possible sides + enum + { + N_sides = 4 + }; + + // we specify {min,max} with a Boolean want_min + // ... values for want_min + // FIXME: these should really be bool, but then we couldn't + // use the "enum hack" for in-class constants + enum + { + side_is_min = true, + side_is_max = false + }; + + // we specify {rho,sigma} with a Boolean want_rho + // ... values for wanr_rho + // FIXME: these should really be bool, but then we couldn't + // use the "enum hack" for in-class constants + enum + { + side_is_rho = true, + side_is_sigma = false + }; + + // human-readable names for the sides (for debugging) + static const char *minmax_name(bool minmax) + { + return minmax ? "min" : "max"; + } + static const char *iang_name(bool want_rho) + { + return want_rho ? "irho" : "isigma"; + } + + // + // ***** array info ***** + // + public: + // nominal-grid min/max/sizes + int min_irho() const { return min_irho_; } + int max_irho() const { return max_irho_; } + int min_isigma() const { return min_isigma_; } + int max_isigma() const { return max_isigma_; } + int min_iang(bool want_rho) const + { + return want_rho ? min_irho() : min_isigma(); + } + int max_iang(bool want_rho) const + { + return want_rho ? max_irho() : max_isigma(); + } + int minmax_iang(bool want_min, bool want_rho) const + { + return want_min ? min_iang(want_rho) : max_iang(want_rho); + } + int N_irho() const + { + return jtutil::how_many_in_range(min_irho(), max_irho()); + } + int N_isigma() const + { + return jtutil::how_many_in_range(min_isigma(), max_isigma()); + } + int N_grid_points() const + { + return N_irho() * N_isigma(); + } + + // ghosted-grid min/max/sizes + int ghosted_min_irho() const { return ghosted_min_irho_; } + int ghosted_max_irho() const { return ghosted_max_irho_; } + int ghosted_min_isigma() const + { + return ghosted_min_isigma_; + } + int ghosted_max_isigma() const + { + return ghosted_max_isigma_; + } + int ghosted_min_iang(bool want_rho) const + { + return want_rho ? ghosted_min_irho() + : ghosted_min_isigma(); + } + int ghosted_max_iang(bool want_rho) const + { + return want_rho ? ghosted_max_irho() + : ghosted_max_isigma(); + } + int ghosted_minmax_iang(bool want_min, bool want_rho) const + { + return want_min ? ghosted_min_iang(want_rho) + : ghosted_max_iang(want_rho); + } + int ghosted_N_irho() const + { + return jtutil::how_many_in_range(ghosted_min_irho(), + ghosted_max_irho()); + } + int ghosted_N_isigma() const + { + return jtutil::how_many_in_range(ghosted_min_isigma(), + ghosted_max_isigma()); + } + int ghosted_N_grid_points() const + { + return ghosted_N_irho() * ghosted_N_isigma(); + } + + // "effective" grid min/max/sizes + // (= dynamic select between nominal and full grids) + int effective_min_irho(bool want_ghost_zones) const + { + return want_ghost_zones ? ghosted_min_irho() : min_irho(); + } + int effective_max_irho(bool want_ghost_zones) const + { + return want_ghost_zones ? ghosted_max_irho() : max_irho(); + } + int effective_min_isigma(bool want_ghost_zones) const + { + return want_ghost_zones ? ghosted_min_isigma() : min_isigma(); + } + int effective_max_isigma(bool want_ghost_zones) const + { + return want_ghost_zones ? ghosted_max_isigma() : max_isigma(); + } + int effective_N_irho(bool want_ghost_zones) const + { + return want_ghost_zones ? ghosted_N_irho() : N_irho(); + } + int effective_N_isigma(bool want_ghost_zones) const + { + return want_ghost_zones ? ghosted_N_isigma() : N_isigma(); + } + + // + // ***** ghost zones ***** + // + public: + // ghost zone min/max perpendicular coordinates + int min_rho_ghost_zone__min_iperp() const + { + return ghosted_min_irho(); + } + int min_rho_ghost_zone__max_iperp() const + { + return min_irho() - 1; + } + int max_rho_ghost_zone__min_iperp() const + { + return max_irho() + 1; + } + int max_rho_ghost_zone__max_iperp() const + { + return ghosted_max_irho(); + } + int min_sigma_ghost_zone__min_iperp() const + { + return ghosted_min_isigma(); + } + int min_sigma_ghost_zone__max_iperp() const + { + return min_isigma() - 1; + } + int max_sigma_ghost_zone__min_iperp() const + { + return max_isigma() + 1; + } + int max_sigma_ghost_zone__max_iperp() const + { + return ghosted_max_isigma(); + } + int minmax_ang_ghost_zone__min_iperp(bool want_min, bool want_rho) const + { + return want_min + ? (want_rho ? min_rho_ghost_zone__min_iperp() + : min_sigma_ghost_zone__min_iperp()) + : (want_rho ? max_rho_ghost_zone__min_iperp() + : max_sigma_ghost_zone__min_iperp()); + } + int minmax_ang_ghost_zone__max_iperp(bool want_min, bool want_rho) const + { + return want_min + ? (want_rho ? min_rho_ghost_zone__max_iperp() + : min_sigma_ghost_zone__max_iperp()) + : (want_rho ? max_rho_ghost_zone__max_iperp() + : max_sigma_ghost_zone__max_iperp()); + } + + // ghost zone min/max parallel coordinates + // ... not including corners + int rho_ghost_zone_without_corners__min_ipar() const + { + return min_isigma(); + } + int rho_ghost_zone_without_corners__max_ipar() const + { + return max_isigma(); + } + int sigma_ghost_zone_without_corners__min_ipar() const + { + return min_irho(); + } + int sigma_ghost_zone_without_corners__max_ipar() const + { + return max_irho(); + } + int ang_ghost_zone_without_corners__min_ipar(bool want_rho) const + { + return want_rho ? rho_ghost_zone_without_corners__min_ipar() + : sigma_ghost_zone_without_corners__min_ipar(); + } + int ang_ghost_zone_without_corners__max_ipar(bool want_rho) const + { + return want_rho ? rho_ghost_zone_without_corners__max_ipar() + : sigma_ghost_zone_without_corners__max_ipar(); + } + // ... including corners + int rho_ghost_zone_with_corners__min_ipar() const + { + return ghosted_min_isigma(); + } + int rho_ghost_zone_with_corners__max_ipar() const + { + return ghosted_max_isigma(); + } + int sigma_ghost_zone_with_corners__min_ipar() const + { + return ghosted_min_irho(); + } + int sigma_ghost_zone_with_corners__max_ipar() const + { + return ghosted_max_irho(); + } + int ang_ghost_zone_with_corners__min_ipar(bool want_rho) const + { + return want_rho ? rho_ghost_zone_with_corners__min_ipar() + : sigma_ghost_zone_with_corners__min_ipar(); + } + int ang_ghost_zone_with_corners__max_ipar(bool want_rho) const + { + return want_rho ? rho_ghost_zone_with_corners__max_ipar() + : sigma_ghost_zone_with_corners__max_ipar(); + } + + // + // ***** grid-point validity and membership predicates ***** + // + public: + bool is_valid_irho(int irho) const + { + return (irho >= min_irho()) && (irho <= max_irho()); + } + bool is_valid_isigma(int isigma) const + { + return (isigma >= min_isigma()) && (isigma <= max_isigma()); + } + bool is_in_nominal_grid(int irho, int isigma) const + { + return is_valid_irho(irho) && is_valid_isigma(isigma); + } + + bool is_valid_ghosted_irho(int irho) const + { + return (irho >= ghosted_min_irho()) && (irho <= ghosted_max_irho()); + } + bool is_valid_ghosted_isigma(int isigma) const + { + return (isigma >= ghosted_min_isigma()) && (isigma <= ghosted_max_isigma()); + } + bool is_in_ghosted_grid(int irho, int isigma) const + { + return is_valid_ghosted_irho(irho) && is_valid_ghosted_isigma(isigma); + } + + bool is_in_ghost_zone(int irho, int isigma) const + { + return is_in_ghosted_grid(irho, isigma) && !is_in_nominal_grid(irho, isigma); + } + + // + // ***** gfn ranges and validity predicates ***** + // + public: + // gfn ranges + int min_gfn() const + { + assert(gridfn_data_ != NULL); + return (*gridfn_data_).min_i(); + } + int max_gfn() const + { + assert(gridfn_data_ != NULL); + return (*gridfn_data_).max_i(); + } + int N_gridfns() const + { + return jtutil::how_many_in_range(min_gfn(), max_gfn()); + } + int ghosted_min_gfn() const + { + assert(ghosted_gridfn_data_ != NULL); + return (*ghosted_gridfn_data_).min_i(); + } + int ghosted_max_gfn() const + { + assert(ghosted_gridfn_data_ != NULL); + return (*ghosted_gridfn_data_).max_i(); + } + int ghosted_N_gridfns() const + { + return jtutil::how_many_in_range(ghosted_min_gfn(), + ghosted_max_gfn()); + } + + // gfn validity predicates + bool is_valid_gfn(int gfn) const + { + return (gfn >= min_gfn()) && (gfn <= max_gfn()); + } + bool is_valid_ghosted_gfn(int gfn) const + { + return (gfn >= ghosted_min_gfn()) && (gfn <= ghosted_max_gfn()); + } + + // + // ***** gridfns ***** + // + // n.b. access to rvalue gridfn data must be via references + // in order to allow using gridfn(...) as the operand + // of a unary & (address-of) operator + // + public: + // access to nominal-grid gridfn data + // ... rvalue + const fp &gridfn(int gfn, int irho, int isigma) const + { + assert(gridfn_data_ != NULL); + return (*gridfn_data_)(gfn, irho, isigma); + } + // ... lvalue + fp &gridfn(int gfn, int irho, int isigma) + { + assert(gridfn_data_ != NULL); + return (*gridfn_data_)(gfn, irho, isigma); + } + + // access to ghosted-grid gridfn data + // ... rvalue + const fp &ghosted_gridfn(int gfn, int irho, int isigma) const + { + assert(gridfn_data_ != NULL); + return (*ghosted_gridfn_data_)(gfn, irho, isigma); + } + // ... lvalue + fp &ghosted_gridfn(int gfn, int irho, int isigma) + { + assert(gridfn_data_ != NULL); + return (*ghosted_gridfn_data_)(gfn, irho, isigma); + } + + // access to unknown-grid gridfn data + // (either nominal or ghosted, depending on Boolean flag) + // ... rvalue + const fp &unknown_gridfn(bool ghosted_flag, + int unknown_gfn, int irho, int isigma) + const + { + return ghosted_flag ? ghosted_gridfn(unknown_gfn, irho, isigma) + : gridfn(unknown_gfn, irho, isigma); + } + // ... lvalue + fp &unknown_gridfn(bool ghosted_flag, + int unknown_gfn, int irho, int isigma) + { + return ghosted_flag ? ghosted_gridfn(unknown_gfn, irho, isigma) + : gridfn(unknown_gfn, irho, isigma); + } + + // subscripting info + int gfn_stride() const + { + assert(gridfn_data_ != NULL); + return gridfn_data_->subscript_stride_i(); + } + int irho_stride() const + { + assert(gridfn_data_ != NULL); + return gridfn_data_->subscript_stride_j(); + } + int isigma_stride() const + { + assert(gridfn_data_ != NULL); + return gridfn_data_->subscript_stride_k(); + } + int iang_stride(bool want_rho) const + { + return want_rho ? irho_stride() : isigma_stride(); + } + int ghosted_gfn_stride() const + { + assert(ghosted_gridfn_data_ != NULL); + return ghosted_gridfn_data_->subscript_stride_i(); + } + int ghosted_irho_stride() const + { + assert(ghosted_gridfn_data_ != NULL); + return ghosted_gridfn_data_->subscript_stride_j(); + } + int ghosted_isigma_stride() const + { + assert(ghosted_gridfn_data_ != NULL); + return ghosted_gridfn_data_->subscript_stride_k(); + } + int ghosted_iang_stride(bool want_rho) const + { + return want_rho ? ghosted_irho_stride() + : ghosted_isigma_stride(); + } + + // validity predicates for 1-D 0-origin grid point number (gpn) + bool is_valid_gpn(int gpn) const + { + return (gpn >= 0) && (gpn < N_grid_points()); + } + bool is_valid_ghosted_gpn(int gpn) const + { + return (gpn >= 0) && (gpn < ghosted_N_grid_points()); + } + + // convert (irho,isigma) <--> 1-D 0-origin grid point number (gpn) + int gpn_of_irho_isigma(int irho, int isigma) const + { + assert(is_valid_irho(irho)); + assert(is_valid_isigma(isigma)); + + return (irho - min_irho()) * irho_stride() + (isigma - min_isigma()) * isigma_stride(); + } + int ghosted_gpn_of_irho_isigma(int irho, int isigma) const + { + assert(is_valid_ghosted_irho(irho)); + assert(is_valid_ghosted_isigma(isigma)); + return (irho - ghosted_min_irho()) * ghosted_irho_stride() + (isigma - ghosted_min_isigma()) * ghosted_isigma_stride(); + } + // ... current implementation assumes (& verifies) isigma is contiguous + void irho_isigma_of_gpn(int gpn, int &irho, int &isigma) const + { + assert(is_valid_gpn(gpn)); + assert(isigma_stride() == 1); // implementation restriction + irho = min_irho() + gpn / N_isigma(); + isigma = min_isigma() + gpn % N_isigma(); + assert(is_valid_irho(irho)); + assert(is_valid_isigma(isigma)); + } + // ... current implementation assumes (& verifies) isigma is contiguous + void ghosted_irho_isigma_of_gpn(int gpn, int &irho, int &isigma) const + { + assert(is_valid_ghosted_gpn(gpn)); + assert(ghosted_isigma_stride() == 1); // implementation + // restriction + irho = ghosted_min_irho() + gpn / ghosted_N_isigma(); + isigma = ghosted_min_isigma() + gpn % ghosted_N_isigma(); + assert(is_valid_ghosted_irho(irho)); + assert(is_valid_ghosted_isigma(isigma)); + } + + // low-level access to data arrays (!!dangerous!!) + const fp *gridfn_data_array(int gfn) const + { + return &gridfn(gfn, min_irho(), min_isigma()); + } + fp *gridfn_data_array(int gfn) + { + return &gridfn(gfn, min_irho(), min_isigma()); + } + const fp *ghosted_gridfn_data_array(int ghosted_gfn) const + { + return &ghosted_gridfn(ghosted_gfn, ghosted_min_irho(), + ghosted_min_isigma()); + } + fp *ghosted_gridfn_data_array(int ghosted_gfn) + { + return &ghosted_gridfn(ghosted_gfn, ghosted_min_irho(), + ghosted_min_isigma()); + } + + // + // ***** argument structures for constructor et al ***** + // + public: + // these structures bundle related arguments together so we don't + // have 20+ (!) separate arguments to our top-level constructors + struct grid_array_pars + { + int min_irho, max_irho; + int min_isigma, max_isigma; + int min_rho_ghost_zone_width, max_rho_ghost_zone_width; + int min_sigma_ghost_zone_width, max_sigma_ghost_zone_width; + }; + struct gridfn_pars + { + int min_gfn, max_gfn; + + // gridfn storage will be automatically allocated + // if pointer is NULL; any 0 strides are automatically + // set to C-style row-major subscripting + fp *storage_array; + int gfn_stride, irho_stride, isigma_stride; + }; + + // + // ***** constructor, gridfn setup, destructor ***** + // + public: + // construct with no gridfns + grid_arrays(const grid_array_pars &grid_array_pars_in); + + // set up storage for gridfns + void setup_gridfn_storage(const gridfn_pars &gridfn_pars_in, + const gridfn_pars &ghosted_gridfn_pars_in); + + ~grid_arrays(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + grid_arrays(const grid_arrays &rhs); + grid_arrays &operator=(const grid_arrays &rhs); + + private: + // + // ***** the actual gridfn storage arrays ***** + // + // n.b. these pointers are *first* data member in this class + // ==> possibly slightly faster access (0 offset from pointer) + // ... indices are (gfn, irho, isigma) + jtutil::array3d *gridfn_data_; + jtutil::array3d *ghosted_gridfn_data_; + + // gfn bounds + const int min_gfn_, max_gfn_; + const int ghosted_min_gfn_, ghosted_max_gfn_; + + // nominal grid min/max bounds + const int min_irho_, max_irho_; + const int min_isigma_, max_isigma_; + + // full grid min/max bounds + const int ghosted_min_irho_, ghosted_max_irho_; + const int ghosted_min_isigma_, ghosted_max_isigma_; + }; + + //****************************************************************************** + + // + // grid - uniform 2D tensor-product grid + // + // The grid is uniform in the floating point grid coordinates (rho,sigma). + // There is also some (limited) support for expressing these coordinates + // in degrees (drho,dsigma); this is useful for humans trying to specify + // things in parameter files. + // + // The nominal (not including the ghost zones) angular grid boundaries + // may coincide with grid points, or they may be at "half-integer" grid + // coordinates. That is, suppose we have a unit grid spacing, and a boundary + // at an angular coordinate of 0; then the grid may be either 0, 1, 2, ..., + // or 0.5, 1.5, 2.5, ... . + // + + class grid + : public grid_arrays + { + // + // ***** low-level access to coordinate maps ***** + // + public: + // direct (read-only) access to the underlying linear_map objects + // ... useful for (eg) passing to interpolators + const jtutil::linear_map &rho_map() const { return rho_map_; } + const jtutil::linear_map &sigma_map() const { return sigma_map_; } + const jtutil::linear_map &ang_map(bool want_rho) const + { + return want_rho ? rho_map() : sigma_map(); + } + + // + // ***** single-axis coordinate conversions ***** + // + public: + // ... angles in radians + fp rho_of_irho(int irho) const { return rho_map().fp_of_int(irho); } + fp sigma_of_isigma(int isigma) const + { + return sigma_map().fp_of_int(isigma); + } + fp ang_of_iang(bool want_rho, int iang) const + { + return want_rho ? rho_of_irho(iang) + : sigma_of_isigma(iang); + } + + fp fp_irho_of_rho(fp rho) const + { + return rho_map().fp_int_of_fp(rho); + } + int irho_of_rho(fp rho, jtutil::linear_map::noninteger_action + nia = jtutil::linear_map::nia_error) + const + { + return rho_map().int_of_fp(rho, nia); + } + fp fp_isigma_of_sigma(fp sigma) const + { + return sigma_map().fp_int_of_fp(sigma); + } + int isigma_of_sigma(fp sigma, jtutil::linear_map::noninteger_action + nia = jtutil::linear_map::nia_error) + const + { + return sigma_map().int_of_fp(sigma, nia); + } + fp fp_iang_of_ang(bool want_rho, fp ang) + const + { + return want_rho ? fp_irho_of_rho(ang) + : fp_isigma_of_sigma(ang); + } + int iang_of_ang(bool want_rho, + fp ang, jtutil::linear_map::noninteger_action nia = jtutil::linear_map::nia_error) + const + { + return want_rho ? irho_of_rho(ang, nia) + : isigma_of_sigma(ang, nia); + } + + // ... angles in degrees + fp rho_of_drho(fp drho) const + { + return jtutil::radians_of_degrees(drho); + } + fp sigma_of_dsigma(fp dsigma) const + { + return jtutil::radians_of_degrees(dsigma); + } + fp drho_of_rho(fp rho) const + { + return jtutil::degrees_of_radians(rho); + } + fp dsigma_of_sigma(fp sigma) const + { + return jtutil::degrees_of_radians(sigma); + } + fp drho_of_irho(int irho) const + { + return jtutil::degrees_of_radians(rho_of_irho(irho)); + } + fp dsigma_of_isigma(int isigma) const + { + return jtutil::degrees_of_radians(sigma_of_isigma(isigma)); + } + + int irho_of_drho(fp drho, jtutil::linear_map::noninteger_action + nia = jtutil::linear_map::nia_error) + const + { + return irho_of_rho(jtutil::radians_of_degrees(drho), nia); + } + int isigma_of_dsigma(fp dsigma, + jtutil::linear_map::noninteger_action + nia = jtutil::linear_map::nia_error) + const + { + return isigma_of_sigma(jtutil::radians_of_degrees(dsigma), nia); + } + + // + // ***** grid info ***** + // + public: + // grid spacings + fp delta_rho() const { return rho_map().delta_fp(); } + fp delta_sigma() const { return sigma_map().delta_fp(); } + fp delta_drho() const + { + return jtutil::degrees_of_radians(delta_rho()); + } + fp delta_dsigma() const + { + return jtutil::degrees_of_radians(delta_sigma()); + } + fp delta_ang(bool want_rho) const + { + return want_rho ? delta_rho() : delta_sigma(); + } + fp delta_dang(bool want_rho) const + { + return want_rho ? delta_drho() : delta_dsigma(); + } + + // inverse grid spacings + fp inverse_delta_rho() const { return rho_map().inverse_delta_fp(); } + fp inverse_delta_sigma() const + { + return sigma_map().inverse_delta_fp(); + } + + // nominal grid min/max + fp min_rho() const { return min_rho_; } + fp max_rho() const { return max_rho_; } + fp min_sigma() const { return min_sigma_; } + fp max_sigma() const { return max_sigma_; } + fp minmax_ang(bool want_min, bool want_rho) const + { + return want_min ? (want_rho ? min_rho() : min_sigma()) + : (want_rho ? max_rho() : max_sigma()); + } + fp min_drho() const { return jtutil::degrees_of_radians(min_rho()); } + fp max_drho() const { return jtutil::degrees_of_radians(max_rho()); } + fp min_dsigma() const + { + return jtutil::degrees_of_radians(min_sigma()); + } + fp max_dsigma() const + { + return jtutil::degrees_of_radians(max_sigma()); + } + fp min_dang(bool want_rho) const + { + return want_rho ? min_drho() : min_dsigma(); + } + fp max_dang(bool want_rho) const + { + return want_rho ? max_drho() : max_dsigma(); + } + + // ghosted-grid min/max + fp ghosted_min_rho() const + { + return rho_of_irho(ghosted_min_irho()); + } + fp ghosted_max_rho() const + { + return rho_of_irho(ghosted_max_irho()); + } + fp ghosted_min_sigma() const + { + return sigma_of_isigma(ghosted_min_isigma()); + } + fp ghosted_max_sigma() const + { + return sigma_of_isigma(ghosted_max_isigma()); + } + + // is a given (drho,dsigma) within the grid? + bool is_valid_drho(fp drho) const + { + return jtutil::fuzzy::GE(drho, min_drho()) && jtutil::fuzzy::LE(drho, max_drho()); + } + bool is_valid_dsigma(fp dsigma) const + { + return jtutil::fuzzy::GE(dsigma, min_dsigma()) && jtutil::fuzzy::LE(dsigma, max_dsigma()); + } + + // reduce a rho/sigma coordinate modulo 2*pi radians (360 degrees) + // to be within the ghosted grid, + // or error_exit() if no such value exists + fp modulo_reduce_rho(fp rho_in) const + { + return local_coords ::modulo_reduce_ang(rho_in, ghosted_min_rho(), + ghosted_max_rho()); + } + fp modulo_reduce_sigma(fp sigma_in) const + { + return local_coords ::modulo_reduce_ang(sigma_in, ghosted_min_sigma(), + ghosted_max_sigma()); + } + fp modulo_reduce_ang(bool want_rho, fp ang_in) const + { + return want_rho ? modulo_reduce_rho(ang_in) + : modulo_reduce_sigma(ang_in); + } + + // + // ***** misc stuff ***** + // + public: + // human-readable names for the sides (for debugging) + static const char *ang_name(bool want_rho) + { + return want_rho ? "rho" : "sigma"; + } + static const char *dang_name(bool want_rho) + { + return want_rho ? "drho" : "dsigma"; + } + + // + // ***** argument structure for constructor ***** + // + + // this structure bundles related arguments together so we don't + // have 20+ (!) separate arguments to our top-level constructors + struct grid_pars // *** note angles in degrees *** + { + fp min_drho, delta_drho, max_drho; + fp min_dsigma, delta_dsigma, max_dsigma; + }; + + // + // ***** constructor, destructor ***** + // + grid(const grid_array_pars &grid_array_pars_in, + const grid_pars &grid_pars_in); + // compiler-generated default destructor is ok + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + grid(const grid &rhs); + grid &operator=(const grid &rhs); + + private: + // range of these is the full grid (including ghost zones) + const jtutil::linear_map rho_map_, sigma_map_; + + // angular boundaries of nominal grid + const fp min_rho_, max_rho_; + const fp min_sigma_, max_sigma_; + }; + + //****************************************************************************** + +} // namespace AHFinderDirect +#endif /* TGRID_H */ diff --git a/AMSS_NCKU_source/util.h b/AMSS_NCKU_source/AHF_Direct/util.h similarity index 96% rename from AMSS_NCKU_source/util.h rename to AMSS_NCKU_source/AHF_Direct/util.h index aabb4ac..c73d328 100644 --- a/AMSS_NCKU_source/util.h +++ b/AMSS_NCKU_source/AHF_Direct/util.h @@ -1,157 +1,157 @@ -#ifndef AHFINDERDIRECT__UTIL_HH -#define AHFINDERDIRECT__UTIL_HH -#ifdef newc -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#endif - -#define PI M_PI - -namespace AHFinderDirect -{ - namespace jtutil - { - inline int how_many_in_range(int low, int high) { return high - low + 1; } - - inline int is_even(int i) { return !(i & 0x1); } - inline int is_odd(int i) { return (i & 0x1); } - - template - inline T tmin(T x, T y) { return (x < y) ? x : y; } - template - inline T tmax(T x, T y) { return (x > y) ? x : y; } - template - inline T abs(T x) { return (x > 0) ? x : -x; } - - template - inline T pow2(T x) { return x * x; } - template - inline T pow3(T x) { return x * x * x; } - template - inline T pow4(T x) { return pow2(pow2(x)); } - - template - inline fp_t degrees_of_radians(fp_t radians) { return (180.0 / PI) * radians; } - template - inline fp_t radians_of_degrees(fp_t degrees) { return (PI / 180.0) * degrees; } - - // in miscfp.cc - //----------------------------------------------------- - double signum(double x); - double hypot3(double x, double y, double z); - double arctan_xy(double x, double y); - - double modulo_reduce(double x, double xmod, double xmin, double xmax); - - template - void zero_C_array(int N, fp_t array[]); - - // in error_exit.cc - // ------------------------------------------------------ - int error_exit(int msg_level, const char *format, ...); - - // in norm.cc - // - template - class norm - { - public: - // get norms etc - fp_t mean() const; - fp_t two_norm() const; // sqrt(sum x_i^2) - fp_t rms_norm() const; // sqrt(average of x_i^2) - fp_t infinity_norm() const { return max_abs_value_; } - - fp_t max_abs_value() const { return max_abs_value_; } - fp_t min_abs_value() const { return min_abs_value_; } - - fp_t max_value() const { return max_value_; } - fp_t min_value() const { return min_value_; } - - // specify data point - void data(fp_t x); - - // have any data points been specified? - bool is_empty() const { return N_ == 0; } - bool is_nonempty() const { return N_ > 0; } - - // reset ==> just like newly-constructed object - void reset(); - - // constructor, destructor - // ... compiler-generated no-op destructor is ok - norm(); - - private: - // we forbid copying and passing by value - // by declaring the copy constructor and assignment operator - // private, but never defining them - norm(const norm &rhs); - norm &operator=(const norm &rhs); - - private: - long N_; // # of data points - fp_t sum_; // sum(data) - fp_t sum2_; // sum(data^2) - fp_t max_abs_value_; // max |data| - fp_t min_abs_value_; // min |data| - fp_t max_value_; // max data - fp_t min_value_; // min data - }; - - // in fuzzy.cc - template - class fuzzy - { - public: - // comparison tolerance (may be modified by user code if needed) - static fp_t get_tolerance() { return tolerance_; } - static void set_tolerance(fp_t new_tolerance) - { - tolerance_ = new_tolerance; - } - - // fuzzy commparisons - static bool EQ(fp_t x, fp_t y); - static bool NE(fp_t x, fp_t y) { return !EQ(x, y); } - static bool LT(fp_t x, fp_t y) { return EQ(x, y) ? false : (x < y); } - static bool LE(fp_t x, fp_t y) { return EQ(x, y) ? true : (x < y); } - static bool GT(fp_t x, fp_t y) { return EQ(x, y) ? false : (x > y); } - static bool GE(fp_t x, fp_t y) { return EQ(x, y) ? true : (x > y); } - - static bool is_integer(fp_t x); // is x fuzzily an integer? - static int floor(fp_t x); // round x fuzzily down to integer - static int ceiling(fp_t x); // round x fuzzily up to integer - - private: - // comparison tolerance - // ... must be explicitly initialized when instantiating - // for a new type, see "fuzzy.cc" for details/examples - static fp_t tolerance_; - }; - - // in round.cc - template - class round - { - public: - static int to_integer(fp_t x); // round to nearest integer - - static int floor(fp_t x); // round down to integer - static int ceiling(fp_t x); // round up to integer - }; - - } // namespace jtutil -} // namespace AHFinderDirect - -#endif /* AHFINDERDIRECT__UTIL_HH */ +#ifndef AHFINDERDIRECT__UTIL_HH +#define AHFINDERDIRECT__UTIL_HH +#ifdef newc +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#endif + +#define PI M_PI + +namespace AHFinderDirect +{ + namespace jtutil + { + inline int how_many_in_range(int low, int high) { return high - low + 1; } + + inline int is_even(int i) { return !(i & 0x1); } + inline int is_odd(int i) { return (i & 0x1); } + + template + inline T tmin(T x, T y) { return (x < y) ? x : y; } + template + inline T tmax(T x, T y) { return (x > y) ? x : y; } + template + inline T abs(T x) { return (x > 0) ? x : -x; } + + template + inline T pow2(T x) { return x * x; } + template + inline T pow3(T x) { return x * x * x; } + template + inline T pow4(T x) { return pow2(pow2(x)); } + + template + inline fp_t degrees_of_radians(fp_t radians) { return (180.0 / PI) * radians; } + template + inline fp_t radians_of_degrees(fp_t degrees) { return (PI / 180.0) * degrees; } + + // in miscfp.cc + //----------------------------------------------------- + double signum(double x); + double hypot3(double x, double y, double z); + double arctan_xy(double x, double y); + + double modulo_reduce(double x, double xmod, double xmin, double xmax); + + template + void zero_C_array(int N, fp_t array[]); + + // in error_exit.cc + // ------------------------------------------------------ + int error_exit(int msg_level, const char *format, ...); + + // in norm.cc + // + template + class norm + { + public: + // get norms etc + fp_t mean() const; + fp_t two_norm() const; // sqrt(sum x_i^2) + fp_t rms_norm() const; // sqrt(average of x_i^2) + fp_t infinity_norm() const { return max_abs_value_; } + + fp_t max_abs_value() const { return max_abs_value_; } + fp_t min_abs_value() const { return min_abs_value_; } + + fp_t max_value() const { return max_value_; } + fp_t min_value() const { return min_value_; } + + // specify data point + void data(fp_t x); + + // have any data points been specified? + bool is_empty() const { return N_ == 0; } + bool is_nonempty() const { return N_ > 0; } + + // reset ==> just like newly-constructed object + void reset(); + + // constructor, destructor + // ... compiler-generated no-op destructor is ok + norm(); + + private: + // we forbid copying and passing by value + // by declaring the copy constructor and assignment operator + // private, but never defining them + norm(const norm &rhs); + norm &operator=(const norm &rhs); + + private: + long N_; // # of data points + fp_t sum_; // sum(data) + fp_t sum2_; // sum(data^2) + fp_t max_abs_value_; // max |data| + fp_t min_abs_value_; // min |data| + fp_t max_value_; // max data + fp_t min_value_; // min data + }; + + // in fuzzy.cc + template + class fuzzy + { + public: + // comparison tolerance (may be modified by user code if needed) + static fp_t get_tolerance() { return tolerance_; } + static void set_tolerance(fp_t new_tolerance) + { + tolerance_ = new_tolerance; + } + + // fuzzy commparisons + static bool EQ(fp_t x, fp_t y); + static bool NE(fp_t x, fp_t y) { return !EQ(x, y); } + static bool LT(fp_t x, fp_t y) { return EQ(x, y) ? false : (x < y); } + static bool LE(fp_t x, fp_t y) { return EQ(x, y) ? true : (x < y); } + static bool GT(fp_t x, fp_t y) { return EQ(x, y) ? false : (x > y); } + static bool GE(fp_t x, fp_t y) { return EQ(x, y) ? true : (x > y); } + + static bool is_integer(fp_t x); // is x fuzzily an integer? + static int floor(fp_t x); // round x fuzzily down to integer + static int ceiling(fp_t x); // round x fuzzily up to integer + + private: + // comparison tolerance + // ... must be explicitly initialized when instantiating + // for a new type, see "fuzzy.cc" for details/examples + static fp_t tolerance_; + }; + + // in round.cc + template + class round + { + public: + static int to_integer(fp_t x); // round to nearest integer + + static int floor(fp_t x); // round down to integer + static int ceiling(fp_t x); // round up to integer + }; + + } // namespace jtutil +} // namespace AHFinderDirect + +#endif /* AHFINDERDIRECT__UTIL_HH */ diff --git a/AMSS_NCKU_source/util_String.h b/AMSS_NCKU_source/AHF_Direct/util_String.h similarity index 96% rename from AMSS_NCKU_source/util_String.h rename to AMSS_NCKU_source/AHF_Direct/util_String.h index a1fa56b..79c7e1e 100644 --- a/AMSS_NCKU_source/util_String.h +++ b/AMSS_NCKU_source/AHF_Direct/util_String.h @@ -1,45 +1,45 @@ -#ifndef _UTIL_STRING_H_ -#define _UTIL_STRING_H_ 1 - -#include -#include - -#ifdef __cplusplus -extern "C" -{ -#endif - - const char *Util_StrSep(const char **stringp, - const char *delim); - - int Util_SplitString(char **before, - char **after, - const char *string, - const char *sep); - - int Util_SplitFilename(char **dir, - char **file, - const char *string); - - char *Util_Strdup(const char *s); - - size_t Util_Strlcpy(char *dst, const char *src, size_t dst_size); - size_t Util_Strlcat(char *dst, const char *src, size_t dst_size); - - int Util_StrCmpi(const char *string1, - const char *string2); - int Util_StrMemCmpi(const char *string1, - const char *string2, - size_t len2); - - int Util_vsnprintf(char *str, size_t count, const char *fmt, va_list args); - int Util_snprintf(char *str, size_t count, const char *fmt, ...); - - int Util_asprintf(char **buffer, const char *fmt, ...); - int Util_asnprintf(char **buffer, size_t size, const char *fmt, ...); - -#ifdef __cplusplus -} -#endif - -#endif /* _UTIL_STRING_H_ */ +#ifndef _UTIL_STRING_H_ +#define _UTIL_STRING_H_ 1 + +#include +#include + +#ifdef __cplusplus +extern "C" +{ +#endif + + const char *Util_StrSep(const char **stringp, + const char *delim); + + int Util_SplitString(char **before, + char **after, + const char *string, + const char *sep); + + int Util_SplitFilename(char **dir, + char **file, + const char *string); + + char *Util_Strdup(const char *s); + + size_t Util_Strlcpy(char *dst, const char *src, size_t dst_size); + size_t Util_Strlcat(char *dst, const char *src, size_t dst_size); + + int Util_StrCmpi(const char *string1, + const char *string2); + int Util_StrMemCmpi(const char *string1, + const char *string2, + size_t len2); + + int Util_vsnprintf(char *str, size_t count, const char *fmt, va_list args); + int Util_snprintf(char *str, size_t count, const char *fmt, ...); + + int Util_asprintf(char **buffer, const char *fmt, ...); + int Util_asnprintf(char **buffer, size_t size, const char *fmt, ...); + +#ifdef __cplusplus +} +#endif + +#endif /* _UTIL_STRING_H_ */ diff --git a/AMSS_NCKU_source/util_Table.h b/AMSS_NCKU_source/AHF_Direct/util_Table.h similarity index 97% rename from AMSS_NCKU_source/util_Table.h rename to AMSS_NCKU_source/AHF_Direct/util_Table.h index ca377d3..91ba759 100644 --- a/AMSS_NCKU_source/util_Table.h +++ b/AMSS_NCKU_source/AHF_Direct/util_Table.h @@ -1,496 +1,496 @@ -#ifndef _UTIL_TABLE_H_ -#define _UTIL_TABLE_H_ 1 - -#include "cctk_Types.h" - -#ifdef __cplusplus -extern "C" -{ -#endif - -/******************************************************************************/ -/***** Macros for Flags Word **************************************************/ -/******************************************************************************/ - -/* - * The hexadecimal forms are more convenient for thinking about - * bitwise-oring, but alas Fortran 77 doesn't seem to support - * hexadecimal constants, so we give the actual values in decimal. - */ - -/*@@ - @defines UTIL_TABLE_FLAGS_DEFAULT - @desc flags-word macro: no flags set (default) - @@*/ -#define UTIL_TABLE_FLAGS_DEFAULT 0 - -/*@@ - @defines UTIL_TABLE_FLAGS_CASE_INSENSITIVE - @desc flags-word macro: key comparisons are case-insensitive - @@*/ -#define UTIL_TABLE_FLAGS_CASE_INSENSITIVE 1 /* 0x1 */ - -/*@@ - @defines UTIL_TABLE_FLAGS_USER_DEFINED_BASE - @desc flags-word macro: user-defined flags word bit masks - should use only this and higher bit positions (i.e. - all bit positions below this one are reserved for - current or future Cactus use) - @@*/ -#define UTIL_TABLE_FLAGS_USER_DEFINED_BASE 65536 /* 0x10000 */ - -/******************************************************************************/ -/***** Error Codes ************************************************************/ -/******************************************************************************/ - -/* - * error codes specific to the table routines (between -100 and -199) - */ - -/*@@ - @defines UTIL_ERROR_TABLE_BAD_FLAGS - @desc error return code: flags word is invalid - @@*/ -#define UTIL_ERROR_TABLE_BAD_FLAGS (-100) - -/*@@ - @defines UTIL_ERROR_TABLE_BAD_KEY - @desc error return code: key contains '/' character - or is otherwise invalid - @@*/ -#define UTIL_ERROR_TABLE_BAD_KEY (-101) - -/*@@ - @defines UTIL_ERROR_TABLE_STRING_TRUNCATED - @desc error return code: string was truncated to fit in buffer - @@*/ -#define UTIL_ERROR_TABLE_STRING_TRUNCATED (-102) - -/*@@ - @defines UTIL_ERROR_TABLE_NO_SUCH_KEY - @desc error return code: no such key in table - @@*/ -#define UTIL_ERROR_TABLE_NO_SUCH_KEY (-103) - -/*@@ - @defines UTIL_ERROR_TABLE_WRONG_DATA_TYPE - @desc error return code: value associated with this key - has the wrong data type for this function - @@*/ -#define UTIL_ERROR_TABLE_WRONG_DATA_TYPE (-104) - -/*@@ - @defines UTIL_ERROR_TABLE_VALUE_IS_EMPTY - @desc error return code: value associated with this key - is an empty (0-element) array - @@*/ -#define UTIL_ERROR_TABLE_VALUE_IS_EMPTY (-105) - -/*@@ - @defines UTIL_ERROR_TABLE_ITERATOR_IS_NULL - @desc error return code: table iterator is in "null-pointer" state - @@*/ -#define UTIL_ERROR_TABLE_ITERATOR_IS_NULL (-106) - -/*@@ - @defines UTIL_ERROR_TABLE_NO_MIXED_TYPE_ARRAY - @desc error return code: different array values have different - datatypes - @@*/ -#define UTIL_ERROR_TABLE_NO_MIXED_TYPE_ARRAY (-107) - - -/******************************************************************************/ -/***** Main Table API *********************************************************/ -/******************************************************************************/ - -/* create/destroy */ -int Util_TableCreate(int flags); -int Util_TableClone(int handle); -int Util_TableDestroy(int handle); - -/* query */ -int Util_TableQueryFlags(int handle); -int Util_TableQueryNKeys(int handle); -int Util_TableQueryMaxKeyLength(int handle); -int Util_TableQueryValueInfo(int handle, - CCTK_INT *type_code, CCTK_INT *N_elements, - const char *key); - -/* misc stuff */ -int Util_TableDeleteKey(int handle, const char *key); - -/* convenience routines to create and/or set from a "parameter-file" string */ -int Util_TableCreateFromString(const char string[]); -int Util_TableSetFromString(int handle, const char string[]); - -/* set/get a C-style null-terminated character string */ -int Util_TableSetString(int handle, - const char *string, - const char *key); -int Util_TableGetString(int handle, - int buffer_length, char buffer[], - const char *key); - -/* set/get generic types described by CCTK_VARIABLE_* type codes */ -int Util_TableSetGeneric(int handle, - int type_code, const void *value_ptr, - const char *key); -int Util_TableSetGenericArray(int handle, - int type_code, int N_elements, const void *array, - const char *key); -int Util_TableGetGeneric(int handle, - int type_code, void *value_ptr, - const char *key); -int Util_TableGetGenericArray(int handle, - int type_code, int N_elements, void *array, - const char *key); - -/**************************************/ - -/* - * set routines - */ - -/* pointers */ -int Util_TableSetPointer(int handle, CCTK_POINTER value, const char *key); -int Util_TableSetPointerToConst(int handle, - CCTK_POINTER_TO_CONST value, - const char *key); -int Util_TableSetFPointer(int handle, CCTK_FPOINTER value, const char *key); -/* - * ... the following function (an alias for the previous one) is for - * backwards compatability only, and is deprecated as of 4.0beta13 - */ -int Util_TableSetFnPointer(int handle, CCTK_FPOINTER value, const char *key); - -/* a single character */ -int Util_TableSetChar(int handle, CCTK_CHAR value, const char *key); - -/* integers */ -int Util_TableSetByte(int handle, CCTK_BYTE value, const char *key); -int Util_TableSetInt(int handle, CCTK_INT value, const char *key); -#ifdef HAVE_CCTK_INT1 -int Util_TableSetInt1(int handle, CCTK_INT1 value, const char *key); -#endif -#ifdef HAVE_CCTK_INT2 -int Util_TableSetInt2(int handle, CCTK_INT2 value, const char *key); -#endif -#ifdef HAVE_CCTK_INT4 -int Util_TableSetInt4(int handle, CCTK_INT4 value, const char *key); -#endif -#ifdef HAVE_CCTK_INT8 -int Util_TableSetInt8(int handle, CCTK_INT8 value, const char *key); -#endif - -/* real numbers */ -int Util_TableSetReal(int handle, CCTK_REAL value, const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableSetReal4(int handle, CCTK_REAL4 value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableSetReal8(int handle, CCTK_REAL8 value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableSetReal16(int handle, CCTK_REAL16 value, const char *key); -#endif - -/* complex numbers */ -int Util_TableSetComplex(int handle, CCTK_COMPLEX value, const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableSetComplex8(int handle, CCTK_COMPLEX8 value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableSetComplex16(int handle, CCTK_COMPLEX16 value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableSetComplex32(int handle, CCTK_COMPLEX32 value, const char *key); -#endif - -/**************************************/ - -/* arrays of pointers */ -int Util_TableSetPointerArray(int handle, - int N_elements, const CCTK_POINTER array[], - const char *key); -int Util_TableSetPointerToConstArray(int handle, - int N_elements, - const CCTK_POINTER_TO_CONST array[], - const char *key); -int Util_TableSetFPointerArray(int handle, - int N_elements, const CCTK_FPOINTER array[], - const char *key); -/* - * ... the following function (an alias for the previous one) is for - * backwards compatability only, and is deprecated as of 4.0beta13 - */ -int Util_TableSetFnPointerArray(int handle, - int N_elements, const CCTK_FPOINTER array[], - const char *key); - -/* arrays of characters (i.e. character strings with known length) */ -/* note null termination is *not* required or enforced */ -int Util_TableSetCharArray(int handle, - int N_elements, const CCTK_CHAR array[], - const char *key); - -/* arrays of integers */ -int Util_TableSetByteArray(int handle, - int N_elements, const CCTK_BYTE array[], - const char *key); -int Util_TableSetIntArray(int handle, - int N_elements, const CCTK_INT array[], - const char *key); -#ifdef HAVE_CCTK_INT1 -int Util_TableSetInt1Array(int handle, - int N_elements, const CCTK_INT1 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_INT2 -int Util_TableSetInt2Array(int handle, - int N_elements, const CCTK_INT2 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_INT4 -int Util_TableSetInt4Array(int handle, - int N_elements, const CCTK_INT4 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_INT8 -int Util_TableSetInt8Array(int handle, - int N_elements, const CCTK_INT8 array[], - const char *key); -#endif - -/* arrays of real numbers */ -int Util_TableSetRealArray(int handle, - int N_elements, const CCTK_REAL array[], - const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableSetReal4Array(int handle, - int N_elements, const CCTK_REAL4 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableSetReal8Array(int handle, - int N_elements, const CCTK_REAL8 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableSetReal16Array(int handle, - int N_elements, const CCTK_REAL16 array[], - const char *key); -#endif - -/* arrays of complex numbers */ -int Util_TableSetComplexArray(int handle, - int N_elements, const CCTK_COMPLEX array[], - const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableSetComplex8Array(int handle, - int N_elements, const CCTK_COMPLEX8 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableSetComplex16Array(int handle, - int N_elements, const CCTK_COMPLEX16 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableSetComplex32Array(int handle, - int N_elements, const CCTK_COMPLEX32 array[], - const char *key); -#endif - -/**************************************/ - -/* - * get routines - */ - -/* pointers */ -int Util_TableGetPointer(int handle, CCTK_POINTER *value, const char *key); -int Util_TableGetPointerToConst(int handle, - CCTK_POINTER_TO_CONST *value, - const char *key); - -int Util_TableGetFPointer(int handle, CCTK_FPOINTER *value, const char *key); -/* - * ... the following function (an alias for the previous one) is for - * backwards compatability only, and is deprecated as of 4.0beta13 - */ -int Util_TableGetFnPointer(int handle, CCTK_FPOINTER *value, const char *key); - -/* a single character */ -int Util_TableGetChar(int handle, CCTK_CHAR *value, const char *key); - -/* integers */ -int Util_TableGetByte(int handle, CCTK_BYTE *value, const char *key); -int Util_TableGetInt(int handle, CCTK_INT *value, const char *key); -#ifdef HAVE_CCTK_INT1 -int Util_TableGetInt1(int handle, CCTK_INT1 *value, const char *key); -#endif -#ifdef HAVE_CCTK_INT2 -int Util_TableGetInt2(int handle, CCTK_INT2 *value, const char *key); -#endif -#ifdef HAVE_CCTK_INT4 -int Util_TableGetInt4(int handle, CCTK_INT4 *value, const char *key); -#endif -#ifdef HAVE_CCTK_INT8 -int Util_TableGetInt8(int handle, CCTK_INT8 *value, const char *key); -#endif - -/* real numbers */ -int Util_TableGetReal(int handle, CCTK_REAL *value, const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableGetReal4(int handle, CCTK_REAL4 *value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableGetReal8(int handle, CCTK_REAL8 *value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableGetReal16(int handle, CCTK_REAL16 *value, const char *key); -#endif - -/* complex numbers */ -int Util_TableGetComplex(int handle, CCTK_COMPLEX *value, const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableGetComplex8(int handle, CCTK_COMPLEX8 *value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableGetComplex16(int handle, CCTK_COMPLEX16 *value, const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableGetComplex32(int handle, CCTK_COMPLEX32 *value, const char *key); -#endif - -/**************************************/ - -/* arrays of pointers */ -int Util_TableGetPointerArray(int handle, - int N_elements, CCTK_POINTER array[], - const char *key); -int Util_TableGetPointerToConstArray(int handle, - int N_elements, - CCTK_POINTER_TO_CONST array[], - const char *key); - -int Util_TableGetFPointerArray(int handle, - int N_elements, CCTK_FPOINTER array[], - const char *key); -/* - * ... the following function (an alias for the previous one) is for - * backwards compatability only, and is deprecated as of 4.0beta13 - */ -int Util_TableGetFnPointerArray(int handle, - int N_elements, CCTK_FPOINTER array[], - const char *key); - -/* arrays of characters (i.e. character strings of known length) */ -/* note null termination is *not* required or enforced */ -int Util_TableGetCharArray(int handle, - int N_elements, CCTK_CHAR array[], - const char *key); - -/* integers */ -int Util_TableGetByteArray(int handle, - int N_elements, CCTK_BYTE array[], - const char *key); -int Util_TableGetIntArray(int handle, - int N_elements, CCTK_INT array[], - const char *key); -#ifdef HAVE_CCTK_INT1 -int Util_TableGetInt1Array(int handle, - int N_elements, CCTK_INT1 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_INT2 -int Util_TableGetInt2Array(int handle, - int N_elements, CCTK_INT2 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_INT4 -int Util_TableGetInt4Array(int handle, - int N_elements, CCTK_INT4 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_INT8 -int Util_TableGetInt8Array(int handle, - int N_elements, CCTK_INT8 array[], - const char *key); -#endif - -/* real numbers */ -int Util_TableGetRealArray(int handle, - int N_elements, CCTK_REAL array[], - const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableGetReal4Array(int handle, - int N_elements, CCTK_REAL4 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableGetReal8Array(int handle, - int N_elements, CCTK_REAL8 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableGetReal16Array(int handle, - int N_elements, CCTK_REAL16 array[], - const char *key); -#endif - -/* complex numbers */ -int Util_TableGetComplexArray(int handle, - int N_elements, CCTK_COMPLEX array[], - const char *key); -#ifdef HAVE_CCTK_REAL4 -int Util_TableGetComplex8Array(int handle, - int N_elements, CCTK_COMPLEX8 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL8 -int Util_TableGetComplex16Array(int handle, - int N_elements, CCTK_COMPLEX16 array[], - const char *key); -#endif -#ifdef HAVE_CCTK_REAL16 -int Util_TableGetComplex32Array(int handle, - int N_elements, CCTK_COMPLEX32 array[], - const char *key); -#endif - -/******************************************************************************/ -/***** Table Iterator API *****************************************************/ -/******************************************************************************/ - -/* create/destroy */ -int Util_TableItCreate(int handle); -int Util_TableItClone(int ihandle); -int Util_TableItDestroy(int ihandle); - -/* test for "null-pointer" state */ -int Util_TableItQueryIsNull(int ihandle); -int Util_TableItQueryIsNonNull(int ihandle); - -/* query what the iterator points to */ -int Util_TableItQueryTableHandle(int ihandle); -int Util_TableItQueryKeyValueInfo(int ihandle, - int key_buffer_length, char key_buffer[], - CCTK_INT *type_code, CCTK_INT *N_elements); - -/* change value of iterator */ -int Util_TableItAdvance(int ihandle); -int Util_TableItResetToStart(int ihandle); -int Util_TableItSetToNull(int ihandle); -int Util_TableItSetToKey(int ihandle, const char *key); - -/******************************************************************************/ -/******************************************************************************/ -/******************************************************************************/ - -#ifdef __cplusplus -} -#endif - -#endif /* _UTIL_TABLE_H_ */ +#ifndef _UTIL_TABLE_H_ +#define _UTIL_TABLE_H_ 1 + +#include "cctk_Types.h" + +#ifdef __cplusplus +extern "C" +{ +#endif + +/******************************************************************************/ +/***** Macros for Flags Word **************************************************/ +/******************************************************************************/ + +/* + * The hexadecimal forms are more convenient for thinking about + * bitwise-oring, but alas Fortran 77 doesn't seem to support + * hexadecimal constants, so we give the actual values in decimal. + */ + +/*@@ + @defines UTIL_TABLE_FLAGS_DEFAULT + @desc flags-word macro: no flags set (default) + @@*/ +#define UTIL_TABLE_FLAGS_DEFAULT 0 + +/*@@ + @defines UTIL_TABLE_FLAGS_CASE_INSENSITIVE + @desc flags-word macro: key comparisons are case-insensitive + @@*/ +#define UTIL_TABLE_FLAGS_CASE_INSENSITIVE 1 /* 0x1 */ + +/*@@ + @defines UTIL_TABLE_FLAGS_USER_DEFINED_BASE + @desc flags-word macro: user-defined flags word bit masks + should use only this and higher bit positions (i.e. + all bit positions below this one are reserved for + current or future Cactus use) + @@*/ +#define UTIL_TABLE_FLAGS_USER_DEFINED_BASE 65536 /* 0x10000 */ + +/******************************************************************************/ +/***** Error Codes ************************************************************/ +/******************************************************************************/ + +/* + * error codes specific to the table routines (between -100 and -199) + */ + +/*@@ + @defines UTIL_ERROR_TABLE_BAD_FLAGS + @desc error return code: flags word is invalid + @@*/ +#define UTIL_ERROR_TABLE_BAD_FLAGS (-100) + +/*@@ + @defines UTIL_ERROR_TABLE_BAD_KEY + @desc error return code: key contains '/' character + or is otherwise invalid + @@*/ +#define UTIL_ERROR_TABLE_BAD_KEY (-101) + +/*@@ + @defines UTIL_ERROR_TABLE_STRING_TRUNCATED + @desc error return code: string was truncated to fit in buffer + @@*/ +#define UTIL_ERROR_TABLE_STRING_TRUNCATED (-102) + +/*@@ + @defines UTIL_ERROR_TABLE_NO_SUCH_KEY + @desc error return code: no such key in table + @@*/ +#define UTIL_ERROR_TABLE_NO_SUCH_KEY (-103) + +/*@@ + @defines UTIL_ERROR_TABLE_WRONG_DATA_TYPE + @desc error return code: value associated with this key + has the wrong data type for this function + @@*/ +#define UTIL_ERROR_TABLE_WRONG_DATA_TYPE (-104) + +/*@@ + @defines UTIL_ERROR_TABLE_VALUE_IS_EMPTY + @desc error return code: value associated with this key + is an empty (0-element) array + @@*/ +#define UTIL_ERROR_TABLE_VALUE_IS_EMPTY (-105) + +/*@@ + @defines UTIL_ERROR_TABLE_ITERATOR_IS_NULL + @desc error return code: table iterator is in "null-pointer" state + @@*/ +#define UTIL_ERROR_TABLE_ITERATOR_IS_NULL (-106) + +/*@@ + @defines UTIL_ERROR_TABLE_NO_MIXED_TYPE_ARRAY + @desc error return code: different array values have different + datatypes + @@*/ +#define UTIL_ERROR_TABLE_NO_MIXED_TYPE_ARRAY (-107) + + +/******************************************************************************/ +/***** Main Table API *********************************************************/ +/******************************************************************************/ + +/* create/destroy */ +int Util_TableCreate(int flags); +int Util_TableClone(int handle); +int Util_TableDestroy(int handle); + +/* query */ +int Util_TableQueryFlags(int handle); +int Util_TableQueryNKeys(int handle); +int Util_TableQueryMaxKeyLength(int handle); +int Util_TableQueryValueInfo(int handle, + CCTK_INT *type_code, CCTK_INT *N_elements, + const char *key); + +/* misc stuff */ +int Util_TableDeleteKey(int handle, const char *key); + +/* convenience routines to create and/or set from a "parameter-file" string */ +int Util_TableCreateFromString(const char string[]); +int Util_TableSetFromString(int handle, const char string[]); + +/* set/get a C-style null-terminated character string */ +int Util_TableSetString(int handle, + const char *string, + const char *key); +int Util_TableGetString(int handle, + int buffer_length, char buffer[], + const char *key); + +/* set/get generic types described by CCTK_VARIABLE_* type codes */ +int Util_TableSetGeneric(int handle, + int type_code, const void *value_ptr, + const char *key); +int Util_TableSetGenericArray(int handle, + int type_code, int N_elements, const void *array, + const char *key); +int Util_TableGetGeneric(int handle, + int type_code, void *value_ptr, + const char *key); +int Util_TableGetGenericArray(int handle, + int type_code, int N_elements, void *array, + const char *key); + +/**************************************/ + +/* + * set routines + */ + +/* pointers */ +int Util_TableSetPointer(int handle, CCTK_POINTER value, const char *key); +int Util_TableSetPointerToConst(int handle, + CCTK_POINTER_TO_CONST value, + const char *key); +int Util_TableSetFPointer(int handle, CCTK_FPOINTER value, const char *key); +/* + * ... the following function (an alias for the previous one) is for + * backwards compatability only, and is deprecated as of 4.0beta13 + */ +int Util_TableSetFnPointer(int handle, CCTK_FPOINTER value, const char *key); + +/* a single character */ +int Util_TableSetChar(int handle, CCTK_CHAR value, const char *key); + +/* integers */ +int Util_TableSetByte(int handle, CCTK_BYTE value, const char *key); +int Util_TableSetInt(int handle, CCTK_INT value, const char *key); +#ifdef HAVE_CCTK_INT1 +int Util_TableSetInt1(int handle, CCTK_INT1 value, const char *key); +#endif +#ifdef HAVE_CCTK_INT2 +int Util_TableSetInt2(int handle, CCTK_INT2 value, const char *key); +#endif +#ifdef HAVE_CCTK_INT4 +int Util_TableSetInt4(int handle, CCTK_INT4 value, const char *key); +#endif +#ifdef HAVE_CCTK_INT8 +int Util_TableSetInt8(int handle, CCTK_INT8 value, const char *key); +#endif + +/* real numbers */ +int Util_TableSetReal(int handle, CCTK_REAL value, const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableSetReal4(int handle, CCTK_REAL4 value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableSetReal8(int handle, CCTK_REAL8 value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableSetReal16(int handle, CCTK_REAL16 value, const char *key); +#endif + +/* complex numbers */ +int Util_TableSetComplex(int handle, CCTK_COMPLEX value, const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableSetComplex8(int handle, CCTK_COMPLEX8 value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableSetComplex16(int handle, CCTK_COMPLEX16 value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableSetComplex32(int handle, CCTK_COMPLEX32 value, const char *key); +#endif + +/**************************************/ + +/* arrays of pointers */ +int Util_TableSetPointerArray(int handle, + int N_elements, const CCTK_POINTER array[], + const char *key); +int Util_TableSetPointerToConstArray(int handle, + int N_elements, + const CCTK_POINTER_TO_CONST array[], + const char *key); +int Util_TableSetFPointerArray(int handle, + int N_elements, const CCTK_FPOINTER array[], + const char *key); +/* + * ... the following function (an alias for the previous one) is for + * backwards compatability only, and is deprecated as of 4.0beta13 + */ +int Util_TableSetFnPointerArray(int handle, + int N_elements, const CCTK_FPOINTER array[], + const char *key); + +/* arrays of characters (i.e. character strings with known length) */ +/* note null termination is *not* required or enforced */ +int Util_TableSetCharArray(int handle, + int N_elements, const CCTK_CHAR array[], + const char *key); + +/* arrays of integers */ +int Util_TableSetByteArray(int handle, + int N_elements, const CCTK_BYTE array[], + const char *key); +int Util_TableSetIntArray(int handle, + int N_elements, const CCTK_INT array[], + const char *key); +#ifdef HAVE_CCTK_INT1 +int Util_TableSetInt1Array(int handle, + int N_elements, const CCTK_INT1 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_INT2 +int Util_TableSetInt2Array(int handle, + int N_elements, const CCTK_INT2 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_INT4 +int Util_TableSetInt4Array(int handle, + int N_elements, const CCTK_INT4 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_INT8 +int Util_TableSetInt8Array(int handle, + int N_elements, const CCTK_INT8 array[], + const char *key); +#endif + +/* arrays of real numbers */ +int Util_TableSetRealArray(int handle, + int N_elements, const CCTK_REAL array[], + const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableSetReal4Array(int handle, + int N_elements, const CCTK_REAL4 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableSetReal8Array(int handle, + int N_elements, const CCTK_REAL8 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableSetReal16Array(int handle, + int N_elements, const CCTK_REAL16 array[], + const char *key); +#endif + +/* arrays of complex numbers */ +int Util_TableSetComplexArray(int handle, + int N_elements, const CCTK_COMPLEX array[], + const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableSetComplex8Array(int handle, + int N_elements, const CCTK_COMPLEX8 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableSetComplex16Array(int handle, + int N_elements, const CCTK_COMPLEX16 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableSetComplex32Array(int handle, + int N_elements, const CCTK_COMPLEX32 array[], + const char *key); +#endif + +/**************************************/ + +/* + * get routines + */ + +/* pointers */ +int Util_TableGetPointer(int handle, CCTK_POINTER *value, const char *key); +int Util_TableGetPointerToConst(int handle, + CCTK_POINTER_TO_CONST *value, + const char *key); + +int Util_TableGetFPointer(int handle, CCTK_FPOINTER *value, const char *key); +/* + * ... the following function (an alias for the previous one) is for + * backwards compatability only, and is deprecated as of 4.0beta13 + */ +int Util_TableGetFnPointer(int handle, CCTK_FPOINTER *value, const char *key); + +/* a single character */ +int Util_TableGetChar(int handle, CCTK_CHAR *value, const char *key); + +/* integers */ +int Util_TableGetByte(int handle, CCTK_BYTE *value, const char *key); +int Util_TableGetInt(int handle, CCTK_INT *value, const char *key); +#ifdef HAVE_CCTK_INT1 +int Util_TableGetInt1(int handle, CCTK_INT1 *value, const char *key); +#endif +#ifdef HAVE_CCTK_INT2 +int Util_TableGetInt2(int handle, CCTK_INT2 *value, const char *key); +#endif +#ifdef HAVE_CCTK_INT4 +int Util_TableGetInt4(int handle, CCTK_INT4 *value, const char *key); +#endif +#ifdef HAVE_CCTK_INT8 +int Util_TableGetInt8(int handle, CCTK_INT8 *value, const char *key); +#endif + +/* real numbers */ +int Util_TableGetReal(int handle, CCTK_REAL *value, const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableGetReal4(int handle, CCTK_REAL4 *value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableGetReal8(int handle, CCTK_REAL8 *value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableGetReal16(int handle, CCTK_REAL16 *value, const char *key); +#endif + +/* complex numbers */ +int Util_TableGetComplex(int handle, CCTK_COMPLEX *value, const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableGetComplex8(int handle, CCTK_COMPLEX8 *value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableGetComplex16(int handle, CCTK_COMPLEX16 *value, const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableGetComplex32(int handle, CCTK_COMPLEX32 *value, const char *key); +#endif + +/**************************************/ + +/* arrays of pointers */ +int Util_TableGetPointerArray(int handle, + int N_elements, CCTK_POINTER array[], + const char *key); +int Util_TableGetPointerToConstArray(int handle, + int N_elements, + CCTK_POINTER_TO_CONST array[], + const char *key); + +int Util_TableGetFPointerArray(int handle, + int N_elements, CCTK_FPOINTER array[], + const char *key); +/* + * ... the following function (an alias for the previous one) is for + * backwards compatability only, and is deprecated as of 4.0beta13 + */ +int Util_TableGetFnPointerArray(int handle, + int N_elements, CCTK_FPOINTER array[], + const char *key); + +/* arrays of characters (i.e. character strings of known length) */ +/* note null termination is *not* required or enforced */ +int Util_TableGetCharArray(int handle, + int N_elements, CCTK_CHAR array[], + const char *key); + +/* integers */ +int Util_TableGetByteArray(int handle, + int N_elements, CCTK_BYTE array[], + const char *key); +int Util_TableGetIntArray(int handle, + int N_elements, CCTK_INT array[], + const char *key); +#ifdef HAVE_CCTK_INT1 +int Util_TableGetInt1Array(int handle, + int N_elements, CCTK_INT1 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_INT2 +int Util_TableGetInt2Array(int handle, + int N_elements, CCTK_INT2 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_INT4 +int Util_TableGetInt4Array(int handle, + int N_elements, CCTK_INT4 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_INT8 +int Util_TableGetInt8Array(int handle, + int N_elements, CCTK_INT8 array[], + const char *key); +#endif + +/* real numbers */ +int Util_TableGetRealArray(int handle, + int N_elements, CCTK_REAL array[], + const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableGetReal4Array(int handle, + int N_elements, CCTK_REAL4 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableGetReal8Array(int handle, + int N_elements, CCTK_REAL8 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableGetReal16Array(int handle, + int N_elements, CCTK_REAL16 array[], + const char *key); +#endif + +/* complex numbers */ +int Util_TableGetComplexArray(int handle, + int N_elements, CCTK_COMPLEX array[], + const char *key); +#ifdef HAVE_CCTK_REAL4 +int Util_TableGetComplex8Array(int handle, + int N_elements, CCTK_COMPLEX8 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL8 +int Util_TableGetComplex16Array(int handle, + int N_elements, CCTK_COMPLEX16 array[], + const char *key); +#endif +#ifdef HAVE_CCTK_REAL16 +int Util_TableGetComplex32Array(int handle, + int N_elements, CCTK_COMPLEX32 array[], + const char *key); +#endif + +/******************************************************************************/ +/***** Table Iterator API *****************************************************/ +/******************************************************************************/ + +/* create/destroy */ +int Util_TableItCreate(int handle); +int Util_TableItClone(int ihandle); +int Util_TableItDestroy(int ihandle); + +/* test for "null-pointer" state */ +int Util_TableItQueryIsNull(int ihandle); +int Util_TableItQueryIsNonNull(int ihandle); + +/* query what the iterator points to */ +int Util_TableItQueryTableHandle(int ihandle); +int Util_TableItQueryKeyValueInfo(int ihandle, + int key_buffer_length, char key_buffer[], + CCTK_INT *type_code, CCTK_INT *N_elements); + +/* change value of iterator */ +int Util_TableItAdvance(int ihandle); +int Util_TableItResetToStart(int ihandle); +int Util_TableItSetToNull(int ihandle); +int Util_TableItSetToKey(int ihandle, const char *key); + +/******************************************************************************/ +/******************************************************************************/ +/******************************************************************************/ + +#ifdef __cplusplus +} +#endif + +#endif /* _UTIL_TABLE_H_ */ diff --git a/AMSS_NCKU_source/adm_constraint.f90 b/AMSS_NCKU_source/BSSN/adm_constraint.f90 similarity index 98% rename from AMSS_NCKU_source/adm_constraint.f90 rename to AMSS_NCKU_source/BSSN/adm_constraint.f90 index ab5f005..9c19c13 100644 --- a/AMSS_NCKU_source/adm_constraint.f90 +++ b/AMSS_NCKU_source/BSSN/adm_constraint.f90 @@ -1,382 +1,382 @@ - -!-------------------------------------------------------------------------------! -! computed constraint for ADM formalism ! -!-------------------------------------------------------------------------------! - subroutine constraint_adm(ex, X, Y, Z,& - dxx,gxy,gxz,dyy,gyz,dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - ham_Res, movx_Res, movy_Res, movz_Res, & - Symmetry) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res -!~~~~~~> Other variables: -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! first order derivative of metric, @_k g_ij - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,trK,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz - - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: PI - - call adm_ricci_gamma(ex, X, Y, Z, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE -! invert metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - trK = gupxx * Kxx + gupyy * Kyy + gupzz * Kzz & - + TWO * (gupxy * Kxy + gupxz * Kxz + gupyz * Kyz) - -! ham_Res = trR + K^2 - K_ij * K^ij - 16 * PI * rho - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = ham_Res + trK * trK -(& - gupxx * ( & - gupxx * Kxx * Kxx + gupyy * Kxy * Kxy + gupzz * Kxz * Kxz + & - TWO * (gupxy * Kxx * Kxy + gupxz * Kxx * Kxz + gupyz * Kxy * Kxz) ) + & - gupyy * ( & - gupxx * Kxy * Kxy + gupyy * Kyy * Kyy + gupzz * Kyz * Kyz + & - TWO * (gupxy * Kxy * Kyy + gupxz * Kxy * Kyz + gupyz * Kyy * Kyz) ) + & - gupzz * ( & - gupxx * Kxz * Kxz + gupyy * Kyz * Kyz + gupzz * Kzz * Kzz + & - TWO * (gupxy * Kxz * Kyz + gupxz * Kxz * Kzz + gupyz * Kyz * Kzz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Kxx * Kxy + gupyy * Kxy * Kyy + gupzz * Kxz * Kyz + & - gupxy * (Kxx * Kyy + Kxy * Kxy) + & - gupxz * (Kxx * Kyz + Kxz * Kxy) + & - gupyz * (Kxy * Kyz + Kxz * Kyy) ) + & - gupxz * ( & - gupxx * Kxx * Kxz + gupyy * Kxy * Kyz + gupzz * Kxz * Kzz + & - gupxy * (Kxx * Kyz + Kxy * Kxz) + & - gupxz * (Kxx * Kzz + Kxz * Kxz) + & - gupyz * (Kxy * Kzz + Kxz * Kyz) ) + & - gupyz * ( & - gupxx * Kxy * Kxz + gupyy * Kyy * Kyz + gupzz * Kyz * Kzz + & - gupxy * (Kxy * Kyz + Kyy * Kxz) + & - gupxz * (Kxy * Kzz + Kyz * Kxz) + & - gupyz * (Kyy * Kzz + Kyz * Kyz) ) ))- F16 * PI * rho - -! mov_Res_j = gupkj*D_k K_ij - d_j trK - 8 PI s_j where D respect to physical metric -! store D_i K_jk - call fderivs(ex,Kxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Kxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Kxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,Kyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Kyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,Kzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - gxxx = gxxx - ( Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz & - + Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz) - gxyx = gxyx - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & - + Gamxxx * Kxy + Gamyxx * Kyy + Gamzxx * Kyz) - gxzx = gxzx - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & - + Gamxxx * Kxz + Gamyxx * Kyz + Gamzxx * Kzz) - gyyx = gyyx - ( Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz & - + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) - gyzx = gyzx - ( Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz & - + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) - gzzx = gzzx - ( Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz & - + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) - gxxy = gxxy - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & - + Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz) - gxyy = gxyy - ( Gamxyy * Kxx + Gamyyy * Kxy + Gamzyy * Kxz & - + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) - gxzy = gxzy - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & - + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) - gyyy = gyyy - ( Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz & - + Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz) - gyzy = gyzy - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & - + Gamxyy * Kxz + Gamyyy * Kyz + Gamzyy * Kzz) - gzzy = gzzy - ( Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz & - + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) - gxxz = gxxz - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & - + Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz) - gxyz = gxyz - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & - + Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz) - gxzz = gxzz - ( Gamxzz * Kxx + Gamyzz * Kxy + Gamzzz * Kxz & - + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) - gyyz = gyyz - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & - + Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz) - gyzz = gyzz - ( Gamxzz * Kxy + Gamyzz * Kyy + Gamzzz * Kyz & - + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) - gzzz = gzzz - ( Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz & - + Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz) -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - - call fderivs(ex,trK,fx,fy,fz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - -movx_Res = movx_Res - fx - F8*PI*sx -movy_Res = movy_Res - fy - F8*PI*sy -movz_Res = movz_Res - fz - F8*PI*sz - - return - - end subroutine constraint_adm -!-------------------------------------------------------------------------------! -! computed constraint for ADM formalism for shell ! -!-------------------------------------------------------------------------------! - subroutine constraint_adm_ss(ex,crho,sigma,R, X, Y, Z,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, & - Symmetry,Lev,sst) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! second kind of Christofel symble Gamma^i_jk respect to physical metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res -!~~~~~~> Other variables: -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! first order derivative of metric, @_k g_ij - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,trK,fx,fy,fz - - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: PI - - call adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,Lev,sst) - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE -! invert metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - trK = gupxx * Kxx + gupyy * Kyy + gupzz * Kzz & - + TWO * (gupxy * Kxy + gupxz * Kxz + gupyz * Kyz) - -! ham_Res = trR + K^2 - K_ij * K^ij - 16 * PI * rho - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = ham_Res + trK * trK -(& - gupxx * ( & - gupxx * Kxx * Kxx + gupyy * Kxy * Kxy + gupzz * Kxz * Kxz + & - TWO * (gupxy * Kxx * Kxy + gupxz * Kxx * Kxz + gupyz * Kxy * Kxz) ) + & - gupyy * ( & - gupxx * Kxy * Kxy + gupyy * Kyy * Kyy + gupzz * Kyz * Kyz + & - TWO * (gupxy * Kxy * Kyy + gupxz * Kxy * Kyz + gupyz * Kyy * Kyz) ) + & - gupzz * ( & - gupxx * Kxz * Kxz + gupyy * Kyz * Kyz + gupzz * Kzz * Kzz + & - TWO * (gupxy * Kxz * Kyz + gupxz * Kxz * Kzz + gupyz * Kyz * Kzz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Kxx * Kxy + gupyy * Kxy * Kyy + gupzz * Kxz * Kyz + & - gupxy * (Kxx * Kyy + Kxy * Kxy) + & - gupxz * (Kxx * Kyz + Kxz * Kxy) + & - gupyz * (Kxy * Kyz + Kxz * Kyy) ) + & - gupxz * ( & - gupxx * Kxx * Kxz + gupyy * Kxy * Kyz + gupzz * Kxz * Kzz + & - gupxy * (Kxx * Kyz + Kxy * Kxz) + & - gupxz * (Kxx * Kzz + Kxz * Kxz) + & - gupyz * (Kxy * Kzz + Kxz * Kyz) ) + & - gupyz * ( & - gupxx * Kxy * Kxz + gupyy * Kyy * Kyz + gupzz * Kyz * Kzz + & - gupxy * (Kxy * Kyz + Kyy * Kxz) + & - gupxz * (Kxy * Kzz + Kyz * Kxz) + & - gupyz * (Kyy * Kzz + Kyz * Kyz) ) ))- F16 * PI * rho - -! mov_Res_j = gupkj*D_k K_ij - d_j trK - 8 PI s_j where D respect to physical metric -! store D_i K_jk - call fderivs_shc(ex,Kxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Kxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Kxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Kyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Kyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Kzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - gxxx = gxxx - ( Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz & - + Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz) - gxyx = gxyx - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & - + Gamxxx * Kxy + Gamyxx * Kyy + Gamzxx * Kyz) - gxzx = gxzx - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & - + Gamxxx * Kxz + Gamyxx * Kyz + Gamzxx * Kzz) - gyyx = gyyx - ( Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz & - + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) - gyzx = gyzx - ( Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz & - + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) - gzzx = gzzx - ( Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz & - + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) - gxxy = gxxy - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & - + Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz) - gxyy = gxyy - ( Gamxyy * Kxx + Gamyyy * Kxy + Gamzyy * Kxz & - + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) - gxzy = gxzy - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & - + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) - gyyy = gyyy - ( Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz & - + Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz) - gyzy = gyzy - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & - + Gamxyy * Kxz + Gamyyy * Kyz + Gamzyy * Kzz) - gzzy = gzzy - ( Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz & - + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) - gxxz = gxxz - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & - + Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz) - gxyz = gxyz - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & - + Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz) - gxzz = gxzz - ( Gamxzz * Kxx + Gamyzz * Kxy + Gamzzz * Kxz & - + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) - gyyz = gyyz - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & - + Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz) - gyzz = gyzz - ( Gamxzz * Kxy + Gamyzz * Kyy + Gamzzz * Kyz & - + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) - gzzz = gzzz - ( Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz & - + Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz) -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - - call fderivs_shc(ex,trK,fx,fy,fz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -movx_Res = movx_Res - fx - F8*PI*sx -movy_Res = movy_Res - fy - F8*PI*sy -movz_Res = movz_Res - fz - F8*PI*sz - - return - - end subroutine constraint_adm_ss + +!-------------------------------------------------------------------------------! +! computed constraint for ADM formalism ! +!-------------------------------------------------------------------------------! + subroutine constraint_adm(ex, X, Y, Z,& + dxx,gxy,gxz,dyy,gyz,dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + ham_Res, movx_Res, movy_Res, movz_Res, & + Symmetry) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res +!~~~~~~> Other variables: +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! first order derivative of metric, @_k g_ij + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,trK,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz + + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: PI + + call adm_ricci_gamma(ex, X, Y, Z, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE +! invert metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + trK = gupxx * Kxx + gupyy * Kyy + gupzz * Kzz & + + TWO * (gupxy * Kxy + gupxz * Kxz + gupyz * Kyz) + +! ham_Res = trR + K^2 - K_ij * K^ij - 16 * PI * rho + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = ham_Res + trK * trK -(& + gupxx * ( & + gupxx * Kxx * Kxx + gupyy * Kxy * Kxy + gupzz * Kxz * Kxz + & + TWO * (gupxy * Kxx * Kxy + gupxz * Kxx * Kxz + gupyz * Kxy * Kxz) ) + & + gupyy * ( & + gupxx * Kxy * Kxy + gupyy * Kyy * Kyy + gupzz * Kyz * Kyz + & + TWO * (gupxy * Kxy * Kyy + gupxz * Kxy * Kyz + gupyz * Kyy * Kyz) ) + & + gupzz * ( & + gupxx * Kxz * Kxz + gupyy * Kyz * Kyz + gupzz * Kzz * Kzz + & + TWO * (gupxy * Kxz * Kyz + gupxz * Kxz * Kzz + gupyz * Kyz * Kzz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Kxx * Kxy + gupyy * Kxy * Kyy + gupzz * Kxz * Kyz + & + gupxy * (Kxx * Kyy + Kxy * Kxy) + & + gupxz * (Kxx * Kyz + Kxz * Kxy) + & + gupyz * (Kxy * Kyz + Kxz * Kyy) ) + & + gupxz * ( & + gupxx * Kxx * Kxz + gupyy * Kxy * Kyz + gupzz * Kxz * Kzz + & + gupxy * (Kxx * Kyz + Kxy * Kxz) + & + gupxz * (Kxx * Kzz + Kxz * Kxz) + & + gupyz * (Kxy * Kzz + Kxz * Kyz) ) + & + gupyz * ( & + gupxx * Kxy * Kxz + gupyy * Kyy * Kyz + gupzz * Kyz * Kzz + & + gupxy * (Kxy * Kyz + Kyy * Kxz) + & + gupxz * (Kxy * Kzz + Kyz * Kxz) + & + gupyz * (Kyy * Kzz + Kyz * Kyz) ) ))- F16 * PI * rho + +! mov_Res_j = gupkj*D_k K_ij - d_j trK - 8 PI s_j where D respect to physical metric +! store D_i K_jk + call fderivs(ex,Kxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Kxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Kxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,Kyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Kyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,Kzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + gxxx = gxxx - ( Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz & + + Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz) + gxyx = gxyx - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & + + Gamxxx * Kxy + Gamyxx * Kyy + Gamzxx * Kyz) + gxzx = gxzx - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & + + Gamxxx * Kxz + Gamyxx * Kyz + Gamzxx * Kzz) + gyyx = gyyx - ( Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz & + + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) + gyzx = gyzx - ( Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz & + + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) + gzzx = gzzx - ( Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz & + + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) + gxxy = gxxy - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & + + Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz) + gxyy = gxyy - ( Gamxyy * Kxx + Gamyyy * Kxy + Gamzyy * Kxz & + + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) + gxzy = gxzy - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & + + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) + gyyy = gyyy - ( Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz & + + Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz) + gyzy = gyzy - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & + + Gamxyy * Kxz + Gamyyy * Kyz + Gamzyy * Kzz) + gzzy = gzzy - ( Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz & + + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) + gxxz = gxxz - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & + + Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz) + gxyz = gxyz - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & + + Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz) + gxzz = gxzz - ( Gamxzz * Kxx + Gamyzz * Kxy + Gamzzz * Kxz & + + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) + gyyz = gyyz - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & + + Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz) + gyzz = gyzz - ( Gamxzz * Kxy + Gamyzz * Kyy + Gamzzz * Kyz & + + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) + gzzz = gzzz - ( Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz & + + Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz) +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + + call fderivs(ex,trK,fx,fy,fz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + +movx_Res = movx_Res - fx - F8*PI*sx +movy_Res = movy_Res - fy - F8*PI*sy +movz_Res = movz_Res - fz - F8*PI*sz + + return + + end subroutine constraint_adm +!-------------------------------------------------------------------------------! +! computed constraint for ADM formalism for shell ! +!-------------------------------------------------------------------------------! + subroutine constraint_adm_ss(ex,crho,sigma,R, X, Y, Z,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, & + Symmetry,Lev,sst) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! second kind of Christofel symble Gamma^i_jk respect to physical metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res +!~~~~~~> Other variables: +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! first order derivative of metric, @_k g_ij + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,trK,fx,fy,fz + + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: PI + + call adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,Lev,sst) + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE +! invert metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + trK = gupxx * Kxx + gupyy * Kyy + gupzz * Kzz & + + TWO * (gupxy * Kxy + gupxz * Kxz + gupyz * Kyz) + +! ham_Res = trR + K^2 - K_ij * K^ij - 16 * PI * rho + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = ham_Res + trK * trK -(& + gupxx * ( & + gupxx * Kxx * Kxx + gupyy * Kxy * Kxy + gupzz * Kxz * Kxz + & + TWO * (gupxy * Kxx * Kxy + gupxz * Kxx * Kxz + gupyz * Kxy * Kxz) ) + & + gupyy * ( & + gupxx * Kxy * Kxy + gupyy * Kyy * Kyy + gupzz * Kyz * Kyz + & + TWO * (gupxy * Kxy * Kyy + gupxz * Kxy * Kyz + gupyz * Kyy * Kyz) ) + & + gupzz * ( & + gupxx * Kxz * Kxz + gupyy * Kyz * Kyz + gupzz * Kzz * Kzz + & + TWO * (gupxy * Kxz * Kyz + gupxz * Kxz * Kzz + gupyz * Kyz * Kzz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Kxx * Kxy + gupyy * Kxy * Kyy + gupzz * Kxz * Kyz + & + gupxy * (Kxx * Kyy + Kxy * Kxy) + & + gupxz * (Kxx * Kyz + Kxz * Kxy) + & + gupyz * (Kxy * Kyz + Kxz * Kyy) ) + & + gupxz * ( & + gupxx * Kxx * Kxz + gupyy * Kxy * Kyz + gupzz * Kxz * Kzz + & + gupxy * (Kxx * Kyz + Kxy * Kxz) + & + gupxz * (Kxx * Kzz + Kxz * Kxz) + & + gupyz * (Kxy * Kzz + Kxz * Kyz) ) + & + gupyz * ( & + gupxx * Kxy * Kxz + gupyy * Kyy * Kyz + gupzz * Kyz * Kzz + & + gupxy * (Kxy * Kyz + Kyy * Kxz) + & + gupxz * (Kxy * Kzz + Kyz * Kxz) + & + gupyz * (Kyy * Kzz + Kyz * Kyz) ) ))- F16 * PI * rho + +! mov_Res_j = gupkj*D_k K_ij - d_j trK - 8 PI s_j where D respect to physical metric +! store D_i K_jk + call fderivs_shc(ex,Kxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Kxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Kxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Kyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Kyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Kzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + gxxx = gxxx - ( Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz & + + Gamxxx * Kxx + Gamyxx * Kxy + Gamzxx * Kxz) + gxyx = gxyx - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & + + Gamxxx * Kxy + Gamyxx * Kyy + Gamzxx * Kyz) + gxzx = gxzx - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & + + Gamxxx * Kxz + Gamyxx * Kyz + Gamzxx * Kzz) + gyyx = gyyx - ( Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz & + + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) + gyzx = gyzx - ( Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz & + + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) + gzzx = gzzx - ( Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz & + + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) + gxxy = gxxy - ( Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz & + + Gamxxy * Kxx + Gamyxy * Kxy + Gamzxy * Kxz) + gxyy = gxyy - ( Gamxyy * Kxx + Gamyyy * Kxy + Gamzyy * Kxz & + + Gamxxy * Kxy + Gamyxy * Kyy + Gamzxy * Kyz) + gxzy = gxzy - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & + + Gamxxy * Kxz + Gamyxy * Kyz + Gamzxy * Kzz) + gyyy = gyyy - ( Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz & + + Gamxyy * Kxy + Gamyyy * Kyy + Gamzyy * Kyz) + gyzy = gyzy - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & + + Gamxyy * Kxz + Gamyyy * Kyz + Gamzyy * Kzz) + gzzy = gzzy - ( Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz & + + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) + gxxz = gxxz - ( Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz & + + Gamxxz * Kxx + Gamyxz * Kxy + Gamzxz * Kxz) + gxyz = gxyz - ( Gamxyz * Kxx + Gamyyz * Kxy + Gamzyz * Kxz & + + Gamxxz * Kxy + Gamyxz * Kyy + Gamzxz * Kyz) + gxzz = gxzz - ( Gamxzz * Kxx + Gamyzz * Kxy + Gamzzz * Kxz & + + Gamxxz * Kxz + Gamyxz * Kyz + Gamzxz * Kzz) + gyyz = gyyz - ( Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz & + + Gamxyz * Kxy + Gamyyz * Kyy + Gamzyz * Kyz) + gyzz = gyzz - ( Gamxzz * Kxy + Gamyzz * Kyy + Gamzzz * Kyz & + + Gamxyz * Kxz + Gamyyz * Kyz + Gamzyz * Kzz) + gzzz = gzzz - ( Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz & + + Gamxzz * Kxz + Gamyzz * Kyz + Gamzzz * Kzz) +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + + call fderivs_shc(ex,trK,fx,fy,fz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +movx_Res = movx_Res - fx - F8*PI*sx +movy_Res = movy_Res - fy - F8*PI*sy +movz_Res = movz_Res - fz - F8*PI*sz + + return + + end subroutine constraint_adm_ss diff --git a/AMSS_NCKU_source/bssn2adm.f90 b/AMSS_NCKU_source/BSSN/bssn2adm.f90 similarity index 97% rename from AMSS_NCKU_source/bssn2adm.f90 rename to AMSS_NCKU_source/BSSN/bssn2adm.f90 index ad7d6ba..7939295 100644 --- a/AMSS_NCKU_source/bssn2adm.f90 +++ b/AMSS_NCKU_source/BSSN/bssn2adm.f90 @@ -1,40 +1,40 @@ - -!-------------------------------------------------------------------------------! -! convert bssn variables to ADM variables ! -!-------------------------------------------------------------------------------! - subroutine bssn2adm(ex,chi,trK, & - gxx,gxy,gxz,gyy,gyz,gzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - adm_gxx,adm_gxy,adm_gxz,adm_gyy,adm_gyz,adm_gzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3) - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::chi,trK - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::gxx,gxy,gxz,gyy,gyz,gzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::Axx,Axy,Axz,Ayy,Ayz,Azz - - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: adm_gxx,adm_gxy,adm_gxz,adm_gyy,adm_gyz,adm_gzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - - real*8, parameter :: F1o3=1.d0/3.d0 - - adm_gxx = gxx/chi - adm_gxy = gxy/chi - adm_gxz = gxz/chi - adm_gyy = gyy/chi - adm_gyz = gyz/chi - adm_gzz = gzz/chi - - Kxx = Axx/chi+F1o3*trK*adm_gxx - Kxy = Axy/chi+F1o3*trK*adm_gxy - Kxz = Axz/chi+F1o3*trK*adm_gxz - Kyy = Ayy/chi+F1o3*trK*adm_gyy - Kyz = Ayz/chi+F1o3*trK*adm_gyz - Kzz = Azz/chi+F1o3*trK*adm_gzz - - return - - end subroutine bssn2adm + +!-------------------------------------------------------------------------------! +! convert bssn variables to ADM variables ! +!-------------------------------------------------------------------------------! + subroutine bssn2adm(ex,chi,trK, & + gxx,gxy,gxz,gyy,gyz,gzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + adm_gxx,adm_gxy,adm_gxz,adm_gyy,adm_gyz,adm_gzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3) + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::chi,trK + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::gxx,gxy,gxz,gyy,gyz,gzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::Axx,Axy,Axz,Ayy,Ayz,Azz + + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: adm_gxx,adm_gxy,adm_gxz,adm_gyy,adm_gyz,adm_gzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + + real*8, parameter :: F1o3=1.d0/3.d0 + + adm_gxx = gxx/chi + adm_gxy = gxy/chi + adm_gxz = gxz/chi + adm_gyy = gyy/chi + adm_gyz = gyz/chi + adm_gzz = gzz/chi + + Kxx = Axx/chi+F1o3*trK*adm_gxx + Kxy = Axy/chi+F1o3*trK*adm_gxy + Kxz = Axz/chi+F1o3*trK*adm_gxz + Kyy = Ayy/chi+F1o3*trK*adm_gyy + Kyz = Ayz/chi+F1o3*trK*adm_gyz + Kzz = Azz/chi+F1o3*trK*adm_gzz + + return + + end subroutine bssn2adm diff --git a/AMSS_NCKU_source/bssnEM_class.C b/AMSS_NCKU_source/BSSN/bssnEM_class.C similarity index 97% rename from AMSS_NCKU_source/bssnEM_class.C rename to AMSS_NCKU_source/BSSN/bssnEM_class.C index e06b701..e50934b 100644 --- a/AMSS_NCKU_source/bssnEM_class.C +++ b/AMSS_NCKU_source/BSSN/bssnEM_class.C @@ -1,2325 +1,2325 @@ - -#ifdef newc -#include -#include -#include -using namespace std; -#else -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "misc.h" -#include "Ansorg.h" -#include "fmisc.h" -#include "Parallel.h" -#include "bssnEM_class.h" -#include "bssn_rhs.h" -#include "empart.h" -#include "initial_puncture.h" -#include "initial_maxwell.h" -#include "enforce_algebra.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" -#include "getnp4.h" -#include "getnpem2.h" -#include "shellfunctions.h" -#include "parameters.h" - -#ifdef With_AHF -#include "derivatives.h" -#include "myglobal.h" -#endif - -//================================================================================================ - -// Define bssnEM_class - -// It inherits some members and methods from the parent class bssn_class and modifies others. -// The modified members and methods are defined below (and in the header bssnEM_class.h). -// The remaining members are inherited from the parent class bssn_class (declared in bssn_class.h). - -//================================================================================================ - -bssnEM_class::bssnEM_class(double Couranti, double StartTimei, double TotalTimei, - double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, - double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi) - : bssn_class(Couranti, StartTimei, TotalTimei, - DumpTimei, d2DumpTimei, CheckTimei, AnasTimei, - Symmetryi, checkruni, checkfilenamei, numepssi, numepsbi, numepshi, - a_levi, maxli, decni, maxrexi, drexi) -{ - // setup Monitors - { - char str[50]; - stringstream a_stream; - a_stream.setf(ios::left); - a_stream.str(""); - a_stream << setw(15) << "# time"; - for (int pl = 1; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - sprintf(str, "R%02dm%03d", pl, pm); - a_stream << setw(16) << str; - sprintf(str, "I%02dm%03d", pl, pm); - a_stream << setw(16) << str; - } - Phi2Monitor = new monitor("bssn_phi2.dat", myrank, a_stream.str()); // myrank has been setup in bssn_class.C - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - for (int pl = 0; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - sprintf(str, "R%02dm%03d", pl, pm); - a_stream << setw(16) << str; - sprintf(str, "I%02dm%03d", pl, pm); - a_stream << setw(16) << str; - } - Phi1Monitor = new monitor("bssn_phi1.dat", myrank, a_stream.str()); // myrank has been setup in bssn_class.C - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function initializes the class - -//================================================================================================ - -void bssnEM_class::Initialize() -{ - Exo = new var("Exo", ngfs++, -1, 1, 1); - Eyo = new var("Eyo", ngfs++, 1, -1, 1); - Ezo = new var("Ezo", ngfs++, 1, 1, -1); - // note B is an axi vector - Bxo = new var("Bxo", ngfs++, 1, -1, -1); - Byo = new var("Byo", ngfs++, -1, 1, -1); - Bzo = new var("Bzo", ngfs++, -1, -1, 1); - Kpsio = new var("Kpsio", ngfs++, 1, 1, 1); - Kphio = new var("Kphio", ngfs++, 1, 1, 1); - - Ex0 = new var("Ex0", ngfs++, -1, 1, 1); - Ey0 = new var("Ey0", ngfs++, 1, -1, 1); - Ez0 = new var("Ez0", ngfs++, 1, 1, -1); - Bx0 = new var("Bx0", ngfs++, 1, -1, -1); - By0 = new var("By0", ngfs++, -1, 1, -1); - Bz0 = new var("Bz0", ngfs++, -1, -1, 1); - Kpsi0 = new var("Kpsi0", ngfs++, 1, 1, 1); - Kphi0 = new var("Kphi0", ngfs++, 1, 1, 1); - - Ex = new var("Ex", ngfs++, -1, 1, 1); - Ey = new var("Ey", ngfs++, 1, -1, 1); - Ez = new var("Ez", ngfs++, 1, 1, -1); - Bx = new var("Bx", ngfs++, 1, -1, -1); - By = new var("By", ngfs++, -1, 1, -1); - Bz = new var("Bz", ngfs++, -1, -1, 1); - Kpsi = new var("Kpsi", ngfs++, 1, 1, 1); - Kphi = new var("Kphi", ngfs++, 1, 1, 1); - - Ex1 = new var("Ex1", ngfs++, -1, 1, 1); - Ey1 = new var("Ey1", ngfs++, 1, -1, 1); - Ez1 = new var("Ez1", ngfs++, 1, 1, -1); - Bx1 = new var("Bx1", ngfs++, 1, -1, -1); - By1 = new var("By1", ngfs++, -1, 1, -1); - Bz1 = new var("Bz1", ngfs++, -1, -1, 1); - Kpsi1 = new var("Kpsi1", ngfs++, 1, 1, 1); - Kphi1 = new var("Kphi1", ngfs++, 1, 1, 1); - - Ex_rhs = new var("Ex_rhs", ngfs++, -1, 1, 1); - Ey_rhs = new var("Ey_rhs", ngfs++, 1, -1, 1); - Ez_rhs = new var("Ez_rhs", ngfs++, 1, 1, -1); - Bx_rhs = new var("Bx_rhs", ngfs++, 1, -1, -1); - By_rhs = new var("By_rhs", ngfs++, -1, 1, -1); - Bz_rhs = new var("Bz_rhs", ngfs++, -1, -1, 1); - Kpsi_rhs = new var("Kpsi_rhs", ngfs++, 1, 1, 1); - Kphi_rhs = new var("Kphi_rhs", ngfs++, 1, 1, 1); - - qchar = new var("qchar", ngfs++, 1, 1, 1); - Jx = new var("Jx", ngfs++, -1, 1, 1); - Jy = new var("Jy", ngfs++, 1, -1, 1); - Jz = new var("Jz", ngfs++, 1, 1, -1); - - Rphi2 = new var("Rphi2", ngfs++, 1, 1, 1); // Etheta - Bphi in fact, so no symmetry at all - Iphi2 = new var("Iphi2", ngfs++, -1, -1, -1); // Ephi - Btheta in fact, so no symmetry at all - - Rphi1 = new var("Rphi1", ngfs++, 1, 1, 1); // Er in fact - Iphi1 = new var("Iphi1", ngfs++, 1, 1, 1); // Br in fact - - if (myrank == 0) - cout << "you have setted " << ngfs << " grid functions." << endl; - - OldStateList->insert(Kpsio); - OldStateList->insert(Kphio); - OldStateList->insert(Exo); - OldStateList->insert(Eyo); - OldStateList->insert(Ezo); - OldStateList->insert(Bxo); - OldStateList->insert(Byo); - OldStateList->insert(Bzo); - - StateList->insert(Kpsi0); - StateList->insert(Kphi0); - StateList->insert(Ex0); - StateList->insert(Ey0); - StateList->insert(Ez0); - StateList->insert(Bx0); - StateList->insert(By0); - StateList->insert(Bz0); - - RHSList->insert(Kpsi_rhs); - RHSList->insert(Kphi_rhs); - RHSList->insert(Ex_rhs); - RHSList->insert(Ey_rhs); - RHSList->insert(Ez_rhs); - RHSList->insert(Bx_rhs); - RHSList->insert(By_rhs); - RHSList->insert(Bz_rhs); - - SynchList_pre->insert(Kpsi); - SynchList_pre->insert(Kphi); - SynchList_pre->insert(Ex); - SynchList_pre->insert(Ey); - SynchList_pre->insert(Ez); - SynchList_pre->insert(Bx); - SynchList_pre->insert(By); - SynchList_pre->insert(Bz); - - SynchList_cor->insert(Kpsi1); - SynchList_cor->insert(Kphi1); - SynchList_cor->insert(Ex1); - SynchList_cor->insert(Ey1); - SynchList_cor->insert(Ez1); - SynchList_cor->insert(Bx1); - SynchList_cor->insert(By1); - SynchList_cor->insert(Bz1); - - DumpList->insert(Rphi2); - DumpList->insert(Iphi2); - DumpList->insert(Rphi1); - DumpList->insert(Iphi1); - DumpList->insert(Ex0); - DumpList->insert(Bx0); - - CheckPoint->addvariablelist(StateList); - CheckPoint->addvariablelist(OldStateList); - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); - if (checkrun) - CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); - else - GH->compose_cgh(nprocs); - -#ifdef WithShell - SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); - SH->matchcheck(GH->PatL[0]); - SH->compose_sh(nprocs); - SH->setupcordtrans(); - SH->Dump_xyz(0, 0, 1); - SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); - - if (checkrun) - CheckPoint->readcheck_sh(SH, myrank); -#endif - - double h = GH->PatL[0]->data->blb->data->getdX(0); - for (int i = 1; i < dim; i++) - h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); - dT = Courant * h; - - if (checkrun) - { - CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); - } - else - { - PhysTime = StartTime; - Setup_Black_Hole_position(); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// Destructor: free allocated variables - -//================================================================================================ - -bssnEM_class::~bssnEM_class() -{ - delete Kpsio; - delete Kphio; - delete Exo; - delete Eyo; - delete Ezo; - delete Bxo; - delete Byo; - delete Bzo; - - delete Kpsi0; - delete Kphi0; - delete Ex0; - delete Ey0; - delete Ez0; - delete Bx0; - delete By0; - delete Bz0; - - delete Kpsi; - delete Kphi; - delete Ex; - delete Ey; - delete Ez; - delete Bx; - delete By; - delete Bz; - - delete Kpsi1; - delete Kphi1; - delete Ex1; - delete Ey1; - delete Ez1; - delete Bx1; - delete By1; - delete Bz1; - - delete Kpsi_rhs; - delete Kphi_rhs; - delete Ex_rhs; - delete Ey_rhs; - delete Ez_rhs; - delete Bx_rhs; - delete By_rhs; - delete Bz_rhs; - - delete qchar; - delete Jx; - delete Jy; - delete Jz; - - delete Rphi2; - delete Iphi2; - - delete Rphi1; - delete Iphi1; - - delete Phi2Monitor; - - delete Phi1Monitor; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function reads TwoPuncture initial data produced by the Ansorg solver - -//================================================================================================ - -// Read initial data solved by Ansorg, PRD 70, 064011 (2004) - -void bssnEM_class::Read_Ansorg() -{ - if (checkrun) - { - CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); -#ifdef WithShell - CheckPoint->readcheck_sh(SH, myrank); -#endif - } - else - { - if (myrank == 0) - cout << "Read initial data from Ansorg's solver," - << " please be sure the input parameters for black holes are puncture parameters!!" << endl; - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here, *Qchar; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom = new double[3 * BH_NM]; - Spin = new double[3 * BH_NM]; - Mass = new double[BH_NM]; - Qchar = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass[sind] = atof(sval.c_str()); - else if (skey == "Qchar") - { - Qchar[sind] = atof(sval.c_str()); - if (myrank == 0) - cout << "black hole #" << sind << " has elctric charge " << Qchar[sind] << endl; - } - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - int order = 6; - Ansorg read_ansorg("Ansorg.psid", order); - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); - - f_get_ansorg_nbhs_em(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - Mass, Qchar, Porg_here, Pmom, Spin, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); - - f_get_ansorg_nbhs_ss_em(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - Mass, Qchar, Porg_here, Pmom, Spin, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - delete[] Porg_here; -// dump read_in initial data -// for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); -// check initial constraint -#if 0 - for(int lev=0;levlevels;lev++) Step(lev,0); - if(myrank == 0) MPI_Abort(MPI_COMM_WORLD,1); -#endif - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets electrovac initial data via analytic functions. -// Note: the description below applies only to head-on collision cases. - -//================================================================================================ - -// Set up initial data given by PRD 80, 104022 (2009) -void bssnEM_class::Setup_Initial_Data() -{ - if (checkrun) - { - CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); -#ifdef WithShell - CheckPoint->readcheck_sh(SH, myrank); -#endif - } - else - { - if (myrank == 0) - cout << "Setup initial data for head on identical charge-mass ratio black holes." << endl; - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here, *Qchar_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - Qchar_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Qchar") - { - Qchar_here[sind] = atof(sval.c_str()); - if (myrank == 0) - cout << "black hole #" << sind << " has elctric charge " << Qchar_here[sind] << endl; - } - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_nbhsem(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - Mass_here, Qchar_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_nbhsem_ss(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - Mass_here, Qchar_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Qchar_here; - delete[] Pmom_here; - delete[] Spin_here; - // dump read_in initial data - // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function configures a single time-step evolution - -//================================================================================================ - -void bssnEM_class::Step(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if ( - f_compute_rhs_empart(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[trK0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], - cg->fgfs[qchar->sgfn], - cg->fgfs[Ex_rhs->sgfn], cg->fgfs[Ey_rhs->sgfn], cg->fgfs[Ez_rhs->sgfn], - cg->fgfs[Bx_rhs->sgfn], cg->fgfs[By_rhs->sgfn], cg->fgfs[Bz_rhs->sgfn], - cg->fgfs[Kpsi_rhs->sgfn], cg->fgfs[Kphi_rhs->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - Symmetry, lev, ndeps) || - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -// check initial constraint -#if 0 - Parallel::Dump_Data(GH->PatL[lev],DumpList,0,PhysTime,dT_lev); -#endif - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if ( - f_compute_rhs_empart_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[trK0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], - cg->fgfs[qchar->sgfn], - cg->fgfs[Ex_rhs->sgfn], cg->fgfs[Ey_rhs->sgfn], cg->fgfs[Ez_rhs->sgfn], - cg->fgfs[Bx_rhs->sgfn], cg->fgfs[By_rhs->sgfn], cg->fgfs[Bz_rhs->sgfn], - cg->fgfs[Kpsi_rhs->sgfn], cg->fgfs[Kphi_rhs->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst) || - f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } -#if 1 - // falloff boundary condition - { - int n = 2; - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Ex->sgfn], n, Ex->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Ey->sgfn], n, Ey->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Ez->sgfn], n, Ez->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Bx->sgfn], n, Bx->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[By->sgfn], n, By->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Bz->sgfn], n, Bz->SoA, Symmetry); - n = 3; - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Kpsi->sgfn], n, Kpsi->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Kphi->sgfn], n, Kphi->SoA, Symmetry); - } -#endif - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff_EM(lev, dT_lev); - } - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if ( - f_compute_rhs_empart(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[trK->sgfn], - cg->fgfs[Ex->sgfn], cg->fgfs[Ey->sgfn], cg->fgfs[Ez->sgfn], - cg->fgfs[Bx->sgfn], cg->fgfs[By->sgfn], cg->fgfs[Bz->sgfn], - cg->fgfs[Kpsi->sgfn], cg->fgfs[Kphi->sgfn], - cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], - cg->fgfs[qchar->sgfn], - cg->fgfs[Ex1->sgfn], cg->fgfs[Ey1->sgfn], cg->fgfs[Ez1->sgfn], - cg->fgfs[Bx1->sgfn], cg->fgfs[By1->sgfn], cg->fgfs[Bz1->sgfn], - cg->fgfs[Kpsi1->sgfn], cg->fgfs[Kphi1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - Symmetry, lev, ndeps) || - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if ( - f_compute_rhs_empart_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Lap->sgfn], cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], - cg->fgfs[Sfz->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[Ex->sgfn], cg->fgfs[Ey->sgfn], cg->fgfs[Ez->sgfn], - cg->fgfs[Bx->sgfn], cg->fgfs[By->sgfn], cg->fgfs[Bz->sgfn], - cg->fgfs[Kpsi->sgfn], cg->fgfs[Kphi->sgfn], - cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], - cg->fgfs[qchar->sgfn], - cg->fgfs[Ex1->sgfn], cg->fgfs[Ey1->sgfn], cg->fgfs[Ez1->sgfn], - cg->fgfs[Bx1->sgfn], cg->fgfs[By1->sgfn], cg->fgfs[Bz1->sgfn], - cg->fgfs[Kpsi1->sgfn], cg->fgfs[Kphi1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst) || - f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } -#if 1 - // falloff boundary condition - { - int n = 2; - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Ex1->sgfn], n, Ex1->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Ey1->sgfn], n, Ey1->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Ez1->sgfn], n, Ez1->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Bx1->sgfn], n, Bx1->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[By1->sgfn], n, By1->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Bz1->sgfn], n, Bz1->SoA, Symmetry); - n = 3; - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Kpsi1->sgfn], n, Kpsi1->SoA, Symmetry); - f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[Kphi1->sgfn], n, Kphi1->SoA, Symmetry); - } -#endif - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } - -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes the electromagnetic radiation scalar Phi2 - -//================================================================================================ - -void bssnEM_class::Compute_Phi2(int lev) -{ - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_getnpem2(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Rphi2->sgfn], cg->fgfs[Iphi2->sgfn], - Symmetry); - f_getnpem1(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Rphi1->sgfn], cg->fgfs[Iphi1->sgfn], - Symmetry); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#ifdef WithShell - // ShellPatch part - if (lev == 0) - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_getnpem2_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Rphi2->sgfn], cg->fgfs[Iphi2->sgfn], - Symmetry, Pp->data->sst); - f_getnpem1_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Rphi1->sgfn], cg->fgfs[Iphi1->sgfn], - Symmetry, Pp->data->sst); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#endif - - MyList *DG_List = new MyList(Rphi2); - DG_List->insert(Iphi2); - DG_List->insert(Rphi1); - DG_List->insert(Iphi1); - Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - SH->Synch(DG_List, Symmetry); - } -#endif - DG_List->clearList(); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function analyzes electromagnetic field data - -//================================================================================================ - -void bssnEM_class::AnalysisStuff_EM(int lev, double dT_lev) -{ - LastAnas += dT_lev; - - if (LastAnas >= AnasTime) - { - Compute_Phi2(lev); - double *RP, *IP; - int NN = 0; - // for phi2 - for (int pl = 1; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - NN++; - RP = new double[NN]; - IP = new double[NN]; - double Rex = maxrex; - for (int i = 0; i < decn; i++) - { -#ifdef WithShell - if (lev > 0 || Rex < GH->bbox[0][0][3]) - { - // Waveshell->surf_Wave(Rex,lev,GH, Rphi2, Iphi2,1,maxl,NN,RP,IP,ErrorMonitor); - Waveshell->surf_Wave(Rex, lev, GH, - Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - 1, maxl, NN, RP, IP, ErrorMonitor, - f_getnpem2_point); - } - else - { - // Waveshell->surf_Wave(Rex,lev,SH, Rphi2, Iphi2,1,maxl,NN,RP,IP,ErrorMonitor); - // Waveshell->surf_Wave(Rex,lev,SH, Ex0,Ey0,Ez0,Bx0,By0,Bz0,phi0,gxx0,gxy0,gxz0,gyy0,gyz0,gzz0,1,maxl,NN,RP,IP,ErrorMonitor); - Waveshell->surf_Wave(Rex, lev, SH, - Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - 1, maxl, NN, RP, IP, ErrorMonitor, - f_getnpem2_point); - } -#else - // Waveshell->surf_Wave(Rex,lev,GH, Rphi2, Iphi2,1,maxl,NN,RP,IP,ErrorMonitor); - Waveshell->surf_Wave(Rex, lev, GH, - Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - 1, maxl, NN, RP, IP, ErrorMonitor, - f_getnpem2_point); -#endif - Phi2Monitor->writefile(PhysTime, NN, RP, IP); - Rex = Rex - drex; - } - delete[] RP; - delete[] IP; - - // for phi1 - NN = 0; - for (int pl = 0; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - NN++; - RP = new double[NN]; - IP = new double[NN]; - Rex = maxrex; - for (int i = 0; i < decn; i++) - { -#ifdef WithShell - if (lev > 0 || Rex < GH->bbox[0][0][3]) - { - // Waveshell->surf_Wave(Rex,lev,GH, Rphi1, Iphi1,0,maxl,NN,RP,IP,ErrorMonitor); - Waveshell->surf_Wave(Rex, lev, GH, - Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - 0, maxl, NN, RP, IP, ErrorMonitor, - f_getnpem1_point); - } - else - { - // Waveshell->surf_Wave(Rex,lev,SH, Rphi1, Iphi1,0,maxl,NN,RP,IP,ErrorMonitor); - Waveshell->surf_Wave(Rex, lev, SH, - Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - 0, maxl, NN, RP, IP, ErrorMonitor, - f_getnpem1_point); - } -#else - // Waveshell->surf_Wave(Rex,lev,GH, Rphi1, Iphi1,0,maxl,NN,RP,IP,ErrorMonitor); - Waveshell->surf_Wave(Rex, lev, GH, - Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - 0, maxl, NN, RP, IP, ErrorMonitor, - f_getnpem1_point); -#endif - Phi1Monitor->writefile(PhysTime, NN, RP, IP); - Rex = Rex - drex; - } - delete[] RP; - delete[] IP; - } - - AnalysisStuff(lev, dT_lev); // LastAnas need and only need control here - - // Is this a shared variable? Should it be reset after each analysis? - LastAnas = 0; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function interpolates constraint data - -//================================================================================================ - -void bssnEM_class::Interp_Constraint() -{ - // we do not support a_lev != 0 yet. - if (a_lev > 0) - return; - - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - if (lev > 0) - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_empart(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[trK0->sgfn], - cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], - cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], - cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], - cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], - cg->fgfs[qchar->sgfn], - cg->fgfs[Ex_rhs->sgfn], cg->fgfs[Ey_rhs->sgfn], cg->fgfs[Ez_rhs->sgfn], - cg->fgfs[Bx_rhs->sgfn], cg->fgfs[By_rhs->sgfn], cg->fgfs[Bz_rhs->sgfn], - cg->fgfs[Kpsi_rhs->sgfn], cg->fgfs[Kphi_rhs->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - Symmetry, lev, ndeps) || - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - SH->Synch(ConstraintList, Symmetry); -#endif - // interpolate - double *x1, *y1, *z1; - const int n = 1000; - double lmax, lmin, dd; - lmin = 0; -#ifdef WithShell - lmax = SH->Rrange[1]; -#else - lmax = GH->bbox[0][0][4]; -#endif -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (lmax - lmin) / (n - 1); -#else -#ifdef Cell - dd = (lmax - lmin) / n; -#else -#error Not define Vertex nor Cell -#endif -#endif - x1 = new double[n]; - y1 = new double[n]; - z1 = new double[n]; - for (int i = 0; i < n; i++) - { - x1[i] = 0; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y1[i] = lmin + i * dd; -#else -#ifdef Cell - y1[i] = lmin + (i + 0.5) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - z1[i] = 0; - } - - int InList = 0; - - MyList *varl = ConstraintList; - while (varl) - { - InList++; - varl = varl->next; - } - double *shellf; - shellf = new double[n * InList]; - for (int i = 0; i < n; i++) - { - double XX[3]; - XX[0] = x1[i]; - XX[1] = y1[i]; - XX[2] = z1[i]; - bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#ifdef WithShell - if (!fg) - fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#endif - if (!fg && myrank == 0) - { - cout << "bssn_class::Interp_Constraint meets wrong" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - ofstream outfile; - char filename[50]; - sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); - // 0.5 for round off - - outfile.open(filename); - outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; - for (int i = 0; i < n; i++) - { - outfile << setw(10) << setprecision(10) << y1[i]; - for (int j = 0; j < InList; j++) - outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; - outfile << endl; - } - - delete[] shellf; -} - -//================================================================================================ - + +#ifdef newc +#include +#include +#include +using namespace std; +#else +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "misc.h" +#include "Ansorg.h" +#include "fmisc.h" +#include "Parallel.h" +#include "bssnEM_class.h" +#include "bssn_rhs.h" +#include "empart.h" +#include "initial_puncture.h" +#include "initial_maxwell.h" +#include "enforce_algebra.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" +#include "getnp4.h" +#include "getnpem2.h" +#include "shellfunctions.h" +#include "parameters.h" + +#ifdef With_AHF +#include "derivatives.h" +#include "myglobal.h" +#endif + +//================================================================================================ + +// Define bssnEM_class + +// It inherits some members and methods from the parent class bssn_class and modifies others. +// The modified members and methods are defined below (and in the header bssnEM_class.h). +// The remaining members are inherited from the parent class bssn_class (declared in bssn_class.h). + +//================================================================================================ + +bssnEM_class::bssnEM_class(double Couranti, double StartTimei, double TotalTimei, + double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, + double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi) + : bssn_class(Couranti, StartTimei, TotalTimei, + DumpTimei, d2DumpTimei, CheckTimei, AnasTimei, + Symmetryi, checkruni, checkfilenamei, numepssi, numepsbi, numepshi, + a_levi, maxli, decni, maxrexi, drexi) +{ + // setup Monitors + { + char str[50]; + stringstream a_stream; + a_stream.setf(ios::left); + a_stream.str(""); + a_stream << setw(15) << "# time"; + for (int pl = 1; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + sprintf(str, "R%02dm%03d", pl, pm); + a_stream << setw(16) << str; + sprintf(str, "I%02dm%03d", pl, pm); + a_stream << setw(16) << str; + } + Phi2Monitor = new monitor("bssn_phi2.dat", myrank, a_stream.str()); // myrank has been setup in bssn_class.C + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + for (int pl = 0; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + sprintf(str, "R%02dm%03d", pl, pm); + a_stream << setw(16) << str; + sprintf(str, "I%02dm%03d", pl, pm); + a_stream << setw(16) << str; + } + Phi1Monitor = new monitor("bssn_phi1.dat", myrank, a_stream.str()); // myrank has been setup in bssn_class.C + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function initializes the class + +//================================================================================================ + +void bssnEM_class::Initialize() +{ + Exo = new var("Exo", ngfs++, -1, 1, 1); + Eyo = new var("Eyo", ngfs++, 1, -1, 1); + Ezo = new var("Ezo", ngfs++, 1, 1, -1); + // note B is an axi vector + Bxo = new var("Bxo", ngfs++, 1, -1, -1); + Byo = new var("Byo", ngfs++, -1, 1, -1); + Bzo = new var("Bzo", ngfs++, -1, -1, 1); + Kpsio = new var("Kpsio", ngfs++, 1, 1, 1); + Kphio = new var("Kphio", ngfs++, 1, 1, 1); + + Ex0 = new var("Ex0", ngfs++, -1, 1, 1); + Ey0 = new var("Ey0", ngfs++, 1, -1, 1); + Ez0 = new var("Ez0", ngfs++, 1, 1, -1); + Bx0 = new var("Bx0", ngfs++, 1, -1, -1); + By0 = new var("By0", ngfs++, -1, 1, -1); + Bz0 = new var("Bz0", ngfs++, -1, -1, 1); + Kpsi0 = new var("Kpsi0", ngfs++, 1, 1, 1); + Kphi0 = new var("Kphi0", ngfs++, 1, 1, 1); + + Ex = new var("Ex", ngfs++, -1, 1, 1); + Ey = new var("Ey", ngfs++, 1, -1, 1); + Ez = new var("Ez", ngfs++, 1, 1, -1); + Bx = new var("Bx", ngfs++, 1, -1, -1); + By = new var("By", ngfs++, -1, 1, -1); + Bz = new var("Bz", ngfs++, -1, -1, 1); + Kpsi = new var("Kpsi", ngfs++, 1, 1, 1); + Kphi = new var("Kphi", ngfs++, 1, 1, 1); + + Ex1 = new var("Ex1", ngfs++, -1, 1, 1); + Ey1 = new var("Ey1", ngfs++, 1, -1, 1); + Ez1 = new var("Ez1", ngfs++, 1, 1, -1); + Bx1 = new var("Bx1", ngfs++, 1, -1, -1); + By1 = new var("By1", ngfs++, -1, 1, -1); + Bz1 = new var("Bz1", ngfs++, -1, -1, 1); + Kpsi1 = new var("Kpsi1", ngfs++, 1, 1, 1); + Kphi1 = new var("Kphi1", ngfs++, 1, 1, 1); + + Ex_rhs = new var("Ex_rhs", ngfs++, -1, 1, 1); + Ey_rhs = new var("Ey_rhs", ngfs++, 1, -1, 1); + Ez_rhs = new var("Ez_rhs", ngfs++, 1, 1, -1); + Bx_rhs = new var("Bx_rhs", ngfs++, 1, -1, -1); + By_rhs = new var("By_rhs", ngfs++, -1, 1, -1); + Bz_rhs = new var("Bz_rhs", ngfs++, -1, -1, 1); + Kpsi_rhs = new var("Kpsi_rhs", ngfs++, 1, 1, 1); + Kphi_rhs = new var("Kphi_rhs", ngfs++, 1, 1, 1); + + qchar = new var("qchar", ngfs++, 1, 1, 1); + Jx = new var("Jx", ngfs++, -1, 1, 1); + Jy = new var("Jy", ngfs++, 1, -1, 1); + Jz = new var("Jz", ngfs++, 1, 1, -1); + + Rphi2 = new var("Rphi2", ngfs++, 1, 1, 1); // Etheta - Bphi in fact, so no symmetry at all + Iphi2 = new var("Iphi2", ngfs++, -1, -1, -1); // Ephi - Btheta in fact, so no symmetry at all + + Rphi1 = new var("Rphi1", ngfs++, 1, 1, 1); // Er in fact + Iphi1 = new var("Iphi1", ngfs++, 1, 1, 1); // Br in fact + + if (myrank == 0) + cout << "you have setted " << ngfs << " grid functions." << endl; + + OldStateList->insert(Kpsio); + OldStateList->insert(Kphio); + OldStateList->insert(Exo); + OldStateList->insert(Eyo); + OldStateList->insert(Ezo); + OldStateList->insert(Bxo); + OldStateList->insert(Byo); + OldStateList->insert(Bzo); + + StateList->insert(Kpsi0); + StateList->insert(Kphi0); + StateList->insert(Ex0); + StateList->insert(Ey0); + StateList->insert(Ez0); + StateList->insert(Bx0); + StateList->insert(By0); + StateList->insert(Bz0); + + RHSList->insert(Kpsi_rhs); + RHSList->insert(Kphi_rhs); + RHSList->insert(Ex_rhs); + RHSList->insert(Ey_rhs); + RHSList->insert(Ez_rhs); + RHSList->insert(Bx_rhs); + RHSList->insert(By_rhs); + RHSList->insert(Bz_rhs); + + SynchList_pre->insert(Kpsi); + SynchList_pre->insert(Kphi); + SynchList_pre->insert(Ex); + SynchList_pre->insert(Ey); + SynchList_pre->insert(Ez); + SynchList_pre->insert(Bx); + SynchList_pre->insert(By); + SynchList_pre->insert(Bz); + + SynchList_cor->insert(Kpsi1); + SynchList_cor->insert(Kphi1); + SynchList_cor->insert(Ex1); + SynchList_cor->insert(Ey1); + SynchList_cor->insert(Ez1); + SynchList_cor->insert(Bx1); + SynchList_cor->insert(By1); + SynchList_cor->insert(Bz1); + + DumpList->insert(Rphi2); + DumpList->insert(Iphi2); + DumpList->insert(Rphi1); + DumpList->insert(Iphi1); + DumpList->insert(Ex0); + DumpList->insert(Bx0); + + CheckPoint->addvariablelist(StateList); + CheckPoint->addvariablelist(OldStateList); + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); + if (checkrun) + CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); + else + GH->compose_cgh(nprocs); + +#ifdef WithShell + SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); + SH->matchcheck(GH->PatL[0]); + SH->compose_sh(nprocs); + SH->setupcordtrans(); + SH->Dump_xyz(0, 0, 1); + SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); + + if (checkrun) + CheckPoint->readcheck_sh(SH, myrank); +#endif + + double h = GH->PatL[0]->data->blb->data->getdX(0); + for (int i = 1; i < dim; i++) + h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); + dT = Courant * h; + + if (checkrun) + { + CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); + } + else + { + PhysTime = StartTime; + Setup_Black_Hole_position(); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// Destructor: free allocated variables + +//================================================================================================ + +bssnEM_class::~bssnEM_class() +{ + delete Kpsio; + delete Kphio; + delete Exo; + delete Eyo; + delete Ezo; + delete Bxo; + delete Byo; + delete Bzo; + + delete Kpsi0; + delete Kphi0; + delete Ex0; + delete Ey0; + delete Ez0; + delete Bx0; + delete By0; + delete Bz0; + + delete Kpsi; + delete Kphi; + delete Ex; + delete Ey; + delete Ez; + delete Bx; + delete By; + delete Bz; + + delete Kpsi1; + delete Kphi1; + delete Ex1; + delete Ey1; + delete Ez1; + delete Bx1; + delete By1; + delete Bz1; + + delete Kpsi_rhs; + delete Kphi_rhs; + delete Ex_rhs; + delete Ey_rhs; + delete Ez_rhs; + delete Bx_rhs; + delete By_rhs; + delete Bz_rhs; + + delete qchar; + delete Jx; + delete Jy; + delete Jz; + + delete Rphi2; + delete Iphi2; + + delete Rphi1; + delete Iphi1; + + delete Phi2Monitor; + + delete Phi1Monitor; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function reads TwoPuncture initial data produced by the Ansorg solver + +//================================================================================================ + +// Read initial data solved by Ansorg, PRD 70, 064011 (2004) + +void bssnEM_class::Read_Ansorg() +{ + if (checkrun) + { + CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); +#ifdef WithShell + CheckPoint->readcheck_sh(SH, myrank); +#endif + } + else + { + if (myrank == 0) + cout << "Read initial data from Ansorg's solver," + << " please be sure the input parameters for black holes are puncture parameters!!" << endl; + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here, *Qchar; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom = new double[3 * BH_NM]; + Spin = new double[3 * BH_NM]; + Mass = new double[BH_NM]; + Qchar = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass[sind] = atof(sval.c_str()); + else if (skey == "Qchar") + { + Qchar[sind] = atof(sval.c_str()); + if (myrank == 0) + cout << "black hole #" << sind << " has elctric charge " << Qchar[sind] << endl; + } + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + int order = 6; + Ansorg read_ansorg("Ansorg.psid", order); + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); + + f_get_ansorg_nbhs_em(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + Mass, Qchar, Porg_here, Pmom, Spin, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); + + f_get_ansorg_nbhs_ss_em(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + Mass, Qchar, Porg_here, Pmom, Spin, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + delete[] Porg_here; +// dump read_in initial data +// for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); +// check initial constraint +#if 0 + for(int lev=0;levlevels;lev++) Step(lev,0); + if(myrank == 0) MPI_Abort(MPI_COMM_WORLD,1); +#endif + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets electrovac initial data via analytic functions. +// Note: the description below applies only to head-on collision cases. + +//================================================================================================ + +// Set up initial data given by PRD 80, 104022 (2009) +void bssnEM_class::Setup_Initial_Data() +{ + if (checkrun) + { + CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); +#ifdef WithShell + CheckPoint->readcheck_sh(SH, myrank); +#endif + } + else + { + if (myrank == 0) + cout << "Setup initial data for head on identical charge-mass ratio black holes." << endl; + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here, *Qchar_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + Qchar_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Qchar") + { + Qchar_here[sind] = atof(sval.c_str()); + if (myrank == 0) + cout << "black hole #" << sind << " has elctric charge " << Qchar_here[sind] << endl; + } + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_nbhsem(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + Mass_here, Qchar_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_nbhsem_ss(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + Mass_here, Qchar_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Qchar_here; + delete[] Pmom_here; + delete[] Spin_here; + // dump read_in initial data + // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function configures a single time-step evolution + +//================================================================================================ + +void bssnEM_class::Step(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if ( + f_compute_rhs_empart(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[trK0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], + cg->fgfs[qchar->sgfn], + cg->fgfs[Ex_rhs->sgfn], cg->fgfs[Ey_rhs->sgfn], cg->fgfs[Ez_rhs->sgfn], + cg->fgfs[Bx_rhs->sgfn], cg->fgfs[By_rhs->sgfn], cg->fgfs[Bz_rhs->sgfn], + cg->fgfs[Kpsi_rhs->sgfn], cg->fgfs[Kphi_rhs->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + Symmetry, lev, ndeps) || + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +// check initial constraint +#if 0 + Parallel::Dump_Data(GH->PatL[lev],DumpList,0,PhysTime,dT_lev); +#endif + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if ( + f_compute_rhs_empart_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[trK0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], + cg->fgfs[qchar->sgfn], + cg->fgfs[Ex_rhs->sgfn], cg->fgfs[Ey_rhs->sgfn], cg->fgfs[Ez_rhs->sgfn], + cg->fgfs[Bx_rhs->sgfn], cg->fgfs[By_rhs->sgfn], cg->fgfs[Bz_rhs->sgfn], + cg->fgfs[Kpsi_rhs->sgfn], cg->fgfs[Kphi_rhs->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst) || + f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } +#if 1 + // falloff boundary condition + { + int n = 2; + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Ex->sgfn], n, Ex->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Ey->sgfn], n, Ey->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Ez->sgfn], n, Ez->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Bx->sgfn], n, Bx->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[By->sgfn], n, By->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Bz->sgfn], n, Bz->SoA, Symmetry); + n = 3; + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Kpsi->sgfn], n, Kpsi->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Kphi->sgfn], n, Kphi->SoA, Symmetry); + } +#endif + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff_EM(lev, dT_lev); + } + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if ( + f_compute_rhs_empart(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[trK->sgfn], + cg->fgfs[Ex->sgfn], cg->fgfs[Ey->sgfn], cg->fgfs[Ez->sgfn], + cg->fgfs[Bx->sgfn], cg->fgfs[By->sgfn], cg->fgfs[Bz->sgfn], + cg->fgfs[Kpsi->sgfn], cg->fgfs[Kphi->sgfn], + cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], + cg->fgfs[qchar->sgfn], + cg->fgfs[Ex1->sgfn], cg->fgfs[Ey1->sgfn], cg->fgfs[Ez1->sgfn], + cg->fgfs[Bx1->sgfn], cg->fgfs[By1->sgfn], cg->fgfs[Bz1->sgfn], + cg->fgfs[Kpsi1->sgfn], cg->fgfs[Kphi1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + Symmetry, lev, ndeps) || + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if ( + f_compute_rhs_empart_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Lap->sgfn], cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], + cg->fgfs[Sfz->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[Ex->sgfn], cg->fgfs[Ey->sgfn], cg->fgfs[Ez->sgfn], + cg->fgfs[Bx->sgfn], cg->fgfs[By->sgfn], cg->fgfs[Bz->sgfn], + cg->fgfs[Kpsi->sgfn], cg->fgfs[Kphi->sgfn], + cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], + cg->fgfs[qchar->sgfn], + cg->fgfs[Ex1->sgfn], cg->fgfs[Ey1->sgfn], cg->fgfs[Ez1->sgfn], + cg->fgfs[Bx1->sgfn], cg->fgfs[By1->sgfn], cg->fgfs[Bz1->sgfn], + cg->fgfs[Kpsi1->sgfn], cg->fgfs[Kphi1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst) || + f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } +#if 1 + // falloff boundary condition + { + int n = 2; + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Ex1->sgfn], n, Ex1->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Ey1->sgfn], n, Ey1->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Ez1->sgfn], n, Ez1->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Bx1->sgfn], n, Bx1->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[By1->sgfn], n, By1->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Bz1->sgfn], n, Bz1->SoA, Symmetry); + n = 3; + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Kpsi1->sgfn], n, Kpsi1->SoA, Symmetry); + f_falloff_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[Kphi1->sgfn], n, Kphi1->SoA, Symmetry); + } +#endif + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } + +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes the electromagnetic radiation scalar Phi2 + +//================================================================================================ + +void bssnEM_class::Compute_Phi2(int lev) +{ + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_getnpem2(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Rphi2->sgfn], cg->fgfs[Iphi2->sgfn], + Symmetry); + f_getnpem1(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Rphi1->sgfn], cg->fgfs[Iphi1->sgfn], + Symmetry); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#ifdef WithShell + // ShellPatch part + if (lev == 0) + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_getnpem2_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Rphi2->sgfn], cg->fgfs[Iphi2->sgfn], + Symmetry, Pp->data->sst); + f_getnpem1_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Rphi1->sgfn], cg->fgfs[Iphi1->sgfn], + Symmetry, Pp->data->sst); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#endif + + MyList *DG_List = new MyList(Rphi2); + DG_List->insert(Iphi2); + DG_List->insert(Rphi1); + DG_List->insert(Iphi1); + Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + SH->Synch(DG_List, Symmetry); + } +#endif + DG_List->clearList(); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function analyzes electromagnetic field data + +//================================================================================================ + +void bssnEM_class::AnalysisStuff_EM(int lev, double dT_lev) +{ + LastAnas += dT_lev; + + if (LastAnas >= AnasTime) + { + Compute_Phi2(lev); + double *RP, *IP; + int NN = 0; + // for phi2 + for (int pl = 1; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + NN++; + RP = new double[NN]; + IP = new double[NN]; + double Rex = maxrex; + for (int i = 0; i < decn; i++) + { +#ifdef WithShell + if (lev > 0 || Rex < GH->bbox[0][0][3]) + { + // Waveshell->surf_Wave(Rex,lev,GH, Rphi2, Iphi2,1,maxl,NN,RP,IP,ErrorMonitor); + Waveshell->surf_Wave(Rex, lev, GH, + Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + 1, maxl, NN, RP, IP, ErrorMonitor, + f_getnpem2_point); + } + else + { + // Waveshell->surf_Wave(Rex,lev,SH, Rphi2, Iphi2,1,maxl,NN,RP,IP,ErrorMonitor); + // Waveshell->surf_Wave(Rex,lev,SH, Ex0,Ey0,Ez0,Bx0,By0,Bz0,phi0,gxx0,gxy0,gxz0,gyy0,gyz0,gzz0,1,maxl,NN,RP,IP,ErrorMonitor); + Waveshell->surf_Wave(Rex, lev, SH, + Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + 1, maxl, NN, RP, IP, ErrorMonitor, + f_getnpem2_point); + } +#else + // Waveshell->surf_Wave(Rex,lev,GH, Rphi2, Iphi2,1,maxl,NN,RP,IP,ErrorMonitor); + Waveshell->surf_Wave(Rex, lev, GH, + Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + 1, maxl, NN, RP, IP, ErrorMonitor, + f_getnpem2_point); +#endif + Phi2Monitor->writefile(PhysTime, NN, RP, IP); + Rex = Rex - drex; + } + delete[] RP; + delete[] IP; + + // for phi1 + NN = 0; + for (int pl = 0; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + NN++; + RP = new double[NN]; + IP = new double[NN]; + Rex = maxrex; + for (int i = 0; i < decn; i++) + { +#ifdef WithShell + if (lev > 0 || Rex < GH->bbox[0][0][3]) + { + // Waveshell->surf_Wave(Rex,lev,GH, Rphi1, Iphi1,0,maxl,NN,RP,IP,ErrorMonitor); + Waveshell->surf_Wave(Rex, lev, GH, + Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + 0, maxl, NN, RP, IP, ErrorMonitor, + f_getnpem1_point); + } + else + { + // Waveshell->surf_Wave(Rex,lev,SH, Rphi1, Iphi1,0,maxl,NN,RP,IP,ErrorMonitor); + Waveshell->surf_Wave(Rex, lev, SH, + Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + 0, maxl, NN, RP, IP, ErrorMonitor, + f_getnpem1_point); + } +#else + // Waveshell->surf_Wave(Rex,lev,GH, Rphi1, Iphi1,0,maxl,NN,RP,IP,ErrorMonitor); + Waveshell->surf_Wave(Rex, lev, GH, + Ex0, Ey0, Ez0, Bx0, By0, Bz0, phi0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + 0, maxl, NN, RP, IP, ErrorMonitor, + f_getnpem1_point); +#endif + Phi1Monitor->writefile(PhysTime, NN, RP, IP); + Rex = Rex - drex; + } + delete[] RP; + delete[] IP; + } + + AnalysisStuff(lev, dT_lev); // LastAnas need and only need control here + + // Is this a shared variable? Should it be reset after each analysis? + LastAnas = 0; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function interpolates constraint data + +//================================================================================================ + +void bssnEM_class::Interp_Constraint() +{ + // we do not support a_lev != 0 yet. + if (a_lev > 0) + return; + + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + if (lev > 0) + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_empart(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[trK0->sgfn], + cg->fgfs[Ex0->sgfn], cg->fgfs[Ey0->sgfn], cg->fgfs[Ez0->sgfn], + cg->fgfs[Bx0->sgfn], cg->fgfs[By0->sgfn], cg->fgfs[Bz0->sgfn], + cg->fgfs[Kpsi0->sgfn], cg->fgfs[Kphi0->sgfn], + cg->fgfs[Jx->sgfn], cg->fgfs[Jy->sgfn], cg->fgfs[Jz->sgfn], + cg->fgfs[qchar->sgfn], + cg->fgfs[Ex_rhs->sgfn], cg->fgfs[Ey_rhs->sgfn], cg->fgfs[Ez_rhs->sgfn], + cg->fgfs[Bx_rhs->sgfn], cg->fgfs[By_rhs->sgfn], cg->fgfs[Bz_rhs->sgfn], + cg->fgfs[Kpsi_rhs->sgfn], cg->fgfs[Kphi_rhs->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + Symmetry, lev, ndeps) || + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + SH->Synch(ConstraintList, Symmetry); +#endif + // interpolate + double *x1, *y1, *z1; + const int n = 1000; + double lmax, lmin, dd; + lmin = 0; +#ifdef WithShell + lmax = SH->Rrange[1]; +#else + lmax = GH->bbox[0][0][4]; +#endif +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (lmax - lmin) / (n - 1); +#else +#ifdef Cell + dd = (lmax - lmin) / n; +#else +#error Not define Vertex nor Cell +#endif +#endif + x1 = new double[n]; + y1 = new double[n]; + z1 = new double[n]; + for (int i = 0; i < n; i++) + { + x1[i] = 0; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y1[i] = lmin + i * dd; +#else +#ifdef Cell + y1[i] = lmin + (i + 0.5) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + z1[i] = 0; + } + + int InList = 0; + + MyList *varl = ConstraintList; + while (varl) + { + InList++; + varl = varl->next; + } + double *shellf; + shellf = new double[n * InList]; + for (int i = 0; i < n; i++) + { + double XX[3]; + XX[0] = x1[i]; + XX[1] = y1[i]; + XX[2] = z1[i]; + bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#ifdef WithShell + if (!fg) + fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#endif + if (!fg && myrank == 0) + { + cout << "bssn_class::Interp_Constraint meets wrong" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + ofstream outfile; + char filename[50]; + sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); + // 0.5 for round off + + outfile.open(filename); + outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; + for (int i = 0; i < n; i++) + { + outfile << setw(10) << setprecision(10) << y1[i]; + for (int j = 0; j < InList; j++) + outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; + outfile << endl; + } + + delete[] shellf; +} + +//================================================================================================ + diff --git a/AMSS_NCKU_source/bssnEM_class.h b/AMSS_NCKU_source/BSSN/bssnEM_class.h similarity index 96% rename from AMSS_NCKU_source/bssnEM_class.h rename to AMSS_NCKU_source/BSSN/bssnEM_class.h index 2bff672..0715f33 100644 --- a/AMSS_NCKU_source/bssnEM_class.h +++ b/AMSS_NCKU_source/BSSN/bssnEM_class.h @@ -1,69 +1,69 @@ - -#ifndef BSSNEM_CLASS_H -#define BSSNEM_CLASS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "cgh.h" -#include "ShellPatch.h" -#include "misc.h" -#include "var.h" -#include "MyList.h" -#include "monitor.h" -#include "surface_integral.h" - -#include "macrodef.h" - -#ifdef USE_GPU -#include "bssn_gpu_class.h" -#else -#include "bssn_class.h" -#endif - -class bssnEM_class : public bssn_class -{ -public: - bssnEM_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi); - ~bssnEM_class(); - - void Initialize(); - void Read_Ansorg(); - void Setup_Initial_Data(); - void Step(int lev, int YN); - void Compute_Phi2(int lev); - void AnalysisStuff_EM(int lev, double dT_lev); - void Interp_Constraint(); - -protected: - var *Exo, *Eyo, *Ezo, *Bxo, *Byo, *Bzo, *Kpsio, *Kphio; - var *Ex0, *Ey0, *Ez0, *Bx0, *By0, *Bz0, *Kpsi0, *Kphi0; - var *Ex, *Ey, *Ez, *Bx, *By, *Bz, *Kpsi, *Kphi; - var *Ex1, *Ey1, *Ez1, *Bx1, *By1, *Bz1, *Kpsi1, *Kphi1; - var *Ex_rhs, *Ey_rhs, *Ez_rhs, *Bx_rhs, *By_rhs, *Bz_rhs, *Kpsi_rhs, *Kphi_rhs; - var *Jx, *Jy, *Jz, *qchar; - var *Rphi2, *Iphi2; - var *Rphi1, *Iphi1; - - monitor *Phi2Monitor; - monitor *Phi1Monitor; -}; -#endif /* BSSNEM_CLASS_H */ + +#ifndef BSSNEM_CLASS_H +#define BSSNEM_CLASS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "cgh.h" +#include "ShellPatch.h" +#include "misc.h" +#include "var.h" +#include "MyList.h" +#include "monitor.h" +#include "surface_integral.h" + +#include "macrodef.h" + +#ifdef USE_GPU +#include "bssn_gpu_class.h" +#else +#include "bssn_class.h" +#endif + +class bssnEM_class : public bssn_class +{ +public: + bssnEM_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi); + ~bssnEM_class(); + + void Initialize(); + void Read_Ansorg(); + void Setup_Initial_Data(); + void Step(int lev, int YN); + void Compute_Phi2(int lev); + void AnalysisStuff_EM(int lev, double dT_lev); + void Interp_Constraint(); + +protected: + var *Exo, *Eyo, *Ezo, *Bxo, *Byo, *Bzo, *Kpsio, *Kphio; + var *Ex0, *Ey0, *Ez0, *Bx0, *By0, *Bz0, *Kpsi0, *Kphi0; + var *Ex, *Ey, *Ez, *Bx, *By, *Bz, *Kpsi, *Kphi; + var *Ex1, *Ey1, *Ez1, *Bx1, *By1, *Bz1, *Kpsi1, *Kphi1; + var *Ex_rhs, *Ey_rhs, *Ez_rhs, *Bx_rhs, *By_rhs, *Bz_rhs, *Kpsi_rhs, *Kphi_rhs; + var *Jx, *Jy, *Jz, *qchar; + var *Rphi2, *Iphi2; + var *Rphi1, *Iphi1; + + monitor *Phi2Monitor; + monitor *Phi1Monitor; +}; +#endif /* BSSNEM_CLASS_H */ diff --git a/AMSS_NCKU_source/bssn_class.C b/AMSS_NCKU_source/BSSN/bssn_class.C similarity index 97% rename from AMSS_NCKU_source/bssn_class.C rename to AMSS_NCKU_source/BSSN/bssn_class.C index ac136dd..e6c3274 100644 --- a/AMSS_NCKU_source/bssn_class.C +++ b/AMSS_NCKU_source/BSSN/bssn_class.C @@ -1,41 +1,41 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "misc.h" -#include "Ansorg.h" -#include "fmisc.h" -#include "Parallel.h" -#include "bssn_class.h" -#include "bssn_rhs.h" -#include "initial_puncture.h" -#include "enforce_algebra.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" -#include "getnp4.h" -#include "shellfunctions.h" -#include "parameters.h" - -#ifdef With_AHF -#include "derivatives.h" -#include "myglobal.h" -#endif - + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "misc.h" +#include "Ansorg.h" +#include "fmisc.h" +#include "Parallel.h" +#include "bssn_class.h" +#include "bssn_rhs.h" +#include "initial_puncture.h" +#include "enforce_algebra.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" +#include "getnp4.h" +#include "shellfunctions.h" +#include "parameters.h" + +#ifdef With_AHF +#include "derivatives.h" +#include "myglobal.h" +#endif + #include "perf.h" #include "derivatives.h" @@ -275,62 +275,62 @@ namespace rhs_kernel_timing_report #endif //================================================================================================ - -// define bssn_class - -//================================================================================================ - -bssn_class::bssn_class(double Couranti, double StartTimei, double TotalTimei, - double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, - double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi) - : Courant(Couranti), StartTime(StartTimei), TotalTime(TotalTimei), - DumpTime(DumpTimei), d2DumpTime(d2DumpTimei), CheckTime(CheckTimei), AnasTime(AnasTimei), - Symmetry(Symmetryi), checkrun(checkruni), numepss(numepssi), numepsb(numepsbi), numepsh(numepshi), -#ifdef With_AHF - xc(0), yc(0), zc(0), xr(0), yr(0), zr(0), trigger(0), dTT(0), dumpid(0), -#endif + +// define bssn_class + +//================================================================================================ + +bssn_class::bssn_class(double Couranti, double StartTimei, double TotalTimei, + double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, + double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi) + : Courant(Couranti), StartTime(StartTimei), TotalTime(TotalTimei), + DumpTime(DumpTimei), d2DumpTime(d2DumpTimei), CheckTime(CheckTimei), AnasTime(AnasTimei), + Symmetry(Symmetryi), checkrun(checkruni), numepss(numepssi), numepsb(numepsbi), numepsh(numepshi), +#ifdef With_AHF + xc(0), yc(0), zc(0), xr(0), yr(0), zr(0), trigger(0), dTT(0), dumpid(0), +#endif a_lev(a_levi), maxl(maxli), decn(decni), maxrex(maxrexi), drex(drexi), ConstraintRefreshLevels(0), CheckPoint(0) - // CheckPoint(0) -{ - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - // setup Monitors - { - stringstream a_stream; - a_stream.setf(ios::left); - a_stream << "# Error log information"; - ErrorMonitor = new monitor("Error.log", myrank, a_stream.str()); - ErrorMonitor->print_message("Warning: we always assume intput parameter in cell center style."); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - char str[50]; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - sprintf(str, "R%02dm%03d", pl, pm); - a_stream << setw(16) << str; - sprintf(str, "I%02dm%03d", pl, pm); - a_stream << setw(16) << str; - } - Psi4Monitor = new monitor("bssn_psi4.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - BHMonitor = new monitor("bssn_BH.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time ADMmass ADMPx ADMPy ADMPz ADMSx ADMSy ADMSz"; - MAPMonitor = new monitor("bssn_ADMQs.dat", myrank, a_stream.str()); - + // CheckPoint(0) +{ + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + // setup Monitors + { + stringstream a_stream; + a_stream.setf(ios::left); + a_stream << "# Error log information"; + ErrorMonitor = new monitor("Error.log", myrank, a_stream.str()); + ErrorMonitor->print_message("Warning: we always assume intput parameter in cell center style."); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + char str[50]; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + sprintf(str, "R%02dm%03d", pl, pm); + a_stream << setw(16) << str; + sprintf(str, "I%02dm%03d", pl, pm); + a_stream << setw(16) << str; + } + Psi4Monitor = new monitor("bssn_psi4.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + BHMonitor = new monitor("bssn_BH.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time ADMmass ADMPx ADMPy ADMPz ADMSx ADMSy ADMSz"; + MAPMonitor = new monitor("bssn_ADMQs.dat", myrank, a_stream.str()); + a_stream.clear(); a_stream.str(""); a_stream << setw(15) << "# time Ham Px Py Pz Gx Gy Gz"; @@ -354,2049 +354,2049 @@ bssn_class::bssn_class(double Couranti, double StartTimei, double TotalTimei, TimingMonitor = 0; #endif } - // setup sphere integration engine - Waveshell = new surface_integral(Symmetry); - - trfls = 0; - chitiny = 0; - // read parameter from file - { - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "chitiny") - chitiny = atof(sval.c_str()); - else if (sgrp == "BSSN" && skey == "time refinement start from level") - trfls = atoi(sval.c_str()); -#ifdef With_AHF - else if (sgrp == "AHF" && skey == "AHfindevery") - AHfindevery = atoi(sval.c_str()); - else if (sgrp == "AHF" && skey == "AHdumptime") - AHdumptime = atof(sval.c_str()); -#endif - } - inf.close(); - } - if (myrank == 0) - { - // echo information of lower bound of chi - cout << " chitiny = " << chitiny << endl; - cout << " time refinement start from level #" << trfls << endl; -#ifdef With_AHF - cout << " parameters for AHF:" << endl; - cout << " AHfindevery = " << AHfindevery << endl; - cout << " AHdumptime = " << AHdumptime << endl; -#endif - } - - chitiny = chitiny - 1; // because we have subtracted one from chi - - strcpy(checkfilename, checkfilenamei); - - ngfs = 0; - phio = new var("phio", ngfs++, 1, 1, 1); - trKo = new var("trKo", ngfs++, 1, 1, 1); - gxxo = new var("gxxo", ngfs++, 1, 1, 1); - gxyo = new var("gxyo", ngfs++, -1, -1, 1); - gxzo = new var("gxzo", ngfs++, -1, 1, -1); - gyyo = new var("gyyo", ngfs++, 1, 1, 1); - gyzo = new var("gyzo", ngfs++, 1, -1, -1); - gzzo = new var("gzzo", ngfs++, 1, 1, 1); - Axxo = new var("Axxo", ngfs++, 1, 1, 1); - Axyo = new var("Axyo", ngfs++, -1, -1, 1); - Axzo = new var("Axzo", ngfs++, -1, 1, -1); - Ayyo = new var("Ayyo", ngfs++, 1, 1, 1); - Ayzo = new var("Ayzo", ngfs++, 1, -1, -1); - Azzo = new var("Azzo", ngfs++, 1, 1, 1); - Gmxo = new var("Gmxo", ngfs++, -1, 1, 1); - Gmyo = new var("Gmyo", ngfs++, 1, -1, 1); - Gmzo = new var("Gmzo", ngfs++, 1, 1, -1); - Lapo = new var("Lapo", ngfs++, 1, 1, 1); - Sfxo = new var("Sfxo", ngfs++, -1, 1, 1); - Sfyo = new var("Sfyo", ngfs++, 1, -1, 1); - Sfzo = new var("Sfzo", ngfs++, 1, 1, -1); - dtSfxo = new var("dtSfxo", ngfs++, -1, 1, 1); - dtSfyo = new var("dtSfyo", ngfs++, 1, -1, 1); - dtSfzo = new var("dtSfzo", ngfs++, 1, 1, -1); - - phi0 = new var("phi0", ngfs++, 1, 1, 1); - trK0 = new var("trK0", ngfs++, 1, 1, 1); - gxx0 = new var("gxx0", ngfs++, 1, 1, 1); - gxy0 = new var("gxy0", ngfs++, -1, -1, 1); - gxz0 = new var("gxz0", ngfs++, -1, 1, -1); - gyy0 = new var("gyy0", ngfs++, 1, 1, 1); - gyz0 = new var("gyz0", ngfs++, 1, -1, -1); - gzz0 = new var("gzz0", ngfs++, 1, 1, 1); - Axx0 = new var("Axx0", ngfs++, 1, 1, 1); - Axy0 = new var("Axy0", ngfs++, -1, -1, 1); - Axz0 = new var("Axz0", ngfs++, -1, 1, -1); - Ayy0 = new var("Ayy0", ngfs++, 1, 1, 1); - Ayz0 = new var("Ayz0", ngfs++, 1, -1, -1); - Azz0 = new var("Azz0", ngfs++, 1, 1, 1); - Gmx0 = new var("Gmx0", ngfs++, -1, 1, 1); - Gmy0 = new var("Gmy0", ngfs++, 1, -1, 1); - Gmz0 = new var("Gmz0", ngfs++, 1, 1, -1); - Lap0 = new var("Lap0", ngfs++, 1, 1, 1); - Sfx0 = new var("Sfx0", ngfs++, -1, 1, 1); - Sfy0 = new var("Sfy0", ngfs++, 1, -1, 1); - Sfz0 = new var("Sfz0", ngfs++, 1, 1, -1); - dtSfx0 = new var("dtSfx0", ngfs++, -1, 1, 1); - dtSfy0 = new var("dtSfy0", ngfs++, 1, -1, 1); - dtSfz0 = new var("dtSfz0", ngfs++, 1, 1, -1); - - phi = new var("phi", ngfs++, 1, 1, 1); - trK = new var("trK", ngfs++, 1, 1, 1); - gxx = new var("gxx", ngfs++, 1, 1, 1); - gxy = new var("gxy", ngfs++, -1, -1, 1); - gxz = new var("gxz", ngfs++, -1, 1, -1); - gyy = new var("gyy", ngfs++, 1, 1, 1); - gyz = new var("gyz", ngfs++, 1, -1, -1); - gzz = new var("gzz", ngfs++, 1, 1, 1); - Axx = new var("Axx", ngfs++, 1, 1, 1); - Axy = new var("Axy", ngfs++, -1, -1, 1); - Axz = new var("Axz", ngfs++, -1, 1, -1); - Ayy = new var("Ayy", ngfs++, 1, 1, 1); - Ayz = new var("Ayz", ngfs++, 1, -1, -1); - Azz = new var("Azz", ngfs++, 1, 1, 1); - Gmx = new var("Gmx", ngfs++, -1, 1, 1); - Gmy = new var("Gmy", ngfs++, 1, -1, 1); - Gmz = new var("Gmz", ngfs++, 1, 1, -1); - Lap = new var("Lap", ngfs++, 1, 1, 1); - Sfx = new var("Sfx", ngfs++, -1, 1, 1); - Sfy = new var("Sfy", ngfs++, 1, -1, 1); - Sfz = new var("Sfz", ngfs++, 1, 1, -1); - dtSfx = new var("dtSfx", ngfs++, -1, 1, 1); - dtSfy = new var("dtSfy", ngfs++, 1, -1, 1); - dtSfz = new var("dtSfz", ngfs++, 1, 1, -1); - - phi1 = new var("phi1", ngfs++, 1, 1, 1); - trK1 = new var("trK1", ngfs++, 1, 1, 1); - gxx1 = new var("gxx1", ngfs++, 1, 1, 1); - gxy1 = new var("gxy1", ngfs++, -1, -1, 1); - gxz1 = new var("gxz1", ngfs++, -1, 1, -1); - gyy1 = new var("gyy1", ngfs++, 1, 1, 1); - gyz1 = new var("gyz1", ngfs++, 1, -1, -1); - gzz1 = new var("gzz1", ngfs++, 1, 1, 1); - Axx1 = new var("Axx1", ngfs++, 1, 1, 1); - Axy1 = new var("Axy1", ngfs++, -1, -1, 1); - Axz1 = new var("Axz1", ngfs++, -1, 1, -1); - Ayy1 = new var("Ayy1", ngfs++, 1, 1, 1); - Ayz1 = new var("Ayz1", ngfs++, 1, -1, -1); - Azz1 = new var("Azz1", ngfs++, 1, 1, 1); - Gmx1 = new var("Gmx1", ngfs++, -1, 1, 1); - Gmy1 = new var("Gmy1", ngfs++, 1, -1, 1); - Gmz1 = new var("Gmz1", ngfs++, 1, 1, -1); - Lap1 = new var("Lap1", ngfs++, 1, 1, 1); - Sfx1 = new var("Sfx1", ngfs++, -1, 1, 1); - Sfy1 = new var("Sfy1", ngfs++, 1, -1, 1); - Sfz1 = new var("Sfz1", ngfs++, 1, 1, -1); - dtSfx1 = new var("dtSfx1", ngfs++, -1, 1, 1); - dtSfy1 = new var("dtSfy1", ngfs++, 1, -1, 1); - dtSfz1 = new var("dtSfz1", ngfs++, 1, 1, -1); - - phi_rhs = new var("phi_rhs", ngfs++, 1, 1, 1); - trK_rhs = new var("trK_rhs", ngfs++, 1, 1, 1); - gxx_rhs = new var("gxx_rhs", ngfs++, 1, 1, 1); - gxy_rhs = new var("gxy_rhs", ngfs++, -1, -1, 1); - gxz_rhs = new var("gxz_rhs", ngfs++, -1, 1, -1); - gyy_rhs = new var("gyy_rhs", ngfs++, 1, 1, 1); - gyz_rhs = new var("gyz_rhs", ngfs++, 1, -1, -1); - gzz_rhs = new var("gzz_rhs", ngfs++, 1, 1, 1); - Axx_rhs = new var("Axx_rhs", ngfs++, 1, 1, 1); - Axy_rhs = new var("Axy_rhs", ngfs++, -1, -1, 1); - Axz_rhs = new var("Axz_rhs", ngfs++, -1, 1, -1); - Ayy_rhs = new var("Ayy_rhs", ngfs++, 1, 1, 1); - Ayz_rhs = new var("Ayz_rhs", ngfs++, 1, -1, -1); - Azz_rhs = new var("Azz_rhs", ngfs++, 1, 1, 1); - Gmx_rhs = new var("Gmx_rhs", ngfs++, -1, 1, 1); - Gmy_rhs = new var("Gmy_rhs", ngfs++, 1, -1, 1); - Gmz_rhs = new var("Gmz_rhs", ngfs++, 1, 1, -1); - Lap_rhs = new var("Lap_rhs", ngfs++, 1, 1, 1); - Sfx_rhs = new var("Sfx_rhs", ngfs++, -1, 1, 1); - Sfy_rhs = new var("Sfy_rhs", ngfs++, 1, -1, 1); - Sfz_rhs = new var("Sfz_rhs", ngfs++, 1, 1, -1); - dtSfx_rhs = new var("dtSfx_rhs", ngfs++, -1, 1, 1); - dtSfy_rhs = new var("dtSfy_rhs", ngfs++, 1, -1, 1); - dtSfz_rhs = new var("dtSfz_rhs", ngfs++, 1, 1, -1); - - rho = new var("rho", ngfs++, 1, 1, 1); - Sx = new var("Sx", ngfs++, -1, 1, 1); - Sy = new var("Sy", ngfs++, 1, -1, 1); - Sz = new var("Sz", ngfs++, 1, 1, -1); - Sxx = new var("Sxx", ngfs++, 1, 1, 1); - Sxy = new var("Sxy", ngfs++, -1, -1, 1); - Sxz = new var("Sxz", ngfs++, -1, 1, -1); - Syy = new var("Syy", ngfs++, 1, 1, 1); - Syz = new var("Syz", ngfs++, 1, -1, -1); - Szz = new var("Szz", ngfs++, 1, 1, 1); - - Gamxxx = new var("Gamxxx", ngfs++, -1, 1, 1); - Gamxxy = new var("Gamxxy", ngfs++, 1, -1, 1); - Gamxxz = new var("Gamxxz", ngfs++, 1, 1, -1); - Gamxyy = new var("Gamxyy", ngfs++, -1, 1, 1); - Gamxyz = new var("Gamxyz", ngfs++, -1, -1, -1); - Gamxzz = new var("Gamxzz", ngfs++, -1, 1, 1); - Gamyxx = new var("Gamyxx", ngfs++, 1, -1, 1); - Gamyxy = new var("Gamyxy", ngfs++, -1, 1, 1); - Gamyxz = new var("Gamyxz", ngfs++, -1, -1, -1); - Gamyyy = new var("Gamyyy", ngfs++, 1, -1, 1); - Gamyyz = new var("Gamyyz", ngfs++, 1, 1, -1); - Gamyzz = new var("Gamyzz", ngfs++, 1, -1, 1); - Gamzxx = new var("Gamzxx", ngfs++, 1, 1, -1); - Gamzxy = new var("Gamzxy", ngfs++, -1, -1, -1); - Gamzxz = new var("Gamzxz", ngfs++, -1, 1, 1); - Gamzyy = new var("Gamzyy", ngfs++, 1, 1, -1); - Gamzyz = new var("Gamzyz", ngfs++, 1, -1, 1); - Gamzzz = new var("Gamzzz", ngfs++, 1, 1, -1); - - Rxx = new var("Rxx", ngfs++, 1, 1, 1); - Rxy = new var("Rxy", ngfs++, -1, -1, 1); - Rxz = new var("Rxz", ngfs++, -1, 1, -1); - Ryy = new var("Ryy", ngfs++, 1, 1, 1); - Ryz = new var("Ryz", ngfs++, 1, -1, -1); - Rzz = new var("Rzz", ngfs++, 1, 1, 1); - - // refer to PRD, 77, 024027 (2008) - Rpsi4 = new var("Rpsi4", ngfs++, 1, 1, 1); - Ipsi4 = new var("Ipsi4", ngfs++, -1, -1, -1); - t1Rpsi4 = new var("t1Rpsi4", ngfs++, 1, 1, 1); - t1Ipsi4 = new var("t1Ipsi4", ngfs++, -1, -1, -1); - t2Rpsi4 = new var("t2Rpsi4", ngfs++, 1, 1, 1); - t2Ipsi4 = new var("t2Ipsi4", ngfs++, -1, -1, -1); - - // constraint violation monitor variables - Cons_Ham = new var("Cons_Ham", ngfs++, 1, 1, 1); - Cons_Px = new var("Cons_Px", ngfs++, -1, 1, 1); - Cons_Py = new var("Cons_Py", ngfs++, 1, -1, 1); - Cons_Pz = new var("Cons_Pz", ngfs++, 1, 1, -1); - Cons_Gx = new var("Cons_Gx", ngfs++, -1, 1, 1); - Cons_Gy = new var("Cons_Gy", ngfs++, 1, -1, 1); - Cons_Gz = new var("Cons_Gz", ngfs++, 1, 1, -1); - -#ifdef Point_Psi4 - phix = new var("phix", ngfs++, -1, 1, 1); - phiy = new var("phiy", ngfs++, 1, -1, 1); - phiz = new var("phiz", ngfs++, 1, 1, -1); - trKx = new var("trKx", ngfs++, -1, 1, 1); - trKy = new var("trKy", ngfs++, 1, -1, 1); - trKz = new var("trKz", ngfs++, 1, 1, -1); - Axxx = new var("Axxx", ngfs++, -1, 1, 1); - Axxy = new var("Axxy", ngfs++, 1, -1, 1); - Axxz = new var("Axxz", ngfs++, 1, 1, -1); - Axyx = new var("Axyx", ngfs++, 1, -1, 1); - Axyy = new var("Axyy", ngfs++, -1, 1, 1); - Axyz = new var("Axyz", ngfs++, -1, -1, -1); - Axzx = new var("Axzx", ngfs++, 1, 1, -1); - Axzy = new var("Axzy", ngfs++, -1, -1, -1); - Axzz = new var("Axzz", ngfs++, -1, 1, 1); - Ayyx = new var("Ayyx", ngfs++, -1, 1, 1); - Ayyy = new var("Ayyy", ngfs++, 1, -1, 1); - Ayyz = new var("Ayyz", ngfs++, 1, 1, -1); - Ayzx = new var("Ayzx", ngfs++, -1, -1, -1); - Ayzy = new var("Ayzy", ngfs++, 1, 1, -1); - Ayzz = new var("Ayzz", ngfs++, 1, -1, 1); - Azzx = new var("Azzx", ngfs++, -1, 1, 1); - Azzy = new var("Azzy", ngfs++, 1, -1, 1); - Azzz = new var("Azzz", ngfs++, 1, 1, -1); -#endif - - // specific properspeed for 1+log slice - { - const double vl = sqrt(2); - trKo->setpropspeed(vl); - trK0->setpropspeed(vl); - trK->setpropspeed(vl); - trK1->setpropspeed(vl); - trK_rhs->setpropspeed(vl); - - phio->setpropspeed(vl); - phi0->setpropspeed(vl); - phi->setpropspeed(vl); - phi1->setpropspeed(vl); - phi_rhs->setpropspeed(vl); - - Lapo->setpropspeed(vl); - Lap0->setpropspeed(vl); - Lap->setpropspeed(vl); - Lap1->setpropspeed(vl); - Lap_rhs->setpropspeed(vl); - } - - OldStateList = new MyList(phio); - OldStateList->insert(trKo); - OldStateList->insert(gxxo); - OldStateList->insert(gxyo); - OldStateList->insert(gxzo); - OldStateList->insert(gyyo); - OldStateList->insert(gyzo); - OldStateList->insert(gzzo); - OldStateList->insert(Axxo); - OldStateList->insert(Axyo); - OldStateList->insert(Axzo); - OldStateList->insert(Ayyo); - OldStateList->insert(Ayzo); - OldStateList->insert(Azzo); - OldStateList->insert(Gmxo); - OldStateList->insert(Gmyo); - OldStateList->insert(Gmzo); - OldStateList->insert(Lapo); - OldStateList->insert(Sfxo); - OldStateList->insert(Sfyo); - OldStateList->insert(Sfzo); - OldStateList->insert(dtSfxo); - OldStateList->insert(dtSfyo); - OldStateList->insert(dtSfzo); - - StateList = new MyList(phi0); - StateList->insert(trK0); - StateList->insert(gxx0); - StateList->insert(gxy0); - StateList->insert(gxz0); - StateList->insert(gyy0); - StateList->insert(gyz0); - StateList->insert(gzz0); - StateList->insert(Axx0); - StateList->insert(Axy0); - StateList->insert(Axz0); - StateList->insert(Ayy0); - StateList->insert(Ayz0); - StateList->insert(Azz0); - StateList->insert(Gmx0); - StateList->insert(Gmy0); - StateList->insert(Gmz0); - StateList->insert(Lap0); - StateList->insert(Sfx0); - StateList->insert(Sfy0); - StateList->insert(Sfz0); - StateList->insert(dtSfx0); - StateList->insert(dtSfy0); - StateList->insert(dtSfz0); - - RHSList = new MyList(phi_rhs); - RHSList->insert(trK_rhs); - RHSList->insert(gxx_rhs); - RHSList->insert(gxy_rhs); - RHSList->insert(gxz_rhs); - RHSList->insert(gyy_rhs); - RHSList->insert(gyz_rhs); - RHSList->insert(gzz_rhs); - RHSList->insert(Axx_rhs); - RHSList->insert(Axy_rhs); - RHSList->insert(Axz_rhs); - RHSList->insert(Ayy_rhs); - RHSList->insert(Ayz_rhs); - RHSList->insert(Azz_rhs); - RHSList->insert(Gmx_rhs); - RHSList->insert(Gmy_rhs); - RHSList->insert(Gmz_rhs); - RHSList->insert(Lap_rhs); - RHSList->insert(Sfx_rhs); - RHSList->insert(Sfy_rhs); - RHSList->insert(Sfz_rhs); - RHSList->insert(dtSfx_rhs); - RHSList->insert(dtSfy_rhs); - RHSList->insert(dtSfz_rhs); - - SynchList_pre = new MyList(phi); - SynchList_pre->insert(trK); - SynchList_pre->insert(gxx); - SynchList_pre->insert(gxy); - SynchList_pre->insert(gxz); - SynchList_pre->insert(gyy); - SynchList_pre->insert(gyz); - SynchList_pre->insert(gzz); - SynchList_pre->insert(Axx); - SynchList_pre->insert(Axy); - SynchList_pre->insert(Axz); - SynchList_pre->insert(Ayy); - SynchList_pre->insert(Ayz); - SynchList_pre->insert(Azz); - SynchList_pre->insert(Gmx); - SynchList_pre->insert(Gmy); - SynchList_pre->insert(Gmz); - SynchList_pre->insert(Lap); - SynchList_pre->insert(Sfx); - SynchList_pre->insert(Sfy); - SynchList_pre->insert(Sfz); - SynchList_pre->insert(dtSfx); - SynchList_pre->insert(dtSfy); - SynchList_pre->insert(dtSfz); - - SynchList_cor = new MyList(phi1); - SynchList_cor->insert(trK1); - SynchList_cor->insert(gxx1); - SynchList_cor->insert(gxy1); - SynchList_cor->insert(gxz1); - SynchList_cor->insert(gyy1); - SynchList_cor->insert(gyz1); - SynchList_cor->insert(gzz1); - SynchList_cor->insert(Axx1); - SynchList_cor->insert(Axy1); - SynchList_cor->insert(Axz1); - SynchList_cor->insert(Ayy1); - SynchList_cor->insert(Ayz1); - SynchList_cor->insert(Azz1); - SynchList_cor->insert(Gmx1); - SynchList_cor->insert(Gmy1); - SynchList_cor->insert(Gmz1); - SynchList_cor->insert(Lap1); - SynchList_cor->insert(Sfx1); - SynchList_cor->insert(Sfy1); - SynchList_cor->insert(Sfz1); - SynchList_cor->insert(dtSfx1); - SynchList_cor->insert(dtSfy1); - SynchList_cor->insert(dtSfz1); - - DumpList = new MyList(phi0); - DumpList->insert(trK0); - DumpList->insert(gxx0); - DumpList->insert(gxy0); - DumpList->insert(gxz0); - DumpList->insert(gyy0); - DumpList->insert(gyz0); - DumpList->insert(gzz0); - // DumpList->insert(Axx0); - // DumpList->insert(Axy0); - // DumpList->insert(Axz0); - // DumpList->insert(Ayy0); - // DumpList->insert(Ayz0); - // DumpList->insert(Azz0); - // DumpList->insert(Gmx0); - // DumpList->insert(Gmy0); - // DumpList->insert(Gmz0); - DumpList->insert(Lap0); - // DumpList->insert(Sfx0); - // DumpList->insert(Sfy0); - // DumpList->insert(Sfz0); - // DumpList->insert(dtSfx0); - // DumpList->insert(dtSfy0); - // DumpList->insert(dtSfz0); - // DumpList->insert(Rpsi4); - // DumpList->insert(Ipsi4); - DumpList->insert(Cons_Ham); - DumpList->insert(Cons_Px); - DumpList->insert(Cons_Py); - DumpList->insert(Cons_Pz); - // DumpList->insert(Cons_Gx); - // DumpList->insert(Cons_Gy); - // DumpList->insert(Cons_Gz); - - ConstraintList = new MyList(Cons_Ham); - ConstraintList->insert(Cons_Px); - ConstraintList->insert(Cons_Py); - ConstraintList->insert(Cons_Pz); - ConstraintList->insert(Cons_Gx); - ConstraintList->insert(Cons_Gy); - ConstraintList->insert(Cons_Gz); -#ifdef With_AHF - // setup kinds of var list - // List for AparentHorizonFinderDirect - // special attension is payed to symmetry type - // gij gij,x gij,y gij,z - AHList = new MyList(gxx0); - AHList->insert(Gamxxx); - AHList->insert(Gamyxx); - AHList->insert(Gamzxx); - AHList->insert(gxy0); - AHList->insert(Gamxxy); - AHList->insert(Gamyxy); - AHList->insert(Gamzxy); - AHList->insert(gxz0); - AHList->insert(Gamxxz); - AHList->insert(Gamyxz); - AHList->insert(Gamzxz); - AHList->insert(gyy0); - AHList->insert(Gamxyy); - AHList->insert(Gamyyy); - AHList->insert(Gamzyy); - AHList->insert(gyz0); - AHList->insert(Gamxyz); - AHList->insert(Gamyyz); - AHList->insert(Gamzyz); - AHList->insert(gzz0); - AHList->insert(Gamxzz); - AHList->insert(Gamyzz); - AHList->insert(Gamzzz); - // phi phi,x phi,y phi,z - AHList->insert(phi0); - AHList->insert(dtSfx_rhs); - AHList->insert(dtSfy_rhs); - AHList->insert(dtSfz_rhs); - // Aij - AHList->insert(Axx0); - AHList->insert(Axy0); - AHList->insert(Axz0); - AHList->insert(Ayy0); - AHList->insert(Ayz0); - AHList->insert(Azz0); - // trK - AHList->insert(trK0); - // gij,x gij,y gij,z - AHDList = new MyList(Gamxxx); - AHDList->insert(Gamyxx); - AHDList->insert(Gamzxx); - AHDList->insert(Gamxxy); - AHDList->insert(Gamyxy); - AHDList->insert(Gamzxy); - AHDList->insert(Gamxxz); - AHDList->insert(Gamyxz); - AHDList->insert(Gamzxz); - AHDList->insert(Gamxyy); - AHDList->insert(Gamyyy); - AHDList->insert(Gamzyy); - AHDList->insert(Gamxyz); - AHDList->insert(Gamyyz); - AHDList->insert(Gamzyz); - AHDList->insert(Gamxzz); - AHDList->insert(Gamyzz); - AHDList->insert(Gamzzz); - // phi,x phi,y phi,z - AHDList->insert(dtSfx_rhs); - AHDList->insert(dtSfy_rhs); - AHDList->insert(dtSfz_rhs); - - GaugeList = new MyList(Lap0); - GaugeList->insert(Sfx0); - GaugeList->insert(Sfy0); - GaugeList->insert(Sfz0); -#endif - - - - // Note: the first checkpoint-class variable is `bool` while the local variable is `int`; - // an explicit conversion may be required in some contexts. - // bool checkrun00 = checkrun; - // Note: the second checkpoint-class variable is `const char*` while the local variable is `char*`; - // an explicit conversion may be required. - // const char* checkfilename00 = checkfilename; - - CheckPoint = new checkpoint(checkrun, checkfilename, myrank); - - if (myrank==0) { - cout << " BSSN class successfully created " << endl; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function initializes the class - -//================================================================================================ - -void bssn_class::Initialize() -{ - if (myrank == 0) - cout << " you have setted " << ngfs << " grid functions." << endl; - - CheckPoint->addvariablelist(StateList); - CheckPoint->addvariablelist(OldStateList); - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } + // setup sphere integration engine + Waveshell = new surface_integral(Symmetry); + + trfls = 0; + chitiny = 0; + // read parameter from file + { + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "chitiny") + chitiny = atof(sval.c_str()); + else if (sgrp == "BSSN" && skey == "time refinement start from level") + trfls = atoi(sval.c_str()); +#ifdef With_AHF + else if (sgrp == "AHF" && skey == "AHfindevery") + AHfindevery = atoi(sval.c_str()); + else if (sgrp == "AHF" && skey == "AHdumptime") + AHdumptime = atof(sval.c_str()); +#endif + } + inf.close(); + } + if (myrank == 0) + { + // echo information of lower bound of chi + cout << " chitiny = " << chitiny << endl; + cout << " time refinement start from level #" << trfls << endl; +#ifdef With_AHF + cout << " parameters for AHF:" << endl; + cout << " AHfindevery = " << AHfindevery << endl; + cout << " AHdumptime = " << AHdumptime << endl; +#endif + } + + chitiny = chitiny - 1; // because we have subtracted one from chi + + strcpy(checkfilename, checkfilenamei); + + ngfs = 0; + phio = new var("phio", ngfs++, 1, 1, 1); + trKo = new var("trKo", ngfs++, 1, 1, 1); + gxxo = new var("gxxo", ngfs++, 1, 1, 1); + gxyo = new var("gxyo", ngfs++, -1, -1, 1); + gxzo = new var("gxzo", ngfs++, -1, 1, -1); + gyyo = new var("gyyo", ngfs++, 1, 1, 1); + gyzo = new var("gyzo", ngfs++, 1, -1, -1); + gzzo = new var("gzzo", ngfs++, 1, 1, 1); + Axxo = new var("Axxo", ngfs++, 1, 1, 1); + Axyo = new var("Axyo", ngfs++, -1, -1, 1); + Axzo = new var("Axzo", ngfs++, -1, 1, -1); + Ayyo = new var("Ayyo", ngfs++, 1, 1, 1); + Ayzo = new var("Ayzo", ngfs++, 1, -1, -1); + Azzo = new var("Azzo", ngfs++, 1, 1, 1); + Gmxo = new var("Gmxo", ngfs++, -1, 1, 1); + Gmyo = new var("Gmyo", ngfs++, 1, -1, 1); + Gmzo = new var("Gmzo", ngfs++, 1, 1, -1); + Lapo = new var("Lapo", ngfs++, 1, 1, 1); + Sfxo = new var("Sfxo", ngfs++, -1, 1, 1); + Sfyo = new var("Sfyo", ngfs++, 1, -1, 1); + Sfzo = new var("Sfzo", ngfs++, 1, 1, -1); + dtSfxo = new var("dtSfxo", ngfs++, -1, 1, 1); + dtSfyo = new var("dtSfyo", ngfs++, 1, -1, 1); + dtSfzo = new var("dtSfzo", ngfs++, 1, 1, -1); + + phi0 = new var("phi0", ngfs++, 1, 1, 1); + trK0 = new var("trK0", ngfs++, 1, 1, 1); + gxx0 = new var("gxx0", ngfs++, 1, 1, 1); + gxy0 = new var("gxy0", ngfs++, -1, -1, 1); + gxz0 = new var("gxz0", ngfs++, -1, 1, -1); + gyy0 = new var("gyy0", ngfs++, 1, 1, 1); + gyz0 = new var("gyz0", ngfs++, 1, -1, -1); + gzz0 = new var("gzz0", ngfs++, 1, 1, 1); + Axx0 = new var("Axx0", ngfs++, 1, 1, 1); + Axy0 = new var("Axy0", ngfs++, -1, -1, 1); + Axz0 = new var("Axz0", ngfs++, -1, 1, -1); + Ayy0 = new var("Ayy0", ngfs++, 1, 1, 1); + Ayz0 = new var("Ayz0", ngfs++, 1, -1, -1); + Azz0 = new var("Azz0", ngfs++, 1, 1, 1); + Gmx0 = new var("Gmx0", ngfs++, -1, 1, 1); + Gmy0 = new var("Gmy0", ngfs++, 1, -1, 1); + Gmz0 = new var("Gmz0", ngfs++, 1, 1, -1); + Lap0 = new var("Lap0", ngfs++, 1, 1, 1); + Sfx0 = new var("Sfx0", ngfs++, -1, 1, 1); + Sfy0 = new var("Sfy0", ngfs++, 1, -1, 1); + Sfz0 = new var("Sfz0", ngfs++, 1, 1, -1); + dtSfx0 = new var("dtSfx0", ngfs++, -1, 1, 1); + dtSfy0 = new var("dtSfy0", ngfs++, 1, -1, 1); + dtSfz0 = new var("dtSfz0", ngfs++, 1, 1, -1); + + phi = new var("phi", ngfs++, 1, 1, 1); + trK = new var("trK", ngfs++, 1, 1, 1); + gxx = new var("gxx", ngfs++, 1, 1, 1); + gxy = new var("gxy", ngfs++, -1, -1, 1); + gxz = new var("gxz", ngfs++, -1, 1, -1); + gyy = new var("gyy", ngfs++, 1, 1, 1); + gyz = new var("gyz", ngfs++, 1, -1, -1); + gzz = new var("gzz", ngfs++, 1, 1, 1); + Axx = new var("Axx", ngfs++, 1, 1, 1); + Axy = new var("Axy", ngfs++, -1, -1, 1); + Axz = new var("Axz", ngfs++, -1, 1, -1); + Ayy = new var("Ayy", ngfs++, 1, 1, 1); + Ayz = new var("Ayz", ngfs++, 1, -1, -1); + Azz = new var("Azz", ngfs++, 1, 1, 1); + Gmx = new var("Gmx", ngfs++, -1, 1, 1); + Gmy = new var("Gmy", ngfs++, 1, -1, 1); + Gmz = new var("Gmz", ngfs++, 1, 1, -1); + Lap = new var("Lap", ngfs++, 1, 1, 1); + Sfx = new var("Sfx", ngfs++, -1, 1, 1); + Sfy = new var("Sfy", ngfs++, 1, -1, 1); + Sfz = new var("Sfz", ngfs++, 1, 1, -1); + dtSfx = new var("dtSfx", ngfs++, -1, 1, 1); + dtSfy = new var("dtSfy", ngfs++, 1, -1, 1); + dtSfz = new var("dtSfz", ngfs++, 1, 1, -1); + + phi1 = new var("phi1", ngfs++, 1, 1, 1); + trK1 = new var("trK1", ngfs++, 1, 1, 1); + gxx1 = new var("gxx1", ngfs++, 1, 1, 1); + gxy1 = new var("gxy1", ngfs++, -1, -1, 1); + gxz1 = new var("gxz1", ngfs++, -1, 1, -1); + gyy1 = new var("gyy1", ngfs++, 1, 1, 1); + gyz1 = new var("gyz1", ngfs++, 1, -1, -1); + gzz1 = new var("gzz1", ngfs++, 1, 1, 1); + Axx1 = new var("Axx1", ngfs++, 1, 1, 1); + Axy1 = new var("Axy1", ngfs++, -1, -1, 1); + Axz1 = new var("Axz1", ngfs++, -1, 1, -1); + Ayy1 = new var("Ayy1", ngfs++, 1, 1, 1); + Ayz1 = new var("Ayz1", ngfs++, 1, -1, -1); + Azz1 = new var("Azz1", ngfs++, 1, 1, 1); + Gmx1 = new var("Gmx1", ngfs++, -1, 1, 1); + Gmy1 = new var("Gmy1", ngfs++, 1, -1, 1); + Gmz1 = new var("Gmz1", ngfs++, 1, 1, -1); + Lap1 = new var("Lap1", ngfs++, 1, 1, 1); + Sfx1 = new var("Sfx1", ngfs++, -1, 1, 1); + Sfy1 = new var("Sfy1", ngfs++, 1, -1, 1); + Sfz1 = new var("Sfz1", ngfs++, 1, 1, -1); + dtSfx1 = new var("dtSfx1", ngfs++, -1, 1, 1); + dtSfy1 = new var("dtSfy1", ngfs++, 1, -1, 1); + dtSfz1 = new var("dtSfz1", ngfs++, 1, 1, -1); + + phi_rhs = new var("phi_rhs", ngfs++, 1, 1, 1); + trK_rhs = new var("trK_rhs", ngfs++, 1, 1, 1); + gxx_rhs = new var("gxx_rhs", ngfs++, 1, 1, 1); + gxy_rhs = new var("gxy_rhs", ngfs++, -1, -1, 1); + gxz_rhs = new var("gxz_rhs", ngfs++, -1, 1, -1); + gyy_rhs = new var("gyy_rhs", ngfs++, 1, 1, 1); + gyz_rhs = new var("gyz_rhs", ngfs++, 1, -1, -1); + gzz_rhs = new var("gzz_rhs", ngfs++, 1, 1, 1); + Axx_rhs = new var("Axx_rhs", ngfs++, 1, 1, 1); + Axy_rhs = new var("Axy_rhs", ngfs++, -1, -1, 1); + Axz_rhs = new var("Axz_rhs", ngfs++, -1, 1, -1); + Ayy_rhs = new var("Ayy_rhs", ngfs++, 1, 1, 1); + Ayz_rhs = new var("Ayz_rhs", ngfs++, 1, -1, -1); + Azz_rhs = new var("Azz_rhs", ngfs++, 1, 1, 1); + Gmx_rhs = new var("Gmx_rhs", ngfs++, -1, 1, 1); + Gmy_rhs = new var("Gmy_rhs", ngfs++, 1, -1, 1); + Gmz_rhs = new var("Gmz_rhs", ngfs++, 1, 1, -1); + Lap_rhs = new var("Lap_rhs", ngfs++, 1, 1, 1); + Sfx_rhs = new var("Sfx_rhs", ngfs++, -1, 1, 1); + Sfy_rhs = new var("Sfy_rhs", ngfs++, 1, -1, 1); + Sfz_rhs = new var("Sfz_rhs", ngfs++, 1, 1, -1); + dtSfx_rhs = new var("dtSfx_rhs", ngfs++, -1, 1, 1); + dtSfy_rhs = new var("dtSfy_rhs", ngfs++, 1, -1, 1); + dtSfz_rhs = new var("dtSfz_rhs", ngfs++, 1, 1, -1); + + rho = new var("rho", ngfs++, 1, 1, 1); + Sx = new var("Sx", ngfs++, -1, 1, 1); + Sy = new var("Sy", ngfs++, 1, -1, 1); + Sz = new var("Sz", ngfs++, 1, 1, -1); + Sxx = new var("Sxx", ngfs++, 1, 1, 1); + Sxy = new var("Sxy", ngfs++, -1, -1, 1); + Sxz = new var("Sxz", ngfs++, -1, 1, -1); + Syy = new var("Syy", ngfs++, 1, 1, 1); + Syz = new var("Syz", ngfs++, 1, -1, -1); + Szz = new var("Szz", ngfs++, 1, 1, 1); + + Gamxxx = new var("Gamxxx", ngfs++, -1, 1, 1); + Gamxxy = new var("Gamxxy", ngfs++, 1, -1, 1); + Gamxxz = new var("Gamxxz", ngfs++, 1, 1, -1); + Gamxyy = new var("Gamxyy", ngfs++, -1, 1, 1); + Gamxyz = new var("Gamxyz", ngfs++, -1, -1, -1); + Gamxzz = new var("Gamxzz", ngfs++, -1, 1, 1); + Gamyxx = new var("Gamyxx", ngfs++, 1, -1, 1); + Gamyxy = new var("Gamyxy", ngfs++, -1, 1, 1); + Gamyxz = new var("Gamyxz", ngfs++, -1, -1, -1); + Gamyyy = new var("Gamyyy", ngfs++, 1, -1, 1); + Gamyyz = new var("Gamyyz", ngfs++, 1, 1, -1); + Gamyzz = new var("Gamyzz", ngfs++, 1, -1, 1); + Gamzxx = new var("Gamzxx", ngfs++, 1, 1, -1); + Gamzxy = new var("Gamzxy", ngfs++, -1, -1, -1); + Gamzxz = new var("Gamzxz", ngfs++, -1, 1, 1); + Gamzyy = new var("Gamzyy", ngfs++, 1, 1, -1); + Gamzyz = new var("Gamzyz", ngfs++, 1, -1, 1); + Gamzzz = new var("Gamzzz", ngfs++, 1, 1, -1); + + Rxx = new var("Rxx", ngfs++, 1, 1, 1); + Rxy = new var("Rxy", ngfs++, -1, -1, 1); + Rxz = new var("Rxz", ngfs++, -1, 1, -1); + Ryy = new var("Ryy", ngfs++, 1, 1, 1); + Ryz = new var("Ryz", ngfs++, 1, -1, -1); + Rzz = new var("Rzz", ngfs++, 1, 1, 1); + + // refer to PRD, 77, 024027 (2008) + Rpsi4 = new var("Rpsi4", ngfs++, 1, 1, 1); + Ipsi4 = new var("Ipsi4", ngfs++, -1, -1, -1); + t1Rpsi4 = new var("t1Rpsi4", ngfs++, 1, 1, 1); + t1Ipsi4 = new var("t1Ipsi4", ngfs++, -1, -1, -1); + t2Rpsi4 = new var("t2Rpsi4", ngfs++, 1, 1, 1); + t2Ipsi4 = new var("t2Ipsi4", ngfs++, -1, -1, -1); + + // constraint violation monitor variables + Cons_Ham = new var("Cons_Ham", ngfs++, 1, 1, 1); + Cons_Px = new var("Cons_Px", ngfs++, -1, 1, 1); + Cons_Py = new var("Cons_Py", ngfs++, 1, -1, 1); + Cons_Pz = new var("Cons_Pz", ngfs++, 1, 1, -1); + Cons_Gx = new var("Cons_Gx", ngfs++, -1, 1, 1); + Cons_Gy = new var("Cons_Gy", ngfs++, 1, -1, 1); + Cons_Gz = new var("Cons_Gz", ngfs++, 1, 1, -1); + +#ifdef Point_Psi4 + phix = new var("phix", ngfs++, -1, 1, 1); + phiy = new var("phiy", ngfs++, 1, -1, 1); + phiz = new var("phiz", ngfs++, 1, 1, -1); + trKx = new var("trKx", ngfs++, -1, 1, 1); + trKy = new var("trKy", ngfs++, 1, -1, 1); + trKz = new var("trKz", ngfs++, 1, 1, -1); + Axxx = new var("Axxx", ngfs++, -1, 1, 1); + Axxy = new var("Axxy", ngfs++, 1, -1, 1); + Axxz = new var("Axxz", ngfs++, 1, 1, -1); + Axyx = new var("Axyx", ngfs++, 1, -1, 1); + Axyy = new var("Axyy", ngfs++, -1, 1, 1); + Axyz = new var("Axyz", ngfs++, -1, -1, -1); + Axzx = new var("Axzx", ngfs++, 1, 1, -1); + Axzy = new var("Axzy", ngfs++, -1, -1, -1); + Axzz = new var("Axzz", ngfs++, -1, 1, 1); + Ayyx = new var("Ayyx", ngfs++, -1, 1, 1); + Ayyy = new var("Ayyy", ngfs++, 1, -1, 1); + Ayyz = new var("Ayyz", ngfs++, 1, 1, -1); + Ayzx = new var("Ayzx", ngfs++, -1, -1, -1); + Ayzy = new var("Ayzy", ngfs++, 1, 1, -1); + Ayzz = new var("Ayzz", ngfs++, 1, -1, 1); + Azzx = new var("Azzx", ngfs++, -1, 1, 1); + Azzy = new var("Azzy", ngfs++, 1, -1, 1); + Azzz = new var("Azzz", ngfs++, 1, 1, -1); +#endif + + // specific properspeed for 1+log slice + { + const double vl = sqrt(2); + trKo->setpropspeed(vl); + trK0->setpropspeed(vl); + trK->setpropspeed(vl); + trK1->setpropspeed(vl); + trK_rhs->setpropspeed(vl); + + phio->setpropspeed(vl); + phi0->setpropspeed(vl); + phi->setpropspeed(vl); + phi1->setpropspeed(vl); + phi_rhs->setpropspeed(vl); + + Lapo->setpropspeed(vl); + Lap0->setpropspeed(vl); + Lap->setpropspeed(vl); + Lap1->setpropspeed(vl); + Lap_rhs->setpropspeed(vl); + } + + OldStateList = new MyList(phio); + OldStateList->insert(trKo); + OldStateList->insert(gxxo); + OldStateList->insert(gxyo); + OldStateList->insert(gxzo); + OldStateList->insert(gyyo); + OldStateList->insert(gyzo); + OldStateList->insert(gzzo); + OldStateList->insert(Axxo); + OldStateList->insert(Axyo); + OldStateList->insert(Axzo); + OldStateList->insert(Ayyo); + OldStateList->insert(Ayzo); + OldStateList->insert(Azzo); + OldStateList->insert(Gmxo); + OldStateList->insert(Gmyo); + OldStateList->insert(Gmzo); + OldStateList->insert(Lapo); + OldStateList->insert(Sfxo); + OldStateList->insert(Sfyo); + OldStateList->insert(Sfzo); + OldStateList->insert(dtSfxo); + OldStateList->insert(dtSfyo); + OldStateList->insert(dtSfzo); + + StateList = new MyList(phi0); + StateList->insert(trK0); + StateList->insert(gxx0); + StateList->insert(gxy0); + StateList->insert(gxz0); + StateList->insert(gyy0); + StateList->insert(gyz0); + StateList->insert(gzz0); + StateList->insert(Axx0); + StateList->insert(Axy0); + StateList->insert(Axz0); + StateList->insert(Ayy0); + StateList->insert(Ayz0); + StateList->insert(Azz0); + StateList->insert(Gmx0); + StateList->insert(Gmy0); + StateList->insert(Gmz0); + StateList->insert(Lap0); + StateList->insert(Sfx0); + StateList->insert(Sfy0); + StateList->insert(Sfz0); + StateList->insert(dtSfx0); + StateList->insert(dtSfy0); + StateList->insert(dtSfz0); + + RHSList = new MyList(phi_rhs); + RHSList->insert(trK_rhs); + RHSList->insert(gxx_rhs); + RHSList->insert(gxy_rhs); + RHSList->insert(gxz_rhs); + RHSList->insert(gyy_rhs); + RHSList->insert(gyz_rhs); + RHSList->insert(gzz_rhs); + RHSList->insert(Axx_rhs); + RHSList->insert(Axy_rhs); + RHSList->insert(Axz_rhs); + RHSList->insert(Ayy_rhs); + RHSList->insert(Ayz_rhs); + RHSList->insert(Azz_rhs); + RHSList->insert(Gmx_rhs); + RHSList->insert(Gmy_rhs); + RHSList->insert(Gmz_rhs); + RHSList->insert(Lap_rhs); + RHSList->insert(Sfx_rhs); + RHSList->insert(Sfy_rhs); + RHSList->insert(Sfz_rhs); + RHSList->insert(dtSfx_rhs); + RHSList->insert(dtSfy_rhs); + RHSList->insert(dtSfz_rhs); + + SynchList_pre = new MyList(phi); + SynchList_pre->insert(trK); + SynchList_pre->insert(gxx); + SynchList_pre->insert(gxy); + SynchList_pre->insert(gxz); + SynchList_pre->insert(gyy); + SynchList_pre->insert(gyz); + SynchList_pre->insert(gzz); + SynchList_pre->insert(Axx); + SynchList_pre->insert(Axy); + SynchList_pre->insert(Axz); + SynchList_pre->insert(Ayy); + SynchList_pre->insert(Ayz); + SynchList_pre->insert(Azz); + SynchList_pre->insert(Gmx); + SynchList_pre->insert(Gmy); + SynchList_pre->insert(Gmz); + SynchList_pre->insert(Lap); + SynchList_pre->insert(Sfx); + SynchList_pre->insert(Sfy); + SynchList_pre->insert(Sfz); + SynchList_pre->insert(dtSfx); + SynchList_pre->insert(dtSfy); + SynchList_pre->insert(dtSfz); + + SynchList_cor = new MyList(phi1); + SynchList_cor->insert(trK1); + SynchList_cor->insert(gxx1); + SynchList_cor->insert(gxy1); + SynchList_cor->insert(gxz1); + SynchList_cor->insert(gyy1); + SynchList_cor->insert(gyz1); + SynchList_cor->insert(gzz1); + SynchList_cor->insert(Axx1); + SynchList_cor->insert(Axy1); + SynchList_cor->insert(Axz1); + SynchList_cor->insert(Ayy1); + SynchList_cor->insert(Ayz1); + SynchList_cor->insert(Azz1); + SynchList_cor->insert(Gmx1); + SynchList_cor->insert(Gmy1); + SynchList_cor->insert(Gmz1); + SynchList_cor->insert(Lap1); + SynchList_cor->insert(Sfx1); + SynchList_cor->insert(Sfy1); + SynchList_cor->insert(Sfz1); + SynchList_cor->insert(dtSfx1); + SynchList_cor->insert(dtSfy1); + SynchList_cor->insert(dtSfz1); + + DumpList = new MyList(phi0); + DumpList->insert(trK0); + DumpList->insert(gxx0); + DumpList->insert(gxy0); + DumpList->insert(gxz0); + DumpList->insert(gyy0); + DumpList->insert(gyz0); + DumpList->insert(gzz0); + // DumpList->insert(Axx0); + // DumpList->insert(Axy0); + // DumpList->insert(Axz0); + // DumpList->insert(Ayy0); + // DumpList->insert(Ayz0); + // DumpList->insert(Azz0); + // DumpList->insert(Gmx0); + // DumpList->insert(Gmy0); + // DumpList->insert(Gmz0); + DumpList->insert(Lap0); + // DumpList->insert(Sfx0); + // DumpList->insert(Sfy0); + // DumpList->insert(Sfz0); + // DumpList->insert(dtSfx0); + // DumpList->insert(dtSfy0); + // DumpList->insert(dtSfz0); + // DumpList->insert(Rpsi4); + // DumpList->insert(Ipsi4); + DumpList->insert(Cons_Ham); + DumpList->insert(Cons_Px); + DumpList->insert(Cons_Py); + DumpList->insert(Cons_Pz); + // DumpList->insert(Cons_Gx); + // DumpList->insert(Cons_Gy); + // DumpList->insert(Cons_Gz); + + ConstraintList = new MyList(Cons_Ham); + ConstraintList->insert(Cons_Px); + ConstraintList->insert(Cons_Py); + ConstraintList->insert(Cons_Pz); + ConstraintList->insert(Cons_Gx); + ConstraintList->insert(Cons_Gy); + ConstraintList->insert(Cons_Gz); +#ifdef With_AHF + // setup kinds of var list + // List for AparentHorizonFinderDirect + // special attension is payed to symmetry type + // gij gij,x gij,y gij,z + AHList = new MyList(gxx0); + AHList->insert(Gamxxx); + AHList->insert(Gamyxx); + AHList->insert(Gamzxx); + AHList->insert(gxy0); + AHList->insert(Gamxxy); + AHList->insert(Gamyxy); + AHList->insert(Gamzxy); + AHList->insert(gxz0); + AHList->insert(Gamxxz); + AHList->insert(Gamyxz); + AHList->insert(Gamzxz); + AHList->insert(gyy0); + AHList->insert(Gamxyy); + AHList->insert(Gamyyy); + AHList->insert(Gamzyy); + AHList->insert(gyz0); + AHList->insert(Gamxyz); + AHList->insert(Gamyyz); + AHList->insert(Gamzyz); + AHList->insert(gzz0); + AHList->insert(Gamxzz); + AHList->insert(Gamyzz); + AHList->insert(Gamzzz); + // phi phi,x phi,y phi,z + AHList->insert(phi0); + AHList->insert(dtSfx_rhs); + AHList->insert(dtSfy_rhs); + AHList->insert(dtSfz_rhs); + // Aij + AHList->insert(Axx0); + AHList->insert(Axy0); + AHList->insert(Axz0); + AHList->insert(Ayy0); + AHList->insert(Ayz0); + AHList->insert(Azz0); + // trK + AHList->insert(trK0); + // gij,x gij,y gij,z + AHDList = new MyList(Gamxxx); + AHDList->insert(Gamyxx); + AHDList->insert(Gamzxx); + AHDList->insert(Gamxxy); + AHDList->insert(Gamyxy); + AHDList->insert(Gamzxy); + AHDList->insert(Gamxxz); + AHDList->insert(Gamyxz); + AHDList->insert(Gamzxz); + AHDList->insert(Gamxyy); + AHDList->insert(Gamyyy); + AHDList->insert(Gamzyy); + AHDList->insert(Gamxyz); + AHDList->insert(Gamyyz); + AHDList->insert(Gamzyz); + AHDList->insert(Gamxzz); + AHDList->insert(Gamyzz); + AHDList->insert(Gamzzz); + // phi,x phi,y phi,z + AHDList->insert(dtSfx_rhs); + AHDList->insert(dtSfy_rhs); + AHDList->insert(dtSfz_rhs); + + GaugeList = new MyList(Lap0); + GaugeList->insert(Sfx0); + GaugeList->insert(Sfy0); + GaugeList->insert(Sfz0); +#endif + + + + // Note: the first checkpoint-class variable is `bool` while the local variable is `int`; + // an explicit conversion may be required in some contexts. + // bool checkrun00 = checkrun; + // Note: the second checkpoint-class variable is `const char*` while the local variable is `char*`; + // an explicit conversion may be required. + // const char* checkfilename00 = checkfilename; + + CheckPoint = new checkpoint(checkrun, checkfilename, myrank); + + if (myrank==0) { + cout << " BSSN class successfully created " << endl; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function initializes the class + +//================================================================================================ + +void bssn_class::Initialize() +{ + if (myrank == 0) + cout << " you have setted " << ngfs << " grid functions." << endl; + + CheckPoint->addvariablelist(StateList); + CheckPoint->addvariablelist(OldStateList); + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); ConstraintRefreshLevels = new int[GH->levels]; for (int il = 0; il < GH->levels; il++) ConstraintRefreshLevels[il] = 0; if (checkrun) CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); - else - GH->compose_cgh(nprocs); -#ifdef WithShell - SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); - SH->matchcheck(GH->PatL[0]); - SH->compose_sh(nprocs); - // SH->compose_shr(nprocs); //sh is faster than shr - SH->setupcordtrans(); - SH->Dump_xyz(0, 0, 1); - SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); - - if (checkrun) - CheckPoint->readcheck_sh(SH, myrank); -#else - SH = 0; -#endif - - double h = GH->PatL[0]->data->blb->data->getdX(0); - for (int i = 1; i < dim; i++) - h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); - dT = Courant * h; - - if (checkrun) - { - CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); - setpbh(BH_num, Porg0, Mass, BH_num_input); - } - else - { - PhysTime = StartTime; - Setup_Black_Hole_position(); - } - - // Initialize sync caches (per-level, for predictor and corrector) - sync_cache_pre = new Parallel::SyncCache[GH->levels]; - sync_cache_cor = new Parallel::SyncCache[GH->levels]; - sync_cache_rp_coarse = new Parallel::SyncCache[GH->levels]; - sync_cache_rp_fine = new Parallel::SyncCache[GH->levels]; - sync_cache_restrict = new Parallel::SyncCache[GH->levels]; - sync_cache_outbd = new Parallel::SyncCache[GH->levels]; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function is the destructor; it releases allocated variables - -//================================================================================================ - -bssn_class::~bssn_class() -{ -#ifdef With_AHF - AHList->clearList(); - AHDList->clearList(); - GaugeList->clearList(); - if (lastahdumpid) - delete[] lastahdumpid; - if (findeveryl) - delete[] findeveryl; - - if (xc) - { - delete[] xc; - delete[] yc; - delete[] zc; - delete[] xr; - delete[] yr; - delete[] zr; - delete[] trigger; - delete[] dumpid; - delete[] dTT; - } - - AHFinderDirect::AHFinderDirect_cleanup(); -#endif - - StateList->clearList(); - RHSList->clearList(); - OldStateList->clearList(); - SynchList_pre->clearList(); - SynchList_cor->clearList(); - DumpList->clearList(); + else + GH->compose_cgh(nprocs); +#ifdef WithShell + SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); + SH->matchcheck(GH->PatL[0]); + SH->compose_sh(nprocs); + // SH->compose_shr(nprocs); //sh is faster than shr + SH->setupcordtrans(); + SH->Dump_xyz(0, 0, 1); + SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); + + if (checkrun) + CheckPoint->readcheck_sh(SH, myrank); +#else + SH = 0; +#endif + + double h = GH->PatL[0]->data->blb->data->getdX(0); + for (int i = 1; i < dim; i++) + h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); + dT = Courant * h; + + if (checkrun) + { + CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); + setpbh(BH_num, Porg0, Mass, BH_num_input); + } + else + { + PhysTime = StartTime; + Setup_Black_Hole_position(); + } + + // Initialize sync caches (per-level, for predictor and corrector) + sync_cache_pre = new Parallel::SyncCache[GH->levels]; + sync_cache_cor = new Parallel::SyncCache[GH->levels]; + sync_cache_rp_coarse = new Parallel::SyncCache[GH->levels]; + sync_cache_rp_fine = new Parallel::SyncCache[GH->levels]; + sync_cache_restrict = new Parallel::SyncCache[GH->levels]; + sync_cache_outbd = new Parallel::SyncCache[GH->levels]; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function is the destructor; it releases allocated variables + +//================================================================================================ + +bssn_class::~bssn_class() +{ +#ifdef With_AHF + AHList->clearList(); + AHDList->clearList(); + GaugeList->clearList(); + if (lastahdumpid) + delete[] lastahdumpid; + if (findeveryl) + delete[] findeveryl; + + if (xc) + { + delete[] xc; + delete[] yc; + delete[] zc; + delete[] xr; + delete[] yr; + delete[] zr; + delete[] trigger; + delete[] dumpid; + delete[] dTT; + } + + AHFinderDirect::AHFinderDirect_cleanup(); +#endif + + StateList->clearList(); + RHSList->clearList(); + OldStateList->clearList(); + SynchList_pre->clearList(); + SynchList_cor->clearList(); + DumpList->clearList(); ConstraintList->clearList(); delete[] ConstraintRefreshLevels; delete phio; - delete trKo; - delete gxxo; - delete gxyo; - delete gxzo; - delete gyyo; - delete gyzo; - delete gzzo; - delete Axxo; - delete Axyo; - delete Axzo; - delete Ayyo; - delete Ayzo; - delete Azzo; - delete Gmxo; - delete Gmyo; - delete Gmzo; - delete Lapo; - delete Sfxo; - delete Sfyo; - delete Sfzo; - delete dtSfxo; - delete dtSfyo; - delete dtSfzo; - - delete phi0; - delete trK0; - delete gxx0; - delete gxy0; - delete gxz0; - delete gyy0; - delete gyz0; - delete gzz0; - delete Axx0; - delete Axy0; - delete Axz0; - delete Ayy0; - delete Ayz0; - delete Azz0; - delete Gmx0; - delete Gmy0; - delete Gmz0; - delete Lap0; - delete Sfx0; - delete Sfy0; - delete Sfz0; - delete dtSfx0; - delete dtSfy0; - delete dtSfz0; - - delete phi; - delete trK; - delete gxx; - delete gxy; - delete gxz; - delete gyy; - delete gyz; - delete gzz; - delete Axx; - delete Axy; - delete Axz; - delete Ayy; - delete Ayz; - delete Azz; - delete Gmx; - delete Gmy; - delete Gmz; - delete Lap; - delete Sfx; - delete Sfy; - delete Sfz; - delete dtSfx; - delete dtSfy; - delete dtSfz; - - delete phi1; - delete trK1; - delete gxx1; - delete gxy1; - delete gxz1; - delete gyy1; - delete gyz1; - delete gzz1; - delete Axx1; - delete Axy1; - delete Axz1; - delete Ayy1; - delete Ayz1; - delete Azz1; - delete Gmx1; - delete Gmy1; - delete Gmz1; - delete Lap1; - delete Sfx1; - delete Sfy1; - delete Sfz1; - delete dtSfx1; - delete dtSfy1; - delete dtSfz1; - - delete phi_rhs; - delete trK_rhs; - delete gxx_rhs; - delete gxy_rhs; - delete gxz_rhs; - delete gyy_rhs; - delete gyz_rhs; - delete gzz_rhs; - delete Axx_rhs; - delete Axy_rhs; - delete Axz_rhs; - delete Ayy_rhs; - delete Ayz_rhs; - delete Azz_rhs; - delete Gmx_rhs; - delete Gmy_rhs; - delete Gmz_rhs; - delete Lap_rhs; - delete Sfx_rhs; - delete Sfy_rhs; - delete Sfz_rhs; - delete dtSfx_rhs; - delete dtSfy_rhs; - delete dtSfz_rhs; - - delete rho; - delete Sx; - delete Sy; - delete Sz; - delete Sxx; - delete Sxy; - delete Sxz; - delete Syy; - delete Syz; - delete Szz; - - delete Gamxxx; - delete Gamxxy; - delete Gamxxz; - delete Gamxyy; - delete Gamxyz; - delete Gamxzz; - delete Gamyxx; - delete Gamyxy; - delete Gamyxz; - delete Gamyyy; - delete Gamyyz; - delete Gamyzz; - delete Gamzxx; - delete Gamzxy; - delete Gamzxz; - delete Gamzyy; - delete Gamzyz; - delete Gamzzz; - - delete Rxx; - delete Rxy; - delete Rxz; - delete Ryy; - delete Ryz; - delete Rzz; - - delete Rpsi4; - delete Ipsi4; - delete t1Rpsi4; - delete t1Ipsi4; - delete t2Rpsi4; - delete t2Ipsi4; - - delete Cons_Ham; - delete Cons_Px; - delete Cons_Py; - delete Cons_Pz; - delete Cons_Gx; - delete Cons_Gy; - delete Cons_Gz; - -#ifdef Point_Psi4 - delete phix; - delete phiy; - delete phiz; - delete trKx; - delete trKy; - delete trKz; - delete Axxx; - delete Axxy; - delete Axxz; - delete Axyx; - delete Axyy; - delete Axyz; - delete Axzx; - delete Axzy; - delete Axzz; - delete Ayyx; - delete Ayyy; - delete Ayyz; - delete Ayzx; - delete Ayzy; - delete Ayzz; - delete Azzx; - delete Azzy; - delete Azzz; -#endif - - // Destroy sync caches before GH - if (sync_cache_pre) - { - for (int i = 0; i < GH->levels; i++) - sync_cache_pre[i].destroy(); - delete[] sync_cache_pre; - } - if (sync_cache_cor) - { - for (int i = 0; i < GH->levels; i++) - sync_cache_cor[i].destroy(); - delete[] sync_cache_cor; - } - if (sync_cache_rp_coarse) - { - for (int i = 0; i < GH->levels; i++) - sync_cache_rp_coarse[i].destroy(); - delete[] sync_cache_rp_coarse; - } - if (sync_cache_rp_fine) - { - for (int i = 0; i < GH->levels; i++) - sync_cache_rp_fine[i].destroy(); - delete[] sync_cache_rp_fine; - } - - delete GH; -#ifdef WithShell - delete SH; -#endif - - for (int i = 0; i < BH_num; i++) - { - delete[] Porg0[i]; - delete[] Porgbr[i]; - delete[] Porg[i]; - delete[] Porg1[i]; - delete[] Porg_rhs[i]; - } - - delete[] Porg0; - delete[] Porgbr; - delete[] Porg; - delete[] Porg1; - delete[] Porg_rhs; - - delete[] Mass; - delete[] Spin; - delete[] Pmom; - - delete ErrorMonitor; - delete Psi4Monitor; + delete trKo; + delete gxxo; + delete gxyo; + delete gxzo; + delete gyyo; + delete gyzo; + delete gzzo; + delete Axxo; + delete Axyo; + delete Axzo; + delete Ayyo; + delete Ayzo; + delete Azzo; + delete Gmxo; + delete Gmyo; + delete Gmzo; + delete Lapo; + delete Sfxo; + delete Sfyo; + delete Sfzo; + delete dtSfxo; + delete dtSfyo; + delete dtSfzo; + + delete phi0; + delete trK0; + delete gxx0; + delete gxy0; + delete gxz0; + delete gyy0; + delete gyz0; + delete gzz0; + delete Axx0; + delete Axy0; + delete Axz0; + delete Ayy0; + delete Ayz0; + delete Azz0; + delete Gmx0; + delete Gmy0; + delete Gmz0; + delete Lap0; + delete Sfx0; + delete Sfy0; + delete Sfz0; + delete dtSfx0; + delete dtSfy0; + delete dtSfz0; + + delete phi; + delete trK; + delete gxx; + delete gxy; + delete gxz; + delete gyy; + delete gyz; + delete gzz; + delete Axx; + delete Axy; + delete Axz; + delete Ayy; + delete Ayz; + delete Azz; + delete Gmx; + delete Gmy; + delete Gmz; + delete Lap; + delete Sfx; + delete Sfy; + delete Sfz; + delete dtSfx; + delete dtSfy; + delete dtSfz; + + delete phi1; + delete trK1; + delete gxx1; + delete gxy1; + delete gxz1; + delete gyy1; + delete gyz1; + delete gzz1; + delete Axx1; + delete Axy1; + delete Axz1; + delete Ayy1; + delete Ayz1; + delete Azz1; + delete Gmx1; + delete Gmy1; + delete Gmz1; + delete Lap1; + delete Sfx1; + delete Sfy1; + delete Sfz1; + delete dtSfx1; + delete dtSfy1; + delete dtSfz1; + + delete phi_rhs; + delete trK_rhs; + delete gxx_rhs; + delete gxy_rhs; + delete gxz_rhs; + delete gyy_rhs; + delete gyz_rhs; + delete gzz_rhs; + delete Axx_rhs; + delete Axy_rhs; + delete Axz_rhs; + delete Ayy_rhs; + delete Ayz_rhs; + delete Azz_rhs; + delete Gmx_rhs; + delete Gmy_rhs; + delete Gmz_rhs; + delete Lap_rhs; + delete Sfx_rhs; + delete Sfy_rhs; + delete Sfz_rhs; + delete dtSfx_rhs; + delete dtSfy_rhs; + delete dtSfz_rhs; + + delete rho; + delete Sx; + delete Sy; + delete Sz; + delete Sxx; + delete Sxy; + delete Sxz; + delete Syy; + delete Syz; + delete Szz; + + delete Gamxxx; + delete Gamxxy; + delete Gamxxz; + delete Gamxyy; + delete Gamxyz; + delete Gamxzz; + delete Gamyxx; + delete Gamyxy; + delete Gamyxz; + delete Gamyyy; + delete Gamyyz; + delete Gamyzz; + delete Gamzxx; + delete Gamzxy; + delete Gamzxz; + delete Gamzyy; + delete Gamzyz; + delete Gamzzz; + + delete Rxx; + delete Rxy; + delete Rxz; + delete Ryy; + delete Ryz; + delete Rzz; + + delete Rpsi4; + delete Ipsi4; + delete t1Rpsi4; + delete t1Ipsi4; + delete t2Rpsi4; + delete t2Ipsi4; + + delete Cons_Ham; + delete Cons_Px; + delete Cons_Py; + delete Cons_Pz; + delete Cons_Gx; + delete Cons_Gy; + delete Cons_Gz; + +#ifdef Point_Psi4 + delete phix; + delete phiy; + delete phiz; + delete trKx; + delete trKy; + delete trKz; + delete Axxx; + delete Axxy; + delete Axxz; + delete Axyx; + delete Axyy; + delete Axyz; + delete Axzx; + delete Axzy; + delete Axzz; + delete Ayyx; + delete Ayyy; + delete Ayyz; + delete Ayzx; + delete Ayzy; + delete Ayzz; + delete Azzx; + delete Azzy; + delete Azzz; +#endif + + // Destroy sync caches before GH + if (sync_cache_pre) + { + for (int i = 0; i < GH->levels; i++) + sync_cache_pre[i].destroy(); + delete[] sync_cache_pre; + } + if (sync_cache_cor) + { + for (int i = 0; i < GH->levels; i++) + sync_cache_cor[i].destroy(); + delete[] sync_cache_cor; + } + if (sync_cache_rp_coarse) + { + for (int i = 0; i < GH->levels; i++) + sync_cache_rp_coarse[i].destroy(); + delete[] sync_cache_rp_coarse; + } + if (sync_cache_rp_fine) + { + for (int i = 0; i < GH->levels; i++) + sync_cache_rp_fine[i].destroy(); + delete[] sync_cache_rp_fine; + } + + delete GH; +#ifdef WithShell + delete SH; +#endif + + for (int i = 0; i < BH_num; i++) + { + delete[] Porg0[i]; + delete[] Porgbr[i]; + delete[] Porg[i]; + delete[] Porg1[i]; + delete[] Porg_rhs[i]; + } + + delete[] Porg0; + delete[] Porgbr; + delete[] Porg; + delete[] Porg1; + delete[] Porg_rhs; + + delete[] Mass; + delete[] Spin; + delete[] Pmom; + + delete ErrorMonitor; + delete Psi4Monitor; delete BHMonitor; delete MAPMonitor; delete ConVMonitor; delete TimingMonitor; delete Waveshell; - - delete CheckPoint; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes initial data using Lousto's analytic method - -//================================================================================================ - -void bssn_class::Setup_Initial_Data_Lousto() -{ - if (!checkrun) - { - if (myrank == 0) - { - cout << endl; - cout << " Setup initial data with Lousto's analytical formula. " << endl; - cout << endl; - } - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - // Use Lousto's analytic formulas to compute initial data - f_get_lousto_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_nbhs_sh(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - // dump read_in initial data - SH->Dump_Data(StateList, 0, PhysTime, dT); -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Pmom_here; - delete[] Spin_here; - // SH->Synch(GH->PatL[0],StateList,Symmetry); - // exit(0); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes initial data using Cao's analytic formulas - -//================================================================================================ - -void bssn_class::Setup_Initial_Data_Cao() -{ - if (!checkrun) - { - if (myrank == 0) - { - cout << endl; - cout << " Setup initial data with Cao's analytical formula. " << endl; - cout << endl; - } - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - // Use Cao's analytic formulas to compute initial data - f_get_initial_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_nbhs_sh(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - // dump read_in initial data - SH->Dump_Data(StateList, 0, PhysTime, dT); -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Pmom_here; - delete[] Spin_here; - // SH->Synch(GH->PatL[0],StateList,Symmetry); - // exit(0); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes Kerr-Schild initial data via an analytic method - -//================================================================================================ - -void bssn_class::Setup_KerrSchild() -{ - if (!checkrun) - { - if (myrank == 0) - { - cout << endl; - cout << " Setup initial data with Kerr-Schild formula. " << endl; - cout << endl; - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_kerrschild(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - int lev = 0, fngfs = Pp->data->fngfs; - - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_kerrschild_ss(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); - /* - f_fderivs_shc(cg->shape,cg->fgfs[phi0->sgfn], - cg->fgfs[Sfx_rhs->sgfn], - cg->fgfs[Sfy_rhs->sgfn], - cg->fgfs[Sfz_rhs->sgfn], - cg->X[0],cg->X[1],cg->X[2], - phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], - Symmetry,lev,Pp->data->sst, - cg->fgfs[fngfs+ShellPatch::drhodx], - cg->fgfs[fngfs+ShellPatch::drhody], - cg->fgfs[fngfs+ShellPatch::drhodz], - cg->fgfs[fngfs+ShellPatch::dsigmadx], - cg->fgfs[fngfs+ShellPatch::dsigmady], - cg->fgfs[fngfs+ShellPatch::dsigmadz], - cg->fgfs[fngfs+ShellPatch::dRdx], - cg->fgfs[fngfs+ShellPatch::dRdy], - cg->fgfs[fngfs+ShellPatch::dRdz]); - f_fdderivs_shc(cg->shape,cg->fgfs[phi0->sgfn], - cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn], - cg->X[0],cg->X[1],cg->X[2], - phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], - Symmetry,lev,Pp->data->sst, - cg->fgfs[fngfs+ShellPatch::drhodx], - cg->fgfs[fngfs+ShellPatch::drhody], - cg->fgfs[fngfs+ShellPatch::drhodz], - cg->fgfs[fngfs+ShellPatch::dsigmadx], - cg->fgfs[fngfs+ShellPatch::dsigmady], - cg->fgfs[fngfs+ShellPatch::dsigmadz], - cg->fgfs[fngfs+ShellPatch::dRdx], - cg->fgfs[fngfs+ShellPatch::dRdy], - cg->fgfs[fngfs+ShellPatch::dRdz], - cg->fgfs[fngfs+ShellPatch::drhodxx], - cg->fgfs[fngfs+ShellPatch::drhodxy], - cg->fgfs[fngfs+ShellPatch::drhodxz], - cg->fgfs[fngfs+ShellPatch::drhodyy], - cg->fgfs[fngfs+ShellPatch::drhodyz], - cg->fgfs[fngfs+ShellPatch::drhodzz], - cg->fgfs[fngfs+ShellPatch::dsigmadxx], - cg->fgfs[fngfs+ShellPatch::dsigmadxy], - cg->fgfs[fngfs+ShellPatch::dsigmadxz], - cg->fgfs[fngfs+ShellPatch::dsigmadyy], - cg->fgfs[fngfs+ShellPatch::dsigmadyz], - cg->fgfs[fngfs+ShellPatch::dsigmadzz], - cg->fgfs[fngfs+ShellPatch::dRdxx], - cg->fgfs[fngfs+ShellPatch::dRdxy], - cg->fgfs[fngfs+ShellPatch::dRdxz], - cg->fgfs[fngfs+ShellPatch::dRdyy], - cg->fgfs[fngfs+ShellPatch::dRdyz], - cg->fgfs[fngfs+ShellPatch::dRdzz]); - */ - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - // dump read_in initial data - // SH->Synch(GH->PatL[0],StateList,Symmetry); - // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); - // SH->Dump_Data(StateList,0,PhysTime,dT); - // exit(0); - - /* - { - MyList * DG_List=new MyList(Sfx_rhs); - DG_List->insert(Sfy_rhs); - DG_List->insert(Sfz_rhs); - DG_List->insert(Axx_rhs); - DG_List->insert(Axy_rhs); - DG_List->insert(Axz_rhs); - DG_List->insert(Ayy_rhs); - DG_List->insert(Ayz_rhs); - DG_List->insert(Azz_rhs); - SH->Synch(DG_List,Symmetry); - SH->Dump_Data(DG_List,0,PhysTime,dT); - DG_List->clearList(); - exit(0); - } - */ - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function reads initial data produced by Pablo Galaviz's Olliptic program - -//================================================================================================ - -// Read initial data solved by Pablo's Olliptic Phys.Rev.D 82 024005 (2010) - -//|---------------------------------------------------------------------------- -// read ASCII file with the style of Pablo -//|---------------------------------------------------------------------------- -bool bssn_class::read_Pablo_file(int *ext, double *datain, char *filename) -{ - if (myrank == 0) - { - cout << endl; - cout << " Setup initial data with Pablo_file. " << endl; - cout << endl; - } - - int nx = ext[0], ny = ext[1], nz = ext[2]; - int i, j, k; - double x, y, z; - //|--->open in put file - ifstream infile; - infile.open(filename); - if (!infile) - { - cout << "bssn_class: read_Pablo_file can't open " << filename << " for input." << endl; - return false; - } - for (k = 0; k < nz; k++) - for (j = 0; j < ny; j++) - for (i = 0; i < nx; i++) - { - infile >> x >> y >> z >> datain[i + j * nx + k * nx * ny]; - } - - infile.close(); - - return true; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function writes initial data file in the style of Pablo Galaviz's Olliptic program - -//================================================================================================ - -//|---------------------------------------------------------------------------- -// write ASCII file with the style of Pablo -//|---------------------------------------------------------------------------- -void bssn_class::write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, - char *filename) -{ - int nx = ext[0], ny = ext[1], nz = ext[2]; - int i, j, k; - double *X, *Y, *Z; - X = new double[nx]; - Y = new double[ny]; - Z = new double[nz]; - double dX, dY, dZ; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dX = (xmax - xmin) / (nx - 1); - for (i = 0; i < nx; i++) - X[i] = xmin + i * dX; - dY = (ymax - ymin) / (ny - 1); - for (j = 0; j < ny; j++) - Y[j] = ymin + j * dY; - dZ = (zmax - zmin) / (nz - 1); - for (k = 0; k < nz; k++) - Z[k] = zmin + k * dZ; -#else -#ifdef Cell - dX = (xmax - xmin) / nx; - for (i = 0; i < nx; i++) - X[i] = xmin + (i + 0.5) * dX; - dY = (ymax - ymin) / ny; - for (j = 0; j < ny; j++) - Y[j] = ymin + (j + 0.5) * dY; - dZ = (zmax - zmin) / nz; - for (k = 0; k < nz; k++) - Z[k] = zmin + (k + 0.5) * dZ; -#else -#error Not define Vertex nor Cell -#endif -#endif - //|--->open out put file - ofstream outfile; - outfile.open(filename); - if (!outfile) - { - cout << "bssn_class: write_Pablo_file can't open " << filename << " for output." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - for (k = 0; k < nz; k++) - for (j = 0; j < ny; j++) - for (i = 0; i < nx; i++) - { - outfile << X[i] << " " << Y[j] << " " << Z[k] << " " - << 0 << endl; - } - outfile.close(); - - delete[] X; - delete[] Y; - delete[] Z; -} - -//================================================================================================ - - - -//================================================================================================ - -// Read initial data solved by Ansorg, PRD 70, 064011 (2004) - -void bssn_class::Read_Ansorg() -{ - if (!checkrun) - { - if (myrank == 0) - { - cout << endl; - cout << " Read initial data from Ansorg's solver," - << " please be sure the input parameters for black holes are puncture parameters!! " << endl; - cout << endl; - } - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - - int order = 6; - Ansorg read_ansorg("Ansorg.psid", order); - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); - - f_get_ansorg_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); - - f_get_ansorg_nbhs_ss(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); -#if 0 -// for check fderivs_sh - f_fderivs_sh(cg->shape,cg->fgfs[Ayz0->sgfn], - cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], - cg->X[0],cg->X[1],cg->X[2], - Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], - Symmetry,Pp->data->sst,Pp->data->sst); -#endif -#if 0 -// for check fderivs_shc - int fngfs = Pp->data->fngfs; - f_fderivs_shc(cg->shape,cg->fgfs[Ayz0->sgfn], - cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], - cg->X[0],cg->X[1],cg->X[2], - Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], - Symmetry,Pp->data->sst,Pp->data->sst, - cg->fgfs[fngfs+ShellPatch::drhodx], - cg->fgfs[fngfs+ShellPatch::drhody], - cg->fgfs[fngfs+ShellPatch::drhodz], - cg->fgfs[fngfs+ShellPatch::dsigmadx], - cg->fgfs[fngfs+ShellPatch::dsigmady], - cg->fgfs[fngfs+ShellPatch::dsigmadz], - cg->fgfs[fngfs+ShellPatch::dRdx], - cg->fgfs[fngfs+ShellPatch::dRdy], - cg->fgfs[fngfs+ShellPatch::dRdz]); -#endif - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Pmom_here; - delete[] Spin_here; - - Compute_Constraint(); - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT); -#ifdef WithShell - SH->Dump_Data(DumpList, 0, PhysTime, dT); -#endif - // if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets up the time evolution for the entire process - -//================================================================================================ - -void bssn_class::Evolve(int Steps) -{ - clock_t prev_clock, curr_clock; - double LastDump = 0.0, LastCheck = 0.0, Last2dDump = 0.0; - LastAnas = 0; -#if 0 -//initial checkpoint for special uasge - { - CheckPoint->write_Black_Hole_position(BH_num_input,BH_num,Porg0,Porgbr,Mass); - CheckPoint->writecheck_cgh(PhysTime,GH); -#ifdef WithShell - CheckPoint->writecheck_sh(PhysTime,SH); -#endif - CheckPoint->write_bssn(LastDump,Last2dDump,LastAnas); - misc::tillherecheck("complete initialization preparation"); // we need synchronization here - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } -#endif - // for step 0 constraint interpolation - Interp_Constraint(true); - -#ifdef With_AHF - // setup apparent horizon finder direct of thornburg - { - HN_num = BH_num; - for (int ia = 0; ia < BH_num; ia++) - for (int ib = ia + 1; ib < BH_num; ib++) - HN_num++; - - AHFinderDirect::AHFinderDirect_setup(AHList, GaugeList, - this, - Symmetry, HN_num, &PhysTime); - - lastahdumpid = new int[HN_num]; - findeveryl = new int[HN_num]; - xc = new double[HN_num]; - yc = new double[HN_num]; - zc = new double[HN_num]; - xr = new double[HN_num]; - yr = new double[HN_num]; - zr = new double[HN_num]; - dTT = new double[HN_num]; - trigger = new bool[HN_num]; - dumpid = new int[HN_num]; - - for (int ihn = 0; ihn < HN_num; ihn++) - { - lastahdumpid[ihn] = 0; - findeveryl[ihn] = AHfindevery; - } - } -#endif - - if (checkrun) - CheckPoint->read_bssn(LastDump, Last2dDump, LastAnas); - - double dT_mon = dT * pow(0.5, Mymax(0, trfls)); - - /* - #ifdef With_AHF - //initial apparent horizon finding - { - double gam; - double massmin=Mass[0]; - for(int ihn=1;ihn::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + // Use Lousto's analytic formulas to compute initial data + f_get_lousto_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_nbhs_sh(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + // dump read_in initial data + SH->Dump_Data(StateList, 0, PhysTime, dT); +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Pmom_here; + delete[] Spin_here; + // SH->Synch(GH->PatL[0],StateList,Symmetry); + // exit(0); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes initial data using Cao's analytic formulas + +//================================================================================================ + +void bssn_class::Setup_Initial_Data_Cao() +{ + if (!checkrun) + { + if (myrank == 0) + { + cout << endl; + cout << " Setup initial data with Cao's analytical formula. " << endl; + cout << endl; + } + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + // Use Cao's analytic formulas to compute initial data + f_get_initial_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_nbhs_sh(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + // dump read_in initial data + SH->Dump_Data(StateList, 0, PhysTime, dT); +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Pmom_here; + delete[] Spin_here; + // SH->Synch(GH->PatL[0],StateList,Symmetry); + // exit(0); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes Kerr-Schild initial data via an analytic method + +//================================================================================================ + +void bssn_class::Setup_KerrSchild() +{ + if (!checkrun) + { + if (myrank == 0) + { + cout << endl; + cout << " Setup initial data with Kerr-Schild formula. " << endl; + cout << endl; + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_kerrschild(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + int lev = 0, fngfs = Pp->data->fngfs; + + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_kerrschild_ss(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); + /* + f_fderivs_shc(cg->shape,cg->fgfs[phi0->sgfn], + cg->fgfs[Sfx_rhs->sgfn], + cg->fgfs[Sfy_rhs->sgfn], + cg->fgfs[Sfz_rhs->sgfn], + cg->X[0],cg->X[1],cg->X[2], + phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], + Symmetry,lev,Pp->data->sst, + cg->fgfs[fngfs+ShellPatch::drhodx], + cg->fgfs[fngfs+ShellPatch::drhody], + cg->fgfs[fngfs+ShellPatch::drhodz], + cg->fgfs[fngfs+ShellPatch::dsigmadx], + cg->fgfs[fngfs+ShellPatch::dsigmady], + cg->fgfs[fngfs+ShellPatch::dsigmadz], + cg->fgfs[fngfs+ShellPatch::dRdx], + cg->fgfs[fngfs+ShellPatch::dRdy], + cg->fgfs[fngfs+ShellPatch::dRdz]); + f_fdderivs_shc(cg->shape,cg->fgfs[phi0->sgfn], + cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn], + cg->X[0],cg->X[1],cg->X[2], + phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], + Symmetry,lev,Pp->data->sst, + cg->fgfs[fngfs+ShellPatch::drhodx], + cg->fgfs[fngfs+ShellPatch::drhody], + cg->fgfs[fngfs+ShellPatch::drhodz], + cg->fgfs[fngfs+ShellPatch::dsigmadx], + cg->fgfs[fngfs+ShellPatch::dsigmady], + cg->fgfs[fngfs+ShellPatch::dsigmadz], + cg->fgfs[fngfs+ShellPatch::dRdx], + cg->fgfs[fngfs+ShellPatch::dRdy], + cg->fgfs[fngfs+ShellPatch::dRdz], + cg->fgfs[fngfs+ShellPatch::drhodxx], + cg->fgfs[fngfs+ShellPatch::drhodxy], + cg->fgfs[fngfs+ShellPatch::drhodxz], + cg->fgfs[fngfs+ShellPatch::drhodyy], + cg->fgfs[fngfs+ShellPatch::drhodyz], + cg->fgfs[fngfs+ShellPatch::drhodzz], + cg->fgfs[fngfs+ShellPatch::dsigmadxx], + cg->fgfs[fngfs+ShellPatch::dsigmadxy], + cg->fgfs[fngfs+ShellPatch::dsigmadxz], + cg->fgfs[fngfs+ShellPatch::dsigmadyy], + cg->fgfs[fngfs+ShellPatch::dsigmadyz], + cg->fgfs[fngfs+ShellPatch::dsigmadzz], + cg->fgfs[fngfs+ShellPatch::dRdxx], + cg->fgfs[fngfs+ShellPatch::dRdxy], + cg->fgfs[fngfs+ShellPatch::dRdxz], + cg->fgfs[fngfs+ShellPatch::dRdyy], + cg->fgfs[fngfs+ShellPatch::dRdyz], + cg->fgfs[fngfs+ShellPatch::dRdzz]); + */ + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + // dump read_in initial data + // SH->Synch(GH->PatL[0],StateList,Symmetry); + // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); + // SH->Dump_Data(StateList,0,PhysTime,dT); + // exit(0); + + /* + { + MyList * DG_List=new MyList(Sfx_rhs); + DG_List->insert(Sfy_rhs); + DG_List->insert(Sfz_rhs); + DG_List->insert(Axx_rhs); + DG_List->insert(Axy_rhs); + DG_List->insert(Axz_rhs); + DG_List->insert(Ayy_rhs); + DG_List->insert(Ayz_rhs); + DG_List->insert(Azz_rhs); + SH->Synch(DG_List,Symmetry); + SH->Dump_Data(DG_List,0,PhysTime,dT); + DG_List->clearList(); + exit(0); + } + */ + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function reads initial data produced by Pablo Galaviz's Olliptic program + +//================================================================================================ + +// Read initial data solved by Pablo's Olliptic Phys.Rev.D 82 024005 (2010) + +//|---------------------------------------------------------------------------- +// read ASCII file with the style of Pablo +//|---------------------------------------------------------------------------- +bool bssn_class::read_Pablo_file(int *ext, double *datain, char *filename) +{ + if (myrank == 0) + { + cout << endl; + cout << " Setup initial data with Pablo_file. " << endl; + cout << endl; + } + + int nx = ext[0], ny = ext[1], nz = ext[2]; + int i, j, k; + double x, y, z; + //|--->open in put file + ifstream infile; + infile.open(filename); + if (!infile) + { + cout << "bssn_class: read_Pablo_file can't open " << filename << " for input." << endl; + return false; + } + for (k = 0; k < nz; k++) + for (j = 0; j < ny; j++) + for (i = 0; i < nx; i++) + { + infile >> x >> y >> z >> datain[i + j * nx + k * nx * ny]; + } + + infile.close(); + + return true; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function writes initial data file in the style of Pablo Galaviz's Olliptic program + +//================================================================================================ + +//|---------------------------------------------------------------------------- +// write ASCII file with the style of Pablo +//|---------------------------------------------------------------------------- +void bssn_class::write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, + char *filename) +{ + int nx = ext[0], ny = ext[1], nz = ext[2]; + int i, j, k; + double *X, *Y, *Z; + X = new double[nx]; + Y = new double[ny]; + Z = new double[nz]; + double dX, dY, dZ; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dX = (xmax - xmin) / (nx - 1); + for (i = 0; i < nx; i++) + X[i] = xmin + i * dX; + dY = (ymax - ymin) / (ny - 1); + for (j = 0; j < ny; j++) + Y[j] = ymin + j * dY; + dZ = (zmax - zmin) / (nz - 1); + for (k = 0; k < nz; k++) + Z[k] = zmin + k * dZ; +#else +#ifdef Cell + dX = (xmax - xmin) / nx; + for (i = 0; i < nx; i++) + X[i] = xmin + (i + 0.5) * dX; + dY = (ymax - ymin) / ny; + for (j = 0; j < ny; j++) + Y[j] = ymin + (j + 0.5) * dY; + dZ = (zmax - zmin) / nz; + for (k = 0; k < nz; k++) + Z[k] = zmin + (k + 0.5) * dZ; +#else +#error Not define Vertex nor Cell +#endif +#endif + //|--->open out put file + ofstream outfile; + outfile.open(filename); + if (!outfile) + { + cout << "bssn_class: write_Pablo_file can't open " << filename << " for output." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + for (k = 0; k < nz; k++) + for (j = 0; j < ny; j++) + for (i = 0; i < nx; i++) + { + outfile << X[i] << " " << Y[j] << " " << Z[k] << " " + << 0 << endl; + } + outfile.close(); + + delete[] X; + delete[] Y; + delete[] Z; +} + +//================================================================================================ + + + +//================================================================================================ + +// Read initial data solved by Ansorg, PRD 70, 064011 (2004) + +void bssn_class::Read_Ansorg() +{ + if (!checkrun) + { + if (myrank == 0) + { + cout << endl; + cout << " Read initial data from Ansorg's solver," + << " please be sure the input parameters for black holes are puncture parameters!! " << endl; + cout << endl; + } + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + + int order = 6; + Ansorg read_ansorg("Ansorg.psid", order); + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); + + f_get_ansorg_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); + + f_get_ansorg_nbhs_ss(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); +#if 0 +// for check fderivs_sh + f_fderivs_sh(cg->shape,cg->fgfs[Ayz0->sgfn], + cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], + cg->X[0],cg->X[1],cg->X[2], + Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], + Symmetry,Pp->data->sst,Pp->data->sst); +#endif +#if 0 +// for check fderivs_shc + int fngfs = Pp->data->fngfs; + f_fderivs_shc(cg->shape,cg->fgfs[Ayz0->sgfn], + cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], + cg->X[0],cg->X[1],cg->X[2], + Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], + Symmetry,Pp->data->sst,Pp->data->sst, + cg->fgfs[fngfs+ShellPatch::drhodx], + cg->fgfs[fngfs+ShellPatch::drhody], + cg->fgfs[fngfs+ShellPatch::drhodz], + cg->fgfs[fngfs+ShellPatch::dsigmadx], + cg->fgfs[fngfs+ShellPatch::dsigmady], + cg->fgfs[fngfs+ShellPatch::dsigmadz], + cg->fgfs[fngfs+ShellPatch::dRdx], + cg->fgfs[fngfs+ShellPatch::dRdy], + cg->fgfs[fngfs+ShellPatch::dRdz]); +#endif + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Pmom_here; + delete[] Spin_here; + + Compute_Constraint(); + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT); +#ifdef WithShell + SH->Dump_Data(DumpList, 0, PhysTime, dT); +#endif + // if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets up the time evolution for the entire process + +//================================================================================================ + +void bssn_class::Evolve(int Steps) +{ + clock_t prev_clock, curr_clock; + double LastDump = 0.0, LastCheck = 0.0, Last2dDump = 0.0; + LastAnas = 0; +#if 0 +//initial checkpoint for special uasge + { + CheckPoint->write_Black_Hole_position(BH_num_input,BH_num,Porg0,Porgbr,Mass); + CheckPoint->writecheck_cgh(PhysTime,GH); +#ifdef WithShell + CheckPoint->writecheck_sh(PhysTime,SH); +#endif + CheckPoint->write_bssn(LastDump,Last2dDump,LastAnas); + misc::tillherecheck("complete initialization preparation"); // we need synchronization here + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } +#endif + // for step 0 constraint interpolation + Interp_Constraint(true); + +#ifdef With_AHF + // setup apparent horizon finder direct of thornburg + { + HN_num = BH_num; + for (int ia = 0; ia < BH_num; ia++) + for (int ib = ia + 1; ib < BH_num; ib++) + HN_num++; + + AHFinderDirect::AHFinderDirect_setup(AHList, GaugeList, + this, + Symmetry, HN_num, &PhysTime); + + lastahdumpid = new int[HN_num]; + findeveryl = new int[HN_num]; + xc = new double[HN_num]; + yc = new double[HN_num]; + zc = new double[HN_num]; + xr = new double[HN_num]; + yr = new double[HN_num]; + zr = new double[HN_num]; + dTT = new double[HN_num]; + trigger = new bool[HN_num]; + dumpid = new int[HN_num]; + + for (int ihn = 0; ihn < HN_num; ihn++) + { + lastahdumpid[ihn] = 0; + findeveryl[ihn] = AHfindevery; + } + } +#endif + + if (checkrun) + CheckPoint->read_bssn(LastDump, Last2dDump, LastAnas); + + double dT_mon = dT * pow(0.5, Mymax(0, trfls)); + + /* + #ifdef With_AHF + //initial apparent horizon finding + { + double gam; + double massmin=Mass[0]; + for(int ihn=1;ihnlevels; lev++) - GH->Lt[lev] = PhysTime; - - GH->settrfls(trfls); - + + for (int lev = 0; lev < GH->levels; lev++) + GH->Lt[lev] = PhysTime; + + GH->settrfls(trfls); + for (int ncount = 1; ncount < Steps + 1; ncount++) { #if BSSN_FINE_TIMING @@ -2409,29 +2409,29 @@ void bssn_class::Evolve(int Steps) const double step_wall_start = MPI_Wtime(); #endif // special for large mass ratio consideration - // if(fabs(Porg0[0][0]-Porg0[1][0])+fabs(Porg0[0][1]-Porg0[1][1])+fabs(Porg0[0][2]-Porg0[1][2])<1e-6) - // { GH->levels=GH->movls; } - - if (myrank == 0) - curr_clock = clock(); -#if (PSTR == 0) - RecursiveStep(0); -#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - AnalysisStuff(a_lev, dT_mon); - ParallelStep(); -#endif - - // misc::tillherecheck("before Constraint_Out"); - - Constraint_Out(); // this will affect the Dump_List - - LastDump += dT_mon; - Last2dDump += dT_mon; - LastCheck += dT_mon; - - // When LastDump >= DumpTime, output corresponding binary data + // if(fabs(Porg0[0][0]-Porg0[1][0])+fabs(Porg0[0][1]-Porg0[1][1])+fabs(Porg0[0][2]-Porg0[1][2])<1e-6) + // { GH->levels=GH->movls; } + + if (myrank == 0) + curr_clock = clock(); +#if (PSTR == 0) + RecursiveStep(0); +#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + AnalysisStuff(a_lev, dT_mon); + ParallelStep(); +#endif + + // misc::tillherecheck("before Constraint_Out"); + + Constraint_Out(); // this will affect the Dump_List + + LastDump += dT_mon; + Last2dDump += dT_mon; + LastCheck += dT_mon; + + // When LastDump >= DumpTime, output corresponding binary data if (LastDump >= DumpTime) { STEP_TIMER_DECL(timer_dump3d); @@ -2445,14 +2445,14 @@ void bssn_class::Evolve(int Steps) STEP_TIMER_ADD(TB_DUMP_3D, timer_dump3d); LastDump = 0; - - if (myrank == 0) - { - cout << " Dump done. " << endl; - } - } - - // When Last2dDump >= d2DumpTime, output corresponding 2D data + + if (myrank == 0) + { + cout << " Dump done. " << endl; + } + } + + // When Last2dDump >= d2DumpTime, output corresponding 2D data if (Last2dDump >= d2DumpTime) { STEP_TIMER_DECL(timer_dump2d); @@ -2463,27 +2463,27 @@ void bssn_class::Evolve(int Steps) STEP_TIMER_ADD(TB_DUMP_2D, timer_dump2d); Last2dDump = 0; - - if (myrank == 0) - { - cout << " 2d Dump done. " << endl; - } - } - - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << endl; - cout << " Timestep # " << ncount << ": integrating to time: " << PhysTime << " " - << " Computer used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - // cout << endl; - } - - if (PhysTime >= TotalTime) - break; - + + if (myrank == 0) + { + cout << " 2d Dump done. " << endl; + } + } + + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << endl; + cout << " Timestep # " << ncount << ": integrating to time: " << PhysTime << " " + << " Computer used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + // cout << endl; + } + + if (PhysTime >= TotalTime) + break; + #if (REGLEV == 1) STEP_TIMER_DECL(timer_regrid); GH->Regrid(Symmetry, BH_num, Porgbr, Porg0, @@ -2492,13 +2492,13 @@ void bssn_class::Evolve(int Steps) for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } STEP_TIMER_ADD(TB_REGRID, timer_regrid); #endif - -#if (REGLEV == 0 && (PSTR == 1 || PSTR == 2)) -// GH->Regrid_fake(Symmetry,BH_num,Porgbr,Porg0, -// SynchList_cor,OldStateList,StateList,SynchList_pre, -// fgt(PhysTime-dT_mon,StartTime,dT_mon/2),ErrorMonitor); -#endif - + +#if (REGLEV == 0 && (PSTR == 1 || PSTR == 2)) +// GH->Regrid_fake(Symmetry,BH_num,Porgbr,Porg0, +// SynchList_cor,OldStateList,StateList,SynchList_pre, +// fgt(PhysTime-dT_mon,StartTime,dT_mon/2),ErrorMonitor); +#endif + #if BSSN_ENABLE_MEM_USAGE_LOG // Retrieve memory usage information used during computation; master process prints it bssn_perf.MemoryUsage(¤t_min, ¤t_avg, ¤t_max, @@ -2516,18 +2516,18 @@ void bssn_class::Evolve(int Steps) cout << endl; } #endif - - // Output puncture positions at each step - if (myrank == 0) - { - for (int i_count=0; i_countCS_Inter(StateList, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - } -#endif - -#endif - - // Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT_lev); - } - -#if 0 - if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); -#endif - + /* + #ifdef With_AHF + // final apparent horizon finding + { + double gam; + for(int ihn=0;ihnCS_Inter(StateList, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + } +#endif + +#endif + + // Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT_lev); + } + +#if 0 + if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); +#endif + #if (REGLEV == 0) STEP_TIMER_DECL(timer_regrid_onelevel); if (GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, @@ -2735,623 +2735,623 @@ void bssn_class::RecursiveStep(int lev) STEP_TIMER_ADD(TB_REGRID, timer_regrid_onelevel); #endif } - -//================================================================================================ - - - -//================================================================================================ - -// This member function implements recursive time-stepping across AMR levels -// This variant handles the cases PSTR == 1 and PSTR == 2 - -//================================================================================================ - -#elif (PSTR == 1 || PSTR == 2) -void bssn_class::RecursiveStep(int lev) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - - int NoIterations = 1, YN; - if (lev <= trfls) - NoIterations = 1; - else - NoIterations = 2; - - for (int i = 0; i < NoIterations; i++) - { - // if(myrank==0) cout<<"level now = "<mylev; - MPI_Status status; - // receive - if (lev < GH->levels - 1) - { - if (myrank == GH->start_rank[lev]) - { - MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev + 1], 1, MPI_COMM_WORLD, &status); - // cout<Commlev[lev]); - - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - Porg0[i][j] = tporg[3 * i + j]; - - // if(myrank==GH->start_rank[lev]) cout< 0 && myrank == GH->start_rank[lev]) - { - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - tporg[3 * i + j] = Porg0[i][j]; - - MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev - 1], 1, MPI_COMM_WORLD); - } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - delete[] tporg; - delete[] tporgo; -#if (REGLEV == 0) - if (GH->Regrid_Onelevel(GH->mylev, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor)) - for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } -#endif -} - -//================================================================================================ - - - -//================================================================================================ - -// ParallelStep performs time evolution across AMR levels (parallelized) -// This is an alternate implementation - -//================================================================================================ - -#else -void bssn_class::ParallelStep() -{ - // stringstream a_stream; - // a_stream.setf(ios::left); - - double *tporg, *tporgo; - tporg = new double[3 * BH_num]; - tporgo = new double[3 * BH_num]; - - int lev = GH->mylev; - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - double dT_levp1 = dT * pow(0.5, Mymax(lev + 1, trfls)); - double dT_levm1 = dT * pow(0.5, Mymax(lev - 1, trfls)); - - int NoIterations = 1, YN; - if (lev <= trfls) - NoIterations = 1; - else - NoIterations = int(pow(2.0, lev - trfls)); - - for (int i = 0; i < NoIterations; i++) - { - // if(myrank==GH->start_rank[lev]) cout<<"level now = "<Commlev[lev],GH->start_rank[lev],a_stream.str()); - Step(lev, YN); - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - -#if (AGM == 2) - if (GH->levels == 1) - { - Enforce_algcon(lev, 0); - } -#endif - - GH->Lt[lev] += dT_lev; - - PhysTime += dT_lev; - -#if (AGM == 2) - if (lev > 0) - { - Enforce_algcon(lev, 0); - if (YN == 1) - Enforce_algcon(lev - 1, 0); - } -#endif - -#if (RPS == 1) - // mesh refinement boundary part - // - // till here the PhysTime has updated dT_lev - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - if (lev < GH->levels - 1) - { - if (lev + 1 <= trfls) - { - // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); - RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); - } - else - { - // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],"between RestrictProlong"); - - // RestrictProlong_aux(lev,0,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); - // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_levp1,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); - RestrictProlong(lev + 1, 0, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); - RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); - } - } - - // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],a_stream.str()); - - RestrictProlong(lev, YN, fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), StateList, OldStateList, SynchList_cor); - // RestrictProlong(lev,YN,false,StateList,OldStateList,SynchList_cor); - -// if(myrank==GH->start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],a_stream.str()); -#endif - - // Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT_lev); - - { - MPI_Status status; - // receive - if (lev < GH->levels - 1) - { - if (myrank == GH->start_rank[lev]) - { - MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev + 1], 1, MPI_COMM_WORLD, &status); - // cout<Commlev[lev]); - - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - Porg0[i][j] = tporg[3 * i + j]; - - // if(myrank==GH->start_rank[lev]) cout< 0 && YN == 1 && myrank == GH->start_rank[lev]) - { - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - tporg[3 * i + j] = Porg0[i][j]; - - MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev - 1], 1, MPI_COMM_WORLD); - } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - } -#if (REGLEV == 0) - // for higher level - if (lev < GH->levels - 1) - { - if (lev + 1 >= GH->movls) - { - // GH->Regrid_Onelevel_aux(lev,Symmetry,BH_num,Porgbr,Porg0, - if (GH->Regrid_Onelevel(lev + 1, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), ErrorMonitor)) - for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel_aux for higher level"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - } - - // for this level - if (YN == 1) - { - if (GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor)) - for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - - // for lower level - if (lev - 1 >= GH->movls) - { - if (lev - 1 <= trfls) - { - if (YN == 1) - { - // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, - if (GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor)) - for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel_aux for lower level"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - } - else - { - if (i % 4 == 3) - { - // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, - if (GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor)) - for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel_aux for lower level"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - } - } -#endif - } - -#ifdef WithShell - SHStep(); - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - -#if (RPS == 1) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(StateList, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - } -#endif - -#endif - -#if 0 - if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); -#endif - - delete[] tporg; - delete[] tporgo; -} -#endif - -//================================================================================================ - - - -//================================================================================================ - -// ParallelStep performs time evolution across AMR levels (parallelized) -// This is another implementation, for the case PSTR == 3 - -//================================================================================================ - -#elif (PSTR == 3) -#warning "remember do not use Shell" -void bssn_class::ParallelStep() -{ - // stringstream a_stream; - // a_stream.setf(ios::left); - - double *tporg, *tporgo; - tporg = new double[3 * BH_num]; - tporgo = new double[3 * BH_num]; - - int lev = GH->mylev; - double dT_lev = dT * pow(0.5, Mymax(GH->levels - 1, trfls)); - if (lev == 1) - { - lev = GH->levels - 1; - for (int i = 0; i < misc::MYpow2(lev); i++) - { - Step(lev, i % 2); - PhysTime += dT_lev; - // if(myrank==nprocs-1) cout<<"OOO level now = "<levels - 2; - for (int i = 1; i < misc::MYpow2(lev + 1); i++) - { - RecursiveStep(lev, i); - PhysTime += dT_lev; - if (i % 2 == 0) - { - // if(myrank==0) cout<<"level now = "<mylev; - if (lev == -1) - lev = 0; - else - lev = GH->levels - 1; - - { - MPI_Status status; - // receive - if (lev == 0) - { - if (myrank == GH->start_rank[lev]) - { - MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[GH->levels - 1], 1, MPI_COMM_WORLD, &status); - // cout<Commlev[lev]); - - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - Porg0[i][j] = tporg[3 * i + j]; - - // if(myrank==GH->start_rank[lev]) cout<start_rank[lev]) - { - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - tporg[3 * i + j] = Porg0[i][j]; - - MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[0], 1, MPI_COMM_WORLD); - } - } - - delete[] tporg; - delete[] tporgo; -} - -//================================================================================================ - - - - -//================================================================================================ - -// This member function implements recursive time-stepping across AMR levels - -//================================================================================================ - -void bssn_class::RecursiveStep(int lev, int num) // in all 2^(lev+1)-1 steps -{ - if (trfls > 0) - cout << "error: bssn_class::RecursiveStep does not support trfls > 0 yet" << endl; - - if (num / 2 * 2 == num) - RecursiveStep(lev - 1, num / 2); - else - { - Step(lev, 0); - double dT_lev = dT * pow(0.5, Mymax(lev + 1, trfls)); - if (myrank == 0) - cout << "level now = " << lev + 1 << ", " << (num - 1) % 2 << ", " - << fgt(PhysTime - dT_lev, StartTime, dT_lev / 2) << endl; - RestrictProlong(lev + 1, (num - 1) % 2, fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), StateList, OldStateList, SynchList_cor); - } -} -#endif - -//================================================================================================ - - - - -//================================================================================================ - -// This member function configures a single time-step evolution for each grid level. -// Applicable for the case PSTR == 0 - -//================================================================================================ - -#if (PSTR == 0) -#if 1 -void bssn_class::Step(int lev, int YN) -{ - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - + +//================================================================================================ + + + +//================================================================================================ + +// This member function implements recursive time-stepping across AMR levels +// This variant handles the cases PSTR == 1 and PSTR == 2 + +//================================================================================================ + +#elif (PSTR == 1 || PSTR == 2) +void bssn_class::RecursiveStep(int lev) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + + int NoIterations = 1, YN; + if (lev <= trfls) + NoIterations = 1; + else + NoIterations = 2; + + for (int i = 0; i < NoIterations; i++) + { + // if(myrank==0) cout<<"level now = "<mylev; + MPI_Status status; + // receive + if (lev < GH->levels - 1) + { + if (myrank == GH->start_rank[lev]) + { + MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev + 1], 1, MPI_COMM_WORLD, &status); + // cout<Commlev[lev]); + + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + Porg0[i][j] = tporg[3 * i + j]; + + // if(myrank==GH->start_rank[lev]) cout< 0 && myrank == GH->start_rank[lev]) + { + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + tporg[3 * i + j] = Porg0[i][j]; + + MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev - 1], 1, MPI_COMM_WORLD); + } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + delete[] tporg; + delete[] tporgo; +#if (REGLEV == 0) + if (GH->Regrid_Onelevel(GH->mylev, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor)) + for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } +#endif +} + +//================================================================================================ + + + +//================================================================================================ + +// ParallelStep performs time evolution across AMR levels (parallelized) +// This is an alternate implementation + +//================================================================================================ + +#else +void bssn_class::ParallelStep() +{ + // stringstream a_stream; + // a_stream.setf(ios::left); + + double *tporg, *tporgo; + tporg = new double[3 * BH_num]; + tporgo = new double[3 * BH_num]; + + int lev = GH->mylev; + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + double dT_levp1 = dT * pow(0.5, Mymax(lev + 1, trfls)); + double dT_levm1 = dT * pow(0.5, Mymax(lev - 1, trfls)); + + int NoIterations = 1, YN; + if (lev <= trfls) + NoIterations = 1; + else + NoIterations = int(pow(2.0, lev - trfls)); + + for (int i = 0; i < NoIterations; i++) + { + // if(myrank==GH->start_rank[lev]) cout<<"level now = "<Commlev[lev],GH->start_rank[lev],a_stream.str()); + Step(lev, YN); + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + +#if (AGM == 2) + if (GH->levels == 1) + { + Enforce_algcon(lev, 0); + } +#endif + + GH->Lt[lev] += dT_lev; + + PhysTime += dT_lev; + +#if (AGM == 2) + if (lev > 0) + { + Enforce_algcon(lev, 0); + if (YN == 1) + Enforce_algcon(lev - 1, 0); + } +#endif + +#if (RPS == 1) + // mesh refinement boundary part + // + // till here the PhysTime has updated dT_lev + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + if (lev < GH->levels - 1) + { + if (lev + 1 <= trfls) + { + // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); + RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); + } + else + { + // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],"between RestrictProlong"); + + // RestrictProlong_aux(lev,0,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); + // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_levp1,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); + RestrictProlong(lev + 1, 0, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); + RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); + } + } + + // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],a_stream.str()); + + RestrictProlong(lev, YN, fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), StateList, OldStateList, SynchList_cor); + // RestrictProlong(lev,YN,false,StateList,OldStateList,SynchList_cor); + +// if(myrank==GH->start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],a_stream.str()); +#endif + + // Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT_lev); + + { + MPI_Status status; + // receive + if (lev < GH->levels - 1) + { + if (myrank == GH->start_rank[lev]) + { + MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev + 1], 1, MPI_COMM_WORLD, &status); + // cout<Commlev[lev]); + + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + Porg0[i][j] = tporg[3 * i + j]; + + // if(myrank==GH->start_rank[lev]) cout< 0 && YN == 1 && myrank == GH->start_rank[lev]) + { + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + tporg[3 * i + j] = Porg0[i][j]; + + MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev - 1], 1, MPI_COMM_WORLD); + } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + } +#if (REGLEV == 0) + // for higher level + if (lev < GH->levels - 1) + { + if (lev + 1 >= GH->movls) + { + // GH->Regrid_Onelevel_aux(lev,Symmetry,BH_num,Porgbr,Porg0, + if (GH->Regrid_Onelevel(lev + 1, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), ErrorMonitor)) + for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel_aux for higher level"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + } + + // for this level + if (YN == 1) + { + if (GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor)) + for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + + // for lower level + if (lev - 1 >= GH->movls) + { + if (lev - 1 <= trfls) + { + if (YN == 1) + { + // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, + if (GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor)) + for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel_aux for lower level"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + } + else + { + if (i % 4 == 3) + { + // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, + if (GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor)) + for (int il = 0; il < GH->levels; il++) { sync_cache_pre[il].invalidate(); sync_cache_cor[il].invalidate(); sync_cache_rp_coarse[il].invalidate(); sync_cache_rp_fine[il].invalidate(); sync_cache_restrict[il].invalidate(); sync_cache_outbd[il].invalidate(); } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel_aux for lower level"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + } + } +#endif + } + +#ifdef WithShell + SHStep(); + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + +#if (RPS == 1) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(StateList, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + } +#endif + +#endif + +#if 0 + if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); +#endif + + delete[] tporg; + delete[] tporgo; +} +#endif + +//================================================================================================ + + + +//================================================================================================ + +// ParallelStep performs time evolution across AMR levels (parallelized) +// This is another implementation, for the case PSTR == 3 + +//================================================================================================ + +#elif (PSTR == 3) +#warning "remember do not use Shell" +void bssn_class::ParallelStep() +{ + // stringstream a_stream; + // a_stream.setf(ios::left); + + double *tporg, *tporgo; + tporg = new double[3 * BH_num]; + tporgo = new double[3 * BH_num]; + + int lev = GH->mylev; + double dT_lev = dT * pow(0.5, Mymax(GH->levels - 1, trfls)); + if (lev == 1) + { + lev = GH->levels - 1; + for (int i = 0; i < misc::MYpow2(lev); i++) + { + Step(lev, i % 2); + PhysTime += dT_lev; + // if(myrank==nprocs-1) cout<<"OOO level now = "<levels - 2; + for (int i = 1; i < misc::MYpow2(lev + 1); i++) + { + RecursiveStep(lev, i); + PhysTime += dT_lev; + if (i % 2 == 0) + { + // if(myrank==0) cout<<"level now = "<mylev; + if (lev == -1) + lev = 0; + else + lev = GH->levels - 1; + + { + MPI_Status status; + // receive + if (lev == 0) + { + if (myrank == GH->start_rank[lev]) + { + MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[GH->levels - 1], 1, MPI_COMM_WORLD, &status); + // cout<Commlev[lev]); + + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + Porg0[i][j] = tporg[3 * i + j]; + + // if(myrank==GH->start_rank[lev]) cout<start_rank[lev]) + { + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + tporg[3 * i + j] = Porg0[i][j]; + + MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[0], 1, MPI_COMM_WORLD); + } + } + + delete[] tporg; + delete[] tporgo; +} + +//================================================================================================ + + + + +//================================================================================================ + +// This member function implements recursive time-stepping across AMR levels + +//================================================================================================ + +void bssn_class::RecursiveStep(int lev, int num) // in all 2^(lev+1)-1 steps +{ + if (trfls > 0) + cout << "error: bssn_class::RecursiveStep does not support trfls > 0 yet" << endl; + + if (num / 2 * 2 == num) + RecursiveStep(lev - 1, num / 2); + else + { + Step(lev, 0); + double dT_lev = dT * pow(0.5, Mymax(lev + 1, trfls)); + if (myrank == 0) + cout << "level now = " << lev + 1 << ", " << (num - 1) % 2 << ", " + << fgt(PhysTime - dT_lev, StartTime, dT_lev / 2) << endl; + RestrictProlong(lev + 1, (num - 1) % 2, fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), StateList, OldStateList, SynchList_cor); + } +} +#endif + +//================================================================================================ + + + + +//================================================================================================ + +// This member function configures a single time-step evolution for each grid level. +// Applicable for the case PSTR == 0 + +//================================================================================================ + +#if (PSTR == 0) +#if 1 +void bssn_class::Step(int lev, int YN) +{ + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + // new code 2013-2-15, zjcao #if (MAPBH == 1) STEP_TIMER_DECL(timer_bh_predictor); // for black hole position if (BH_num > 0 && lev == GH->levels - 1) { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - for (int ith = 0; ith < 3; ith++) - Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + for (int ith = 0; ith < 3; ith++) + Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); DG_List->clearList(); } } @@ -3359,33 +3359,33 @@ void bssn_class::Step(int lev, int YN) STEP_TIMER_ADD(TB_BH_PREDICTOR, timer_bh_predictor); // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } -#endif - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } +#endif + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; int ERROR = 0; MyList *sPp; STEP_TIMER_DECL(timer_predictor_rhs); // Predictor MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) { Block *cg = BP->data; if (myrank == cg->rank) @@ -3399,39 +3399,39 @@ void bssn_class::Step(int lev, int YN) #endif if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) { cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," @@ -3442,213 +3442,213 @@ void bssn_class::Step(int lev, int YN) // rk4 substep and boundary { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) -#warning "shell part still bam type" - if (lev == 0) // Shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) +#warning "shell part still bam type" + if (lev == 0) // Shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } } f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check rhs - { - SH->Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check rhs + { + SH->Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<PatL[lev], SynchList_pre, Symmetry, sync_cache_pre[lev], async_pre); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - Parallel::Sync_finish(sync_cache_pre[lev], async_pre, SynchList_pre, Symmetry); - + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + Parallel::Sync_finish(sync_cache_pre[lev], async_pre, SynchList_pre, Symmetry); + #ifdef WithShell // Complete non-blocking error reduction and check MPI_Wait(&err_req, MPI_STATUS_IGNORE); - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; MPI_Abort(MPI_COMM_WORLD, 1); } } @@ -3698,45 +3698,45 @@ void bssn_class::Step(int lev, int YN) STEP_TIMER_ADD(TB_PREDICTOR_SYNC, timer_predictor_sync); #if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } -#endif - + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } +#endif + // corrector for (iter_count = 1; iter_count < 4; iter_count++) { @@ -3744,11 +3744,11 @@ void bssn_class::Step(int lev, int YN) // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; if (iter_count == 1 || iter_count == 3) TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) { Block *cg = BP->data; if (myrank == cg->rank) @@ -3760,8 +3760,8 @@ void bssn_class::Step(int lev, int YN) cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); #elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, + if (iter_count == 3) + f_enforce_ga(cg->shape, cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], @@ -3769,39 +3769,39 @@ void bssn_class::Step(int lev, int YN) #endif if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) { cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," @@ -3811,209 +3811,209 @@ void bssn_class::Step(int lev, int YN) } // rk4 substep and boundary { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) - if (lev == 1) // shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) + if (lev == 1) // shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } } f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // Non-blocking error reduction overlapped with Sync to hide Allreduce latency - MPI_Request err_req_cor; + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // Non-blocking error reduction overlapped with Sync to hide Allreduce latency + MPI_Request err_req_cor; { int erh = ERROR; MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req_cor); @@ -4025,40 +4025,40 @@ void bssn_class::Step(int lev, int YN) STEP_TIMER_DECL(timer_corrector_sync); Parallel::AsyncSyncState async_cor; Parallel::Sync_start(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_cor[lev], async_cor); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - Parallel::Sync_finish(sync_cache_cor[lev], async_cor, SynchList_cor, Symmetry); - -#ifdef WithShell - // Complete non-blocking error reduction and check - MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + Parallel::Sync_finish(sync_cache_cor[lev], async_cor, SynchList_cor, Symmetry); + +#ifdef WithShell + // Complete non-blocking error reduction and check + MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); } } #endif @@ -4069,31 +4069,31 @@ void bssn_class::Step(int lev, int YN) // for black hole position if (BH_num > 0 && lev == GH->levels - 1) { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); DG_List->clearList(); } } @@ -4106,48 +4106,48 @@ void bssn_class::Step(int lev, int YN) { STEP_TIMER_DECL(timer_state_swap); Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; } } #endif #if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; } } #endif @@ -4158,415 +4158,415 @@ void bssn_class::Step(int lev, int YN) STEP_TIMER_DECL(timer_restrict_prolong); // mesh refinement boundary part RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } #endif STEP_TIMER_ADD(TB_RESTRICT_PROLONG, timer_restrict_prolong); #endif // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // // OldStateList old ----------- // update STEP_TIMER_DECL(timer_state_commit); Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; Porg0[ithBH][2] = Porg1[ithBH][2]; } } STEP_TIMER_ADD(TB_STATE_SWAP, timer_state_commit); } - -//================================================================================================ - - - - -//================================================================================================ - -// This member function implements single-step time evolution for each AMR level (alternate) - -//================================================================================================ - -// ICN for bam comparison - -#else -void bssn_class::Step(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif - f_icn_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_icn_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check rhs - { - SH->Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<PatL[lev], SynchList_pre, Symmetry, sync_cache_pre[lev], async_pre); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - Parallel::Sync_finish(sync_cache_pre[lev], async_pre, SynchList_pre, Symmetry); - -#ifdef WithShell - // Complete non-blocking error reduction and check - MPI_Wait(&err_req, MPI_STATUS_IGNORE); - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } + +//================================================================================================ + + + + +//================================================================================================ + +// This member function implements single-step time evolution for each AMR level (alternate) + +//================================================================================================ + +// ICN for bam comparison + +#else +void bssn_class::Step(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif + f_icn_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_icn_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check rhs + { + SH->Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<PatL[lev], SynchList_pre, Symmetry, sync_cache_pre[lev], async_pre); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + Parallel::Sync_finish(sync_cache_pre[lev], async_pre, SynchList_pre, Symmetry); + +#ifdef WithShell + // Complete non-blocking error reduction and check + MPI_Wait(&err_req, MPI_STATUS_IGNORE); + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } } #endif STEP_TIMER_ADD(TB_PREDICTOR_SYNC, timer_predictor_sync); @@ -4575,1503 +4575,1503 @@ void bssn_class::Step(int lev, int YN) // for black hole position if (BH_num > 0 && lev == GH->levels - 1) { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room if (lev == a_lev) { AnalysisStuff(lev, dT_lev); } STEP_TIMER_ADD(TB_BH_PREDICTOR, timer_bh_predictor); - // corrector - for (iter_count = 1; iter_count < 3; iter_count++) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_icn_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // Non-blocking error reduction overlapped with Sync to hide Allreduce latency - MPI_Request err_req_cor; - { - int erh = ERROR; - MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req_cor); - } -#endif - - Parallel::AsyncSyncState async_cor; - Parallel::Sync_start(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_cor[lev], async_cor); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - Parallel::Sync_finish(sync_cache_cor[lev], async_cor, SynchList_cor, Symmetry); - -#ifdef WithShell - // Complete non-blocking error reduction and check - MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} -#endif - -//================================================================================================ - - - -//================================================================================================ - -// This member function implements single-step time evolution for each AMR level -// Variant for the case PSTR == 0 - -//================================================================================================ - -#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) -void bssn_class::Step(int lev, int YN) -{ - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); - - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - -// new code 2013-2-15, zjcao -#if (MAPBH == 1) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - for (int ith = 0; ith < 3; ith++) - Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) -#warning "shell part still bam type" - if (lev == 0) // Shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Predictor rhs calculation"); - - // Non-blocking error reduction overlapped with Sync to hide Allreduce latency - MPI_Request err_req; - { - int erh = ERROR; - MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev], &err_req); - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor sync"); - - Parallel::Sync_cached(GH->PatL[lev], SynchList_pre, Symmetry, sync_cache_pre[lev]); - - // Complete non-blocking error reduction and check - MPI_Wait(&err_req, MPI_STATUS_IGNORE); - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector"); - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"head of Corrector"); - - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) - if (lev == 1) // shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector error check"); - - // Non-blocking error reduction overlapped with Sync to hide Allreduce latency - MPI_Request err_req_cor; - { - int erh = ERROR; - MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev], &err_req_cor); - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector sync"); - - Parallel::Sync_cached(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_cor[lev]); - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector sync"); - - // Complete non-blocking error reduction and check - MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector of black hole position"); -#endif - - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after pre cor swap"); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } -#endif - } - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"tail of corrector"); - } -#if (RPS == 0) - // mesh refinement boundary part - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before RestrictProlong"); - RestrictProlong(lev, YN, BB); -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - // if(myrank==GH->start_rank[lev]) - // cout<start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],"complet GH Step"); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function configures a single time-step evolution for the spherical-shell grid portion. - -//================================================================================================ - -#ifdef WithShell -void bssn_class::SHStep() -{ - int lev = 0; - // #if (PSTR == 1 || PSTR == 2) - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); - // #endif - - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - - // #if (PSTR == 1 || PSTR == 2) - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); - // #endif - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - -#if (PSTR == 1 || PSTR == 2) -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor's error check"); -#endif - // Non-blocking error reduction overlapped with Synch to hide Allreduce latency - MPI_Request err_req; - { - int erh = ERROR; - MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req); - } - - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } - - // Complete non-blocking error reduction and check - MPI_Wait(&err_req, MPI_STATUS_IGNORE); - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // Non-blocking error reduction overlapped with Synch to hide Allreduce latency - MPI_Request err_req_cor; - { - int erh = ERROR; - MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req_cor); - } - - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } - - // Complete non-blocking error reduction and check - MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#if (RPS == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -} -#endif -#endif - -//================================================================================================ - - - -//================================================================================================ - -// 0: do not use mixing two levels data for OutBD; 1: do use - -#define MIXOUTB 0 + // corrector + for (iter_count = 1; iter_count < 3; iter_count++) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_icn_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // NOTE: error check deferred to after Shell Patch computation to reduce MPI_Allreduce calls + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // Non-blocking error reduction overlapped with Sync to hide Allreduce latency + MPI_Request err_req_cor; + { + int erh = ERROR; + MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req_cor); + } +#endif + + Parallel::AsyncSyncState async_cor; + Parallel::Sync_start(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_cor[lev], async_cor); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + Parallel::Sync_finish(sync_cache_cor[lev], async_cor, SynchList_cor, Symmetry); + +#ifdef WithShell + // Complete non-blocking error reduction and check + MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} +#endif + +//================================================================================================ + + + +//================================================================================================ + +// This member function implements single-step time evolution for each AMR level +// Variant for the case PSTR == 0 + +//================================================================================================ + +#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) +void bssn_class::Step(int lev, int YN) +{ + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); + + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + +// new code 2013-2-15, zjcao +#if (MAPBH == 1) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + for (int ith = 0; ith < 3; ith++) + Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) +#warning "shell part still bam type" + if (lev == 0) // Shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Predictor rhs calculation"); + + // Non-blocking error reduction overlapped with Sync to hide Allreduce latency + MPI_Request err_req; + { + int erh = ERROR; + MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev], &err_req); + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor sync"); + + Parallel::Sync_cached(GH->PatL[lev], SynchList_pre, Symmetry, sync_cache_pre[lev]); + + // Complete non-blocking error reduction and check + MPI_Wait(&err_req, MPI_STATUS_IGNORE); + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector"); + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"head of Corrector"); + + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) + if (lev == 1) // shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector error check"); + + // Non-blocking error reduction overlapped with Sync to hide Allreduce latency + MPI_Request err_req_cor; + { + int erh = ERROR; + MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev], &err_req_cor); + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector sync"); + + Parallel::Sync_cached(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_cor[lev]); + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector sync"); + + // Complete non-blocking error reduction and check + MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector of black hole position"); +#endif + + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after pre cor swap"); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } +#endif + } + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"tail of corrector"); + } +#if (RPS == 0) + // mesh refinement boundary part + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before RestrictProlong"); + RestrictProlong(lev, YN, BB); +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + // if(myrank==GH->start_rank[lev]) + // cout<start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],"complet GH Step"); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function configures a single time-step evolution for the spherical-shell grid portion. + +//================================================================================================ + +#ifdef WithShell +void bssn_class::SHStep() +{ + int lev = 0; + // #if (PSTR == 1 || PSTR == 2) + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); + // #endif + + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + + // #if (PSTR == 1 || PSTR == 2) + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); + // #endif + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + +#if (PSTR == 1 || PSTR == 2) +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor's error check"); +#endif + // Non-blocking error reduction overlapped with Synch to hide Allreduce latency + MPI_Request err_req; + { + int erh = ERROR; + MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req); + } + + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } + + // Complete non-blocking error reduction and check + MPI_Wait(&err_req, MPI_STATUS_IGNORE); + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // Non-blocking error reduction overlapped with Synch to hide Allreduce latency + MPI_Request err_req_cor; + { + int erh = ERROR; + MPI_Iallreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD, &err_req_cor); + } + + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } + + // Complete non-blocking error reduction and check + MPI_Wait(&err_req_cor, MPI_STATUS_IGNORE); + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#if (RPS == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +} +#endif +#endif + +//================================================================================================ + + + +//================================================================================================ + +// 0: do not use mixing two levels data for OutBD; 1: do use + +#define MIXOUTB 0 void bssn_class::RestrictProlong(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL) // we assume @@ -6085,138 +6085,138 @@ void bssn_class::RestrictProlong(int lev, int YN, bool BB, #if (PSTR == 1 || PSTR == 2) // stringstream a_stream; // a_stream.setf(ios::left); -#endif - - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, SL, OL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - -#if (PSTR == 1 || PSTR == 2) -// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); -#endif - Pp = Pp->next; - } - -#if (PSTR == 1 || PSTR == 2) -// Pp=GH->PatL[lev]; -// while(Pp) -// { -// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); -// Pp=Pp->next; -// } - -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 before Restrict"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) - Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry, sync_cache_restrict[lev]); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); -#endif - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 after Restrict"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - - Parallel::Sync_cached(GH->PatL[lev - 1], SynchList_pre, Symmetry, sync_cache_rp_coarse[lev]); - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 after Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); -#endif - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 after OutBdLow2Hi"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - } - else // no time refinement levels and for all same time levels - { - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 before Restrict"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) - Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_restrict[lev]); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); -#endif - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 before Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - - Parallel::Sync_cached(GH->PatL[lev - 1], SL, Symmetry, sync_cache_rp_coarse[lev]); - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 after Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); -#endif - -#if (PSTR == 1 || PSTR == 2) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 after OutBdLow2Hi"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - } - - Parallel::Sync_cached(GH->PatL[lev], SL, Symmetry, sync_cache_rp_fine[lev]); - +#endif + + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, SL, OL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + +#if (PSTR == 1 || PSTR == 2) +// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); +#endif + Pp = Pp->next; + } + +#if (PSTR == 1 || PSTR == 2) +// Pp=GH->PatL[lev]; +// while(Pp) +// { +// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); +// Pp=Pp->next; +// } + +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 before Restrict"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) + Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry, sync_cache_restrict[lev]); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); +#endif + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 after Restrict"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + + Parallel::Sync_cached(GH->PatL[lev - 1], SynchList_pre, Symmetry, sync_cache_rp_coarse[lev]); + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 after Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); +#endif + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 after OutBdLow2Hi"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + } + else // no time refinement levels and for all same time levels + { + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 before Restrict"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) + Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_restrict[lev]); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); +#endif + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 before Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + + Parallel::Sync_cached(GH->PatL[lev - 1], SL, Symmetry, sync_cache_rp_coarse[lev]); + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 after Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); +#endif + +#if (PSTR == 1 || PSTR == 2) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 after OutBdLow2Hi"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + } + + Parallel::Sync_cached(GH->PatL[lev], SL, Symmetry, sync_cache_rp_fine[lev]); + #if (PSTR == 1 || PSTR == 2) // a_stream.clear(); // a_stream.str(""); @@ -6226,15 +6226,15 @@ void bssn_class::RestrictProlong(int lev, int YN, bool BB, } STEP_TIMER_ADD(TB_RESTRICT_PROLONG, timer_restrict_prolong); } - -//================================================================================================ - - - -//================================================================================================ - -// auxiliary operation, input lev means original lev-1 - + +//================================================================================================ + + + +//================================================================================================ + +// auxiliary operation, input lev means original lev-1 + void bssn_class::RestrictProlong_aux(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL) // we assume @@ -6246,913 +6246,913 @@ void bssn_class::RestrictProlong_aux(int lev, int YN, bool BB, { STEP_TIMER_DECL(timer_restrict_prolong); // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"starting RestrictProlong_aux"); - - if (lev >= GH->levels - 1) - return; - lev = lev + 1; - - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, SL, OL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - -#if (RPB == 0) - Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry, sync_cache_restrict[lev]); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync_cached(GH->PatL[lev - 1], SynchList_pre, Symmetry, sync_cache_rp_coarse[lev]); - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); -#endif - } - else // no time refinement levels and for all same time levels - { -#if (RPB == 0) - Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_restrict[lev]); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync_cached(GH->PatL[lev - 1], SL, Symmetry, sync_cache_rp_coarse[lev]); - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); -#endif - } + + if (lev >= GH->levels - 1) + return; + lev = lev + 1; + + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, SL, OL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + +#if (RPB == 0) + Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry, sync_cache_restrict[lev]); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync_cached(GH->PatL[lev - 1], SynchList_pre, Symmetry, sync_cache_rp_coarse[lev]); + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); +#endif + } + else // no time refinement levels and for all same time levels + { +#if (RPB == 0) + Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_restrict[lev]); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync_cached(GH->PatL[lev - 1], SL, Symmetry, sync_cache_rp_coarse[lev]); + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); +#endif + } Parallel::Sync_cached(GH->PatL[lev], SL, Symmetry, sync_cache_rp_fine[lev]); } STEP_TIMER_ADD(TB_RESTRICT_PROLONG, timer_restrict_prolong); } - -//================================================================================================ - - - -//================================================================================================ - + +//================================================================================================ + + + +//================================================================================================ + void bssn_class::RestrictProlong(int lev, int YN, bool BB) { STEP_TIMER_DECL(timer_restrict_prolong); double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - // we assume for fine - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // for coarse - // StateList 1 ----------- - // - // OldStateList 0 ----------- - // - // SynchList_cor old ----------- - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - if (myrank == 0) - cout << "/=: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - -#if (RPB == 0) - Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, Symmetry, sync_cache_restrict[lev]); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,SynchList_pre,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync_cached(GH->PatL[lev - 1], SynchList_pre, Symmetry, sync_cache_rp_coarse[lev]); - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - } - else // no time refinement levels and for all same time levels - { - if (myrank == 0) - cout << "===: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; -#if (RPB == 0) - Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry, sync_cache_restrict[lev]); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync_cached(GH->PatL[lev - 1], StateList, Symmetry, sync_cache_rp_coarse[lev]); - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - } + // we assume for fine + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // for coarse + // StateList 1 ----------- + // + // OldStateList 0 ----------- + // + // SynchList_cor old ----------- + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + if (myrank == 0) + cout << "/=: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + +#if (RPB == 0) + Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, Symmetry, sync_cache_restrict[lev]); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,SynchList_pre,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync_cached(GH->PatL[lev - 1], SynchList_pre, Symmetry, sync_cache_rp_coarse[lev]); + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + } + else // no time refinement levels and for all same time levels + { + if (myrank == 0) + cout << "===: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; +#if (RPB == 0) + Parallel::Restrict_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry, sync_cache_restrict[lev]); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync_cached(GH->PatL[lev - 1], StateList, Symmetry, sync_cache_rp_coarse[lev]); + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + } Parallel::Sync_cached(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_rp_fine[lev]); } STEP_TIMER_ADD(TB_RESTRICT_PROLONG, timer_restrict_prolong); } - -//================================================================================================ - - - -//================================================================================================ - -void bssn_class::ProlongRestrict(int lev, int YN, bool BB) -{ - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - } - else // no time refinement levels and for all same time levels - { -#if (RPB == 0) -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry, sync_cache_outbd[lev]); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry); -#endif -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - -#if 0 -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); -#elif (RPB == 1) -// Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,GH->rsul[lev],Symmetry); -#endif -#else - Parallel::Restrict_after(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); -#endif - Parallel::Sync_cached(GH->PatL[lev - 1], StateList, Symmetry, sync_cache_rp_coarse[lev]); - } - - Parallel::Sync_cached(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_rp_fine[lev]); - } -} -#undef MIXOUTB - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes the gravitational-wave quantity Psi4 - -//================================================================================================ - -void bssn_class::Compute_Psi4(int lev) -{ - MyList *DG_List = new MyList(Rpsi4); - DG_List->insert(Ipsi4); - -#if 0 // test showes this operation does not help -for(int ilev = GH->levels-1;ilev>=lev;ilev--) -{ - MyList *Pp=GH->PatL[ilev]; -#else - MyList *Pp = GH->PatL[lev]; -#endif - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (Psi4type == 0) - if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation - f_ricci_gamma(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - Symmetry); - // the input arguments Gamma^i_jk and R_ij do not need synch, because we do not need to derivate them - f_getnp4(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry); -#elif (Psi4type == 1) - f_getnp4old(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry); -#else -#error "not recognized Psi4type" -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#if 0 - Parallel::Sync(GH->PatL[ilev],DG_List,Symmetry); -} -// because of double level data change, you can not do this in above loop -// prolong restrict Psi4 -for(int ilev=GH->levels-1;ilev>lev;ilev--) - RestrictProlong(ilev,1,false,DG_List,DG_List,DG_List); -#else - Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); -#endif - -#ifdef WithShell - // ShellPatch part - if (lev == 0) - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { -#if (Psi4type == 0) - if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation - f_ricci_gamma_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + - ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - Symmetry, lev, Pp->data->sst); - - f_getnp4_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry, Pp->data->sst); -#elif (Psi4type == 1) - f_getnp4old_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry, Pp->data->sst); -#else -#error "not recognized Psi4type" -#endif - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - - SH->Synch(DG_List, Symmetry); -#if 0 -// interpolate Psi4 - SH->CS_Inter(DG_List,Symmetry); -#endif - } -#endif - - DG_List->clearList(); - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end of Compute_Psi4"); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets the black holes' initial puncture positions - -//================================================================================================ - -void bssn_class::Setup_Black_Hole_position() -{ - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_num_input = BH_num = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - // set up the data for black holes - // these arrays will be deleted when bssn_class is deleted - Pmom = new double[3 * BH_num]; - Spin = new double[3 * BH_num]; - Mass = new double[BH_num]; - Porg0 = new double *[BH_num]; - Porgbr = new double *[BH_num]; - Porg = new double *[BH_num]; - Porg1 = new double *[BH_num]; - Porg_rhs = new double *[BH_num]; - for (int i = 0; i < BH_num; i++) - { - Porg0[i] = new double[3]; - Porgbr[i] = new double[3]; - Porg[i] = new double[3]; - Porg1[i] = new double[3]; - Porg_rhs[i] = new double[3]; - } - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_num) - { - if (skey == "Mass") - Mass[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg0[sind][0] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg0[sind][1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg0[sind][2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // echo information of Black holes - if (myrank == 0) - { - cout << endl; - cout << " initial information of " << BH_num << " Black Hole(s) " << endl; - cout << setw(12) << "Mass" - << setw(12) << "x" - << setw(12) << "y" - << setw(12) << "z" - << setw(16) << "Px" - << setw(16) << "Py" - << setw(12) << "Pz" - << setw(12) << "Sx" - << setw(12) << "Sy" - << setw(12) << "Sz" << endl; - for (int i = 0; i < BH_num; i++) - { - cout << setw(12) << Mass[i] - << setw(12) << Porg0[i][0] - << setw(12) << Porg0[i][1] - << setw(12) << Porg0[i][2] - << setw(16) << Pmom[i * 3] - << setw(16) << Pmom[i * 3 + 1] - << setw(12) << Pmom[i * 3 + 2] - << setw(12) << Spin[i * 3] - << setw(12) << Spin[i * 3 + 1] - << setw(12) << Spin[i * 3 + 2] << endl; - } - } - - int maxl = 1; - int levels; - int *grids; - double bbox[6]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && skey == "levels") - { - levels = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - grids = new int[levels]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && skey == "grids" && sind1 < levels) - grids[sind1] = atoi(sval.c_str()); - if (sgrp == "cgh" && skey == "bbox" && sind1 == 0 && sind2 == 0) - bbox[sind3] = atof(sval.c_str()); - } - inf.close(); - } - for (int i = 0; i < levels; i++) - if (maxl < grids[i]) - maxl = grids[i]; - - delete[] grids; - - if (BH_num > maxl) - { - int BH_numc = BH_num; - for (int i = 0; i < BH_num; i++) - if (Porg0[i][0] < bbox[0] || Porg0[i][0] > bbox[3] || - Porg0[i][1] < bbox[1] || Porg0[i][1] > bbox[4] || - Porg0[i][2] < bbox[2] || Porg0[i][2] > bbox[5]) - { - delete[] Porg0[i]; - Porg0[i] = 0; - BH_numc--; - } - - if (BH_num > BH_numc) - { - maxl = BH_numc; - int bhi; - double *tmp; - - tmp = Pmom; - Pmom = new double[3 * maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (Porg0[i]) - { - for (int j = 0; j < 3; j++) - Pmom[3 * bhi + j] = tmp[3 * i + j]; - bhi++; - } - delete[] tmp; - - tmp = Spin; - Spin = new double[3 * maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (Porg0[i]) - { - for (int j = 0; j < 3; j++) - Spin[3 * bhi + j] = tmp[3 * i + j]; - bhi++; - } - delete[] tmp; - - tmp = Mass; - Mass = new double[3 * maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (Porg0[i]) - { - Mass[bhi] = tmp[i]; - bhi++; - } - delete[] tmp; - - double **ttmp; - ttmp = Porg0; - Porg0 = new double *[maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (ttmp[i]) - { - Porg0[bhi] = ttmp[i]; - bhi++; - } - delete[] ttmp; - - for (int i = 0; i < BH_num; i++) - { - delete[] Porgbr[i]; - delete[] Porg[i]; - delete[] Porg1[i]; - delete[] Porg_rhs[i]; - } - delete[] Porgbr; - delete[] Porg; - delete[] Porg1; - delete[] Porg_rhs; - - BH_num = maxl; - - Porgbr = new double *[BH_num]; - Porg = new double *[BH_num]; - Porg1 = new double *[BH_num]; - Porg_rhs = new double *[BH_num]; - - for (int i = 0; i < BH_num; i++) - { - Porgbr[i] = new double[3]; - Porg[i] = new double[3]; - Porg1[i] = new double[3]; - Porg_rhs[i] = new double[3]; - } - } - } - - for (int i = 0; i < BH_num; i++) - { - for (int j = 0; j < dim; j++) - Porgbr[i][j] = Porg0[i][j]; - } - - setpbh(BH_num, Porg0, Mass, BH_num_input); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes black hole positions - -//================================================================================================ - -#if 0 -// old code - -void bssn_class::compute_Porg_rhs(double **BH_PS,double **BH_RHS,var *forx,var *fory,var *forz,int lev) -{ - const int InList = 3; - - MyList * DG_List=new MyList(forx); - DG_List->insert(fory); DG_List->insert(forz); - - int n; - double *x1,*y1,*z1; - double *shellf; - shellf=new double[3*BH_num]; - double *pox[3]; - for(int i=0;i<3;i++) pox[i] = new double[BH_num]; - for( n = 0; n < BH_num; n++) - { - pox[0][n] = BH_PS[n][0]; - pox[1][n] = BH_PS[n][1]; - pox[2][n] = BH_PS[n][2]; - } - - if(!Parallel::PatList_Interp_Points(GH->PatL[lev],DG_List,BH_num,pox,shellf,Symmetry)) - { - ErrorMonitor->outfile<<"fail to find black holes at t = "<outfile<<"(x,y,z) = ("<clearList(); - delete[] shellf; - for(int i=0;i<3;i++) delete[] pox[i]; -} - -#else - -// new code considering diferent levels for different black hole - + +//================================================================================================ + + + +//================================================================================================ + +void bssn_class::ProlongRestrict(int lev, int YN, bool BB) +{ + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + } + else // no time refinement levels and for all same time levels + { +#if (RPB == 0) +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi_cached(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry, sync_cache_outbd[lev]); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, Symmetry); +#endif +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + +#if 0 +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); +#elif (RPB == 1) +// Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,GH->rsul[lev],Symmetry); +#endif +#else + Parallel::Restrict_after(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); +#endif + Parallel::Sync_cached(GH->PatL[lev - 1], StateList, Symmetry, sync_cache_rp_coarse[lev]); + } + + Parallel::Sync_cached(GH->PatL[lev], SynchList_cor, Symmetry, sync_cache_rp_fine[lev]); + } +} +#undef MIXOUTB + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes the gravitational-wave quantity Psi4 + +//================================================================================================ + +void bssn_class::Compute_Psi4(int lev) +{ + MyList *DG_List = new MyList(Rpsi4); + DG_List->insert(Ipsi4); + +#if 0 // test showes this operation does not help +for(int ilev = GH->levels-1;ilev>=lev;ilev--) +{ + MyList *Pp=GH->PatL[ilev]; +#else + MyList *Pp = GH->PatL[lev]; +#endif + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (Psi4type == 0) + if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation + f_ricci_gamma(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + Symmetry); + // the input arguments Gamma^i_jk and R_ij do not need synch, because we do not need to derivate them + f_getnp4(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry); +#elif (Psi4type == 1) + f_getnp4old(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry); +#else +#error "not recognized Psi4type" +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#if 0 + Parallel::Sync(GH->PatL[ilev],DG_List,Symmetry); +} +// because of double level data change, you can not do this in above loop +// prolong restrict Psi4 +for(int ilev=GH->levels-1;ilev>lev;ilev--) + RestrictProlong(ilev,1,false,DG_List,DG_List,DG_List); +#else + Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); +#endif + +#ifdef WithShell + // ShellPatch part + if (lev == 0) + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { +#if (Psi4type == 0) + if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation + f_ricci_gamma_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + Symmetry, lev, Pp->data->sst); + + f_getnp4_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry, Pp->data->sst); +#elif (Psi4type == 1) + f_getnp4old_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry, Pp->data->sst); +#else +#error "not recognized Psi4type" +#endif + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + + SH->Synch(DG_List, Symmetry); +#if 0 +// interpolate Psi4 + SH->CS_Inter(DG_List,Symmetry); +#endif + } +#endif + + DG_List->clearList(); + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end of Compute_Psi4"); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets the black holes' initial puncture positions + +//================================================================================================ + +void bssn_class::Setup_Black_Hole_position() +{ + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_num_input = BH_num = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + // set up the data for black holes + // these arrays will be deleted when bssn_class is deleted + Pmom = new double[3 * BH_num]; + Spin = new double[3 * BH_num]; + Mass = new double[BH_num]; + Porg0 = new double *[BH_num]; + Porgbr = new double *[BH_num]; + Porg = new double *[BH_num]; + Porg1 = new double *[BH_num]; + Porg_rhs = new double *[BH_num]; + for (int i = 0; i < BH_num; i++) + { + Porg0[i] = new double[3]; + Porgbr[i] = new double[3]; + Porg[i] = new double[3]; + Porg1[i] = new double[3]; + Porg_rhs[i] = new double[3]; + } + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_num) + { + if (skey == "Mass") + Mass[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg0[sind][0] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg0[sind][1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg0[sind][2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // echo information of Black holes + if (myrank == 0) + { + cout << endl; + cout << " initial information of " << BH_num << " Black Hole(s) " << endl; + cout << setw(12) << "Mass" + << setw(12) << "x" + << setw(12) << "y" + << setw(12) << "z" + << setw(16) << "Px" + << setw(16) << "Py" + << setw(12) << "Pz" + << setw(12) << "Sx" + << setw(12) << "Sy" + << setw(12) << "Sz" << endl; + for (int i = 0; i < BH_num; i++) + { + cout << setw(12) << Mass[i] + << setw(12) << Porg0[i][0] + << setw(12) << Porg0[i][1] + << setw(12) << Porg0[i][2] + << setw(16) << Pmom[i * 3] + << setw(16) << Pmom[i * 3 + 1] + << setw(12) << Pmom[i * 3 + 2] + << setw(12) << Spin[i * 3] + << setw(12) << Spin[i * 3 + 1] + << setw(12) << Spin[i * 3 + 2] << endl; + } + } + + int maxl = 1; + int levels; + int *grids; + double bbox[6]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && skey == "levels") + { + levels = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + grids = new int[levels]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && skey == "grids" && sind1 < levels) + grids[sind1] = atoi(sval.c_str()); + if (sgrp == "cgh" && skey == "bbox" && sind1 == 0 && sind2 == 0) + bbox[sind3] = atof(sval.c_str()); + } + inf.close(); + } + for (int i = 0; i < levels; i++) + if (maxl < grids[i]) + maxl = grids[i]; + + delete[] grids; + + if (BH_num > maxl) + { + int BH_numc = BH_num; + for (int i = 0; i < BH_num; i++) + if (Porg0[i][0] < bbox[0] || Porg0[i][0] > bbox[3] || + Porg0[i][1] < bbox[1] || Porg0[i][1] > bbox[4] || + Porg0[i][2] < bbox[2] || Porg0[i][2] > bbox[5]) + { + delete[] Porg0[i]; + Porg0[i] = 0; + BH_numc--; + } + + if (BH_num > BH_numc) + { + maxl = BH_numc; + int bhi; + double *tmp; + + tmp = Pmom; + Pmom = new double[3 * maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (Porg0[i]) + { + for (int j = 0; j < 3; j++) + Pmom[3 * bhi + j] = tmp[3 * i + j]; + bhi++; + } + delete[] tmp; + + tmp = Spin; + Spin = new double[3 * maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (Porg0[i]) + { + for (int j = 0; j < 3; j++) + Spin[3 * bhi + j] = tmp[3 * i + j]; + bhi++; + } + delete[] tmp; + + tmp = Mass; + Mass = new double[3 * maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (Porg0[i]) + { + Mass[bhi] = tmp[i]; + bhi++; + } + delete[] tmp; + + double **ttmp; + ttmp = Porg0; + Porg0 = new double *[maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (ttmp[i]) + { + Porg0[bhi] = ttmp[i]; + bhi++; + } + delete[] ttmp; + + for (int i = 0; i < BH_num; i++) + { + delete[] Porgbr[i]; + delete[] Porg[i]; + delete[] Porg1[i]; + delete[] Porg_rhs[i]; + } + delete[] Porgbr; + delete[] Porg; + delete[] Porg1; + delete[] Porg_rhs; + + BH_num = maxl; + + Porgbr = new double *[BH_num]; + Porg = new double *[BH_num]; + Porg1 = new double *[BH_num]; + Porg_rhs = new double *[BH_num]; + + for (int i = 0; i < BH_num; i++) + { + Porgbr[i] = new double[3]; + Porg[i] = new double[3]; + Porg1[i] = new double[3]; + Porg_rhs[i] = new double[3]; + } + } + } + + for (int i = 0; i < BH_num; i++) + { + for (int j = 0; j < dim; j++) + Porgbr[i][j] = Porg0[i][j]; + } + + setpbh(BH_num, Porg0, Mass, BH_num_input); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes black hole positions + +//================================================================================================ + +#if 0 +// old code + +void bssn_class::compute_Porg_rhs(double **BH_PS,double **BH_RHS,var *forx,var *fory,var *forz,int lev) +{ + const int InList = 3; + + MyList * DG_List=new MyList(forx); + DG_List->insert(fory); DG_List->insert(forz); + + int n; + double *x1,*y1,*z1; + double *shellf; + shellf=new double[3*BH_num]; + double *pox[3]; + for(int i=0;i<3;i++) pox[i] = new double[BH_num]; + for( n = 0; n < BH_num; n++) + { + pox[0][n] = BH_PS[n][0]; + pox[1][n] = BH_PS[n][1]; + pox[2][n] = BH_PS[n][2]; + } + + if(!Parallel::PatList_Interp_Points(GH->PatL[lev],DG_List,BH_num,pox,shellf,Symmetry)) + { + ErrorMonitor->outfile<<"fail to find black holes at t = "<outfile<<"(x,y,z) = ("<clearList(); + delete[] shellf; + for(int i=0;i<3;i++) delete[] pox[i]; +} + +#else + +// new code considering diferent levels for different black hole + void bssn_class::compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int ilev) { MyList DG_List_x(forx); @@ -7167,11 +7167,11 @@ void bssn_class::compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, va for (int n = 0; n < BH_num; n++) { - pox[0][0] = BH_PS[n][0]; - pox[1][0] = BH_PS[n][1]; - pox[2][0] = BH_PS[n][2]; - - int lev = ilev; + pox[0][0] = BH_PS[n][0]; + pox[1][0] = BH_PS[n][1]; + pox[2][0] = BH_PS[n][2]; + + int lev = ilev; #if (PSTR == 0) while (!Parallel::PatList_Interp_Points(GH->PatL[lev], &DG_List_x, 1, pox, shellf, Symmetry)) @@ -7189,233 +7189,233 @@ void bssn_class::compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, va << ")" << endl; break; } - } - - if (lev >= 0) - { - BH_RHS[n][0] = -shellf[0]; - BH_RHS[n][1] = -shellf[1]; + } + + if (lev >= 0) + { + BH_RHS[n][0] = -shellf[0]; + BH_RHS[n][1] = -shellf[1]; BH_RHS[n][2] = -shellf[2]; } } } -#endif - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes gravitational-wave related quantities and performs analysis - -//================================================================================================ - -void bssn_class::AnalysisStuff(int lev, double dT_lev) -{ - LastAnas += dT_lev; - - if (LastAnas >= AnasTime) - { -#ifdef Point_Psi4 -#error "not support parallel levels yet" - // Gam_ijk and R_ij have been calculated in Interp_Constraint() - double SYM = 1, ANT = -1; - for (int levh = lev; levh < GH->levels; levh++) - { - MyList *Pp = GH->PatL[levh]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], - cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[trK0->sgfn], - cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Axx0->sgfn], - cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Axy0->sgfn], - cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, ANT, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Axz0->sgfn], - cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, SYM, ANT, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Ayy0->sgfn], - cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Ayz0->sgfn], - cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, ANT, ANT, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Azz0->sgfn], - cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#ifdef WithShell - // ShellPatch part - if (lev == 0) - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_fderivs_shc(cg->shape, cg->fgfs[phi0->sgfn], - cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - phi0->SoA[0], phi0->SoA[1], phi0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[trK0->sgfn], - cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - trK0->SoA[0], trK0->SoA[1], trK0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Axx0->sgfn], - cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Axx0->SoA[0], Axx0->SoA[1], Axx0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Axy0->sgfn], - cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Axy0->SoA[0], Axy0->SoA[1], Axy0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Axz0->sgfn], - cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Axz0->SoA[0], Axz0->SoA[1], Axz0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Ayy0->sgfn], - cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Ayy0->SoA[0], Ayy0->SoA[1], Ayy0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Ayz0->sgfn], - cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Ayz0->SoA[0], Ayz0->SoA[1], Ayz0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Azz0->sgfn], - cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Azz0->SoA[0], Azz0->SoA[1], Azz0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#endif - } -#else - Compute_Psi4(lev); -#endif - double *RP, *IP, *RoutMAP; - int NN = 0; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - NN++; +#endif + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes gravitational-wave related quantities and performs analysis + +//================================================================================================ + +void bssn_class::AnalysisStuff(int lev, double dT_lev) +{ + LastAnas += dT_lev; + + if (LastAnas >= AnasTime) + { +#ifdef Point_Psi4 +#error "not support parallel levels yet" + // Gam_ijk and R_ij have been calculated in Interp_Constraint() + double SYM = 1, ANT = -1; + for (int levh = lev; levh < GH->levels; levh++) + { + MyList *Pp = GH->PatL[levh]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], + cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[trK0->sgfn], + cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Axx0->sgfn], + cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Axy0->sgfn], + cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, ANT, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Axz0->sgfn], + cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, SYM, ANT, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Ayy0->sgfn], + cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Ayz0->sgfn], + cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, ANT, ANT, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Azz0->sgfn], + cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#ifdef WithShell + // ShellPatch part + if (lev == 0) + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_fderivs_shc(cg->shape, cg->fgfs[phi0->sgfn], + cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + phi0->SoA[0], phi0->SoA[1], phi0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[trK0->sgfn], + cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + trK0->SoA[0], trK0->SoA[1], trK0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Axx0->sgfn], + cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Axx0->SoA[0], Axx0->SoA[1], Axx0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Axy0->sgfn], + cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Axy0->SoA[0], Axy0->SoA[1], Axy0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Axz0->sgfn], + cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Axz0->SoA[0], Axz0->SoA[1], Axz0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Ayy0->sgfn], + cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Ayy0->SoA[0], Ayy0->SoA[1], Ayy0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Ayz0->sgfn], + cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Ayz0->SoA[0], Ayz0->SoA[1], Ayz0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Azz0->sgfn], + cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Azz0->SoA[0], Azz0->SoA[1], Azz0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#endif + } +#else + Compute_Psi4(lev); +#endif + double *RP, *IP, *RoutMAP; + int NN = 0; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + NN++; RP = new double[NN]; IP = new double[NN]; RoutMAP = new double[7]; @@ -7427,24 +7427,24 @@ void bssn_class::AnalysisStuff(int lev, double dT_lev) for (int i = 0; i < decn; i++) { #ifdef Point_Psi4 - Waveshell->surf_Wave(Rex, GH, SH, - phi, trK, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - phix, phiy, phiz, - trKx, trKy, trKz, - Axxx, Axxy, Axxz, - Axyx, Axyy, Axyz, - Axzx, Axzy, Axzz, - Ayyx, Ayyy, Ayyz, - Ayzx, Ayzy, Ayzz, - Azzx, Azzy, Azzz, - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, - 2, maxl, NN, RP, IP, ErrorMonitor); -#ifdef WithShell + Waveshell->surf_Wave(Rex, GH, SH, + phi, trK, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + phix, phiy, phiz, + trKx, trKy, trKz, + Axxx, Axxy, Axxz, + Axyx, Axyy, Axyz, + Axzx, Axzy, Axzz, + Ayyx, Ayyy, Ayyz, + Ayzx, Ayzy, Ayzz, + Azzx, Azzy, Azzz, + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, + 2, maxl, NN, RP, IP, ErrorMonitor); +#ifdef WithShell if (lev > 0 || Rex < GH->bbox[0][0][3]) { Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, @@ -7518,226 +7518,226 @@ void bssn_class::AnalysisStuff(int lev, double dT_lev) #endif #endif // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end surface integral"); -#endif - if (i == 0) - { - ADMMass = RoutMAP[0]; - } -#if (PSTR == 1 || PSTR == 2) - if (GH->start_rank[a_lev] > 0) - { - MPI_Status status; - // receive - if (myrank == 0) - { - MPI_Recv(RP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 1, MPI_COMM_WORLD, &status); - MPI_Recv(IP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 2, MPI_COMM_WORLD, &status); - MPI_Recv(RoutMAP, 7, MPI_DOUBLE, GH->start_rank[a_lev], 3, MPI_COMM_WORLD, &status); - } - // send - if (myrank == GH->start_rank[a_lev]) - { - MPI_Send(RP, NN, MPI_DOUBLE, 0, 1, MPI_COMM_WORLD); - MPI_Send(IP, NN, MPI_DOUBLE, 0, 2, MPI_COMM_WORLD); - MPI_Send(RoutMAP, 7, MPI_DOUBLE, 0, 3, MPI_COMM_WORLD); - } - } -#endif - Psi4Monitor->writefile(PhysTime, NN, RP, IP); - MAPMonitor->writefile(PhysTime, 7, RoutMAP); - Rex = Rex - drex; - } - delete[] RP; - delete[] IP; - delete[] RoutMAP; - - // black hole's position - { - double *pox; - pox = new double[dim * BH_num]; - for (int bhi = 0; bhi < BH_num; bhi++) - for (int i = 0; i < dim; i++) - pox[dim * bhi + i] = Porg0[bhi][i]; - BHMonitor->writefile(PhysTime, dim * BH_num, pox); - delete[] pox; - } - - LastAnas = 0; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes and outputs constraint violations - -//================================================================================================ - -void bssn_class::Constraint_Out() -{ - LastConsOut += dT * pow(0.5, Mymax(0, trfls)); - - if (LastConsOut >= AnasTime) - // Constraint violation - { - // recompute least the constraint data lost for moved new grid - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels +#endif + if (i == 0) + { + ADMMass = RoutMAP[0]; + } +#if (PSTR == 1 || PSTR == 2) + if (GH->start_rank[a_lev] > 0) + { + MPI_Status status; + // receive + if (myrank == 0) + { + MPI_Recv(RP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 1, MPI_COMM_WORLD, &status); + MPI_Recv(IP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 2, MPI_COMM_WORLD, &status); + MPI_Recv(RoutMAP, 7, MPI_DOUBLE, GH->start_rank[a_lev], 3, MPI_COMM_WORLD, &status); + } + // send + if (myrank == GH->start_rank[a_lev]) + { + MPI_Send(RP, NN, MPI_DOUBLE, 0, 1, MPI_COMM_WORLD); + MPI_Send(IP, NN, MPI_DOUBLE, 0, 2, MPI_COMM_WORLD); + MPI_Send(RoutMAP, 7, MPI_DOUBLE, 0, 3, MPI_COMM_WORLD); + } + } +#endif + Psi4Monitor->writefile(PhysTime, NN, RP, IP); + MAPMonitor->writefile(PhysTime, 7, RoutMAP); + Rex = Rex - drex; + } + delete[] RP; + delete[] IP; + delete[] RoutMAP; + + // black hole's position + { + double *pox; + pox = new double[dim * BH_num]; + for (int bhi = 0; bhi < BH_num; bhi++) + for (int i = 0; i < dim; i++) + pox[dim * bhi + i] = Porg0[bhi][i]; + BHMonitor->writefile(PhysTime, dim * BH_num, pox); + delete[] pox; + } + + LastAnas = 0; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes and outputs constraint violations + +//================================================================================================ + +void bssn_class::Constraint_Out() +{ + LastConsOut += dT * pow(0.5, Mymax(0, trfls)); + + if (LastConsOut >= AnasTime) + // Constraint violation + { + // recompute least the constraint data lost for moved new grid + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels if (lev > 0 && ConstraintRefreshLevels && ConstraintRefreshLevels[lev]) // only refresh levels whose grid layout changed after evolution { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - if (0) // if the constrait quantities can be reused from the step rhs calculation - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - double TRK4 = PhysTime; - int pre = 0; - int lev = 0; - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); -#endif - - double ConV[7]; + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + if (0) // if the constrait quantities can be reused from the step rhs calculation + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + double TRK4 = PhysTime; + int pre = 0; + int lev = 0; + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); +#endif + + double ConV[7]; #if (PSTR == 1 || PSTR == 2) double ConV_h[7]; #endif @@ -7756,30 +7756,30 @@ void bssn_class::Constraint_Out() // misc::tillherecheck("before collect data to cpu0"); // MPI_ALLREDUCE( sendbuf, recvbuf, count, datatype, op, comm), sendbu and recvbuf must be different if (levi > 0) - { - if (GH->mylev == levi && myrank == GH->start_rank[levi]) - for (int i = 0; i < 7; i++) - ConV_h[i] = ConV[i]; - else - for (int i = 0; i < 7; i++) - ConV_h[i] = 0; - MPI_Allreduce(ConV_h, ConV, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - } -#endif - ConVMonitor->writefile(PhysTime, 7, ConV); - /* - if(fabs(ConV[0])<0.00001) - { - MyList * DG_List=new MyList(Cons_Ham); - DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); - DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); - Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); - DG_List->clearList(); - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } - */ - } - + { + if (GH->mylev == levi && myrank == GH->start_rank[levi]) + for (int i = 0; i < 7; i++) + ConV_h[i] = ConV[i]; + else + for (int i = 0; i < 7; i++) + ConV_h[i] = 0; + MPI_Allreduce(ConV_h, ConV, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + } +#endif + ConVMonitor->writefile(PhysTime, 7, ConV); + /* + if(fabs(ConV[0])<0.00001) + { + MyList * DG_List=new MyList(Cons_Ham); + DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); + DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); + Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); + DG_List->clearList(); + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } + */ + } + Interp_Constraint(false); LastConsOut = 0; @@ -7788,948 +7788,948 @@ void bssn_class::Constraint_Out() ConstraintRefreshLevels[lev] = 0; } } - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes derivatives required for apparent-horizon calculations - -//================================================================================================ - -#ifdef With_AHF -void bssn_class::AH_Prepare_derivatives() -{ - double SYM = 1.0, ANT = -1.0; - int ZEO = 0; - - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gxx0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamzxx->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gxy0->sgfn], - cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamzxy->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, ANT, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gxz0->sgfn], - cg->fgfs[Gamxxz->sgfn], cg->fgfs[Gamyxz->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, SYM, ANT, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gyy0->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamzyy->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gyz0->sgfn], - cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamzyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, ANT, ANT, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gzz0->sgfn], - cg->fgfs[Gamxzz->sgfn], cg->fgfs[Gamyzz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - Parallel::Sync(GH->PatL[lev], AHDList, Symmetry); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function interpolates apparent-horizon data - -//================================================================================================ - -bool bssn_class::AH_Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetryi) -{ - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double pox[3]; - for (int i = 0; i < NN; i++) - { - for (int j = 0; j < 3; j++) - pox[j] = XX[j][i]; - int lev = GH->levels - 1; - bool notfound = true; - - while (notfound) - { - if (lev < 0) - { -#ifdef WithShell - if (SH->Interp_One_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) - { - return true; - } - if (myrank == 0) - { - cout << " bssn_class::AH_Interp_Points: point (" - << pox[0] << "," << pox[1] << "," << pox[2] - << ") is out of cgh and shell domain!" << endl; - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << " bssn_class::AH_Interp_Points: point (" - << pox[0] << "," << pox[1] << "," << pox[2] - << ") is out of cgh and shell domain!" << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); -#else - if (myrank == 0) - { - cout << " bssn_class::AH_Interp_Points: point (" - << pox[0] << "," << pox[1] << "," << pox[2] - << ") is out of cgh domain!" << endl; - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << " bssn_class::AH_Interp_Points: point (" - << pox[0] << "," << pox[1] << "," << pox[2] - << ") is out of cgh domain!" << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); -#endif - return false; - } - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - if (Pp->data->Interp_ONE_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) - { - notfound = false; - break; - } - Pp = Pp->next; - } - lev--; - } - } - return true; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes apparent horizons - -//================================================================================================ - -void bssn_class::AH_Step_Find(int lev, double dT_lev) -{ - if ((lev == GH->levels - 1)) - { - int ncount = int(PhysTime / dT_lev); - bool tf = false; - for (int ihn = 0; ihn < HN_num; ihn++) - { - if (ncount % findeveryl[ihn] == 0) - { - tf = true; - break; - } - } - if (tf) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - prev_clock = clock(); - const int cdumpid = int(PhysTime / AHdumptime) + 1; - for (int ihn = 0; ihn < HN_num; ihn++) - dumpid[ihn] = cdumpid; - - double gam; - for (int ihn = 0; ihn < BH_num; ihn++) - { - xc[ihn] = Porg0[ihn][0]; - yc[ihn] = Porg0[ihn][1]; - zc[ihn] = Porg0[ihn][2]; - gam = fabs(Pmom[ihn * 3]) / (Mass[ihn]); - gam = sqrt(1 - gam * gam); - xr[ihn] = Mass[ihn] * gam; - gam = fabs(Pmom[ihn * 3 + 1]) / (Mass[ihn]); - gam = sqrt(1 - gam * gam); - yr[ihn] = Mass[ihn] * gam; - gam = fabs(Pmom[ihn * 3 + 2]) / (Mass[ihn]); - gam = sqrt(1 - gam * gam); - zr[ihn] = Mass[ihn] * gam; - dTT[ihn] = -1; - - if (ncount % findeveryl[ihn] == 0) - { - trigger[ihn] = true; - dTT[ihn] = findeveryl[ihn] * dT_lev; - } - else - trigger[ihn] = false; - if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) - lastahdumpid[ihn] = dumpid[ihn]; - else - dumpid[ihn] = 0; - } - int ihn = BH_num; - for (int ia = 0; ia < BH_num; ia++) - for (int ib = ia + 1; ib < BH_num; ib++) - { - xc[ihn] = (Porg0[ia][0] + Porg0[ib][0]) / 2; - yc[ihn] = (Porg0[ia][1] + Porg0[ib][1]) / 2; - zc[ihn] = (Porg0[ia][2] + Porg0[ib][2]) / 2; - - xr[ihn] = yr[ihn] = zr[ihn] = Mass[ia] + Mass[ib]; - - dTT[ihn] = -1; - - if (fabs(Porg0[ia][0] - Porg0[ib][0]) < 2 * xr[ihn] && - fabs(Porg0[ia][1] - Porg0[ib][1]) < 2 * xr[ihn] && - fabs(Porg0[ia][2] - Porg0[ib][2]) < 2 * xr[ihn] && - (ncount % findeveryl[ihn] == 0)) - { - trigger[ihn] = true; - dTT[ihn] = findeveryl[ihn] * dT_lev; - } - else - trigger[ihn] = false; - - if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) - lastahdumpid[ihn] = dumpid[ihn]; - else - dumpid[ihn] = 0; - - ihn++; - } -#if (ABEtype == 1) - if (PhysTime > 10) - { - ihn--; - trigger[ihn] = true; - xr[ihn] = yr[ihn] = zr[ihn] = 50; - // if(myrank==0) for(ihn=0;ihn 0) - return; - - // recompute least the constraint data lost for moved new grid - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - if (lev > 0) // if the constrait quantities can be reused from the step rhs calculation - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - if (0) // if the constrait quantities can be reused from the step rhs calculation - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - double TRK4 = PhysTime; - int pre = 0; - int lev = 0; - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); -#endif - } - // interpolate - double *x1, *y1, *z1; - const int n = 1000; - double lmax, lmin, dd; - lmin = 0; -#ifdef WithShell - lmax = SH->Rrange[1]; -#else - lmax = GH->bbox[0][0][4]; -#endif -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (lmax - lmin) / (n - 1); -#else -#ifdef Cell - dd = (lmax - lmin) / n; -#else -#error Not define Vertex nor Cell -#endif -#endif - x1 = new double[n]; - y1 = new double[n]; - z1 = new double[n]; - for (int i = 0; i < n; i++) - { - x1[i] = 0; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y1[i] = lmin + i * dd; -#else -#ifdef Cell - y1[i] = lmin + (i + 0.5) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - z1[i] = 0; - } - - int InList = 0; - - MyList *varl = ConstraintList; - while (varl) - { - InList++; - varl = varl->next; - } - double *shellf; - shellf = new double[n * InList]; - for (int i = 0; i < n; i++) - { - double XX[3]; - XX[0] = x1[i]; - XX[1] = y1[i]; - XX[2] = z1[i]; - bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#ifdef WithShell - if (!fg) - fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#endif - if (!fg && myrank == 0) - { - cout << "bssn_class::Interp_Constraint meets wrong" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - if (myrank == 0) - { - ofstream outfile; - char filename[50]; - sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); - // 0.5 for round off - - outfile.open(filename); - outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; - for (int i = 0; i < n; i++) - { - outfile << setw(10) << setprecision(10) << y1[i]; - for (int j = 0; j < InList; j++) - outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; - outfile << endl; - } - outfile.close(); - } - - delete[] shellf; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes constraint violations - -//================================================================================================ - -void bssn_class::Compute_Constraint() -{ - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - int lev; - - for (lev = 0; lev < GH->levels; lev++) - { - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } - // prolong restrict constraint quantities - for (lev = GH->levels - 1; lev > 0; lev--) - RestrictProlong(lev, 1, false, ConstraintList, ConstraintList, ConstraintList); - -#ifdef WithShell - lev = 0; - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); - // interpolate constraint quantities - SH->CS_Inter(ConstraintList, Symmetry); -#endif -} - -//================================================================================================ - - - -//================================================================================================ - -void bssn_class::testRestrict() -{ - MyList *DG_List = new MyList(phi0); - int lev = 0; - double ZEO = 0, ONE = 1; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - lev = 1; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], DG_List, DG_List, Symmetry); - Parallel::Sync(GH->PatL[lev - 1], DG_List, Symmetry); - - Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); - - DG_List->clearList(); - exit(0); -} - -//================================================================================================ - - - -//================================================================================================ - -void bssn_class::testOutBd() -{ - MyList *DG_List = new MyList(phi0); - int lev = 1; - double ZEO = 0, ONE = 1; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - lev = 0; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - lev = 1; - MyList *Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, DG_List, DG_List, Symmetry); - Pp = Pp->next; - } - Ppc = Ppc->next; - } - - Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); - - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); - Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); - - DG_List->clearList(); - exit(0); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function enforces/checks the traceless condition - -//================================================================================================ - -void bssn_class::Enforce_algcon(int lev, int fg) -{ - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (fg == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); - else - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#ifdef WithShell - if (lev == 0) - { - MyList *sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (fg == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); - else - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function monitors stdin for an 'abort' input - -//================================================================================================ - -bool bssn_class::check_Stdin_Abort() -{ - - fd_set readfds; - - struct timeval timeout; - - FD_ZERO(&readfds); - FD_SET(STDIN_FILENO, &readfds); - - // Set timeout to 0 — perform a non-blocking check - timeout.tv_sec = 0; - timeout.tv_usec = 0; - - int activity = select(STDIN_FILENO + 1, &readfds, nullptr, nullptr, &timeout); - - if (activity > 0 && FD_ISSET(STDIN_FILENO, &readfds)) { - string input_abort; - if (cin >> input_abort) { - if (input_abort == "stop") { - return true; - } - } - } - - return false; -} - -//================================================================================================ - + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes derivatives required for apparent-horizon calculations + +//================================================================================================ + +#ifdef With_AHF +void bssn_class::AH_Prepare_derivatives() +{ + double SYM = 1.0, ANT = -1.0; + int ZEO = 0; + + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gxx0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamzxx->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gxy0->sgfn], + cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamzxy->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, ANT, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gxz0->sgfn], + cg->fgfs[Gamxxz->sgfn], cg->fgfs[Gamyxz->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, SYM, ANT, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gyy0->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamzyy->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gyz0->sgfn], + cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamzyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, ANT, ANT, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gzz0->sgfn], + cg->fgfs[Gamxzz->sgfn], cg->fgfs[Gamyzz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + Parallel::Sync(GH->PatL[lev], AHDList, Symmetry); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function interpolates apparent-horizon data + +//================================================================================================ + +bool bssn_class::AH_Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetryi) +{ + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double pox[3]; + for (int i = 0; i < NN; i++) + { + for (int j = 0; j < 3; j++) + pox[j] = XX[j][i]; + int lev = GH->levels - 1; + bool notfound = true; + + while (notfound) + { + if (lev < 0) + { +#ifdef WithShell + if (SH->Interp_One_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) + { + return true; + } + if (myrank == 0) + { + cout << " bssn_class::AH_Interp_Points: point (" + << pox[0] << "," << pox[1] << "," << pox[2] + << ") is out of cgh and shell domain!" << endl; + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << " bssn_class::AH_Interp_Points: point (" + << pox[0] << "," << pox[1] << "," << pox[2] + << ") is out of cgh and shell domain!" << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); +#else + if (myrank == 0) + { + cout << " bssn_class::AH_Interp_Points: point (" + << pox[0] << "," << pox[1] << "," << pox[2] + << ") is out of cgh domain!" << endl; + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << " bssn_class::AH_Interp_Points: point (" + << pox[0] << "," << pox[1] << "," << pox[2] + << ") is out of cgh domain!" << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); +#endif + return false; + } + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + if (Pp->data->Interp_ONE_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) + { + notfound = false; + break; + } + Pp = Pp->next; + } + lev--; + } + } + return true; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes apparent horizons + +//================================================================================================ + +void bssn_class::AH_Step_Find(int lev, double dT_lev) +{ + if ((lev == GH->levels - 1)) + { + int ncount = int(PhysTime / dT_lev); + bool tf = false; + for (int ihn = 0; ihn < HN_num; ihn++) + { + if (ncount % findeveryl[ihn] == 0) + { + tf = true; + break; + } + } + if (tf) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + prev_clock = clock(); + const int cdumpid = int(PhysTime / AHdumptime) + 1; + for (int ihn = 0; ihn < HN_num; ihn++) + dumpid[ihn] = cdumpid; + + double gam; + for (int ihn = 0; ihn < BH_num; ihn++) + { + xc[ihn] = Porg0[ihn][0]; + yc[ihn] = Porg0[ihn][1]; + zc[ihn] = Porg0[ihn][2]; + gam = fabs(Pmom[ihn * 3]) / (Mass[ihn]); + gam = sqrt(1 - gam * gam); + xr[ihn] = Mass[ihn] * gam; + gam = fabs(Pmom[ihn * 3 + 1]) / (Mass[ihn]); + gam = sqrt(1 - gam * gam); + yr[ihn] = Mass[ihn] * gam; + gam = fabs(Pmom[ihn * 3 + 2]) / (Mass[ihn]); + gam = sqrt(1 - gam * gam); + zr[ihn] = Mass[ihn] * gam; + dTT[ihn] = -1; + + if (ncount % findeveryl[ihn] == 0) + { + trigger[ihn] = true; + dTT[ihn] = findeveryl[ihn] * dT_lev; + } + else + trigger[ihn] = false; + if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) + lastahdumpid[ihn] = dumpid[ihn]; + else + dumpid[ihn] = 0; + } + int ihn = BH_num; + for (int ia = 0; ia < BH_num; ia++) + for (int ib = ia + 1; ib < BH_num; ib++) + { + xc[ihn] = (Porg0[ia][0] + Porg0[ib][0]) / 2; + yc[ihn] = (Porg0[ia][1] + Porg0[ib][1]) / 2; + zc[ihn] = (Porg0[ia][2] + Porg0[ib][2]) / 2; + + xr[ihn] = yr[ihn] = zr[ihn] = Mass[ia] + Mass[ib]; + + dTT[ihn] = -1; + + if (fabs(Porg0[ia][0] - Porg0[ib][0]) < 2 * xr[ihn] && + fabs(Porg0[ia][1] - Porg0[ib][1]) < 2 * xr[ihn] && + fabs(Porg0[ia][2] - Porg0[ib][2]) < 2 * xr[ihn] && + (ncount % findeveryl[ihn] == 0)) + { + trigger[ihn] = true; + dTT[ihn] = findeveryl[ihn] * dT_lev; + } + else + trigger[ihn] = false; + + if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) + lastahdumpid[ihn] = dumpid[ihn]; + else + dumpid[ihn] = 0; + + ihn++; + } +#if (ABEtype == 1) + if (PhysTime > 10) + { + ihn--; + trigger[ihn] = true; + xr[ihn] = yr[ihn] = zr[ihn] = 50; + // if(myrank==0) for(ihn=0;ihn 0) + return; + + // recompute least the constraint data lost for moved new grid + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + if (lev > 0) // if the constrait quantities can be reused from the step rhs calculation + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + if (0) // if the constrait quantities can be reused from the step rhs calculation + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + double TRK4 = PhysTime; + int pre = 0; + int lev = 0; + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); +#endif + } + // interpolate + double *x1, *y1, *z1; + const int n = 1000; + double lmax, lmin, dd; + lmin = 0; +#ifdef WithShell + lmax = SH->Rrange[1]; +#else + lmax = GH->bbox[0][0][4]; +#endif +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (lmax - lmin) / (n - 1); +#else +#ifdef Cell + dd = (lmax - lmin) / n; +#else +#error Not define Vertex nor Cell +#endif +#endif + x1 = new double[n]; + y1 = new double[n]; + z1 = new double[n]; + for (int i = 0; i < n; i++) + { + x1[i] = 0; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y1[i] = lmin + i * dd; +#else +#ifdef Cell + y1[i] = lmin + (i + 0.5) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + z1[i] = 0; + } + + int InList = 0; + + MyList *varl = ConstraintList; + while (varl) + { + InList++; + varl = varl->next; + } + double *shellf; + shellf = new double[n * InList]; + for (int i = 0; i < n; i++) + { + double XX[3]; + XX[0] = x1[i]; + XX[1] = y1[i]; + XX[2] = z1[i]; + bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#ifdef WithShell + if (!fg) + fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#endif + if (!fg && myrank == 0) + { + cout << "bssn_class::Interp_Constraint meets wrong" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + if (myrank == 0) + { + ofstream outfile; + char filename[50]; + sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); + // 0.5 for round off + + outfile.open(filename); + outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; + for (int i = 0; i < n; i++) + { + outfile << setw(10) << setprecision(10) << y1[i]; + for (int j = 0; j < InList; j++) + outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; + outfile << endl; + } + outfile.close(); + } + + delete[] shellf; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes constraint violations + +//================================================================================================ + +void bssn_class::Compute_Constraint() +{ + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + int lev; + + for (lev = 0; lev < GH->levels; lev++) + { + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } + // prolong restrict constraint quantities + for (lev = GH->levels - 1; lev > 0; lev--) + RestrictProlong(lev, 1, false, ConstraintList, ConstraintList, ConstraintList); + +#ifdef WithShell + lev = 0; + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); + // interpolate constraint quantities + SH->CS_Inter(ConstraintList, Symmetry); +#endif +} + +//================================================================================================ + + + +//================================================================================================ + +void bssn_class::testRestrict() +{ + MyList *DG_List = new MyList(phi0); + int lev = 0; + double ZEO = 0, ONE = 1; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + lev = 1; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], DG_List, DG_List, Symmetry); + Parallel::Sync(GH->PatL[lev - 1], DG_List, Symmetry); + + Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); + + DG_List->clearList(); + exit(0); +} + +//================================================================================================ + + + +//================================================================================================ + +void bssn_class::testOutBd() +{ + MyList *DG_List = new MyList(phi0); + int lev = 1; + double ZEO = 0, ONE = 1; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + lev = 0; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + lev = 1; + MyList *Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, DG_List, DG_List, Symmetry); + Pp = Pp->next; + } + Ppc = Ppc->next; + } + + Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); + + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); + Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); + + DG_List->clearList(); + exit(0); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function enforces/checks the traceless condition + +//================================================================================================ + +void bssn_class::Enforce_algcon(int lev, int fg) +{ + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (fg == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); + else + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#ifdef WithShell + if (lev == 0) + { + MyList *sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (fg == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); + else + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function monitors stdin for an 'abort' input + +//================================================================================================ + +bool bssn_class::check_Stdin_Abort() +{ + + fd_set readfds; + + struct timeval timeout; + + FD_ZERO(&readfds); + FD_SET(STDIN_FILENO, &readfds); + + // Set timeout to 0 — perform a non-blocking check + timeout.tv_sec = 0; + timeout.tv_usec = 0; + + int activity = select(STDIN_FILENO + 1, &readfds, nullptr, nullptr, &timeout); + + if (activity > 0 && FD_ISSET(STDIN_FILENO, &readfds)) { + string input_abort; + if (cin >> input_abort) { + if (input_abort == "stop") { + return true; + } + } + } + + return false; +} + +//================================================================================================ + diff --git a/AMSS_NCKU_source/bssn_class.h b/AMSS_NCKU_source/BSSN/bssn_class.h similarity index 97% rename from AMSS_NCKU_source/bssn_class.h rename to AMSS_NCKU_source/BSSN/bssn_class.h index a2536cb..2b4f376 100644 --- a/AMSS_NCKU_source/bssn_class.h +++ b/AMSS_NCKU_source/BSSN/bssn_class.h @@ -1,206 +1,206 @@ - -#ifndef BSSN_CLASS_H -#define BSSN_CLASS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "cgh.h" -#include "ShellPatch.h" -#include "misc.h" -#include "var.h" -#include "MyList.h" -#include "monitor.h" -#include "surface_integral.h" -#include "checkpoint.h" - -extern void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN); - -class bssn_class -{ -public: - int ngfs; - int nprocs, myrank; - cgh *GH; - ShellPatch *SH; - double PhysTime; - - int checkrun; - char checkfilename[50]; - int Steps; + +#ifndef BSSN_CLASS_H +#define BSSN_CLASS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "cgh.h" +#include "ShellPatch.h" +#include "misc.h" +#include "var.h" +#include "MyList.h" +#include "monitor.h" +#include "surface_integral.h" +#include "checkpoint.h" + +extern void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN); + +class bssn_class +{ +public: + int ngfs; + int nprocs, myrank; + cgh *GH; + ShellPatch *SH; + double PhysTime; + + int checkrun; + char checkfilename[50]; + int Steps; double StartTime, TotalTime; double AnasTime, DumpTime, d2DumpTime, CheckTime; double LastAnas, LastConsOut; int *ConstraintRefreshLevels; double Courant; - double numepss, numepsb, numepsh; - int Symmetry; - int maxl, decn; - double maxrex, drex; - int trfls, a_lev; - - double dT; - double chitiny; - - double **Porg0, **Porgbr, **Porg, **Porg1, **Porg_rhs; - int BH_num, BH_num_input; - double *Mass, *Pmom, *Spin; - double ADMMass; - - var *phio, *trKo; - var *gxxo, *gxyo, *gxzo, *gyyo, *gyzo, *gzzo; - var *Axxo, *Axyo, *Axzo, *Ayyo, *Ayzo, *Azzo; - var *Gmxo, *Gmyo, *Gmzo; - var *Lapo, *Sfxo, *Sfyo, *Sfzo; - var *dtSfxo, *dtSfyo, *dtSfzo; - - var *phi0, *trK0; - var *gxx0, *gxy0, *gxz0, *gyy0, *gyz0, *gzz0; - var *Axx0, *Axy0, *Axz0, *Ayy0, *Ayz0, *Azz0; - var *Gmx0, *Gmy0, *Gmz0; - var *Lap0, *Sfx0, *Sfy0, *Sfz0; - var *dtSfx0, *dtSfy0, *dtSfz0; - - var *phi, *trK; - var *gxx, *gxy, *gxz, *gyy, *gyz, *gzz; - var *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz; - var *Gmx, *Gmy, *Gmz; - var *Lap, *Sfx, *Sfy, *Sfz; - var *dtSfx, *dtSfy, *dtSfz; - - var *phi1, *trK1; - var *gxx1, *gxy1, *gxz1, *gyy1, *gyz1, *gzz1; - var *Axx1, *Axy1, *Axz1, *Ayy1, *Ayz1, *Azz1; - var *Gmx1, *Gmy1, *Gmz1; - var *Lap1, *Sfx1, *Sfy1, *Sfz1; - var *dtSfx1, *dtSfy1, *dtSfz1; - - var *phi_rhs, *trK_rhs; - var *gxx_rhs, *gxy_rhs, *gxz_rhs, *gyy_rhs, *gyz_rhs, *gzz_rhs; - var *Axx_rhs, *Axy_rhs, *Axz_rhs, *Ayy_rhs, *Ayz_rhs, *Azz_rhs; - var *Gmx_rhs, *Gmy_rhs, *Gmz_rhs; - var *Lap_rhs, *Sfx_rhs, *Sfy_rhs, *Sfz_rhs; - var *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs; - - var *rho, *Sx, *Sy, *Sz, *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz; - - var *Gamxxx, *Gamxxy, *Gamxxz, *Gamxyy, *Gamxyz, *Gamxzz; - var *Gamyxx, *Gamyxy, *Gamyxz, *Gamyyy, *Gamyyz, *Gamyzz; - var *Gamzxx, *Gamzxy, *Gamzxz, *Gamzyy, *Gamzyz, *Gamzzz; - - var *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz; - - var *Rpsi4, *Ipsi4; - var *t1Rpsi4, *t1Ipsi4, *t2Rpsi4, *t2Ipsi4; - - var *Cons_Ham, *Cons_Px, *Cons_Py, *Cons_Pz, *Cons_Gx, *Cons_Gy, *Cons_Gz; - -#ifdef Point_Psi4 - var *phix, *phiy, *phiz; - var *trKx, *trKy, *trKz; - var *Axxx, *Axxy, *Axxz; - var *Axyx, *Axyy, *Axyz; - var *Axzx, *Axzy, *Axzz; - var *Ayyx, *Ayyy, *Ayyz; - var *Ayzx, *Ayzy, *Ayzz; - var *Azzx, *Azzy, *Azzz; -#endif - // FIXME: uc = StateList, up = OldStateList, upp = SynchList_cor; so never touch these three data - MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; - MyList *OldStateList, *DumpList; - MyList *ConstraintList; - - Parallel::SyncCache *sync_cache_pre; // per-level cache for predictor sync - Parallel::SyncCache *sync_cache_cor; // per-level cache for corrector sync - Parallel::SyncCache *sync_cache_rp_coarse; // RestrictProlong sync on PatL[lev-1] - Parallel::SyncCache *sync_cache_rp_fine; // RestrictProlong sync on PatL[lev] - Parallel::SyncCache *sync_cache_restrict; // cached Restrict in RestrictProlong - Parallel::SyncCache *sync_cache_outbd; // cached OutBdLow2Hi in RestrictProlong - + double numepss, numepsb, numepsh; + int Symmetry; + int maxl, decn; + double maxrex, drex; + int trfls, a_lev; + + double dT; + double chitiny; + + double **Porg0, **Porgbr, **Porg, **Porg1, **Porg_rhs; + int BH_num, BH_num_input; + double *Mass, *Pmom, *Spin; + double ADMMass; + + var *phio, *trKo; + var *gxxo, *gxyo, *gxzo, *gyyo, *gyzo, *gzzo; + var *Axxo, *Axyo, *Axzo, *Ayyo, *Ayzo, *Azzo; + var *Gmxo, *Gmyo, *Gmzo; + var *Lapo, *Sfxo, *Sfyo, *Sfzo; + var *dtSfxo, *dtSfyo, *dtSfzo; + + var *phi0, *trK0; + var *gxx0, *gxy0, *gxz0, *gyy0, *gyz0, *gzz0; + var *Axx0, *Axy0, *Axz0, *Ayy0, *Ayz0, *Azz0; + var *Gmx0, *Gmy0, *Gmz0; + var *Lap0, *Sfx0, *Sfy0, *Sfz0; + var *dtSfx0, *dtSfy0, *dtSfz0; + + var *phi, *trK; + var *gxx, *gxy, *gxz, *gyy, *gyz, *gzz; + var *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz; + var *Gmx, *Gmy, *Gmz; + var *Lap, *Sfx, *Sfy, *Sfz; + var *dtSfx, *dtSfy, *dtSfz; + + var *phi1, *trK1; + var *gxx1, *gxy1, *gxz1, *gyy1, *gyz1, *gzz1; + var *Axx1, *Axy1, *Axz1, *Ayy1, *Ayz1, *Azz1; + var *Gmx1, *Gmy1, *Gmz1; + var *Lap1, *Sfx1, *Sfy1, *Sfz1; + var *dtSfx1, *dtSfy1, *dtSfz1; + + var *phi_rhs, *trK_rhs; + var *gxx_rhs, *gxy_rhs, *gxz_rhs, *gyy_rhs, *gyz_rhs, *gzz_rhs; + var *Axx_rhs, *Axy_rhs, *Axz_rhs, *Ayy_rhs, *Ayz_rhs, *Azz_rhs; + var *Gmx_rhs, *Gmy_rhs, *Gmz_rhs; + var *Lap_rhs, *Sfx_rhs, *Sfy_rhs, *Sfz_rhs; + var *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs; + + var *rho, *Sx, *Sy, *Sz, *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz; + + var *Gamxxx, *Gamxxy, *Gamxxz, *Gamxyy, *Gamxyz, *Gamxzz; + var *Gamyxx, *Gamyxy, *Gamyxz, *Gamyyy, *Gamyyz, *Gamyzz; + var *Gamzxx, *Gamzxy, *Gamzxz, *Gamzyy, *Gamzyz, *Gamzzz; + + var *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz; + + var *Rpsi4, *Ipsi4; + var *t1Rpsi4, *t1Ipsi4, *t2Rpsi4, *t2Ipsi4; + + var *Cons_Ham, *Cons_Px, *Cons_Py, *Cons_Pz, *Cons_Gx, *Cons_Gy, *Cons_Gz; + +#ifdef Point_Psi4 + var *phix, *phiy, *phiz; + var *trKx, *trKy, *trKz; + var *Axxx, *Axxy, *Axxz; + var *Axyx, *Axyy, *Axyz; + var *Axzx, *Axzy, *Axzz; + var *Ayyx, *Ayyy, *Ayyz; + var *Ayzx, *Ayzy, *Ayzz; + var *Azzx, *Azzy, *Azzz; +#endif + // FIXME: uc = StateList, up = OldStateList, upp = SynchList_cor; so never touch these three data + MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; + MyList *OldStateList, *DumpList; + MyList *ConstraintList; + + Parallel::SyncCache *sync_cache_pre; // per-level cache for predictor sync + Parallel::SyncCache *sync_cache_cor; // per-level cache for corrector sync + Parallel::SyncCache *sync_cache_rp_coarse; // RestrictProlong sync on PatL[lev-1] + Parallel::SyncCache *sync_cache_rp_fine; // RestrictProlong sync on PatL[lev] + Parallel::SyncCache *sync_cache_restrict; // cached Restrict in RestrictProlong + Parallel::SyncCache *sync_cache_outbd; // cached OutBdLow2Hi in RestrictProlong + monitor *ErrorMonitor, *Psi4Monitor, *BHMonitor, *MAPMonitor; monitor *ConVMonitor, *TimingMonitor; surface_integral *Waveshell; - checkpoint *CheckPoint; - -public: - bssn_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi); - ~bssn_class(); - - void Evolve(int Steps); - void RecursiveStep(int lev); -#if (PSTR == 3) - void RecursiveStep(int lev, int num); -#endif -#if (PSTR == 1 || PSTR == 2 || PSTR == 3) - void ParallelStep(); - void SHStep(); -#endif - void RestrictProlong(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); - void RestrictProlong_aux(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); - void RestrictProlong(int lev, int YN, bool BB); - void ProlongRestrict(int lev, int YN, bool BB); - void Setup_Black_Hole_position(); - void compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int lev); - bool read_Pablo_file(int *ext, double *datain, char *filename); - void write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, - char *filename); - void AnalysisStuff(int lev, double dT_lev); - void Setup_KerrSchild(); - void Enforce_algcon(int lev, int fg); - - void testRestrict(); - void testOutBd(); - - bool check_Stdin_Abort(); - - virtual void Setup_Initial_Data_Cao(); - virtual void Setup_Initial_Data_Lousto(); - virtual void Initialize(); - virtual void Read_Ansorg(); - virtual void Read_Pablo() {}; - virtual void Compute_Psi4(int lev); - virtual void Step(int lev, int YN); - virtual void Interp_Constraint(bool infg); - virtual void Constraint_Out(); - virtual void Compute_Constraint(); - -#ifdef With_AHF -protected: - MyList *AHList, *AHDList, *GaugeList; - int AHfindevery; - double AHdumptime; - int *lastahdumpid, HN_num; // number of possible horizons - int *findeveryl; - double *xc, *yc, *zc, *xr, *yr, *zr; - bool *trigger; - double *dTT; - int *dumpid; - -public: - void AH_Prepare_derivatives(); - bool AH_Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetryi); - void AH_Step_Find(int lev, double dT_lev); -#endif -}; -#endif /* BSSN_CLASS_H */ + checkpoint *CheckPoint; + +public: + bssn_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi); + ~bssn_class(); + + void Evolve(int Steps); + void RecursiveStep(int lev); +#if (PSTR == 3) + void RecursiveStep(int lev, int num); +#endif +#if (PSTR == 1 || PSTR == 2 || PSTR == 3) + void ParallelStep(); + void SHStep(); +#endif + void RestrictProlong(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); + void RestrictProlong_aux(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); + void RestrictProlong(int lev, int YN, bool BB); + void ProlongRestrict(int lev, int YN, bool BB); + void Setup_Black_Hole_position(); + void compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int lev); + bool read_Pablo_file(int *ext, double *datain, char *filename); + void write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, + char *filename); + void AnalysisStuff(int lev, double dT_lev); + void Setup_KerrSchild(); + void Enforce_algcon(int lev, int fg); + + void testRestrict(); + void testOutBd(); + + bool check_Stdin_Abort(); + + virtual void Setup_Initial_Data_Cao(); + virtual void Setup_Initial_Data_Lousto(); + virtual void Initialize(); + virtual void Read_Ansorg(); + virtual void Read_Pablo() {}; + virtual void Compute_Psi4(int lev); + virtual void Step(int lev, int YN); + virtual void Interp_Constraint(bool infg); + virtual void Constraint_Out(); + virtual void Compute_Constraint(); + +#ifdef With_AHF +protected: + MyList *AHList, *AHDList, *GaugeList; + int AHfindevery; + double AHdumptime; + int *lastahdumpid, HN_num; // number of possible horizons + int *findeveryl; + double *xc, *yc, *zc, *xr, *yr, *zr; + bool *trigger; + double *dTT; + int *dumpid; + +public: + void AH_Prepare_derivatives(); + bool AH_Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetryi); + void AH_Step_Find(int lev, double dT_lev); +#endif +}; +#endif /* BSSN_CLASS_H */ diff --git a/AMSS_NCKU_source/bssn_constraint.f90 b/AMSS_NCKU_source/BSSN/bssn_constraint.f90 similarity index 98% rename from AMSS_NCKU_source/bssn_constraint.f90 rename to AMSS_NCKU_source/BSSN/bssn_constraint.f90 index cef113a..409b5b8 100644 --- a/AMSS_NCKU_source/bssn_constraint.f90 +++ b/AMSS_NCKU_source/BSSN/bssn_constraint.f90 @@ -1,787 +1,787 @@ - - -#include "macrodef.fh" - -#if (ABV == 0) -!! using BSSN variables -!-------------------------------------------------------------------------------! -! computed constraint for bssn formalism ! -!-------------------------------------------------------------------------------! - subroutine constraint_bssn(ex, X, Y, Z,& - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gmx,Gmy,Gmz,& - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! second kind of Christofel symble Gamma^i_jk respect to physical metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -!~~~~~~> Other variables: -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! first order derivative of metric, @_k g_ij - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz -! partial derivative of chi, chi_i - real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: PI - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chin1 = chi+ONE -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - -! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho - -! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - -!store K,i in chi,i - call fderivs(ex,trK,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - -movx_Res = movx_Res - F2o3*chix - F8*PI*sx -movy_Res = movy_Res - F2o3*chiy - F8*PI*sy -movz_Res = movz_Res - F2o3*chiz - F8*PI*sz - - return - - end subroutine constraint_bssn -!-------------------------------------------------------------------------------! -! computed constraint for bssn formalism for shell ! -!-------------------------------------------------------------------------------! - subroutine constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gmx,Gmy,Gmz,& - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry,Lev,sst) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! second kind of Christofel symble Gamma^i_jk respect to physical metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -!~~~~~~> Other variables: -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! first order derivative of metric, @_k g_ij - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz -! partial derivative of chi, chi_i - real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: PI - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chin1 = chi+ONE -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - -! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho - -! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - -!store K,i in chi,i - call fderivs_shc(ex,trK,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -movx_Res = movx_Res - F2o3*chix - F8*PI*sx -movy_Res = movy_Res - F2o3*chiy - F8*PI*sy -movz_Res = movz_Res - F2o3*chiz - F8*PI*sz - - return - - end subroutine constraint_bssn_ss -#elif (ABV == 1) -!! using ADM variables -!-------------------------------------------------------------------------------! -! computed constraint for bssn formalism ! -!-------------------------------------------------------------------------------! - subroutine constraint_bssn(ex, X, Y, Z,& - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gmx,Gmy,Gmz,& - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! second kind of Christofel symble Gamma^i_jk respect to physical metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -!~~~~~~> Other variables: -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! first order derivative of metric, @_k g_ij - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz -! partial derivative of chi, chi_i - real*8, dimension(ex(1),ex(2),ex(3)) :: chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_dyy,adm_dzz,adm_gxy,adm_gxz,adm_gyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kyy,Kzz,Kxy,Kxz,Kyz - - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: PI - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chin1 = chi+ONE -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - - call bssn2adm(ex,chin1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) - adm_dxx = adm_dxx - ONE - adm_dyy = adm_dyy - ONE - adm_dzz = adm_dzz - ONE - - call constraint_adm(ex, X, Y, Z,& - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - ham_Res, movx_Res, movy_Res, movz_Res, & - Symmetry) - - return - - end subroutine constraint_bssn -!-------------------------------------------------------------------------------! -! computed constraint for bssn formalism for shell ! -!-------------------------------------------------------------------------------! - subroutine constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gmx,Gmy,Gmz,& - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry,Lev,sst) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! second kind of Christofel symble Gamma^i_jk respect to physical metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -!~~~~~~> Other variables: -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! first order derivative of metric, @_k g_ij - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz -! partial derivative of chi, chi_i - real*8, dimension(ex(1),ex(2),ex(3)) :: chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_dyy,adm_dzz,adm_gxy,adm_gxz,adm_gyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kyy,Kzz,Kxy,Kxz,Kyz - - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: PI - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chin1 = chi+ONE -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - - call bssn2adm(ex,chin1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) - adm_dxx = adm_dxx - ONE - adm_dyy = adm_dyy - ONE - adm_dzz = adm_dzz - ONE - - call constraint_adm_ss(ex,crho,sigma,R, X, Y, Z,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, & - Symmetry,Lev,sst) - - return - - end subroutine constraint_bssn_ss -#else -#error "not recognized ABV" -#endif + + +#include "macrodef.fh" + +#if (ABV == 0) +!! using BSSN variables +!-------------------------------------------------------------------------------! +! computed constraint for bssn formalism ! +!-------------------------------------------------------------------------------! + subroutine constraint_bssn(ex, X, Y, Z,& + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gmx,Gmy,Gmz,& + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! second kind of Christofel symble Gamma^i_jk respect to physical metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +!~~~~~~> Other variables: +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! first order derivative of metric, @_k g_ij + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz +! partial derivative of chi, chi_i + real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: PI + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chin1 = chi+ONE +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + +! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho + +! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + +!store K,i in chi,i + call fderivs(ex,trK,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + +movx_Res = movx_Res - F2o3*chix - F8*PI*sx +movy_Res = movy_Res - F2o3*chiy - F8*PI*sy +movz_Res = movz_Res - F2o3*chiz - F8*PI*sz + + return + + end subroutine constraint_bssn +!-------------------------------------------------------------------------------! +! computed constraint for bssn formalism for shell ! +!-------------------------------------------------------------------------------! + subroutine constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gmx,Gmy,Gmz,& + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry,Lev,sst) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! second kind of Christofel symble Gamma^i_jk respect to physical metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +!~~~~~~> Other variables: +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! first order derivative of metric, @_k g_ij + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz +! partial derivative of chi, chi_i + real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: PI + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chin1 = chi+ONE +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + +! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho + +! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + +!store K,i in chi,i + call fderivs_shc(ex,trK,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +movx_Res = movx_Res - F2o3*chix - F8*PI*sx +movy_Res = movy_Res - F2o3*chiy - F8*PI*sy +movz_Res = movz_Res - F2o3*chiz - F8*PI*sz + + return + + end subroutine constraint_bssn_ss +#elif (ABV == 1) +!! using ADM variables +!-------------------------------------------------------------------------------! +! computed constraint for bssn formalism ! +!-------------------------------------------------------------------------------! + subroutine constraint_bssn(ex, X, Y, Z,& + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gmx,Gmy,Gmz,& + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! second kind of Christofel symble Gamma^i_jk respect to physical metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +!~~~~~~> Other variables: +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! first order derivative of metric, @_k g_ij + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz +! partial derivative of chi, chi_i + real*8, dimension(ex(1),ex(2),ex(3)) :: chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_dyy,adm_dzz,adm_gxy,adm_gxz,adm_gyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kyy,Kzz,Kxy,Kxz,Kyz + + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: PI + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chin1 = chi+ONE +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + + call bssn2adm(ex,chin1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) + adm_dxx = adm_dxx - ONE + adm_dyy = adm_dyy - ONE + adm_dzz = adm_dzz - ONE + + call constraint_adm(ex, X, Y, Z,& + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + ham_Res, movx_Res, movy_Res, movz_Res, & + Symmetry) + + return + + end subroutine constraint_bssn +!-------------------------------------------------------------------------------! +! computed constraint for bssn formalism for shell ! +!-------------------------------------------------------------------------------! + subroutine constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gmx,Gmy,Gmz,& + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry,Lev,sst) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! second kind of Christofel symble Gamma^i_jk respect to physical metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +!~~~~~~> Other variables: +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! first order derivative of metric, @_k g_ij + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyz,gyzz,gzzz +! partial derivative of chi, chi_i + real*8, dimension(ex(1),ex(2),ex(3)) :: chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_dyy,adm_dzz,adm_gxy,adm_gxz,adm_gyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kyy,Kzz,Kxy,Kxz,Kyz + + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8, parameter :: ZERO = 0.D0, HALF = 0.5d0, ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8, parameter :: F2o3 = 2.d0/3.d0, F8 = 8.d0, F16 = 1.6d1, SIX = 6.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: PI + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chin1 = chi+ONE +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gmx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gmy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gmz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + + call bssn2adm(ex,chin1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) + adm_dxx = adm_dxx - ONE + adm_dyy = adm_dyy - ONE + adm_dzz = adm_dzz - ONE + + call constraint_adm_ss(ex,crho,sigma,R, X, Y, Z,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Lap,Sfx,Sfy,Sfz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, & + Symmetry,Lev,sst) + + return + + end subroutine constraint_bssn_ss +#else +#error "not recognized ABV" +#endif diff --git a/AMSS_NCKU_source/bssn_rhs.f90 b/AMSS_NCKU_source/BSSN/bssn_rhs.f90 similarity index 98% rename from AMSS_NCKU_source/bssn_rhs.f90 rename to AMSS_NCKU_source/BSSN/bssn_rhs.f90 index 2f386f6..2be51f3 100644 --- a/AMSS_NCKU_source/bssn_rhs.f90 +++ b/AMSS_NCKU_source/BSSN/bssn_rhs.f90 @@ -1,89 +1,89 @@ - - -#include "macrodef.fh" - - function compute_rhs_bssn(ex, T,X, Y, Z, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, & - Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry,Lev,eps,co) result(gont) -! calculate constraint violation when co=0 - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,co - real*8, intent(in ):: T - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8,intent(in) :: eps - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: ham_Res, movx_Res, movy_Res, movz_Res + + +#include "macrodef.fh" + + function compute_rhs_bssn(ex, T,X, Y, Z, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, & + Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry,Lev,eps,co) result(gont) +! calculate constraint violation when co=0 + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,co + real*8, intent(in ):: T + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8,intent(in) :: eps + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: ham_Res, movx_Res, movy_Res, movz_Res real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gmx_Res, Gmy_Res, Gmz_Res ! gont = 0: success; gont = 1: something wrong integer::gont integer :: i,j,k - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA real*8 :: dX, dY, dZ, PI real*8 :: divb_loc,det_loc @@ -96,63 +96,63 @@ real*8, parameter :: ZEO = 0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - double precision,parameter::FF = 0.75d0,eta=2.d0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - real*8, parameter :: F16=1.6d1,F8=8.d0 - -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) - real*8, dimension(ex(1),ex(2),ex(3)) :: reta -#endif - + double precision,parameter::FF = 0.75d0,eta=2.d0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + real*8, parameter :: F16=1.6d1,F8=8.d0 + +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) + real*8, dimension(ex(1),ex(2),ex(3)) :: reta +#endif + #if (GAUGE == 6 || GAUGE == 7) integer :: BHN real*8, dimension(9) :: Porg real*8, dimension(3) :: Mass real*8 :: r1,r2,M,A,w1,w2,C1,C2 - real*8, dimension(ex(1),ex(2),ex(3)) :: reta - - call getpbh(BHN,Porg,Mass) -#endif - -!!! sanity check (disabled in production builds for performance) -#ifdef DEBUG - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" - gont = 1 - return - endif -#endif - - PI = dacos(-ONE) - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - + real*8, dimension(ex(1),ex(2),ex(3)) :: reta + + call getpbh(BHN,Porg,Mass) +#endif + +!!! sanity check (disabled in production builds for performance) +#ifdef DEBUG + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" + gont = 1 + return + endif +#endif + + PI = dacos(-ONE) + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + do k=1,ex(3) do j=1,ex(2) do i=1,ex(1) @@ -164,13 +164,13 @@ enddo enddo enddo - - call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - + + call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) @@ -351,14 +351,14 @@ enddo enddo enddo - - call fdderivs(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,& - X,Y,Z,ANTI,SYM, SYM ,Symmetry,Lev) - call fdderivs(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,& - X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) - call fdderivs(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,& - X,Y,Z,SYM ,SYM, ANTI,Symmetry,Lev) - + + call fdderivs(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,& + X,Y,Z,ANTI,SYM, SYM ,Symmetry,Lev) + call fdderivs(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,& + X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) + call fdderivs(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,& + X,Y,Z,SYM ,SYM, ANTI,Symmetry,Lev) + call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,Lev) call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,Lev) @@ -407,254 +407,254 @@ enddo enddo enddo - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - call fdderivs(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI, ANTI,SYM ,symmetry,Lev) - Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI ,SYM ,ANTI,symmetry,Lev) - Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,ANTI ,ANTI,symmetry,Lev) - Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + call fdderivs(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI, ANTI,SYM ,symmetry,Lev) + Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI ,SYM ,ANTI,symmetry,Lev) + Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,ANTI ,ANTI,symmetry,Lev) + Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) !covariant second derivative of chi respect to tilted metric call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) @@ -839,167 +839,167 @@ enddo enddo enddo - -!!!! gauge variable part - - Lap_rhs = -TWO*alpn1*trK -#if (GAUGE == 0) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz -#elif (GAUGE == 1) - betax_rhs = Gamx - eta*betax - betay_rhs = Gamy - eta*betay - betaz_rhs = Gamz - eta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#elif (GAUGE == 2) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#elif (GAUGE == 3) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#elif (GAUGE == 4) - call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 - betax_rhs = FF*Gamx - reta*betax - betay_rhs = FF*Gamy - reta*betay - betaz_rhs = FF*Gamz - reta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#elif (GAUGE == 5) - call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 - betax_rhs = FF*Gamx - reta*betax - betay_rhs = FF*Gamy - reta*betay - betaz_rhs = FF*Gamz - reta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#elif (GAUGE == 6) - if(BHN==2)then - M = Mass(1)+Mass(2) - A = 2.d0/M - w1 = 1.2d1 - w2 = w1 - C1 = 1.d0/Mass(1) - A - C2 = 1.d0/Mass(2) - A - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - r1 = ((Porg(1)-X(i))**2+(Porg(2)-Y(j))**2+(Porg(3)-Z(k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - r2 = ((Porg(4)-X(i))**2+(Porg(5)-Y(j))**2+(Porg(6)-Z(k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - reta(i,j,k) = A + C1/(ONE+w1*r1) + C2/(ONE+w2*r2) - enddo - enddo - enddo - else - write(*,*) "not support BH_num in Jason's form 1",BHN - endif - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#elif (GAUGE == 7) - if(BHN==2)then - M = Mass(1)+Mass(2) - A = 2.d0/M - w1 = 1.2d1 - w2 = w1 - C1 = 1.d0/Mass(1) - A - C2 = 1.d0/Mass(2) - A - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - r1 = ((Porg(1)-X(i))**2+(Porg(2)-Y(j))**2+(Porg(3)-Z(k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - r2 = ((Porg(4)-X(i))**2+(Porg(5)-Y(j))**2+(Porg(6)-Z(k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - reta(i,j,k) = A + C1*dexp(-w1*r1) + C2*dexp(-w2*r2) - enddo - enddo - enddo - else - write(*,*) "not support BH_num in Jason's form 2",BHN - endif - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#endif - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term + Kreiss-Oliger dissipation (merged for cache efficiency) -! lopsided_kodis shares the symmetry_bd buffer between advection and -! dissipation, eliminating redundant full-grid copies. For metric variables + +!!!! gauge variable part + + Lap_rhs = -TWO*alpn1*trK +#if (GAUGE == 0) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz +#elif (GAUGE == 1) + betax_rhs = Gamx - eta*betax + betay_rhs = Gamy - eta*betay + betaz_rhs = Gamz - eta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#elif (GAUGE == 2) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#elif (GAUGE == 3) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#elif (GAUGE == 4) + call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 + betax_rhs = FF*Gamx - reta*betax + betay_rhs = FF*Gamy - reta*betay + betaz_rhs = FF*Gamz - reta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#elif (GAUGE == 5) + call fderivs(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 + betax_rhs = FF*Gamx - reta*betax + betay_rhs = FF*Gamy - reta*betay + betaz_rhs = FF*Gamz - reta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#elif (GAUGE == 6) + if(BHN==2)then + M = Mass(1)+Mass(2) + A = 2.d0/M + w1 = 1.2d1 + w2 = w1 + C1 = 1.d0/Mass(1) - A + C2 = 1.d0/Mass(2) - A + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + r1 = ((Porg(1)-X(i))**2+(Porg(2)-Y(j))**2+(Porg(3)-Z(k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + r2 = ((Porg(4)-X(i))**2+(Porg(5)-Y(j))**2+(Porg(6)-Z(k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + reta(i,j,k) = A + C1/(ONE+w1*r1) + C2/(ONE+w2*r2) + enddo + enddo + enddo + else + write(*,*) "not support BH_num in Jason's form 1",BHN + endif + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#elif (GAUGE == 7) + if(BHN==2)then + M = Mass(1)+Mass(2) + A = 2.d0/M + w1 = 1.2d1 + w2 = w1 + C1 = 1.d0/Mass(1) - A + C2 = 1.d0/Mass(2) - A + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + r1 = ((Porg(1)-X(i))**2+(Porg(2)-Y(j))**2+(Porg(3)-Z(k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + r2 = ((Porg(4)-X(i))**2+(Porg(5)-Y(j))**2+(Porg(6)-Z(k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + reta(i,j,k) = A + C1*dexp(-w1*r1) + C2*dexp(-w2*r2) + enddo + enddo + enddo + else + write(*,*) "not support BH_num in Jason's form 2",BHN + endif + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#endif + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term + Kreiss-Oliger dissipation (merged for cache efficiency) +! lopsided_kodis shares the symmetry_bd buffer between advection and +! dissipation, eliminating redundant full-grid copies. For metric variables ! gxx/gyy/gzz (=dxx/dyy/dzz+1): stencil coefficients sum to zero, ! so the constant offset has no effect on dissipation. @@ -1009,189 +1009,189 @@ call lopsided_kodis(ex,X,Y,Z,dyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS,eps) call lopsided_kodis(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA,eps) call lopsided_kodis(ex,X,Y,Z,dzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS,eps) - - call lopsided_kodis(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS,eps) - call lopsided_kodis(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS,eps) - call lopsided_kodis(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA,eps) - call lopsided_kodis(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS,eps) - call lopsided_kodis(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA,eps) - call lopsided_kodis(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS,eps) - - call lopsided_kodis(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS,eps) - call lopsided_kodis(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS,eps) - - call lopsided_kodis(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS,eps) - call lopsided_kodis(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS,eps) - call lopsided_kodis(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA,eps) - -#if 1 -!! bam does not apply dissipation on gauge variables - call lopsided_kodis(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS,eps) -#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - call lopsided_kodis(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS,eps) - call lopsided_kodis(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS,eps) - call lopsided_kodis(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA,eps) -#endif -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - call lopsided_kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS,eps) - call lopsided_kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS,eps) - call lopsided_kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA,eps) -#endif -#else -! No dissipation on gauge variables (advection only) - call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) -#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) -#endif -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) -#endif -#endif - - if(co == 0)then -! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho - -! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - -movx_Res = movx_Res - F2o3*Kx - F8*PI*sx -movy_Res = movy_Res - F2o3*Ky - F8*PI*sy -movz_Res = movz_Res - F2o3*Kz - F8*PI*sz - endif - -#if (ABV == 1) - call ricci_gamma(ex, X, Y, Z, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) - call constraint_bssn(ex, X, Y, Z,& - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res,movx_Res,movy_Res,movz_Res,Gmx_Res,Gmy_Res,Gmz_Res, & - Symmetry) -#endif -#if 0 -#define i 2 -if(Lev == 1)then -write(*,*) X(i),Y(i),Z(i) -write(*,*) Axx(i,i,i),Axy(i,i,i),Axz(i,i,i),Ayy(i,i,i),Ayz(i,i,i),Azz(i,i,i) -write(*,*) 1+Lap(i,i,i),dtSfx(i,i,i),dtSfy(i,i,i),dtSfz(i,i,i) -write(*,*) betax(i,i,i),betay(i,i,i),betaz(i,i,i) -write(*,*) 1+chi(i,i,i),Gamx(i,i,i),Gamy(i,i,i),Gamz(i,i,i) -write(*,*) gxx(i,i,i),gxy(i,i,i),gxz(i,i,i),gyy(i,i,i),gyz(i,i,i),gzz(i,i,i) -write(*,*) trK(i,i,i) -write(*,*) "=====" -write(*,*) Axx_rhs(i,i,i),Axy_rhs(i,i,i),Axz_rhs(i,i,i),Ayy_rhs(i,i,i),Ayz_rhs(i,i,i),Azz_rhs(i,i,i) -write(*,*) Lap_rhs(i,i,i),dtSfx_rhs(i,i,i),dtSfy_rhs(i,i,i),dtSfz_rhs(i,i,i) -write(*,*) betax_rhs(i,i,i),betay_rhs(i,i,i),betaz_rhs(i,i,i) -write(*,*) chi_rhs(i,i,i),Gamx_rhs(i,i,i),Gamy_rhs(i,i,i),Gamz_rhs(i,i,i) -write(*,*) gxx_rhs(i,i,i),gxy_rhs(i,i,i),gxz_rhs(i,i,i),gyy_rhs(i,i,i),gyz_rhs(i,i,i),gzz_rhs(i,i,i) -write(*,*) trK_rhs(i,i,i) -endif -#undef i -!!stop -#endif - - gont = 0 - - return - - end function compute_rhs_bssn + + call lopsided_kodis(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS,eps) + call lopsided_kodis(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS,eps) + call lopsided_kodis(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA,eps) + call lopsided_kodis(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS,eps) + call lopsided_kodis(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA,eps) + call lopsided_kodis(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS,eps) + + call lopsided_kodis(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS,eps) + call lopsided_kodis(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS,eps) + + call lopsided_kodis(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS,eps) + call lopsided_kodis(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS,eps) + call lopsided_kodis(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA,eps) + +#if 1 +!! bam does not apply dissipation on gauge variables + call lopsided_kodis(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS,eps) +#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + call lopsided_kodis(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS,eps) + call lopsided_kodis(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS,eps) + call lopsided_kodis(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA,eps) +#endif +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + call lopsided_kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS,eps) + call lopsided_kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS,eps) + call lopsided_kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA,eps) +#endif +#else +! No dissipation on gauge variables (advection only) + call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) +#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) +#endif +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) +#endif +#endif + + if(co == 0)then +! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho + +! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + +movx_Res = movx_Res - F2o3*Kx - F8*PI*sx +movy_Res = movy_Res - F2o3*Ky - F8*PI*sy +movz_Res = movz_Res - F2o3*Kz - F8*PI*sz + endif + +#if (ABV == 1) + call ricci_gamma(ex, X, Y, Z, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) + call constraint_bssn(ex, X, Y, Z,& + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res,movx_Res,movy_Res,movz_Res,Gmx_Res,Gmy_Res,Gmz_Res, & + Symmetry) +#endif +#if 0 +#define i 2 +if(Lev == 1)then +write(*,*) X(i),Y(i),Z(i) +write(*,*) Axx(i,i,i),Axy(i,i,i),Axz(i,i,i),Ayy(i,i,i),Ayz(i,i,i),Azz(i,i,i) +write(*,*) 1+Lap(i,i,i),dtSfx(i,i,i),dtSfy(i,i,i),dtSfz(i,i,i) +write(*,*) betax(i,i,i),betay(i,i,i),betaz(i,i,i) +write(*,*) 1+chi(i,i,i),Gamx(i,i,i),Gamy(i,i,i),Gamz(i,i,i) +write(*,*) gxx(i,i,i),gxy(i,i,i),gxz(i,i,i),gyy(i,i,i),gyz(i,i,i),gzz(i,i,i) +write(*,*) trK(i,i,i) +write(*,*) "=====" +write(*,*) Axx_rhs(i,i,i),Axy_rhs(i,i,i),Axz_rhs(i,i,i),Ayy_rhs(i,i,i),Ayz_rhs(i,i,i),Azz_rhs(i,i,i) +write(*,*) Lap_rhs(i,i,i),dtSfx_rhs(i,i,i),dtSfy_rhs(i,i,i),dtSfz_rhs(i,i,i) +write(*,*) betax_rhs(i,i,i),betay_rhs(i,i,i),betaz_rhs(i,i,i) +write(*,*) chi_rhs(i,i,i),Gamx_rhs(i,i,i),Gamy_rhs(i,i,i),Gamz_rhs(i,i,i) +write(*,*) gxx_rhs(i,i,i),gxy_rhs(i,i,i),gxz_rhs(i,i,i),gyy_rhs(i,i,i),gyz_rhs(i,i,i),gzz_rhs(i,i,i) +write(*,*) trK_rhs(i,i,i) +endif +#undef i +!!stop +#endif + + gont = 0 + + return + + end function compute_rhs_bssn diff --git a/AMSS_NCKU_source/bssn_rhs.h b/AMSS_NCKU_source/BSSN/bssn_rhs.h similarity index 99% rename from AMSS_NCKU_source/bssn_rhs.h rename to AMSS_NCKU_source/BSSN/bssn_rhs.h index 96a545a..7285f08 100644 --- a/AMSS_NCKU_source/bssn_rhs.h +++ b/AMSS_NCKU_source/BSSN/bssn_rhs.h @@ -1,35 +1,35 @@ - -#ifndef BSSN_H -#define BSSN_H - -#ifdef fortran1 -#define f_compute_rhs_bssn compute_rhs_bssn -#define f_compute_rhs_bssn_ss compute_rhs_bssn_ss -#define f_compute_rhs_bssn_escalar compute_rhs_bssn_escalar -#define f_compute_rhs_bssn_escalar_ss compute_rhs_bssn_escalar_ss -#define f_compute_rhs_Z4c compute_rhs_z4c -#define f_compute_rhs_Z4cnot compute_rhs_z4cnot -#define f_compute_rhs_Z4c_ss compute_rhs_z4c_ss -#define f_compute_constraint_fr compute_constraint_fr -#endif -#ifdef fortran2 -#define f_compute_rhs_bssn COMPUTE_RHS_BSSN -#define f_compute_rhs_bssn_ss COMPUTE_RHS_BSSN_SS -#define f_compute_rhs_bssn_escalar COMPUTE_RHS_BSSN_ESCALAR -#define f_compute_rhs_bssn_escalar_ss COMPUTE_RHS_BSSN_ESCALAR_SS -#define f_compute_rhs_Z4c COMPUTE_RHS_Z4C -#define f_compute_rhs_Z4cnot COMPUTE_RHS_Z4CNOT -#define f_compute_rhs_Z4c_ss COMPUTE_RHS_Z4C_SS -#define f_compute_constraint_fr COMPUTE_CONSTRAINT_FR -#endif + +#ifndef BSSN_H +#define BSSN_H + +#ifdef fortran1 +#define f_compute_rhs_bssn compute_rhs_bssn +#define f_compute_rhs_bssn_ss compute_rhs_bssn_ss +#define f_compute_rhs_bssn_escalar compute_rhs_bssn_escalar +#define f_compute_rhs_bssn_escalar_ss compute_rhs_bssn_escalar_ss +#define f_compute_rhs_Z4c compute_rhs_z4c +#define f_compute_rhs_Z4cnot compute_rhs_z4cnot +#define f_compute_rhs_Z4c_ss compute_rhs_z4c_ss +#define f_compute_constraint_fr compute_constraint_fr +#endif +#ifdef fortran2 +#define f_compute_rhs_bssn COMPUTE_RHS_BSSN +#define f_compute_rhs_bssn_ss COMPUTE_RHS_BSSN_SS +#define f_compute_rhs_bssn_escalar COMPUTE_RHS_BSSN_ESCALAR +#define f_compute_rhs_bssn_escalar_ss COMPUTE_RHS_BSSN_ESCALAR_SS +#define f_compute_rhs_Z4c COMPUTE_RHS_Z4C +#define f_compute_rhs_Z4cnot COMPUTE_RHS_Z4CNOT +#define f_compute_rhs_Z4c_ss COMPUTE_RHS_Z4C_SS +#define f_compute_constraint_fr COMPUTE_CONSTRAINT_FR +#endif #ifdef fortran3 #define f_compute_rhs_bssn compute_rhs_bssn_ -#define f_compute_rhs_bssn_ss compute_rhs_bssn_ss_ -#define f_compute_rhs_bssn_escalar compute_rhs_bssn_escalar_ -#define f_compute_rhs_bssn_escalar_ss compute_rhs_bssn_escalar_ss_ -#define f_compute_rhs_Z4c compute_rhs_z4c_ -#define f_compute_rhs_Z4cnot compute_rhs_z4cnot_ -#define f_compute_rhs_Z4c_ss compute_rhs_z4c_ss_ +#define f_compute_rhs_bssn_ss compute_rhs_bssn_ss_ +#define f_compute_rhs_bssn_escalar compute_rhs_bssn_escalar_ +#define f_compute_rhs_bssn_escalar_ss compute_rhs_bssn_escalar_ss_ +#define f_compute_rhs_Z4c compute_rhs_z4c_ +#define f_compute_rhs_Z4cnot compute_rhs_z4cnot_ +#define f_compute_rhs_Z4c_ss compute_rhs_z4c_ss_ #define f_compute_constraint_fr compute_constraint_fr_ #endif @@ -48,197 +48,197 @@ extern "C" extern "C" { int f_compute_rhs_bssn(int *, double &, double *, double *, double *, // ex,T,X,Y,Z - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Ricci - double *, double *, double *, double *, double *, double *, double *, // constraint violation - int &, int &, double &, int &); -} - -extern "C" -{ - int f_compute_rhs_bssn_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R - double *, double *, double *, // X,Y,Z - double *, double *, double *, // drhodx,drhody,drhodz - double *, double *, double *, // dsigmadx,dsigmady,dsigmadz - double *, double *, double *, // dRdx,dRdy,dRdz - double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Ricci - double *, double *, double *, double *, double *, double *, double *, // constraint violation - int &, int &, double &, int &, int &); -} - -extern "C" -{ - int f_compute_rhs_bssn_escalar(int *, double &, double *, double *, double *, // ex,T,X,Y,Z - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, // Sphi, Spi - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, // Sphi, Spi - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Ricci - double *, double *, double *, double *, double *, double *, double *, // constraint violation - int &, int &, double &, int &); -} - -extern "C" -{ - int f_compute_rhs_bssn_escalar_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R - double *, double *, double *, // X,Y,Z - double *, double *, double *, // drhodx,drhody,drhodz - double *, double *, double *, // dsigmadx,dsigmady,dsigmadz - double *, double *, double *, // dRdx,dRdy,dRdz - double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, // Sphi,Spi - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, // Sphi,Spi - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Ricci - double *, double *, double *, double *, double *, double *, double *, // constraint violation - int &, int &, double &, int &, int &); -} - -extern "C" -{ - int f_compute_rhs_Z4c(int *, double &, double *, double *, double *, // ex,T,X,Y,Z - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, // Z4 - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, // Z4 - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - int &, int &, double &, int &); -} - -extern "C" -{ - int f_compute_rhs_Z4c_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R - double *, double *, double *, // X,Y,Z - double *, double *, double *, // drhodx,drhody,drhodz - double *, double *, double *, // dsigmadx,dsigmady,dsigmadz - double *, double *, double *, // dRdx,dRdy,dRdz - double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, // TZ - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, // TZ - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Ricci - double *, double *, double *, double *, double *, double *, double *, // constraint violation - int &, int &, double &, int &, int &); -} - -extern "C" -{ - int f_compute_rhs_Z4cnot(int *, double &, double *, double *, double *, // ex,T,X,Y,Z - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, // Z4 - double *, double *, // chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, // Z4 - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - int &, int &, double &, int &, double &); -} - -extern "C" -{ - void f_compute_constraint_fr(int *, double *, double *, double *, // ex,X,Y,Z - double *, double *, double *, double *, // chi, trK,rho,Sphi - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, double *, double *, double *, // Rij - double *, double *, double *, double *, double *, double *, // Sij - double *); -} // FR_cons - -#endif /* BSSN_H */ + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Ricci + double *, double *, double *, double *, double *, double *, double *, // constraint violation + int &, int &, double &, int &); +} + +extern "C" +{ + int f_compute_rhs_bssn_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R + double *, double *, double *, // X,Y,Z + double *, double *, double *, // drhodx,drhody,drhodz + double *, double *, double *, // dsigmadx,dsigmady,dsigmadz + double *, double *, double *, // dRdx,dRdy,dRdz + double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Ricci + double *, double *, double *, double *, double *, double *, double *, // constraint violation + int &, int &, double &, int &, int &); +} + +extern "C" +{ + int f_compute_rhs_bssn_escalar(int *, double &, double *, double *, double *, // ex,T,X,Y,Z + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, // Sphi, Spi + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, // Sphi, Spi + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Ricci + double *, double *, double *, double *, double *, double *, double *, // constraint violation + int &, int &, double &, int &); +} + +extern "C" +{ + int f_compute_rhs_bssn_escalar_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R + double *, double *, double *, // X,Y,Z + double *, double *, double *, // drhodx,drhody,drhodz + double *, double *, double *, // dsigmadx,dsigmady,dsigmadz + double *, double *, double *, // dRdx,dRdy,dRdz + double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, // Sphi,Spi + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, // Sphi,Spi + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Ricci + double *, double *, double *, double *, double *, double *, double *, // constraint violation + int &, int &, double &, int &, int &); +} + +extern "C" +{ + int f_compute_rhs_Z4c(int *, double &, double *, double *, double *, // ex,T,X,Y,Z + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, // Z4 + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, // Z4 + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + int &, int &, double &, int &); +} + +extern "C" +{ + int f_compute_rhs_Z4c_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R + double *, double *, double *, // X,Y,Z + double *, double *, double *, // drhodx,drhody,drhodz + double *, double *, double *, // dsigmadx,dsigmady,dsigmadz + double *, double *, double *, // dRdx,dRdy,dRdz + double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, // TZ + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, // TZ + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, // stress-energy + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Ricci + double *, double *, double *, double *, double *, double *, double *, // constraint violation + int &, int &, double &, int &, int &); +} + +extern "C" +{ + int f_compute_rhs_Z4cnot(int *, double &, double *, double *, double *, // ex,T,X,Y,Z + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, // Z4 + double *, double *, // chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, // Z4 + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + int &, int &, double &, int &, double &); +} + +extern "C" +{ + void f_compute_constraint_fr(int *, double *, double *, double *, // ex,X,Y,Z + double *, double *, double *, double *, // chi, trK,rho,Sphi + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, double *, double *, double *, // Rij + double *, double *, double *, double *, double *, double *, // Sij + double *); +} // FR_cons + +#endif /* BSSN_H */ diff --git a/AMSS_NCKU_source/bssn_rhs_c.C b/AMSS_NCKU_source/BSSN/bssn_rhs_c.C similarity index 100% rename from AMSS_NCKU_source/bssn_rhs_c.C rename to AMSS_NCKU_source/BSSN/bssn_rhs_c.C diff --git a/AMSS_NCKU_source/bssn_rhs_ss.f90 b/AMSS_NCKU_source/BSSN/bssn_rhs_ss.f90 similarity index 98% rename from AMSS_NCKU_source/bssn_rhs_ss.f90 rename to AMSS_NCKU_source/BSSN/bssn_rhs_ss.f90 index 7ee3608..1b38c76 100644 --- a/AMSS_NCKU_source/bssn_rhs_ss.f90 +++ b/AMSS_NCKU_source/BSSN/bssn_rhs_ss.f90 @@ -1,1358 +1,1358 @@ - - -#include "macrodef.fh" - - function compute_rhs_bssn_ss(ex, T,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, & - Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry,Lev,eps,sst,co) result(gont) -! calculate constraint violation when co=0 - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co - real*8, intent(in ):: T - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8,intent(in) :: eps - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ZEO = 0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - double precision,parameter::FF = 0.75d0,eta=2.d0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - real*8, parameter :: F16=1.6d1,F8=8.d0 - -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) - real*8, dimension(ex(1),ex(2),ex(3)) :: reta -#endif - -#if (GAUGE == 6 || GAUGE == 7) - integer :: BHN,i,j,k - real*8, dimension(9) :: Porg - real*8, dimension(3) :: Mass - real*8 :: r1,r2,M,A,w1,w2,C1,C2 - real*8, dimension(ex(1),ex(2),ex(3)) :: reta - - call getpbh(BHN,Porg,Mass) -#endif - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = crho(2) - crho(1) - dY = sigma(2) - sigma(1) - dZ = R(2) - R(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - div_beta = betaxx + betayy + betazz - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - chi_rhs = F2o3 *chin1*( alpn1 * trK - div_beta ) !rhs for chi - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - if(co == 0)then -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gamx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gamy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gamz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - endif - - gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & - TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) - - gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & - TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) - - gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & - TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) - - gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & - gxx * betaxy + gxz * betazy + & - gyy * betayx + gyz * betazx & - - gxy * betazz - - gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & - gxy * betaxz + gyy * betayz + & - gxz * betaxy + gzz * betazy & - - gyz * betaxx - - gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & - gxx * betaxz + gxy * betayz + & - gyz * betayx + gzz * betazx & - - gxz * betayy !rhs for gij - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) -! Raise indices of \tilde A_{ij} and store in R_ij - - Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & - TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) - - Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & - TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) - - Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & - TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) - - Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & - (gupxx * gupyy + gupxy * gupxy)* Axy + & - (gupxx * gupyz + gupxz * gupxy)* Axz + & - (gupxy * gupyz + gupxz * gupyy)* Ayz - - Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & - (gupxx * gupyz + gupxy * gupxz)* Axy + & - (gupxx * gupzz + gupxz * gupxz)* Axz + & - (gupxy * gupzz + gupxz * gupyz)* Ayz - - Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & - (gupxy * gupyz + gupyy * gupxz)* Axy + & - (gupxy * gupzz + gupyz * gupxz)* Axz + & - (gupyy * gupzz + gupyz * gupyz)* Ayz - -! Right hand side for Gam^i without shift terms... - call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & - gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & - TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) - - Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & - gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & - TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) - - Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & - gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & - TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) - - call fdderivs_shc(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = gxxx + gxyy + gxzz - fxy = gxyx + gyyy + gyzz - fxz = gxzx + gyzy + gzzz - - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - - call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & - Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & - F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & - gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & - TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) - - Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & - Gamxa * betayx - Gamya * betayy - Gamza * betayz + & - F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & - gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & - TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) - - Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & - Gamxa * betazx - Gamya * betazy - Gamza * betazz + & - F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & - gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & - TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - call fdderivs_shc(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) -! Add chi part to Ricci tensor: - - Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO - -! covariant second derivatives of the lapse respect to physical metric - call fdderivs_shc(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - - fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz - fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz - fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz - fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz - fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz - fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz - -! store D^i D_i Lap in trK_rhs upto chi - trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) -! Add lapse and S_ij parts to Ricci tensor: - - fxx = alpn1 * (Rxx - EIGHT * PI * Sxx) - fxx - fxy = alpn1 * (Rxy - EIGHT * PI * Sxy) - fxy - fxz = alpn1 * (Rxz - EIGHT * PI * Sxz) - fxz - fyy = alpn1 * (Ryy - EIGHT * PI * Syy) - fyy - fyz = alpn1 * (Ryz - EIGHT * PI * Syz) - fyz - fzz = alpn1 * (Rzz - EIGHT * PI * Szz) - fzz - -! Compute trace-free part (note: chi^-1 and chi cancel!): - - f = F1o3 *( gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) ) - - Axx_rhs = fxx - gxx * f - Ayy_rhs = fyy - gyy * f - Azz_rhs = fzz - gzz * f - Axy_rhs = fxy - gxy * f - Axz_rhs = fxz - gxz * f - Ayz_rhs = fyz - gyz * f - -! Now: store A_il A^l_j into fij: - - fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) - fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) - fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) - fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy *(Axx * Ayy + Axy * Axy) + & - gupxz *(Axx * Ayz + Axz * Axy) + & - gupyz *(Axy * Ayz + Axz * Ayy) - fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy *(Axx * Ayz + Axy * Axz) + & - gupxz *(Axx * Azz + Axz * Axz) + & - gupyz *(Axy * Azz + Axz * Ayz) - fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy *(Axy * Ayz + Ayy * Axz) + & - gupxz *(Axy * Azz + Ayz * Axz) + & - gupyz *(Ayy * Azz + Ayz * Ayz) - - f = chin1 -! store D^i D_i Lap in trK_rhs - trK_rhs = f*trK_rhs - - Axx_rhs = f * Axx_rhs+ alpn1 * (trK * Axx - TWO * fxx) + & - TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx )- & - F2o3 * Axx * div_beta - - Ayy_rhs = f * Ayy_rhs+ alpn1 * (trK * Ayy - TWO * fyy) + & - TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy )- & - F2o3 * Ayy * div_beta - - Azz_rhs = f * Azz_rhs+ alpn1 * (trK * Azz - TWO * fzz) + & - TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz )- & - F2o3 * Azz * div_beta - - Axy_rhs = f * Axy_rhs+ alpn1 *( trK * Axy - TWO * fxy )+ & - Axx * betaxy + Axz * betazy + & - Ayy * betayx + Ayz * betazx + & - F1o3 * Axy * div_beta - Axy * betazz - - Ayz_rhs = f * Ayz_rhs+ alpn1 *( trK * Ayz - TWO * fyz )+ & - Axy * betaxz + Ayy * betayz + & - Axz * betaxy + Azz * betazy + & - F1o3 * Ayz * div_beta - Ayz * betaxx - - Axz_rhs = f * Axz_rhs+ alpn1 *( trK * Axz - TWO * fxz )+ & - Axx * betaxz + Axy * betayz + & - Ayz * betayx + Azz * betazx + & - F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij - -! Compute trace of S_ij - - S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & - TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) - - trK_rhs = - trK_rhs + alpn1 *( F1o3 * trK * trK + & - gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & - FOUR * PI * ( rho + S )) !rhs for trK - -!!!! gauge variable part - - Lap_rhs = -TWO*alpn1*trK - -#if (GAUGE == 0) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz -#elif (GAUGE == 1) - betax_rhs = Gamx - eta*betax - betay_rhs = Gamy - eta*betay - betaz_rhs = Gamz - eta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#elif (GAUGE == 2) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#elif (GAUGE == 3) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#elif (GAUGE == 4) - call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 - betax_rhs = FF*Gamx - reta*betax - betay_rhs = FF*Gamy - reta*betay - betaz_rhs = FF*Gamz - reta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#elif (GAUGE == 5) - call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & - TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) - reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 - betax_rhs = FF*Gamx - reta*betax - betay_rhs = FF*Gamy - reta*betay - betaz_rhs = FF*Gamz - reta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#elif (GAUGE == 6) - if(BHN==2)then - M = Mass(1)+Mass(2) - A = 2.d0/M - w1 = 1.2d1 - w2 = w1 - C1 = 1.d0/Mass(1) - A - C2 = 1.d0/Mass(2) - A - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - r1 = ((Porg(1)-X(i,j,k))**2+(Porg(2)-Y(i,j,k))**2+(Porg(3)-Z(i,j,k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - r2 = ((Porg(4)-X(i,j,k))**2+(Porg(5)-Y(i,j,k))**2+(Porg(6)-Z(i,j,k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - reta(i,j,k) = A + C1/(ONE+w1*r1) + C2/(ONE+w2*r2) - enddo - enddo - enddo - else - write(*,*) "not support BH_num in Jason's form 1",BHN - endif - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#elif (GAUGE == 7) - if(BHN==2)then - M = Mass(1)+Mass(2) - A = 2.d0/M - w1 = 1.2d1 - w2 = w1 - C1 = 1.d0/Mass(1) - A - C2 = 1.d0/Mass(2) - A - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - r1 = ((Porg(1)-X(i,j,k))**2+(Porg(2)-Y(i,j,k))**2+(Porg(3)-Z(i,j,k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - r2 = ((Porg(4)-X(i,j,k))**2+(Porg(5)-Y(i,j,k))**2+(Porg(6)-Z(i,j,k))**2)/ & - ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) - reta(i,j,k) = A + C1*dexp(-w1*r1) + C2*dexp(-w2*r2) - enddo - enddo - enddo - else - write(*,*) "not support BH_num in Jason's form 2",BHN - endif - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - reta*dtSfx - dtSfy_rhs = Gamy_rhs - reta*dtSfy - dtSfz_rhs = Gamz_rhs - reta*dtSfz -#endif - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term part -!g_ij - call fderivs_shc(ex,dxx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxx_rhs = gxx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gxy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxy_rhs = gxy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gxz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxz_rhs = gxz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dyy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gyy_rhs = gyy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gyz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gyz_rhs = gyz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dzz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gzz_rhs = gzz_rhs + betax*fxx+betay*fxy+betaz*fxz -!A_ij - call fderivs_shc(ex,Axx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axx_rhs = Axx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Axy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axy_rhs = Axy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Axz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axz_rhs = Axz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Ayy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Ayy_rhs = Ayy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Ayz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Ayz_rhs = Ayz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Azz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Azz_rhs = Azz_rhs + betax*fxx+betay*fxy+betaz*fxz -!chi and trK - call fderivs_shc(ex,chi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - chi_rhs = chi_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,trK,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - trK_rhs = trK_rhs + betax*fxx+betay*fxy+betaz*fxz -!Gam^i - call fderivs_shc(ex,Gamx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamx_rhs = Gamx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Gamy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamy_rhs = Gamy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Gamz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamz_rhs = Gamz_rhs + betax*fxx+betay*fxy+betaz*fxz -!gauge variables - call fderivs_shc(ex,Lap,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Lap_rhs = Lap_rhs + betax*fxx+betay*fxy+betaz*fxz - -#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - call fderivs_shc(ex,betax,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betax_rhs = betax_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betay,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betay_rhs = betay_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betaz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betaz_rhs = betaz_rhs + betax*fxx+betay*fxy+betaz*fxz -#endif - -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - call fderivs_shc(ex,dtSfx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfx_rhs = dtSfx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfy_rhs = dtSfy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfz_rhs = dtSfz_rhs + betax*fxx+betay*fxy+betaz*fxz -#endif - - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) - -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) -#endif - - endif - - if(co == 0)then -! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho - -! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - - call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - -movx_Res = movx_Res - F2o3*Kx - F8*PI*sx -movy_Res = movy_Res - F2o3*Ky - F8*PI*sy -movz_Res = movz_Res - F2o3*Kz - F8*PI*sz - endif - -#if (ABV == 1) - call ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,Lev,sst) - call constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res,movx_Res,movy_Res,movz_Res,Gmx_Res,Gmy_Res,Gmz_Res, & - Symmetry,Lev,sst) -#endif - - gont = 0 - - return - - end function compute_rhs_bssn_ss + + +#include "macrodef.fh" + + function compute_rhs_bssn_ss(ex, T,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, & + Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry,Lev,eps,sst,co) result(gont) +! calculate constraint violation when co=0 + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co + real*8, intent(in ):: T + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8,intent(in) :: eps + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ZEO = 0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + double precision,parameter::FF = 0.75d0,eta=2.d0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + real*8, parameter :: F16=1.6d1,F8=8.d0 + +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) + real*8, dimension(ex(1),ex(2),ex(3)) :: reta +#endif + +#if (GAUGE == 6 || GAUGE == 7) + integer :: BHN,i,j,k + real*8, dimension(9) :: Porg + real*8, dimension(3) :: Mass + real*8 :: r1,r2,M,A,w1,w2,C1,C2 + real*8, dimension(ex(1),ex(2),ex(3)) :: reta + + call getpbh(BHN,Porg,Mass) +#endif + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = crho(2) - crho(1) + dY = sigma(2) - sigma(1) + dZ = R(2) - R(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + div_beta = betaxx + betayy + betazz + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + chi_rhs = F2o3 *chin1*( alpn1 * trK - div_beta ) !rhs for chi + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + if(co == 0)then +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gamx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gamy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gamz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + endif + + gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & + TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) + + gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & + TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) + + gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & + TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) + + gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & + gxx * betaxy + gxz * betazy + & + gyy * betayx + gyz * betazx & + - gxy * betazz + + gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & + gxy * betaxz + gyy * betayz + & + gxz * betaxy + gzz * betazy & + - gyz * betaxx + + gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & + gxx * betaxz + gxy * betayz + & + gyz * betayx + gzz * betazx & + - gxz * betayy !rhs for gij + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) +! Raise indices of \tilde A_{ij} and store in R_ij + + Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & + TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) + + Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & + TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) + + Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & + TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) + + Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & + (gupxx * gupyy + gupxy * gupxy)* Axy + & + (gupxx * gupyz + gupxz * gupxy)* Axz + & + (gupxy * gupyz + gupxz * gupyy)* Ayz + + Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & + (gupxx * gupyz + gupxy * gupxz)* Axy + & + (gupxx * gupzz + gupxz * gupxz)* Axz + & + (gupxy * gupzz + gupxz * gupyz)* Ayz + + Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & + (gupxy * gupyz + gupyy * gupxz)* Axy + & + (gupxy * gupzz + gupyz * gupxz)* Axz + & + (gupyy * gupzz + gupyz * gupyz)* Ayz + +! Right hand side for Gam^i without shift terms... + call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & + gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & + TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) + + Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & + gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & + TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) + + Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & + gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & + TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) + + call fdderivs_shc(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = gxxx + gxyy + gxzz + fxy = gxyx + gyyy + gyzz + fxz = gxzx + gyzy + gzzz + + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + + call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & + Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & + F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & + gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & + TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) + + Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & + Gamxa * betayx - Gamya * betayy - Gamza * betayz + & + F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & + gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & + TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) + + Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & + Gamxa * betazx - Gamya * betazy - Gamza * betazz + & + F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & + gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & + TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + call fdderivs_shc(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) +! Add chi part to Ricci tensor: + + Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO + +! covariant second derivatives of the lapse respect to physical metric + call fdderivs_shc(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + + fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz + fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz + fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz + fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz + fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz + fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz + +! store D^i D_i Lap in trK_rhs upto chi + trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) +! Add lapse and S_ij parts to Ricci tensor: + + fxx = alpn1 * (Rxx - EIGHT * PI * Sxx) - fxx + fxy = alpn1 * (Rxy - EIGHT * PI * Sxy) - fxy + fxz = alpn1 * (Rxz - EIGHT * PI * Sxz) - fxz + fyy = alpn1 * (Ryy - EIGHT * PI * Syy) - fyy + fyz = alpn1 * (Ryz - EIGHT * PI * Syz) - fyz + fzz = alpn1 * (Rzz - EIGHT * PI * Szz) - fzz + +! Compute trace-free part (note: chi^-1 and chi cancel!): + + f = F1o3 *( gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) ) + + Axx_rhs = fxx - gxx * f + Ayy_rhs = fyy - gyy * f + Azz_rhs = fzz - gzz * f + Axy_rhs = fxy - gxy * f + Axz_rhs = fxz - gxz * f + Ayz_rhs = fyz - gyz * f + +! Now: store A_il A^l_j into fij: + + fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) + fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) + fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) + fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy *(Axx * Ayy + Axy * Axy) + & + gupxz *(Axx * Ayz + Axz * Axy) + & + gupyz *(Axy * Ayz + Axz * Ayy) + fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy *(Axx * Ayz + Axy * Axz) + & + gupxz *(Axx * Azz + Axz * Axz) + & + gupyz *(Axy * Azz + Axz * Ayz) + fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy *(Axy * Ayz + Ayy * Axz) + & + gupxz *(Axy * Azz + Ayz * Axz) + & + gupyz *(Ayy * Azz + Ayz * Ayz) + + f = chin1 +! store D^i D_i Lap in trK_rhs + trK_rhs = f*trK_rhs + + Axx_rhs = f * Axx_rhs+ alpn1 * (trK * Axx - TWO * fxx) + & + TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx )- & + F2o3 * Axx * div_beta + + Ayy_rhs = f * Ayy_rhs+ alpn1 * (trK * Ayy - TWO * fyy) + & + TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy )- & + F2o3 * Ayy * div_beta + + Azz_rhs = f * Azz_rhs+ alpn1 * (trK * Azz - TWO * fzz) + & + TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz )- & + F2o3 * Azz * div_beta + + Axy_rhs = f * Axy_rhs+ alpn1 *( trK * Axy - TWO * fxy )+ & + Axx * betaxy + Axz * betazy + & + Ayy * betayx + Ayz * betazx + & + F1o3 * Axy * div_beta - Axy * betazz + + Ayz_rhs = f * Ayz_rhs+ alpn1 *( trK * Ayz - TWO * fyz )+ & + Axy * betaxz + Ayy * betayz + & + Axz * betaxy + Azz * betazy + & + F1o3 * Ayz * div_beta - Ayz * betaxx + + Axz_rhs = f * Axz_rhs+ alpn1 *( trK * Axz - TWO * fxz )+ & + Axx * betaxz + Axy * betayz + & + Ayz * betayx + Azz * betazx + & + F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij + +! Compute trace of S_ij + + S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & + TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) + + trK_rhs = - trK_rhs + alpn1 *( F1o3 * trK * trK + & + gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & + FOUR * PI * ( rho + S )) !rhs for trK + +!!!! gauge variable part + + Lap_rhs = -TWO*alpn1*trK + +#if (GAUGE == 0) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz +#elif (GAUGE == 1) + betax_rhs = Gamx - eta*betax + betay_rhs = Gamy - eta*betay + betaz_rhs = Gamz - eta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#elif (GAUGE == 2) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#elif (GAUGE == 3) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#elif (GAUGE == 4) + call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-dsqrt(chin1))**2 + betax_rhs = FF*Gamx - reta*betax + betay_rhs = FF*Gamy - reta*betay + betaz_rhs = FF*Gamz - reta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#elif (GAUGE == 5) + call fderivs_shc(ex,chi,dtSfx_rhs,dtSfy_rhs,dtSfz_rhs,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + reta = gupxx * dtSfx_rhs * dtSfx_rhs + gupyy * dtSfy_rhs * dtSfy_rhs + gupzz * dtSfz_rhs * dtSfz_rhs + & + TWO * (gupxy * dtSfx_rhs * dtSfy_rhs + gupxz * dtSfx_rhs * dtSfz_rhs + gupyz * dtSfy_rhs * dtSfz_rhs) + reta = 1.31d0/2*dsqrt(reta/chin1)/(1-chin1)**2 + betax_rhs = FF*Gamx - reta*betax + betay_rhs = FF*Gamy - reta*betay + betaz_rhs = FF*Gamz - reta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#elif (GAUGE == 6) + if(BHN==2)then + M = Mass(1)+Mass(2) + A = 2.d0/M + w1 = 1.2d1 + w2 = w1 + C1 = 1.d0/Mass(1) - A + C2 = 1.d0/Mass(2) - A + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + r1 = ((Porg(1)-X(i,j,k))**2+(Porg(2)-Y(i,j,k))**2+(Porg(3)-Z(i,j,k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + r2 = ((Porg(4)-X(i,j,k))**2+(Porg(5)-Y(i,j,k))**2+(Porg(6)-Z(i,j,k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + reta(i,j,k) = A + C1/(ONE+w1*r1) + C2/(ONE+w2*r2) + enddo + enddo + enddo + else + write(*,*) "not support BH_num in Jason's form 1",BHN + endif + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#elif (GAUGE == 7) + if(BHN==2)then + M = Mass(1)+Mass(2) + A = 2.d0/M + w1 = 1.2d1 + w2 = w1 + C1 = 1.d0/Mass(1) - A + C2 = 1.d0/Mass(2) - A + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + r1 = ((Porg(1)-X(i,j,k))**2+(Porg(2)-Y(i,j,k))**2+(Porg(3)-Z(i,j,k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + r2 = ((Porg(4)-X(i,j,k))**2+(Porg(5)-Y(i,j,k))**2+(Porg(6)-Z(i,j,k))**2)/ & + ((Porg(1)-Porg(4))**2+(Porg(2)-Porg(5))**2+(Porg(3)-Porg(6))**2) + reta(i,j,k) = A + C1*dexp(-w1*r1) + C2*dexp(-w2*r2) + enddo + enddo + enddo + else + write(*,*) "not support BH_num in Jason's form 2",BHN + endif + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - reta*dtSfx + dtSfy_rhs = Gamy_rhs - reta*dtSfy + dtSfz_rhs = Gamz_rhs - reta*dtSfz +#endif + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term part +!g_ij + call fderivs_shc(ex,dxx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxx_rhs = gxx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gxy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxy_rhs = gxy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gxz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxz_rhs = gxz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dyy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gyy_rhs = gyy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gyz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gyz_rhs = gyz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dzz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gzz_rhs = gzz_rhs + betax*fxx+betay*fxy+betaz*fxz +!A_ij + call fderivs_shc(ex,Axx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axx_rhs = Axx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Axy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axy_rhs = Axy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Axz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axz_rhs = Axz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Ayy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Ayy_rhs = Ayy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Ayz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Ayz_rhs = Ayz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Azz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Azz_rhs = Azz_rhs + betax*fxx+betay*fxy+betaz*fxz +!chi and trK + call fderivs_shc(ex,chi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + chi_rhs = chi_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,trK,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + trK_rhs = trK_rhs + betax*fxx+betay*fxy+betaz*fxz +!Gam^i + call fderivs_shc(ex,Gamx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamx_rhs = Gamx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Gamy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamy_rhs = Gamy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Gamz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamz_rhs = Gamz_rhs + betax*fxx+betay*fxy+betaz*fxz +!gauge variables + call fderivs_shc(ex,Lap,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Lap_rhs = Lap_rhs + betax*fxx+betay*fxy+betaz*fxz + +#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + call fderivs_shc(ex,betax,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betax_rhs = betax_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betay,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betay_rhs = betay_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betaz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betaz_rhs = betaz_rhs + betax*fxx+betay*fxy+betaz*fxz +#endif + +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + call fderivs_shc(ex,dtSfx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfx_rhs = dtSfx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfy_rhs = dtSfy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfz_rhs = dtSfz_rhs + betax*fxx+betay*fxy+betaz*fxz +#endif + + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) + +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) +#endif + + endif + + if(co == 0)then +! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho + +! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + + call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + +movx_Res = movx_Res - F2o3*Kx - F8*PI*sx +movy_Res = movy_Res - F2o3*Ky - F8*PI*sy +movz_Res = movz_Res - F2o3*Kz - F8*PI*sz + endif + +#if (ABV == 1) + call ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,Lev,sst) + call constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res,movx_Res,movy_Res,movz_Res,Gmx_Res,Gmy_Res,Gmz_Res, & + Symmetry,Lev,sst) +#endif + + gont = 0 + + return + + end function compute_rhs_bssn_ss diff --git a/AMSS_NCKU_source/empart.f90 b/AMSS_NCKU_source/BSSN/empart.f90 similarity index 98% rename from AMSS_NCKU_source/empart.f90 rename to AMSS_NCKU_source/BSSN/empart.f90 index c29e80e..ee08c6f 100644 --- a/AMSS_NCKU_source/empart.f90 +++ b/AMSS_NCKU_source/BSSN/empart.f90 @@ -1,610 +1,610 @@ - -!including advection term in this routine - function compute_rhs_empart(ext, X, Y, Z, & - chi , dxx , dxy , dxz , dyy , dyz , dzz,& - Lap , betax , betay , betaz , trK, & - Ex, Ey, Ez, Bx, By, Bz, Kpsi, Kphi,Jx,Jy,Jz,qchar, & - Ex_rhs, Ey_rhs, Ez_rhs, Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs, & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Symmetry,Lev,eps) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ext(1:3), Symmetry,Lev - real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3)) - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Jx,Jy,Jz,qchar - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,dxy,dxz,dyy,dyz,dzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Lap, betax, betay, betaz, trK - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Ex_rhs, Ey_rhs, Ez_rhs - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: rho,Sx,Sy,Sz - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Sxx,Sxy,Sxz,Syy,Syz,Szz - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz,gxy,gxz,gyz - real*8, dimension(ext(1),ext(2),ext(3)) :: chix,chiy,chiz,chi3o2 - real*8, dimension(ext(1),ext(2),ext(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ext(1),ext(2),ext(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ext(1),ext(2),ext(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ext(1),ext(2),ext(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ext(1),ext(2),ext(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ext(1),ext(2),ext(3)) :: betayx,betayy,betayz - real*8, dimension(ext(1),ext(2),ext(3)) :: betazx,betazy,betazz - real*8, dimension(ext(1),ext(2),ext(3)) :: alpn1,chin1 - real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ext(1),ext(2),ext(3)) :: Exx,Exy,Exz,Eyx,Eyy,Eyz,Ezx,Ezy,Ezz - real*8, dimension(ext(1),ext(2),ext(3)) :: Bxx,Bxy,Bxz,Byx,Byy,Byz,Bzx,Bzy,Bzz - real*8, dimension(ext(1),ext(2),ext(3)) :: Kpsix,Kpsiy,Kpsiz - real*8, dimension(ext(1),ext(2),ext(3)) :: Kphix,Kphiy,Kphiz - real*8, dimension(ext(1),ext(2),ext(3)) :: lEx,lEy,lEz,lBx,lBy,lBz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: F3o2=1.5d0,EIT=8.d0 - real*8,parameter :: kappa = 1.d0 -!!! sanity check - dX = sum(Ex)+sum(Ey)+sum(Ez)+sum(Bx)+sum(By)+sum(Bz)+sum(Kpsi)+sum(Kphi) - if(dX.ne.dX) then - if(sum(Ex).ne.sum(Ex))write(*,*)"empart.f90: find NaN in Ex" - if(sum(Ey).ne.sum(Ey))write(*,*)"empart.f90: find NaN in Ey" - if(sum(Ez).ne.sum(Ez))write(*,*)"empart.f90: find NaN in Ez" - if(sum(Bx).ne.sum(Bx))write(*,*)"empart.f90: find NaN in Bx" - if(sum(By).ne.sum(By))write(*,*)"empart.f90: find NaN in By" - if(sum(Bz).ne.sum(Bz))write(*,*)"empart.f90: find NaN in Bz" - if(sum(Kpsi).ne.sum(Kpsi))write(*,*)"empart.f90: find NaN in Kpsi" - if(sum(Kphi).ne.sum(Kphi))write(*,*)"empart.f90: find NaN in Kphi" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - chi3o2 = dsqrt(chin1)**3 - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - gxy = dxy - gxz = dxz - gyz = dyz - - call fderivs(ext,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - call fderivs(ext,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fderivs(ext,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fderivs(ext,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - - call fderivs(ext,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - - call fderivs(ext,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - call fderivs(ext,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) - call fderivs(ext,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) - call fderivs(ext,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - call fderivs(ext,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) - call fderivs(ext,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - - call fderivs(ext,Kpsi,Kpsix,Kpsiy,Kpsiz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - call fderivs(ext,Kphi,Kphix,Kphiy,Kphiz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - - call fderivs(ext,Ex,Exx,Exy,Exz,X,Y,Z,ANTI,SYM,SYM ,Symmetry,Lev) - call fderivs(ext,Ey,Eyx,Eyy,Eyz,X,Y,Z,SYM,ANTI,SYM ,Symmetry,Lev) - call fderivs(ext,Ez,Ezx,Ezy,Ezz,X,Y,Z,SYM,SYM,ANTI ,Symmetry,Lev) - - call fderivs(ext,Bx,Bxx,Bxy,Bxz,X,Y,Z,SYM,ANTI,ANTI ,Symmetry,Lev) - call fderivs(ext,By,Byx,Byy,Byz,X,Y,Z,ANTI,SYM,ANTI ,Symmetry,Lev) - call fderivs(ext,Bz,Bzx,Bzy,Bzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) - -! physical gij - gxx = gxx/chin1 - gxy = gxy/chin1 - gxz = gxz/chin1 - gyy = gyy/chin1 - gyz = gyz/chin1 - gzz = gzz/chin1 -!physical gij,k - gxxx = (gxxx-gxx*chix)/chin1 - gxxy = (gxxy-gxx*chiy)/chin1 - gxxz = (gxxz-gxx*chiz)/chin1 - gxyx = (gxyx-gxy*chix)/chin1 - gxyy = (gxyy-gxy*chiy)/chin1 - gxyz = (gxyz-gxy*chiz)/chin1 - gxzx = (gxzx-gxz*chix)/chin1 - gxzy = (gxzy-gxz*chiy)/chin1 - gxzz = (gxzz-gxz*chiz)/chin1 - gyyx = (gyyx-gyy*chix)/chin1 - gyyy = (gyyy-gyy*chiy)/chin1 - gyyz = (gyyz-gyy*chiz)/chin1 - gyzx = (gyzx-gyz*chix)/chin1 - gyzy = (gyzy-gyz*chiy)/chin1 - gyzz = (gyzz-gyz*chiz)/chin1 - gzzx = (gzzx-gzz*chix)/chin1 - gzzy = (gzzy-gzz*chiy)/chin1 - gzzz = (gzzz-gzz*chiz)/chin1 - -! physical inverse metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - Ex_rhs = alpn1*trK*Ex-(Ex*betaxx+Ey*betaxy+Ez*betaxz) & - -FOUR*PI*alpn1*Jx-alpn1*(gupxx*Kpsix+gupxy*Kpsiy+gupxz*Kpsiz) & - +chi3o2*( & - ((gxz*Bx+gyz*By+gzz*Bz)*Lapy+alpn1*(gxz*Bxy+gyz*Byy+gzz*Bzy)+alpn1*(Bx*gxzy+By*gyzy+Bz*gzzy))-& - ((gxy*Bx+gyy*By+gyz*Bz)*Lapz+alpn1*(gxy*Bxz+gyy*Byz+gyz*Bzz)+alpn1*(Bx*gxyz+By*gyyz+Bz*gyzz))) - Ey_rhs = alpn1*trK*Ey-(Ex*betayx+Ey*betayy+Ez*betayz) & - -FOUR*PI*alpn1*Jy-alpn1*(gupxy*Kpsix+gupyy*Kpsiy+gupyz*Kpsiz) & - +chi3o2*( & - ((gxx*Bx+gxy*By+gxz*Bz)*Lapz+alpn1*(gxx*Bxz+gxy*Byz+gxz*Bzz)+alpn1*(Bx*gxxz+By*gxyz+Bz*gxzz))-& - ((gxz*Bx+gyz*By+gzz*Bz)*Lapx+alpn1*(gxz*Bxx+gyz*Byx+gzz*Bzx)+alpn1*(Bx*gxzx+By*gyzx+Bz*gzzx))) - Ez_rhs = alpn1*trK*Ez-(Ex*betazx+Ey*betazy+Ez*betazz) & - -FOUR*PI*alpn1*Jz-alpn1*(gupxz*Kpsix+gupyz*Kpsiy+gupzz*Kpsiz) & - +chi3o2*( & - ((gxy*Bx+gyy*By+gyz*Bz)*Lapx+alpn1*(gxy*Bxx+gyy*Byx+gyz*Bzx)+alpn1*(Bx*gxyx+By*gyyx+Bz*gyzx))-& - ((gxx*Bx+gxy*By+gxz*Bz)*Lapy+alpn1*(gxx*Bxy+gxy*Byy+gxz*Bzy)+alpn1*(Bx*gxxy+By*gxyy+Bz*gxzy))) - - Bx_rhs = alpn1*trK*Bx-(Bx*betaxx+By*betaxy+Bz*betaxz) & - -alpn1*(gupxx*Kphix+gupxy*Kphiy+gupxz*Kphiz) & - -chi3o2*( & - ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapy+alpn1*(gxz*Exy+gyz*Eyy+gzz*Ezy)+alpn1*(Ex*gxzy+Ey*gyzy+Ez*gzzy))-& - ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapz+alpn1*(gxy*Exz+gyy*Eyz+gyz*Ezz)+alpn1*(Ex*gxyz+Ey*gyyz+Ez*gyzz))) - By_rhs = alpn1*trK*By-(Bx*betayx+By*betayy+Bz*betayz) & - -alpn1*(gupxy*Kphix+gupyy*Kphiy+gupyz*Kphiz) & - -chi3o2*( & - ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapz+alpn1*(gxx*Exz+gxy*Eyz+gxz*Ezz)+alpn1*(Ex*gxxz+Ey*gxyz+Ez*gxzz))-& - ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapx+alpn1*(gxz*Exx+gyz*Eyx+gzz*Ezx)+alpn1*(Ex*gxzx+Ey*gyzx+Ez*gzzx))) - Bz_rhs = alpn1*trK*Bz-(Bx*betazx+By*betazy+Bz*betazz) & - -alpn1*(gupxz*Kphix+gupyz*Kphiy+gupzz*Kphiz) & - -chi3o2*( & - ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapx+alpn1*(gxy*Exx+gyy*Eyx+gyz*Ezx)+alpn1*(Ex*gxyx+Ey*gyyx+Ez*gyzx))-& - ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapy+alpn1*(gxx*Exy+gxy*Eyy+gxz*Ezy)+alpn1*(Ex*gxxy+Ey*gxyy+Ez*gxzy))) - - Kpsi_rhs = FOUR*PI*alpn1*qchar-alpn1*kappa*Kpsi - & - alpn1*(Exx+Eyy+Ezz-F3o2/chin1*(chix*Ex+chiy*Ey+chiz*Ez)) - Kphi_rhs = -alpn1*kappa*Kphi - & - alpn1*(Bxx+Byy+Bzz-F3o2/chin1*(chix*Bx+chiy*By+chiz*Bz)) - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term part - call lopsided(ext,X,Y,Z,KPsi,KPsi_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ext,X,Y,Z,KPhi,KPhi_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ext,X,Y,Z,Ex,Ex_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ext,X,Y,Z,Ey,Ey_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ext,X,Y,Z,Ez,Ez_rhs,betax,betay,betaz,Symmetry,SSA) - - call lopsided(ext,X,Y,Z,Bx,Bx_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ext,X,Y,Z,By,By_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ext,X,Y,Z,Bz,Bz_rhs,betax,betay,betaz,Symmetry,AAS) - -! numerical dissipation part - if(eps>0)then -! usual Kreiss-Oliger dissipation - - call kodis(ext,X,Y,Z,Kpsi,Kpsi_rhs,SSS,Symmetry,eps) - call kodis(ext,X,Y,Z,Kphi,Kphi_rhs,SSS,Symmetry,eps) - call kodis(ext,X,Y,Z,Ex,Ex_rhs,ASS,Symmetry,eps) - call kodis(ext,X,Y,Z,Ey,Ey_rhs,SAS,Symmetry,eps) - call kodis(ext,X,Y,Z,Ez,Ez_rhs,SSA,Symmetry,eps) - call kodis(ext,X,Y,Z,Bx,Bx_rhs,SAA,Symmetry,eps) - call kodis(ext,X,Y,Z,By,By_rhs,ASA,Symmetry,eps) - call kodis(ext,X,Y,Z,Bz,Bz_rhs,AAS,Symmetry,eps) - - endif -! stress-energy tensor - rho = (gxx*(Ex*Ex+Bx*Bx)+gyy*(Ey*Ey+By*By)+gzz*(Ez*Ez+Bz*Bz) + & - +TWO*(gxy*(Ex*Ey+Bx*By)+gxz*(Ex*Ez+Bx*Bz)+gyz*(Ey*Ez+By*Bz)))/EIT/PI - Sx = (Ey*Bz-Ez*By)/FOUR/PI/chi3o2 - Sy = (Ez*Bx-Ex*Bz)/FOUR/PI/chi3o2 - Sz = (Ex*By-Ey*Bx)/FOUR/PI/chi3o2 - lEx = gxx*Ex+gxy*Ey+gxz*Ez - lEy = gxy*Ex+gyy*Ey+gyz*Ez - lEz = gxz*Ex+gyz*Ey+gzz*Ez - lBx = gxx*Bx+gxy*By+gxz*Bz - lBy = gxy*Bx+gyy*By+gyz*Bz - lBz = gxz*Bx+gyz*By+gzz*Bz - Sxx = rho*gxx-(lEx*lEx+lBx*lBx)/FOUR/PI - Sxy = rho*gxy-(lEx*lEy+lBx*lBy)/FOUR/PI - Sxz = rho*gxz-(lEx*lEz+lBx*lBz)/FOUR/PI - Syy = rho*gyy-(lEy*lEy+lBy*lBy)/FOUR/PI - Syz = rho*gyz-(lEy*lEz+lBy*lBz)/FOUR/PI - Szz = rho*gzz-(lEz*lEz+lBz*lBz)/FOUR/PI - - gont = 0 - - return - - end function compute_rhs_empart -!including advection term in this routine -! for shell - function compute_rhs_empart_ss(ext,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi , dxx , dxy , dxz , dyy , dyz , dzz,& - Lap , betax , betay , betaz , trK, & - Ex, Ey, Ez, Bx, By, Bz, Kpsi, Kphi,Jx,Jy,Jz,qchar, & - Ex_rhs, Ey_rhs, Ez_rhs, Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs, & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Symmetry,Lev,eps,sst) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ext(1:3), Symmetry,Lev,sst - double precision,intent(in),dimension(ext(1))::crho - double precision,intent(in),dimension(ext(2))::sigma - double precision,intent(in),dimension(ext(3))::R - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::x,y,z - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Jx,Jy,Jz,qchar - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,dxy,dxz,dyy,dyz,dzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Lap, betax, betay, betaz, trK - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Ex_rhs, Ey_rhs, Ez_rhs - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: rho,Sx,Sy,Sz - real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Sxx,Sxy,Sxz,Syy,Syz,Szz - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz,gxy,gxz,gyz - real*8, dimension(ext(1),ext(2),ext(3)) :: chix,chiy,chiz,chi3o2 - real*8, dimension(ext(1),ext(2),ext(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ext(1),ext(2),ext(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ext(1),ext(2),ext(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ext(1),ext(2),ext(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ext(1),ext(2),ext(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ext(1),ext(2),ext(3)) :: betayx,betayy,betayz - real*8, dimension(ext(1),ext(2),ext(3)) :: betazx,betazy,betazz - real*8, dimension(ext(1),ext(2),ext(3)) :: alpn1,chin1 - real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ext(1),ext(2),ext(3)) :: Exx,Exy,Exz,Eyx,Eyy,Eyz,Ezx,Ezy,Ezz - real*8, dimension(ext(1),ext(2),ext(3)) :: Bxx,Bxy,Bxz,Byx,Byy,Byz,Bzx,Bzy,Bzz - real*8, dimension(ext(1),ext(2),ext(3)) :: Kpsix,Kpsiy,Kpsiz - real*8, dimension(ext(1),ext(2),ext(3)) :: Kphix,Kphiy,Kphiz - real*8, dimension(ext(1),ext(2),ext(3)) :: lEx,lEy,lEz,lBx,lBy,lBz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: F3o2=1.5d0,EIT=8.d0 - real*8,parameter :: kappa = 1.d0 - -!!! sanity check - dX = sum(Ex)+sum(Ey)+sum(Ez)+sum(Bx)+sum(By)+sum(Bz)+sum(Kpsi)+sum(Kphi) - if(dX.ne.dX) then - if(sum(Ex).ne.sum(Ex))write(*,*)"empart.f90: find NaN in Ex" - if(sum(Ey).ne.sum(Ey))write(*,*)"empart.f90: find NaN in Ey" - if(sum(Ez).ne.sum(Ez))write(*,*)"empart.f90: find NaN in Ez" - if(sum(Bx).ne.sum(Bx))write(*,*)"empart.f90: find NaN in Bx" - if(sum(By).ne.sum(By))write(*,*)"empart.f90: find NaN in By" - if(sum(Bz).ne.sum(Bz))write(*,*)"empart.f90: find NaN in Bz" - if(sum(Kpsi).ne.sum(Kpsi))write(*,*)"empart.f90: find NaN in Kpsi" - if(sum(Kphi).ne.sum(Kphi))write(*,*)"empart.f90: find NaN in Kphi" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = crho(2) - crho(1) - dY = sigma(2) - sigma(1) - dZ = R(2) - R(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - chi3o2 = dsqrt(chin1)**3 - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - gxy = dxy - gxz = dxz - gyz = dyz - - call fderivs_shc(ext,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ext,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ext,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ext,Kpsi,Kpsix,Kpsiy,Kpsiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,Kphi,Kphix,Kphiy,Kphiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ext,Ex,Exx,Exy,Exz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,Ey,Eyx,Eyy,Eyz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,Ez,Ezx,Ezy,Ezz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -#if 1 - call fderivs_shc(ext,Bx,Bxx,Bxy,Bxz,crho,sigma,R, SYM,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,By,Byx,Byy,Byz,crho,sigma,R,ANTI, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,Bz,Bzx,Bzy,Bzz,crho,sigma,R,ANTI,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -#else - call fderivs_shc(ext,Bx,Bxx,Bxy,Bxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,By,Byx,Byy,Byz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ext,Bz,Bzx,Bzy,Bzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -#endif -! check axal vector -! physical gij - gxx = gxx/chin1 - gxy = gxy/chin1 - gxz = gxz/chin1 - gyy = gyy/chin1 - gyz = gyz/chin1 - gzz = gzz/chin1 -!physical gij,k - gxxx = (gxxx-gxx*chix)/chin1 - gxxy = (gxxy-gxx*chiy)/chin1 - gxxz = (gxxz-gxx*chiz)/chin1 - gxyx = (gxyx-gxy*chix)/chin1 - gxyy = (gxyy-gxy*chiy)/chin1 - gxyz = (gxyz-gxy*chiz)/chin1 - gxzx = (gxzx-gxz*chix)/chin1 - gxzy = (gxzy-gxz*chiy)/chin1 - gxzz = (gxzz-gxz*chiz)/chin1 - gyyx = (gyyx-gyy*chix)/chin1 - gyyy = (gyyy-gyy*chiy)/chin1 - gyyz = (gyyz-gyy*chiz)/chin1 - gyzx = (gyzx-gyz*chix)/chin1 - gyzy = (gyzy-gyz*chiy)/chin1 - gyzz = (gyzz-gyz*chiz)/chin1 - gzzx = (gzzx-gzz*chix)/chin1 - gzzy = (gzzy-gzz*chiy)/chin1 - gzzz = (gzzz-gzz*chiz)/chin1 - -! physical inverse metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - Ex_rhs = alpn1*trK*Ex-(Ex*betaxx+Ey*betaxy+Ez*betaxz) & - -FOUR*PI*alpn1*Jx-alpn1*(gupxx*Kpsix+gupxy*Kpsiy+gupxz*Kpsiz) & - +chi3o2*( & - ((gxz*Bx+gyz*By+gzz*Bz)*Lapy+alpn1*(gxz*Bxy+gyz*Byy+gzz*Bzy)+alpn1*(Bx*gxzy+By*gyzy+Bz*gzzy))-& - ((gxy*Bx+gyy*By+gyz*Bz)*Lapz+alpn1*(gxy*Bxz+gyy*Byz+gyz*Bzz)+alpn1*(Bx*gxyz+By*gyyz+Bz*gyzz))) - Ey_rhs = alpn1*trK*Ey-(Ex*betayx+Ey*betayy+Ez*betayz) & - -FOUR*PI*alpn1*Jy-alpn1*(gupxy*Kpsix+gupyy*Kpsiy+gupyz*Kpsiz) & - +chi3o2*( & - ((gxx*Bx+gxy*By+gxz*Bz)*Lapz+alpn1*(gxx*Bxz+gxy*Byz+gxz*Bzz)+alpn1*(Bx*gxxz+By*gxyz+Bz*gxzz))-& - ((gxz*Bx+gyz*By+gzz*Bz)*Lapx+alpn1*(gxz*Bxx+gyz*Byx+gzz*Bzx)+alpn1*(Bx*gxzx+By*gyzx+Bz*gzzx))) - Ez_rhs = alpn1*trK*Ez-(Ex*betazx+Ey*betazy+Ez*betazz) & - -FOUR*PI*alpn1*Jz-alpn1*(gupxz*Kpsix+gupyz*Kpsiy+gupzz*Kpsiz) & - +chi3o2*( & - ((gxy*Bx+gyy*By+gyz*Bz)*Lapx+alpn1*(gxy*Bxx+gyy*Byx+gyz*Bzx)+alpn1*(Bx*gxyx+By*gyyx+Bz*gyzx))-& - ((gxx*Bx+gxy*By+gxz*Bz)*Lapy+alpn1*(gxx*Bxy+gxy*Byy+gxz*Bzy)+alpn1*(Bx*gxxy+By*gxyy+Bz*gxzy))) - - Bx_rhs = alpn1*trK*Bx-(Bx*betaxx+By*betaxy+Bz*betaxz) & - -alpn1*(gupxx*Kphix+gupxy*Kphiy+gupxz*Kphiz) & - -chi3o2*( & - ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapy+alpn1*(gxz*Exy+gyz*Eyy+gzz*Ezy)+alpn1*(Ex*gxzy+Ey*gyzy+Ez*gzzy))-& - ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapz+alpn1*(gxy*Exz+gyy*Eyz+gyz*Ezz)+alpn1*(Ex*gxyz+Ey*gyyz+Ez*gyzz))) - By_rhs = alpn1*trK*By-(Bx*betayx+By*betayy+Bz*betayz) & - -alpn1*(gupxy*Kphix+gupyy*Kphiy+gupyz*Kphiz) & - -chi3o2*( & - ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapz+alpn1*(gxx*Exz+gxy*Eyz+gxz*Ezz)+alpn1*(Ex*gxxz+Ey*gxyz+Ez*gxzz))-& - ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapx+alpn1*(gxz*Exx+gyz*Eyx+gzz*Ezx)+alpn1*(Ex*gxzx+Ey*gyzx+Ez*gzzx))) - Bz_rhs = alpn1*trK*Bz-(Bx*betazx+By*betazy+Bz*betazz) & - -alpn1*(gupxz*Kphix+gupyz*Kphiy+gupzz*Kphiz) & - -chi3o2*( & - ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapx+alpn1*(gxy*Exx+gyy*Eyx+gyz*Ezx)+alpn1*(Ex*gxyx+Ey*gyyx+Ez*gyzx))-& - ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapy+alpn1*(gxx*Exy+gxy*Eyy+gxz*Ezy)+alpn1*(Ex*gxxy+Ey*gxyy+Ez*gxzy))) - - Kpsi_rhs = FOUR*PI*alpn1*qchar-alpn1*kappa*Kpsi - & - alpn1*(Exx+Eyy+Ezz-F3o2/chin1*(chix*Ex+chiy*Ey+chiz*Ez)) - Kphi_rhs = -alpn1*kappa*Kphi - & - alpn1*(Bxx+Byy+Bzz-F3o2/chin1*(chix*Bx+chiy*By+chiz*Bz)) - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term part - Kpsi_rhs = Kpsi_rhs + betax*Kpsix+betay*Kpsiy+betaz*Kpsiz - Kphi_rhs = Kphi_rhs + betax*Kphix+betay*Kphiy+betaz*Kphiz - - Ex_rhs = Ex_rhs + betax*Exx+betay*Exy+betaz*Exz - Ey_rhs = Ey_rhs + betax*Eyx+betay*Eyy+betaz*Eyz - Ez_rhs = Ez_rhs + betax*Ezx+betay*Ezy+betaz*Ezz - - Bx_rhs = Bx_rhs + betax*Bxx+betay*Bxy+betaz*Bxz - By_rhs = By_rhs + betax*Byx+betay*Byy+betaz*Byz - Bz_rhs = Bz_rhs + betax*Bzx+betay*Bzy+betaz*Bzz - -! numerical dissipation part - if(eps>0)then -! usual Kreiss-Oliger dissipation - - call kodis_sh(ext,crho,sigma,R,Kpsi,Kpsi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,Kphi,Kphi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,Ex,Ex_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,Ey,Ey_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,Ez,Ez_rhs,SSA,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,Bx,Bx_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,By,By_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ext,crho,sigma,R,Bz,Bz_rhs,AAS,Symmetry,eps,sst) - - endif -! stress-energy tensor - rho = (gxx*(Ex*Ex+Bx*Bx)+gyy*(Ey*Ey+By*By)+gzz*(Ez*Ez+Bz*Bz) + & - +TWO*(gxy*(Ex*Ey+Bx*By)+gxz*(Ex*Ez+Bx*Bz)+gyz*(Ey*Ez+By*Bz)))/EIT/PI - Sx = (Ey*Bz-Ez*By)/FOUR/PI/chi3o2 - Sy = (Ez*Bx-Ex*Bz)/FOUR/PI/chi3o2 - Sz = (Ex*By-Ey*Bx)/FOUR/PI/chi3o2 - lEx = gxx*Ex+gxy*Ey+gxz*Ez - lEy = gxy*Ex+gyy*Ey+gyz*Ez - lEz = gxz*Ex+gyz*Ey+gzz*Ez - lBx = gxx*Bx+gxy*By+gxz*Bz - lBy = gxy*Bx+gyy*By+gyz*Bz - lBz = gxz*Bx+gyz*By+gzz*Bz - Sxx = rho*gxx-(lEx*lEx+lBx*lBx)/FOUR/PI - Sxy = rho*gxy-(lEx*lEy+lBx*lBy)/FOUR/PI - Sxz = rho*gxz-(lEx*lEz+lBx*lBz)/FOUR/PI - Syy = rho*gyy-(lEy*lEy+lBy*lBy)/FOUR/PI - Syz = rho*gyz-(lEy*lEz+lBy*lBz)/FOUR/PI - Szz = rho*gzz-(lEz*lEz+lBz*lBz)/FOUR/PI - - gont = 0 - - return - - end function compute_rhs_empart_ss + +!including advection term in this routine + function compute_rhs_empart(ext, X, Y, Z, & + chi , dxx , dxy , dxz , dyy , dyz , dzz,& + Lap , betax , betay , betaz , trK, & + Ex, Ey, Ez, Bx, By, Bz, Kpsi, Kphi,Jx,Jy,Jz,qchar, & + Ex_rhs, Ey_rhs, Ez_rhs, Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs, & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Symmetry,Lev,eps) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ext(1:3), Symmetry,Lev + real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3)) + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Jx,Jy,Jz,qchar + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,dxy,dxz,dyy,dyz,dzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Lap, betax, betay, betaz, trK + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Ex_rhs, Ey_rhs, Ez_rhs + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: rho,Sx,Sy,Sz + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Sxx,Sxy,Sxz,Syy,Syz,Szz + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz,gxy,gxz,gyz + real*8, dimension(ext(1),ext(2),ext(3)) :: chix,chiy,chiz,chi3o2 + real*8, dimension(ext(1),ext(2),ext(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ext(1),ext(2),ext(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ext(1),ext(2),ext(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ext(1),ext(2),ext(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ext(1),ext(2),ext(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ext(1),ext(2),ext(3)) :: betayx,betayy,betayz + real*8, dimension(ext(1),ext(2),ext(3)) :: betazx,betazy,betazz + real*8, dimension(ext(1),ext(2),ext(3)) :: alpn1,chin1 + real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ext(1),ext(2),ext(3)) :: Exx,Exy,Exz,Eyx,Eyy,Eyz,Ezx,Ezy,Ezz + real*8, dimension(ext(1),ext(2),ext(3)) :: Bxx,Bxy,Bxz,Byx,Byy,Byz,Bzx,Bzy,Bzz + real*8, dimension(ext(1),ext(2),ext(3)) :: Kpsix,Kpsiy,Kpsiz + real*8, dimension(ext(1),ext(2),ext(3)) :: Kphix,Kphiy,Kphiz + real*8, dimension(ext(1),ext(2),ext(3)) :: lEx,lEy,lEz,lBx,lBy,lBz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: F3o2=1.5d0,EIT=8.d0 + real*8,parameter :: kappa = 1.d0 +!!! sanity check + dX = sum(Ex)+sum(Ey)+sum(Ez)+sum(Bx)+sum(By)+sum(Bz)+sum(Kpsi)+sum(Kphi) + if(dX.ne.dX) then + if(sum(Ex).ne.sum(Ex))write(*,*)"empart.f90: find NaN in Ex" + if(sum(Ey).ne.sum(Ey))write(*,*)"empart.f90: find NaN in Ey" + if(sum(Ez).ne.sum(Ez))write(*,*)"empart.f90: find NaN in Ez" + if(sum(Bx).ne.sum(Bx))write(*,*)"empart.f90: find NaN in Bx" + if(sum(By).ne.sum(By))write(*,*)"empart.f90: find NaN in By" + if(sum(Bz).ne.sum(Bz))write(*,*)"empart.f90: find NaN in Bz" + if(sum(Kpsi).ne.sum(Kpsi))write(*,*)"empart.f90: find NaN in Kpsi" + if(sum(Kphi).ne.sum(Kphi))write(*,*)"empart.f90: find NaN in Kphi" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + chi3o2 = dsqrt(chin1)**3 + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + gxy = dxy + gxz = dxz + gyz = dyz + + call fderivs(ext,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + call fderivs(ext,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fderivs(ext,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fderivs(ext,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + + call fderivs(ext,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) + + call fderivs(ext,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + call fderivs(ext,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) + call fderivs(ext,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) + call fderivs(ext,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + call fderivs(ext,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) + call fderivs(ext,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + + call fderivs(ext,Kpsi,Kpsix,Kpsiy,Kpsiz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + call fderivs(ext,Kphi,Kphix,Kphiy,Kphiz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + + call fderivs(ext,Ex,Exx,Exy,Exz,X,Y,Z,ANTI,SYM,SYM ,Symmetry,Lev) + call fderivs(ext,Ey,Eyx,Eyy,Eyz,X,Y,Z,SYM,ANTI,SYM ,Symmetry,Lev) + call fderivs(ext,Ez,Ezx,Ezy,Ezz,X,Y,Z,SYM,SYM,ANTI ,Symmetry,Lev) + + call fderivs(ext,Bx,Bxx,Bxy,Bxz,X,Y,Z,SYM,ANTI,ANTI ,Symmetry,Lev) + call fderivs(ext,By,Byx,Byy,Byz,X,Y,Z,ANTI,SYM,ANTI ,Symmetry,Lev) + call fderivs(ext,Bz,Bzx,Bzy,Bzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) + +! physical gij + gxx = gxx/chin1 + gxy = gxy/chin1 + gxz = gxz/chin1 + gyy = gyy/chin1 + gyz = gyz/chin1 + gzz = gzz/chin1 +!physical gij,k + gxxx = (gxxx-gxx*chix)/chin1 + gxxy = (gxxy-gxx*chiy)/chin1 + gxxz = (gxxz-gxx*chiz)/chin1 + gxyx = (gxyx-gxy*chix)/chin1 + gxyy = (gxyy-gxy*chiy)/chin1 + gxyz = (gxyz-gxy*chiz)/chin1 + gxzx = (gxzx-gxz*chix)/chin1 + gxzy = (gxzy-gxz*chiy)/chin1 + gxzz = (gxzz-gxz*chiz)/chin1 + gyyx = (gyyx-gyy*chix)/chin1 + gyyy = (gyyy-gyy*chiy)/chin1 + gyyz = (gyyz-gyy*chiz)/chin1 + gyzx = (gyzx-gyz*chix)/chin1 + gyzy = (gyzy-gyz*chiy)/chin1 + gyzz = (gyzz-gyz*chiz)/chin1 + gzzx = (gzzx-gzz*chix)/chin1 + gzzy = (gzzy-gzz*chiy)/chin1 + gzzz = (gzzz-gzz*chiz)/chin1 + +! physical inverse metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + Ex_rhs = alpn1*trK*Ex-(Ex*betaxx+Ey*betaxy+Ez*betaxz) & + -FOUR*PI*alpn1*Jx-alpn1*(gupxx*Kpsix+gupxy*Kpsiy+gupxz*Kpsiz) & + +chi3o2*( & + ((gxz*Bx+gyz*By+gzz*Bz)*Lapy+alpn1*(gxz*Bxy+gyz*Byy+gzz*Bzy)+alpn1*(Bx*gxzy+By*gyzy+Bz*gzzy))-& + ((gxy*Bx+gyy*By+gyz*Bz)*Lapz+alpn1*(gxy*Bxz+gyy*Byz+gyz*Bzz)+alpn1*(Bx*gxyz+By*gyyz+Bz*gyzz))) + Ey_rhs = alpn1*trK*Ey-(Ex*betayx+Ey*betayy+Ez*betayz) & + -FOUR*PI*alpn1*Jy-alpn1*(gupxy*Kpsix+gupyy*Kpsiy+gupyz*Kpsiz) & + +chi3o2*( & + ((gxx*Bx+gxy*By+gxz*Bz)*Lapz+alpn1*(gxx*Bxz+gxy*Byz+gxz*Bzz)+alpn1*(Bx*gxxz+By*gxyz+Bz*gxzz))-& + ((gxz*Bx+gyz*By+gzz*Bz)*Lapx+alpn1*(gxz*Bxx+gyz*Byx+gzz*Bzx)+alpn1*(Bx*gxzx+By*gyzx+Bz*gzzx))) + Ez_rhs = alpn1*trK*Ez-(Ex*betazx+Ey*betazy+Ez*betazz) & + -FOUR*PI*alpn1*Jz-alpn1*(gupxz*Kpsix+gupyz*Kpsiy+gupzz*Kpsiz) & + +chi3o2*( & + ((gxy*Bx+gyy*By+gyz*Bz)*Lapx+alpn1*(gxy*Bxx+gyy*Byx+gyz*Bzx)+alpn1*(Bx*gxyx+By*gyyx+Bz*gyzx))-& + ((gxx*Bx+gxy*By+gxz*Bz)*Lapy+alpn1*(gxx*Bxy+gxy*Byy+gxz*Bzy)+alpn1*(Bx*gxxy+By*gxyy+Bz*gxzy))) + + Bx_rhs = alpn1*trK*Bx-(Bx*betaxx+By*betaxy+Bz*betaxz) & + -alpn1*(gupxx*Kphix+gupxy*Kphiy+gupxz*Kphiz) & + -chi3o2*( & + ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapy+alpn1*(gxz*Exy+gyz*Eyy+gzz*Ezy)+alpn1*(Ex*gxzy+Ey*gyzy+Ez*gzzy))-& + ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapz+alpn1*(gxy*Exz+gyy*Eyz+gyz*Ezz)+alpn1*(Ex*gxyz+Ey*gyyz+Ez*gyzz))) + By_rhs = alpn1*trK*By-(Bx*betayx+By*betayy+Bz*betayz) & + -alpn1*(gupxy*Kphix+gupyy*Kphiy+gupyz*Kphiz) & + -chi3o2*( & + ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapz+alpn1*(gxx*Exz+gxy*Eyz+gxz*Ezz)+alpn1*(Ex*gxxz+Ey*gxyz+Ez*gxzz))-& + ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapx+alpn1*(gxz*Exx+gyz*Eyx+gzz*Ezx)+alpn1*(Ex*gxzx+Ey*gyzx+Ez*gzzx))) + Bz_rhs = alpn1*trK*Bz-(Bx*betazx+By*betazy+Bz*betazz) & + -alpn1*(gupxz*Kphix+gupyz*Kphiy+gupzz*Kphiz) & + -chi3o2*( & + ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapx+alpn1*(gxy*Exx+gyy*Eyx+gyz*Ezx)+alpn1*(Ex*gxyx+Ey*gyyx+Ez*gyzx))-& + ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapy+alpn1*(gxx*Exy+gxy*Eyy+gxz*Ezy)+alpn1*(Ex*gxxy+Ey*gxyy+Ez*gxzy))) + + Kpsi_rhs = FOUR*PI*alpn1*qchar-alpn1*kappa*Kpsi - & + alpn1*(Exx+Eyy+Ezz-F3o2/chin1*(chix*Ex+chiy*Ey+chiz*Ez)) + Kphi_rhs = -alpn1*kappa*Kphi - & + alpn1*(Bxx+Byy+Bzz-F3o2/chin1*(chix*Bx+chiy*By+chiz*Bz)) + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term part + call lopsided(ext,X,Y,Z,KPsi,KPsi_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ext,X,Y,Z,KPhi,KPhi_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ext,X,Y,Z,Ex,Ex_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ext,X,Y,Z,Ey,Ey_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ext,X,Y,Z,Ez,Ez_rhs,betax,betay,betaz,Symmetry,SSA) + + call lopsided(ext,X,Y,Z,Bx,Bx_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ext,X,Y,Z,By,By_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ext,X,Y,Z,Bz,Bz_rhs,betax,betay,betaz,Symmetry,AAS) + +! numerical dissipation part + if(eps>0)then +! usual Kreiss-Oliger dissipation + + call kodis(ext,X,Y,Z,Kpsi,Kpsi_rhs,SSS,Symmetry,eps) + call kodis(ext,X,Y,Z,Kphi,Kphi_rhs,SSS,Symmetry,eps) + call kodis(ext,X,Y,Z,Ex,Ex_rhs,ASS,Symmetry,eps) + call kodis(ext,X,Y,Z,Ey,Ey_rhs,SAS,Symmetry,eps) + call kodis(ext,X,Y,Z,Ez,Ez_rhs,SSA,Symmetry,eps) + call kodis(ext,X,Y,Z,Bx,Bx_rhs,SAA,Symmetry,eps) + call kodis(ext,X,Y,Z,By,By_rhs,ASA,Symmetry,eps) + call kodis(ext,X,Y,Z,Bz,Bz_rhs,AAS,Symmetry,eps) + + endif +! stress-energy tensor + rho = (gxx*(Ex*Ex+Bx*Bx)+gyy*(Ey*Ey+By*By)+gzz*(Ez*Ez+Bz*Bz) + & + +TWO*(gxy*(Ex*Ey+Bx*By)+gxz*(Ex*Ez+Bx*Bz)+gyz*(Ey*Ez+By*Bz)))/EIT/PI + Sx = (Ey*Bz-Ez*By)/FOUR/PI/chi3o2 + Sy = (Ez*Bx-Ex*Bz)/FOUR/PI/chi3o2 + Sz = (Ex*By-Ey*Bx)/FOUR/PI/chi3o2 + lEx = gxx*Ex+gxy*Ey+gxz*Ez + lEy = gxy*Ex+gyy*Ey+gyz*Ez + lEz = gxz*Ex+gyz*Ey+gzz*Ez + lBx = gxx*Bx+gxy*By+gxz*Bz + lBy = gxy*Bx+gyy*By+gyz*Bz + lBz = gxz*Bx+gyz*By+gzz*Bz + Sxx = rho*gxx-(lEx*lEx+lBx*lBx)/FOUR/PI + Sxy = rho*gxy-(lEx*lEy+lBx*lBy)/FOUR/PI + Sxz = rho*gxz-(lEx*lEz+lBx*lBz)/FOUR/PI + Syy = rho*gyy-(lEy*lEy+lBy*lBy)/FOUR/PI + Syz = rho*gyz-(lEy*lEz+lBy*lBz)/FOUR/PI + Szz = rho*gzz-(lEz*lEz+lBz*lBz)/FOUR/PI + + gont = 0 + + return + + end function compute_rhs_empart +!including advection term in this routine +! for shell + function compute_rhs_empart_ss(ext,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi , dxx , dxy , dxz , dyy , dyz , dzz,& + Lap , betax , betay , betaz , trK, & + Ex, Ey, Ez, Bx, By, Bz, Kpsi, Kphi,Jx,Jy,Jz,qchar, & + Ex_rhs, Ey_rhs, Ez_rhs, Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs, & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Symmetry,Lev,eps,sst) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ext(1:3), Symmetry,Lev,sst + double precision,intent(in),dimension(ext(1))::crho + double precision,intent(in),dimension(ext(2))::sigma + double precision,intent(in),dimension(ext(3))::R + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::x,y,z + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Jx,Jy,Jz,qchar + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,dxy,dxz,dyy,dyz,dzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Lap, betax, betay, betaz, trK + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Ex_rhs, Ey_rhs, Ez_rhs + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Bx_rhs, By_rhs, Bz_rhs, Kpsi_rhs, Kphi_rhs + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: rho,Sx,Sy,Sz + real*8, dimension(ext(1),ext(2),ext(3)),intent(out) :: Sxx,Sxy,Sxz,Syy,Syz,Szz + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz,gxy,gxz,gyz + real*8, dimension(ext(1),ext(2),ext(3)) :: chix,chiy,chiz,chi3o2 + real*8, dimension(ext(1),ext(2),ext(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ext(1),ext(2),ext(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ext(1),ext(2),ext(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ext(1),ext(2),ext(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ext(1),ext(2),ext(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ext(1),ext(2),ext(3)) :: betayx,betayy,betayz + real*8, dimension(ext(1),ext(2),ext(3)) :: betazx,betazy,betazz + real*8, dimension(ext(1),ext(2),ext(3)) :: alpn1,chin1 + real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ext(1),ext(2),ext(3)) :: Exx,Exy,Exz,Eyx,Eyy,Eyz,Ezx,Ezy,Ezz + real*8, dimension(ext(1),ext(2),ext(3)) :: Bxx,Bxy,Bxz,Byx,Byy,Byz,Bzx,Bzy,Bzz + real*8, dimension(ext(1),ext(2),ext(3)) :: Kpsix,Kpsiy,Kpsiz + real*8, dimension(ext(1),ext(2),ext(3)) :: Kphix,Kphiy,Kphiz + real*8, dimension(ext(1),ext(2),ext(3)) :: lEx,lEy,lEz,lBx,lBy,lBz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: F3o2=1.5d0,EIT=8.d0 + real*8,parameter :: kappa = 1.d0 + +!!! sanity check + dX = sum(Ex)+sum(Ey)+sum(Ez)+sum(Bx)+sum(By)+sum(Bz)+sum(Kpsi)+sum(Kphi) + if(dX.ne.dX) then + if(sum(Ex).ne.sum(Ex))write(*,*)"empart.f90: find NaN in Ex" + if(sum(Ey).ne.sum(Ey))write(*,*)"empart.f90: find NaN in Ey" + if(sum(Ez).ne.sum(Ez))write(*,*)"empart.f90: find NaN in Ez" + if(sum(Bx).ne.sum(Bx))write(*,*)"empart.f90: find NaN in Bx" + if(sum(By).ne.sum(By))write(*,*)"empart.f90: find NaN in By" + if(sum(Bz).ne.sum(Bz))write(*,*)"empart.f90: find NaN in Bz" + if(sum(Kpsi).ne.sum(Kpsi))write(*,*)"empart.f90: find NaN in Kpsi" + if(sum(Kphi).ne.sum(Kphi))write(*,*)"empart.f90: find NaN in Kphi" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = crho(2) - crho(1) + dY = sigma(2) - sigma(1) + dZ = R(2) - R(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + chi3o2 = dsqrt(chin1)**3 + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + gxy = dxy + gxz = dxz + gyz = dyz + + call fderivs_shc(ext,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ext,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ext,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ext,Kpsi,Kpsix,Kpsiy,Kpsiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,Kphi,Kphix,Kphiy,Kphiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ext,Ex,Exx,Exy,Exz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,Ey,Eyx,Eyy,Eyz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,Ez,Ezx,Ezy,Ezz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +#if 1 + call fderivs_shc(ext,Bx,Bxx,Bxy,Bxz,crho,sigma,R, SYM,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,By,Byx,Byy,Byz,crho,sigma,R,ANTI, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,Bz,Bzx,Bzy,Bzz,crho,sigma,R,ANTI,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +#else + call fderivs_shc(ext,Bx,Bxx,Bxy,Bxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,By,Byx,Byy,Byz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ext,Bz,Bzx,Bzy,Bzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +#endif +! check axal vector +! physical gij + gxx = gxx/chin1 + gxy = gxy/chin1 + gxz = gxz/chin1 + gyy = gyy/chin1 + gyz = gyz/chin1 + gzz = gzz/chin1 +!physical gij,k + gxxx = (gxxx-gxx*chix)/chin1 + gxxy = (gxxy-gxx*chiy)/chin1 + gxxz = (gxxz-gxx*chiz)/chin1 + gxyx = (gxyx-gxy*chix)/chin1 + gxyy = (gxyy-gxy*chiy)/chin1 + gxyz = (gxyz-gxy*chiz)/chin1 + gxzx = (gxzx-gxz*chix)/chin1 + gxzy = (gxzy-gxz*chiy)/chin1 + gxzz = (gxzz-gxz*chiz)/chin1 + gyyx = (gyyx-gyy*chix)/chin1 + gyyy = (gyyy-gyy*chiy)/chin1 + gyyz = (gyyz-gyy*chiz)/chin1 + gyzx = (gyzx-gyz*chix)/chin1 + gyzy = (gyzy-gyz*chiy)/chin1 + gyzz = (gyzz-gyz*chiz)/chin1 + gzzx = (gzzx-gzz*chix)/chin1 + gzzy = (gzzy-gzz*chiy)/chin1 + gzzz = (gzzz-gzz*chiz)/chin1 + +! physical inverse metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + Ex_rhs = alpn1*trK*Ex-(Ex*betaxx+Ey*betaxy+Ez*betaxz) & + -FOUR*PI*alpn1*Jx-alpn1*(gupxx*Kpsix+gupxy*Kpsiy+gupxz*Kpsiz) & + +chi3o2*( & + ((gxz*Bx+gyz*By+gzz*Bz)*Lapy+alpn1*(gxz*Bxy+gyz*Byy+gzz*Bzy)+alpn1*(Bx*gxzy+By*gyzy+Bz*gzzy))-& + ((gxy*Bx+gyy*By+gyz*Bz)*Lapz+alpn1*(gxy*Bxz+gyy*Byz+gyz*Bzz)+alpn1*(Bx*gxyz+By*gyyz+Bz*gyzz))) + Ey_rhs = alpn1*trK*Ey-(Ex*betayx+Ey*betayy+Ez*betayz) & + -FOUR*PI*alpn1*Jy-alpn1*(gupxy*Kpsix+gupyy*Kpsiy+gupyz*Kpsiz) & + +chi3o2*( & + ((gxx*Bx+gxy*By+gxz*Bz)*Lapz+alpn1*(gxx*Bxz+gxy*Byz+gxz*Bzz)+alpn1*(Bx*gxxz+By*gxyz+Bz*gxzz))-& + ((gxz*Bx+gyz*By+gzz*Bz)*Lapx+alpn1*(gxz*Bxx+gyz*Byx+gzz*Bzx)+alpn1*(Bx*gxzx+By*gyzx+Bz*gzzx))) + Ez_rhs = alpn1*trK*Ez-(Ex*betazx+Ey*betazy+Ez*betazz) & + -FOUR*PI*alpn1*Jz-alpn1*(gupxz*Kpsix+gupyz*Kpsiy+gupzz*Kpsiz) & + +chi3o2*( & + ((gxy*Bx+gyy*By+gyz*Bz)*Lapx+alpn1*(gxy*Bxx+gyy*Byx+gyz*Bzx)+alpn1*(Bx*gxyx+By*gyyx+Bz*gyzx))-& + ((gxx*Bx+gxy*By+gxz*Bz)*Lapy+alpn1*(gxx*Bxy+gxy*Byy+gxz*Bzy)+alpn1*(Bx*gxxy+By*gxyy+Bz*gxzy))) + + Bx_rhs = alpn1*trK*Bx-(Bx*betaxx+By*betaxy+Bz*betaxz) & + -alpn1*(gupxx*Kphix+gupxy*Kphiy+gupxz*Kphiz) & + -chi3o2*( & + ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapy+alpn1*(gxz*Exy+gyz*Eyy+gzz*Ezy)+alpn1*(Ex*gxzy+Ey*gyzy+Ez*gzzy))-& + ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapz+alpn1*(gxy*Exz+gyy*Eyz+gyz*Ezz)+alpn1*(Ex*gxyz+Ey*gyyz+Ez*gyzz))) + By_rhs = alpn1*trK*By-(Bx*betayx+By*betayy+Bz*betayz) & + -alpn1*(gupxy*Kphix+gupyy*Kphiy+gupyz*Kphiz) & + -chi3o2*( & + ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapz+alpn1*(gxx*Exz+gxy*Eyz+gxz*Ezz)+alpn1*(Ex*gxxz+Ey*gxyz+Ez*gxzz))-& + ((gxz*Ex+gyz*Ey+gzz*Ez)*Lapx+alpn1*(gxz*Exx+gyz*Eyx+gzz*Ezx)+alpn1*(Ex*gxzx+Ey*gyzx+Ez*gzzx))) + Bz_rhs = alpn1*trK*Bz-(Bx*betazx+By*betazy+Bz*betazz) & + -alpn1*(gupxz*Kphix+gupyz*Kphiy+gupzz*Kphiz) & + -chi3o2*( & + ((gxy*Ex+gyy*Ey+gyz*Ez)*Lapx+alpn1*(gxy*Exx+gyy*Eyx+gyz*Ezx)+alpn1*(Ex*gxyx+Ey*gyyx+Ez*gyzx))-& + ((gxx*Ex+gxy*Ey+gxz*Ez)*Lapy+alpn1*(gxx*Exy+gxy*Eyy+gxz*Ezy)+alpn1*(Ex*gxxy+Ey*gxyy+Ez*gxzy))) + + Kpsi_rhs = FOUR*PI*alpn1*qchar-alpn1*kappa*Kpsi - & + alpn1*(Exx+Eyy+Ezz-F3o2/chin1*(chix*Ex+chiy*Ey+chiz*Ez)) + Kphi_rhs = -alpn1*kappa*Kphi - & + alpn1*(Bxx+Byy+Bzz-F3o2/chin1*(chix*Bx+chiy*By+chiz*Bz)) + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term part + Kpsi_rhs = Kpsi_rhs + betax*Kpsix+betay*Kpsiy+betaz*Kpsiz + Kphi_rhs = Kphi_rhs + betax*Kphix+betay*Kphiy+betaz*Kphiz + + Ex_rhs = Ex_rhs + betax*Exx+betay*Exy+betaz*Exz + Ey_rhs = Ey_rhs + betax*Eyx+betay*Eyy+betaz*Eyz + Ez_rhs = Ez_rhs + betax*Ezx+betay*Ezy+betaz*Ezz + + Bx_rhs = Bx_rhs + betax*Bxx+betay*Bxy+betaz*Bxz + By_rhs = By_rhs + betax*Byx+betay*Byy+betaz*Byz + Bz_rhs = Bz_rhs + betax*Bzx+betay*Bzy+betaz*Bzz + +! numerical dissipation part + if(eps>0)then +! usual Kreiss-Oliger dissipation + + call kodis_sh(ext,crho,sigma,R,Kpsi,Kpsi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,Kphi,Kphi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,Ex,Ex_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,Ey,Ey_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,Ez,Ez_rhs,SSA,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,Bx,Bx_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,By,By_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ext,crho,sigma,R,Bz,Bz_rhs,AAS,Symmetry,eps,sst) + + endif +! stress-energy tensor + rho = (gxx*(Ex*Ex+Bx*Bx)+gyy*(Ey*Ey+By*By)+gzz*(Ez*Ez+Bz*Bz) + & + +TWO*(gxy*(Ex*Ey+Bx*By)+gxz*(Ex*Ez+Bx*Bz)+gyz*(Ey*Ez+By*Bz)))/EIT/PI + Sx = (Ey*Bz-Ez*By)/FOUR/PI/chi3o2 + Sy = (Ez*Bx-Ex*Bz)/FOUR/PI/chi3o2 + Sz = (Ex*By-Ey*Bx)/FOUR/PI/chi3o2 + lEx = gxx*Ex+gxy*Ey+gxz*Ez + lEy = gxy*Ex+gyy*Ey+gyz*Ez + lEz = gxz*Ex+gyz*Ey+gzz*Ez + lBx = gxx*Bx+gxy*By+gxz*Bz + lBy = gxy*Bx+gyy*By+gyz*Bz + lBz = gxz*Bx+gyz*By+gzz*Bz + Sxx = rho*gxx-(lEx*lEx+lBx*lBx)/FOUR/PI + Sxy = rho*gxy-(lEx*lEy+lBx*lBy)/FOUR/PI + Sxz = rho*gxz-(lEx*lEz+lBx*lBz)/FOUR/PI + Syy = rho*gyy-(lEy*lEy+lBy*lBy)/FOUR/PI + Syz = rho*gyz-(lEy*lEz+lBy*lBz)/FOUR/PI + Szz = rho*gzz-(lEz*lEz+lBz*lBz)/FOUR/PI + + gont = 0 + + return + + end function compute_rhs_empart_ss diff --git a/AMSS_NCKU_source/empart.h b/AMSS_NCKU_source/BSSN/empart.h similarity index 98% rename from AMSS_NCKU_source/empart.h rename to AMSS_NCKU_source/BSSN/empart.h index 98b205e..bca9fd2 100644 --- a/AMSS_NCKU_source/empart.h +++ b/AMSS_NCKU_source/BSSN/empart.h @@ -1,45 +1,45 @@ - -#ifndef EMPART_H -#define EMPART_H - -#ifdef fortran1 -#define f_compute_rhs_empart compute_rhs_empart -#define f_compute_rhs_empart_ss compute_rhs_empart_ss -#endif -#ifdef fortran2 -#define f_compute_rhs_empart COMPUTE_RHS_EMPART -#define f_compute_rhs_empart_ss COMPUTE_RHS_EMPART_SS -#endif -#ifdef fortran3 -#define f_compute_rhs_empart compute_rhs_empart_ -#define f_compute_rhs_empart_ss compute_rhs_empart_ss_ -#endif - -extern "C" -{ - int f_compute_rhs_empart(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - int &, int &, double &); -} - -extern "C" -{ - int f_compute_rhs_empart_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - int &, int &, double &, int &); -} -#endif /* EMPART_H */ + +#ifndef EMPART_H +#define EMPART_H + +#ifdef fortran1 +#define f_compute_rhs_empart compute_rhs_empart +#define f_compute_rhs_empart_ss compute_rhs_empart_ss +#endif +#ifdef fortran2 +#define f_compute_rhs_empart COMPUTE_RHS_EMPART +#define f_compute_rhs_empart_ss COMPUTE_RHS_EMPART_SS +#endif +#ifdef fortran3 +#define f_compute_rhs_empart compute_rhs_empart_ +#define f_compute_rhs_empart_ss compute_rhs_empart_ss_ +#endif + +extern "C" +{ + int f_compute_rhs_empart(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + int &, int &, double &); +} + +extern "C" +{ + int f_compute_rhs_empart_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + int &, int &, double &, int &); +} +#endif /* EMPART_H */ diff --git a/AMSS_NCKU_source/enforce_algebra.f90 b/AMSS_NCKU_source/BSSN/enforce_algebra.f90 similarity index 96% rename from AMSS_NCKU_source/enforce_algebra.f90 rename to AMSS_NCKU_source/BSSN/enforce_algebra.f90 index 2a511a5..48013e8 100644 --- a/AMSS_NCKU_source/enforce_algebra.f90 +++ b/AMSS_NCKU_source/BSSN/enforce_algebra.f90 @@ -1,230 +1,230 @@ - -!----------------------------------------------------------------------------- -! -! remove the trace of Aij -! trace-free Aij and enforce the determinant of bssn metric to one -!----------------------------------------------------------------------------- - - subroutine enforce_ag(ex, dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz - -!~~~~~~~> Local variable: - - integer :: i,j,k - real*8 :: lgxx,lgyy,lgzz,ldetg - real*8 :: lgupxx,lgupxy,lgupxz,lgupyy,lgupyz,lgupzz - real*8 :: ltrA,lscale - real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0 - -!~~~~~~> - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - lgxx = dxx(i,j,k) + ONE - lgyy = dyy(i,j,k) + ONE - lgzz = dzz(i,j,k) + ONE - - ldetg = lgxx * lgyy * lgzz & - + gxy(i,j,k) * gyz(i,j,k) * gxz(i,j,k) & - + gxz(i,j,k) * gxy(i,j,k) * gyz(i,j,k) & - - gxz(i,j,k) * lgyy * gxz(i,j,k) & - - gxy(i,j,k) * gxy(i,j,k) * lgzz & - - lgxx * gyz(i,j,k) * gyz(i,j,k) - - lgupxx = ( lgyy * lgzz - gyz(i,j,k) * gyz(i,j,k) ) / ldetg - lgupxy = - ( gxy(i,j,k) * lgzz - gyz(i,j,k) * gxz(i,j,k) ) / ldetg - lgupxz = ( gxy(i,j,k) * gyz(i,j,k) - lgyy * gxz(i,j,k) ) / ldetg - lgupyy = ( lgxx * lgzz - gxz(i,j,k) * gxz(i,j,k) ) / ldetg - lgupyz = - ( lgxx * gyz(i,j,k) - gxy(i,j,k) * gxz(i,j,k) ) / ldetg - lgupzz = ( lgxx * lgyy - gxy(i,j,k) * gxy(i,j,k) ) / ldetg - - ltrA = lgupxx * Axx(i,j,k) + lgupyy * Ayy(i,j,k) & - + lgupzz * Azz(i,j,k) & - + TWO * (lgupxy * Axy(i,j,k) + lgupxz * Axz(i,j,k) & - + lgupyz * Ayz(i,j,k)) - - Axx(i,j,k) = Axx(i,j,k) - F1o3 * lgxx * ltrA - Axy(i,j,k) = Axy(i,j,k) - F1o3 * gxy(i,j,k) * ltrA - Axz(i,j,k) = Axz(i,j,k) - F1o3 * gxz(i,j,k) * ltrA - Ayy(i,j,k) = Ayy(i,j,k) - F1o3 * lgyy * ltrA - Ayz(i,j,k) = Ayz(i,j,k) - F1o3 * gyz(i,j,k) * ltrA - Azz(i,j,k) = Azz(i,j,k) - F1o3 * lgzz * ltrA - - lscale = ONE / ( ldetg ** F1o3 ) - - dxx(i,j,k) = lgxx * lscale - ONE - gxy(i,j,k) = gxy(i,j,k) * lscale - gxz(i,j,k) = gxz(i,j,k) * lscale - dyy(i,j,k) = lgyy * lscale - ONE - gyz(i,j,k) = gyz(i,j,k) * lscale - dzz(i,j,k) = lgzz * lscale - ONE - - enddo - enddo - enddo - - return - - end subroutine enforce_ag -#if 1 -!---------------------------------------------------------------------------------- -! swap the turn of a and g -!---------------------------------------------------------------------------------- - subroutine enforce_ga(ex, dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz - -!~~~~~~~> Local variable: - - integer :: i,j,k - real*8 :: lgxx,lgyy,lgzz,lscale - real*8 :: lgxy,lgxz,lgyz - real*8 :: lgupxx,lgupxy,lgupxz,lgupyy,lgupyz,lgupzz - real*8 :: ltrA - real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0 - -!~~~~~~> - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - -! for g: normalize determinant first - lgxx = dxx(i,j,k) + ONE - lgyy = dyy(i,j,k) + ONE - lgzz = dzz(i,j,k) + ONE - lgxy = gxy(i,j,k) - lgxz = gxz(i,j,k) - lgyz = gyz(i,j,k) - - lscale = lgxx * lgyy * lgzz + lgxy * lgyz * lgxz & - + lgxz * lgxy * lgyz - lgxz * lgyy * lgxz & - - lgxy * lgxy * lgzz - lgxx * lgyz * lgyz - - lscale = ONE / ( lscale ** F1o3 ) - - lgxx = lgxx * lscale - lgxy = lgxy * lscale - lgxz = lgxz * lscale - lgyy = lgyy * lscale - lgyz = lgyz * lscale - lgzz = lgzz * lscale - - dxx(i,j,k) = lgxx - ONE - gxy(i,j,k) = lgxy - gxz(i,j,k) = lgxz - dyy(i,j,k) = lgyy - ONE - gyz(i,j,k) = lgyz - dzz(i,j,k) = lgzz - ONE - -! for A: trace-free using normalized metric (det=1, no division needed) - lgupxx = ( lgyy * lgzz - lgyz * lgyz ) - lgupxy = - ( lgxy * lgzz - lgyz * lgxz ) - lgupxz = ( lgxy * lgyz - lgyy * lgxz ) - lgupyy = ( lgxx * lgzz - lgxz * lgxz ) - lgupyz = - ( lgxx * lgyz - lgxy * lgxz ) - lgupzz = ( lgxx * lgyy - lgxy * lgxy ) - - ltrA = lgupxx * Axx(i,j,k) + lgupyy * Ayy(i,j,k) & - + lgupzz * Azz(i,j,k) & - + TWO * (lgupxy * Axy(i,j,k) + lgupxz * Axz(i,j,k) & - + lgupyz * Ayz(i,j,k)) - - Axx(i,j,k) = Axx(i,j,k) - F1o3 * lgxx * ltrA - Axy(i,j,k) = Axy(i,j,k) - F1o3 * lgxy * ltrA - Axz(i,j,k) = Axz(i,j,k) - F1o3 * lgxz * ltrA - Ayy(i,j,k) = Ayy(i,j,k) - F1o3 * lgyy * ltrA - Ayz(i,j,k) = Ayz(i,j,k) - F1o3 * lgyz * ltrA - Azz(i,j,k) = Azz(i,j,k) - F1o3 * lgzz * ltrA - - enddo - enddo - enddo - - return - - end subroutine enforce_ga -#else -!---------------------------------------------------------------------------------- -! duplicate bam -!---------------------------------------------------------------------------------- - subroutine enforce_ga(ex, dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz - -!~~~~~~~> Local variable: - - real*8, dimension(ex(1),ex(2),ex(3)) :: trA - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: aux,detginv - real*8, parameter :: oot = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0 - -!~~~~~~> - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE -! for g -aux = (2.d0*gxy*gxz*gyz + gxx*gyy*gzz & - - gzz*gxy**2 - gyy*gxz**2 - gxx*gyz**2)**(-oot) - - gxx = gxx * aux - gxy = gxy * aux - gxz = gxz * aux - gyy = gyy * aux - gyz = gyz * aux - gzz = gzz * aux - - dxx = gxx - ONE - dyy = gyy - ONE - dzz = gzz - ONE -! for A - -detginv = 1/(2.d0*gxy*gxz*gyz + gxx*gyy*gzz & - - gzz*gxy**2 - gyy*gxz**2 - gxx*gyz**2) - -trA = detginv*(-2.d0*Ayz*gxx*gyz + Axx*gyy*gzz + & - gxx*(Azz*gyy + Ayy*gzz) + 2.d0*(gxz*(Ayz*gxy - Axz*gyy + & - Axy*gyz) + gxy*(Axz*gyz - Axy*gzz)) - Azz*gxy**2 - Ayy*gxz**2 - & - Axx*gyz**2) - -aux = -(oot*trA) - - Axx = Axx + aux * gxx - Axy = Axy + aux * gxy - Axz = Axz + aux * gxz - Ayy = Ayy + aux * gyy - Ayz = Ayz + aux * gyz - Azz = Azz + aux * gzz - - return - - end subroutine enforce_ga -#endif + +!----------------------------------------------------------------------------- +! +! remove the trace of Aij +! trace-free Aij and enforce the determinant of bssn metric to one +!----------------------------------------------------------------------------- + + subroutine enforce_ag(ex, dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz + +!~~~~~~~> Local variable: + + integer :: i,j,k + real*8 :: lgxx,lgyy,lgzz,ldetg + real*8 :: lgupxx,lgupxy,lgupxz,lgupyy,lgupyz,lgupzz + real*8 :: ltrA,lscale + real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0 + +!~~~~~~> + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + lgxx = dxx(i,j,k) + ONE + lgyy = dyy(i,j,k) + ONE + lgzz = dzz(i,j,k) + ONE + + ldetg = lgxx * lgyy * lgzz & + + gxy(i,j,k) * gyz(i,j,k) * gxz(i,j,k) & + + gxz(i,j,k) * gxy(i,j,k) * gyz(i,j,k) & + - gxz(i,j,k) * lgyy * gxz(i,j,k) & + - gxy(i,j,k) * gxy(i,j,k) * lgzz & + - lgxx * gyz(i,j,k) * gyz(i,j,k) + + lgupxx = ( lgyy * lgzz - gyz(i,j,k) * gyz(i,j,k) ) / ldetg + lgupxy = - ( gxy(i,j,k) * lgzz - gyz(i,j,k) * gxz(i,j,k) ) / ldetg + lgupxz = ( gxy(i,j,k) * gyz(i,j,k) - lgyy * gxz(i,j,k) ) / ldetg + lgupyy = ( lgxx * lgzz - gxz(i,j,k) * gxz(i,j,k) ) / ldetg + lgupyz = - ( lgxx * gyz(i,j,k) - gxy(i,j,k) * gxz(i,j,k) ) / ldetg + lgupzz = ( lgxx * lgyy - gxy(i,j,k) * gxy(i,j,k) ) / ldetg + + ltrA = lgupxx * Axx(i,j,k) + lgupyy * Ayy(i,j,k) & + + lgupzz * Azz(i,j,k) & + + TWO * (lgupxy * Axy(i,j,k) + lgupxz * Axz(i,j,k) & + + lgupyz * Ayz(i,j,k)) + + Axx(i,j,k) = Axx(i,j,k) - F1o3 * lgxx * ltrA + Axy(i,j,k) = Axy(i,j,k) - F1o3 * gxy(i,j,k) * ltrA + Axz(i,j,k) = Axz(i,j,k) - F1o3 * gxz(i,j,k) * ltrA + Ayy(i,j,k) = Ayy(i,j,k) - F1o3 * lgyy * ltrA + Ayz(i,j,k) = Ayz(i,j,k) - F1o3 * gyz(i,j,k) * ltrA + Azz(i,j,k) = Azz(i,j,k) - F1o3 * lgzz * ltrA + + lscale = ONE / ( ldetg ** F1o3 ) + + dxx(i,j,k) = lgxx * lscale - ONE + gxy(i,j,k) = gxy(i,j,k) * lscale + gxz(i,j,k) = gxz(i,j,k) * lscale + dyy(i,j,k) = lgyy * lscale - ONE + gyz(i,j,k) = gyz(i,j,k) * lscale + dzz(i,j,k) = lgzz * lscale - ONE + + enddo + enddo + enddo + + return + + end subroutine enforce_ag +#if 1 +!---------------------------------------------------------------------------------- +! swap the turn of a and g +!---------------------------------------------------------------------------------- + subroutine enforce_ga(ex, dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz + +!~~~~~~~> Local variable: + + integer :: i,j,k + real*8 :: lgxx,lgyy,lgzz,lscale + real*8 :: lgxy,lgxz,lgyz + real*8 :: lgupxx,lgupxy,lgupxz,lgupyy,lgupyz,lgupzz + real*8 :: ltrA + real*8, parameter :: F1o3 = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0 + +!~~~~~~> + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + +! for g: normalize determinant first + lgxx = dxx(i,j,k) + ONE + lgyy = dyy(i,j,k) + ONE + lgzz = dzz(i,j,k) + ONE + lgxy = gxy(i,j,k) + lgxz = gxz(i,j,k) + lgyz = gyz(i,j,k) + + lscale = lgxx * lgyy * lgzz + lgxy * lgyz * lgxz & + + lgxz * lgxy * lgyz - lgxz * lgyy * lgxz & + - lgxy * lgxy * lgzz - lgxx * lgyz * lgyz + + lscale = ONE / ( lscale ** F1o3 ) + + lgxx = lgxx * lscale + lgxy = lgxy * lscale + lgxz = lgxz * lscale + lgyy = lgyy * lscale + lgyz = lgyz * lscale + lgzz = lgzz * lscale + + dxx(i,j,k) = lgxx - ONE + gxy(i,j,k) = lgxy + gxz(i,j,k) = lgxz + dyy(i,j,k) = lgyy - ONE + gyz(i,j,k) = lgyz + dzz(i,j,k) = lgzz - ONE + +! for A: trace-free using normalized metric (det=1, no division needed) + lgupxx = ( lgyy * lgzz - lgyz * lgyz ) + lgupxy = - ( lgxy * lgzz - lgyz * lgxz ) + lgupxz = ( lgxy * lgyz - lgyy * lgxz ) + lgupyy = ( lgxx * lgzz - lgxz * lgxz ) + lgupyz = - ( lgxx * lgyz - lgxy * lgxz ) + lgupzz = ( lgxx * lgyy - lgxy * lgxy ) + + ltrA = lgupxx * Axx(i,j,k) + lgupyy * Ayy(i,j,k) & + + lgupzz * Azz(i,j,k) & + + TWO * (lgupxy * Axy(i,j,k) + lgupxz * Axz(i,j,k) & + + lgupyz * Ayz(i,j,k)) + + Axx(i,j,k) = Axx(i,j,k) - F1o3 * lgxx * ltrA + Axy(i,j,k) = Axy(i,j,k) - F1o3 * lgxy * ltrA + Axz(i,j,k) = Axz(i,j,k) - F1o3 * lgxz * ltrA + Ayy(i,j,k) = Ayy(i,j,k) - F1o3 * lgyy * ltrA + Ayz(i,j,k) = Ayz(i,j,k) - F1o3 * lgyz * ltrA + Azz(i,j,k) = Azz(i,j,k) - F1o3 * lgzz * ltrA + + enddo + enddo + enddo + + return + + end subroutine enforce_ga +#else +!---------------------------------------------------------------------------------- +! duplicate bam +!---------------------------------------------------------------------------------- + subroutine enforce_ga(ex, dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Ayy,Ayz,Azz + +!~~~~~~~> Local variable: + + real*8, dimension(ex(1),ex(2),ex(3)) :: trA + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: aux,detginv + real*8, parameter :: oot = 1.D0 / 3.D0, ONE = 1.D0, TWO = 2.D0 + +!~~~~~~> + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE +! for g +aux = (2.d0*gxy*gxz*gyz + gxx*gyy*gzz & + - gzz*gxy**2 - gyy*gxz**2 - gxx*gyz**2)**(-oot) + + gxx = gxx * aux + gxy = gxy * aux + gxz = gxz * aux + gyy = gyy * aux + gyz = gyz * aux + gzz = gzz * aux + + dxx = gxx - ONE + dyy = gyy - ONE + dzz = gzz - ONE +! for A + +detginv = 1/(2.d0*gxy*gxz*gyz + gxx*gyy*gzz & + - gzz*gxy**2 - gyy*gxz**2 - gxx*gyz**2) + +trA = detginv*(-2.d0*Ayz*gxx*gyz + Axx*gyy*gzz + & + gxx*(Azz*gyy + Ayy*gzz) + 2.d0*(gxz*(Ayz*gxy - Axz*gyy + & + Axy*gyz) + gxy*(Axz*gyz - Axy*gzz)) - Azz*gxy**2 - Ayy*gxz**2 - & + Axx*gyz**2) + +aux = -(oot*trA) + + Axx = Axx + aux * gxx + Axy = Axy + aux * gxy + Axz = Axz + aux * gxz + Ayy = Ayy + aux * gyy + Ayz = Ayz + aux * gyz + Azz = Azz + aux * gzz + + return + + end subroutine enforce_ga +#endif diff --git a/AMSS_NCKU_source/enforce_algebra.h b/AMSS_NCKU_source/BSSN/enforce_algebra.h similarity index 95% rename from AMSS_NCKU_source/enforce_algebra.h rename to AMSS_NCKU_source/BSSN/enforce_algebra.h index e6eeaad..4a54b46 100644 --- a/AMSS_NCKU_source/enforce_algebra.h +++ b/AMSS_NCKU_source/BSSN/enforce_algebra.h @@ -1,30 +1,30 @@ - -#ifndef ENFORCE_ALGEBRA_H -#define ENFORCE_ALGEBRA_H - -#ifdef fortran1 -#define f_enforce_ag enforce_ag -#define f_enforce_ga enforce_ga -#endif -#ifdef fortran2 -#define f_enforce_ag ENFORCE_AG -#define f_enforce_ga ENFORCE_GA -#endif -#ifdef fortran3 -#define f_enforce_ag enforce_ag_ -#define f_enforce_ga enforce_ga_ -#endif - -extern "C" -{ - void f_enforce_ag(int *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_enforce_ga(int *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} -#endif /* ENFORCE_ALGEBRA_H */ + +#ifndef ENFORCE_ALGEBRA_H +#define ENFORCE_ALGEBRA_H + +#ifdef fortran1 +#define f_enforce_ag enforce_ag +#define f_enforce_ga enforce_ga +#endif +#ifdef fortran2 +#define f_enforce_ag ENFORCE_AG +#define f_enforce_ga ENFORCE_GA +#endif +#ifdef fortran3 +#define f_enforce_ag enforce_ag_ +#define f_enforce_ga enforce_ga_ +#endif + +extern "C" +{ + void f_enforce_ag(int *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_enforce_ga(int *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} +#endif /* ENFORCE_ALGEBRA_H */ diff --git a/AMSS_NCKU_source/fadmquantites_bssn.f90 b/AMSS_NCKU_source/BSSN/fadmquantites_bssn.f90 similarity index 97% rename from AMSS_NCKU_source/fadmquantites_bssn.f90 rename to AMSS_NCKU_source/BSSN/fadmquantites_bssn.f90 index 1bced91..b7ec1e1 100644 --- a/AMSS_NCKU_source/fadmquantites_bssn.f90 +++ b/AMSS_NCKU_source/BSSN/fadmquantites_bssn.f90 @@ -1,245 +1,245 @@ - -!----------------------------------------------------------------------------- -! ADM quantites for surface intergral -!----------------------------------------------------------------------------- - subroutine admmass_bssn(ex, X, Y, Z, & - chi , trK, & - dxx , gxy , gxz , dyy , gyz , dzz , & - Axx , Axy , Axz , Ayy , Ayz , Azz , & - Gamx , Gamy , Gamz , & - massx,massy,massz, symmetry) - - implicit none - !~~~~~~= Input parameters: - - integer,intent(in) :: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: massx,massy,massz -! local variables - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! partial derivative of chi, chi_i - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: f - real*8 :: PI, F1o2pi - real*8, parameter :: ONE = 1.d0, F1o8 = 1.d0/8.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: dX, dY, dZ - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - PI = dacos( - ONE ) - F1o2pi = ONE / ( 2.d0 * PI ) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - - f=1/4.d0/(chi+ONE)**1.25d0 -! mass_i = (Gami/8 + gupij*phi_j/(4*chi^1.25))/(2*Pi) - massx = (F1o8*Gamx + f*(gupxx*chix+gupxy*chiy+gupxz*chiz))*F1o2pi - massy = (F1o8*Gamy + f*(gupxy*chix+gupyy*chiy+gupyz*chiz))*F1o2pi - massz = (F1o8*Gamz + f*(gupxz*chix+gupyz*chiy+gupzz*chiz))*F1o2pi - - return - - end subroutine admmass_bssn -!----------------------------------------------------------------------------------------------- -! P^i = int r^j p_ji -!----------------------------------------------------------------------------------------------- - subroutine admmomentum_bssn(ex, & - chi, trK, & - dxx , gxy , gxz , dyy , gyz , dzz , & - Axx , Axy , Axz , Ayy , Ayz , Azz , & - Gamx , Gamy , Gamz , & - pxx,pxy,pxz,pyy,pyz,pzz) - - implicit none - !~~~~~~= Input parameters: - - integer,intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: pxx,pxy,pxz,pyy,pyz,pzz -! local variables - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,chim4 - real*8 :: PI, F1o8pi - real*8, parameter :: ONE = 1.d0, F1o3 = 1.d0/3.d0 - - PI = acos( - ONE ) - F1o8pi = ONE / ( 8.d0 * PI ) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - chim4=1.d0/(chi+ONE)**4 - Kxx = chim4*(Axx+F1o3*gxx*trK) - Kxy = chim4*(Axy+F1o3*gxy*trK) - Kxz = chim4*(Axz+F1o3*gxz*trK) - Kyy = chim4*(Ayy+F1o3*gyy*trK) - Kyz = chim4*(Ayz+F1o3*gyz*trK) - Kzz = chim4*(Azz+F1o3*gzz*trK) - - pxx = (Kxx-trK)*F1o8pi - pxy = (Kxy )*F1o8pi - pxz = (Kxz )*F1o8pi - pyy = (Kyy-trK)*F1o8pi - pyz = (Kyz )*F1o8pi - pzz = (Kzz-trK)*F1o8pi - - return - - end subroutine admmomentum_bssn -!----------------------------------------------------------------------------------------------- -! S^i = int r^j s_ji -!----------------------------------------------------------------------------------------------- - subroutine admangularmomentum_bssn(ex,X,Y,Z,& - pxx,pxy,pxz,pyy,pyz,pzz, & - sxx,sxy,sxz,syx,syy,syz,szx,szy,szz) - - implicit none - !~~~~~~= Input parameters: - - integer,intent(in) :: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pxx,pxy,pxz,pyy,pyz,pzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: sxx,sxy,sxz,syx,syy,syz,szx,szy,szz -!local variable - real*8, dimension(ex(1),ex(2),ex(3))::XX,YY,ZZ - integer::i,j,k - - do j = 1,ex(2) - do k = 1,ex(3) - XX(:,j,k) = X - enddo - enddo - - do i = 1,ex(1) - do k = 1,ex(3) - YY(i,:,k) = Y - enddo - enddo - - do i = 1,ex(1) - do j = 1,ex(2) - ZZ(i,j,:) = Z - enddo - enddo - - sxx = YY*pxy - ZZ*pxz - sxy = YY*pyy - ZZ*pyz - sxz = YY*pyz - ZZ*pzz - syx = ZZ*pxy - YY*pxz - syy = ZZ*pyy - YY*pyz - syz = ZZ*pyz - YY*pzz - szx = XX*pxy - YY*pxx - szy = XX*pyy - YY*pxy - szz = XX*pyz - YY*pxz - - return - - end subroutine admangularmomentum_bssn - -! for shell - subroutine admmass_bssn_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi , trK, & - dxx , gxy , gxz , dyy , gyz , dzz , & - Axx , Axy , Axz , Ayy , Ayz , Azz , & - Gamx , Gamy , Gamz , & - massx,massy,massz, symmetry,sst) - - implicit none - !~~~~~~= Input parameters: - - integer,intent(in) :: ex(1:3),symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: massx,massy,massz -! local variables - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz -! inverse metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz -! partial derivative of chi, chi_i - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: f - real*8 :: PI, F1o2pi - real*8, parameter :: ONE = 1.d0, F1o8 = 1.d0/8.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: dX, dY, dZ - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - PI = dacos( - ONE ) - F1o2pi = ONE / ( 2.d0 * PI ) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - f=1/4.d0/(chi+ONE)**1.25d0 -! mass_i = (Gami/8 + gupij*phi_j/(4*chi^1.25))/(2*Pi) - massx = (F1o8*Gamx + f*(gupxx*chix+gupxy*chiy+gupxz*chiz))*F1o2pi - massy = (F1o8*Gamy + f*(gupxy*chix+gupyy*chiy+gupyz*chiz))*F1o2pi - massz = (F1o8*Gamz + f*(gupxz*chix+gupyz*chiy+gupzz*chiz))*F1o2pi - - return - - end subroutine admmass_bssn_ss + +!----------------------------------------------------------------------------- +! ADM quantites for surface intergral +!----------------------------------------------------------------------------- + subroutine admmass_bssn(ex, X, Y, Z, & + chi , trK, & + dxx , gxy , gxz , dyy , gyz , dzz , & + Axx , Axy , Axz , Ayy , Ayz , Azz , & + Gamx , Gamy , Gamz , & + massx,massy,massz, symmetry) + + implicit none + !~~~~~~= Input parameters: + + integer,intent(in) :: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: massx,massy,massz +! local variables + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! partial derivative of chi, chi_i + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: f + real*8 :: PI, F1o2pi + real*8, parameter :: ONE = 1.d0, F1o8 = 1.d0/8.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: dX, dY, dZ + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + PI = dacos( - ONE ) + F1o2pi = ONE / ( 2.d0 * PI ) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + + f=1/4.d0/(chi+ONE)**1.25d0 +! mass_i = (Gami/8 + gupij*phi_j/(4*chi^1.25))/(2*Pi) + massx = (F1o8*Gamx + f*(gupxx*chix+gupxy*chiy+gupxz*chiz))*F1o2pi + massy = (F1o8*Gamy + f*(gupxy*chix+gupyy*chiy+gupyz*chiz))*F1o2pi + massz = (F1o8*Gamz + f*(gupxz*chix+gupyz*chiy+gupzz*chiz))*F1o2pi + + return + + end subroutine admmass_bssn +!----------------------------------------------------------------------------------------------- +! P^i = int r^j p_ji +!----------------------------------------------------------------------------------------------- + subroutine admmomentum_bssn(ex, & + chi, trK, & + dxx , gxy , gxz , dyy , gyz , dzz , & + Axx , Axy , Axz , Ayy , Ayz , Azz , & + Gamx , Gamy , Gamz , & + pxx,pxy,pxz,pyy,pyz,pzz) + + implicit none + !~~~~~~= Input parameters: + + integer,intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: pxx,pxy,pxz,pyy,pyz,pzz +! local variables + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,chim4 + real*8 :: PI, F1o8pi + real*8, parameter :: ONE = 1.d0, F1o3 = 1.d0/3.d0 + + PI = acos( - ONE ) + F1o8pi = ONE / ( 8.d0 * PI ) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + chim4=1.d0/(chi+ONE)**4 + Kxx = chim4*(Axx+F1o3*gxx*trK) + Kxy = chim4*(Axy+F1o3*gxy*trK) + Kxz = chim4*(Axz+F1o3*gxz*trK) + Kyy = chim4*(Ayy+F1o3*gyy*trK) + Kyz = chim4*(Ayz+F1o3*gyz*trK) + Kzz = chim4*(Azz+F1o3*gzz*trK) + + pxx = (Kxx-trK)*F1o8pi + pxy = (Kxy )*F1o8pi + pxz = (Kxz )*F1o8pi + pyy = (Kyy-trK)*F1o8pi + pyz = (Kyz )*F1o8pi + pzz = (Kzz-trK)*F1o8pi + + return + + end subroutine admmomentum_bssn +!----------------------------------------------------------------------------------------------- +! S^i = int r^j s_ji +!----------------------------------------------------------------------------------------------- + subroutine admangularmomentum_bssn(ex,X,Y,Z,& + pxx,pxy,pxz,pyy,pyz,pzz, & + sxx,sxy,sxz,syx,syy,syz,szx,szy,szz) + + implicit none + !~~~~~~= Input parameters: + + integer,intent(in) :: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pxx,pxy,pxz,pyy,pyz,pzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: sxx,sxy,sxz,syx,syy,syz,szx,szy,szz +!local variable + real*8, dimension(ex(1),ex(2),ex(3))::XX,YY,ZZ + integer::i,j,k + + do j = 1,ex(2) + do k = 1,ex(3) + XX(:,j,k) = X + enddo + enddo + + do i = 1,ex(1) + do k = 1,ex(3) + YY(i,:,k) = Y + enddo + enddo + + do i = 1,ex(1) + do j = 1,ex(2) + ZZ(i,j,:) = Z + enddo + enddo + + sxx = YY*pxy - ZZ*pxz + sxy = YY*pyy - ZZ*pyz + sxz = YY*pyz - ZZ*pzz + syx = ZZ*pxy - YY*pxz + syy = ZZ*pyy - YY*pyz + syz = ZZ*pyz - YY*pzz + szx = XX*pxy - YY*pxx + szy = XX*pyy - YY*pxy + szz = XX*pyz - YY*pxz + + return + + end subroutine admangularmomentum_bssn + +! for shell + subroutine admmass_bssn_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi , trK, & + dxx , gxy , gxz , dyy , gyz , dzz , & + Axx , Axy , Axz , Ayy , Ayz , Azz , & + Gamx , Gamy , Gamz , & + massx,massy,massz, symmetry,sst) + + implicit none + !~~~~~~= Input parameters: + + integer,intent(in) :: ex(1:3),symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: massx,massy,massz +! local variables + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz +! inverse metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz +! partial derivative of chi, chi_i + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: f + real*8 :: PI, F1o2pi + real*8, parameter :: ONE = 1.d0, F1o8 = 1.d0/8.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: dX, dY, dZ + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + PI = dacos( - ONE ) + F1o2pi = ONE / ( 2.d0 * PI ) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + f=1/4.d0/(chi+ONE)**1.25d0 +! mass_i = (Gami/8 + gupij*phi_j/(4*chi^1.25))/(2*Pi) + massx = (F1o8*Gamx + f*(gupxx*chix+gupxy*chiy+gupxz*chiz))*F1o2pi + massy = (F1o8*Gamy + f*(gupxy*chix+gupyy*chiy+gupyz*chiz))*F1o2pi + massz = (F1o8*Gamz + f*(gupxz*chix+gupyz*chiy+gupzz*chiz))*F1o2pi + + return + + end subroutine admmass_bssn_ss diff --git a/AMSS_NCKU_source/fadmquantites_bssn.h b/AMSS_NCKU_source/BSSN/fadmquantites_bssn.h similarity index 96% rename from AMSS_NCKU_source/fadmquantites_bssn.h rename to AMSS_NCKU_source/BSSN/fadmquantites_bssn.h index 1aa1b9c..d9ea94f 100644 --- a/AMSS_NCKU_source/fadmquantites_bssn.h +++ b/AMSS_NCKU_source/BSSN/fadmquantites_bssn.h @@ -1,60 +1,60 @@ - -#ifndef FADMQUANTITES_H -#define FADMQUANTITES_H - -#ifdef fortran1 -#define f_admmass_bssn admmass_bssn -#define f_admmass_bssn_ss admmass_bssn_ss -#define f_admmomentum_bssn admmomentum_bssn -#endif -#ifdef fortran2 -#define f_admmass_bssn ADMMASS_BSSN -#define f_admmass_bssn_ss ADMMASS_BSSN_SS -#define f_admmomentum_bssn ADMMOMENTUM_BSSN -#endif -#ifdef fortran3 -#define f_admmass_bssn admmass_bssn_ -#define f_admmass_bssn_ss admmass_bssn_ss_ -#define f_admmomentum_bssn admmomentum_bssn_ -#endif - -extern "C" -{ - void f_admmass_bssn(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - int &); -} - -extern "C" -{ - void f_admmass_bssn_ss(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - int &, int &); -} - -extern "C" -{ - void f_admmomentum_bssn(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} -#endif /* FADMQUANTITES_H */ + +#ifndef FADMQUANTITES_H +#define FADMQUANTITES_H + +#ifdef fortran1 +#define f_admmass_bssn admmass_bssn +#define f_admmass_bssn_ss admmass_bssn_ss +#define f_admmomentum_bssn admmomentum_bssn +#endif +#ifdef fortran2 +#define f_admmass_bssn ADMMASS_BSSN +#define f_admmass_bssn_ss ADMMASS_BSSN_SS +#define f_admmomentum_bssn ADMMOMENTUM_BSSN +#endif +#ifdef fortran3 +#define f_admmass_bssn admmass_bssn_ +#define f_admmass_bssn_ss admmass_bssn_ss_ +#define f_admmomentum_bssn admmomentum_bssn_ +#endif + +extern "C" +{ + void f_admmass_bssn(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + int &); +} + +extern "C" +{ + void f_admmass_bssn_ss(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + int &, int &); +} + +extern "C" +{ + void f_admmomentum_bssn(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} +#endif /* FADMQUANTITES_H */ diff --git a/AMSS_NCKU_source/fourdcurvature.f90 b/AMSS_NCKU_source/BSSN/fourdcurvature.f90 similarity index 97% rename from AMSS_NCKU_source/fourdcurvature.f90 rename to AMSS_NCKU_source/BSSN/fourdcurvature.f90 index 0b1b5ff..e05cc2e 100644 --- a/AMSS_NCKU_source/fourdcurvature.f90 +++ b/AMSS_NCKU_source/BSSN/fourdcurvature.f90 @@ -1,91 +1,91 @@ - - -#include "macrodef.fh" - -!----------------------------------------------------------------------------- -! -! compute 4 dimensional Ricci scalar -! this routine is valid for both box and shell -! -!----------------------------------------------------------------------------- - - subroutine get4ricciscalar(ex, X, Y, Z, & - chi, trK, rho, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Sxx,Sxy,Sxz,Syy,Syz,Szz,& - RR) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,rho -! physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! matter - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Sxx,Sxy,Sxz,Syy,Syz,Szz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: RR - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,chipn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, parameter :: ONE = 1.d0, TWO = 2.d0, THR = 3.d0, F8 = 8.d0, F2o3 = 2.d0/3.d0 - real*8 :: PI - - PI = dacos(-ONE) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - RR =(gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) )) - F2o3*trK*trK & - -(gupxx*Rxx+gupyy*Ryy+gupzz*Rzz+TWO*(gupxy*Rxy+gupxz*Rxz+gupyz*Ryz))*chipn1 & - -F8*PI*(THR*rho- & - (gupxx*Sxx+gupyy*Syy+gupzz*Szz+TWO*(gupxy*Sxy+gupxz*Sxz+gupyz*Syz))*chipn1) - - return - - end subroutine get4ricciscalar + + +#include "macrodef.fh" + +!----------------------------------------------------------------------------- +! +! compute 4 dimensional Ricci scalar +! this routine is valid for both box and shell +! +!----------------------------------------------------------------------------- + + subroutine get4ricciscalar(ex, X, Y, Z, & + chi, trK, rho, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Sxx,Sxy,Sxz,Syy,Syz,Szz,& + RR) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,rho +! physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! matter + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Sxx,Sxy,Sxz,Syy,Syz,Szz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: RR + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,chipn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, parameter :: ONE = 1.d0, TWO = 2.d0, THR = 3.d0, F8 = 8.d0, F2o3 = 2.d0/3.d0 + real*8 :: PI + + PI = dacos(-ONE) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + RR =(gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) )) - F2o3*trK*trK & + -(gupxx*Rxx+gupyy*Ryy+gupzz*Rzz+TWO*(gupxy*Rxy+gupxz*Rxz+gupyz*Ryz))*chipn1 & + -F8*PI*(THR*rho- & + (gupxx*Sxx+gupyy*Syy+gupzz*Szz+TWO*(gupxy*Sxy+gupxz*Sxz+gupyz*Syz))*chipn1) + + return + + end subroutine get4ricciscalar diff --git a/AMSS_NCKU_source/lopsided_c.C b/AMSS_NCKU_source/BSSN/lopsided_c.C similarity index 100% rename from AMSS_NCKU_source/lopsided_c.C rename to AMSS_NCKU_source/BSSN/lopsided_c.C diff --git a/AMSS_NCKU_source/lopsided_kodis_c.C b/AMSS_NCKU_source/BSSN/lopsided_kodis_c.C similarity index 100% rename from AMSS_NCKU_source/lopsided_kodis_c.C rename to AMSS_NCKU_source/BSSN/lopsided_kodis_c.C diff --git a/AMSS_NCKU_source/lopsidediff.f90 b/AMSS_NCKU_source/BSSN/lopsidediff.f90 similarity index 97% rename from AMSS_NCKU_source/lopsidediff.f90 rename to AMSS_NCKU_source/BSSN/lopsidediff.f90 index f0af27b..93001c3 100644 --- a/AMSS_NCKU_source/lopsidediff.f90 +++ b/AMSS_NCKU_source/BSSN/lopsidediff.f90 @@ -1,1097 +1,1097 @@ - -! Compute advection terms in right hand sides of field equations - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!----------------------------------------------------------------------------- -! v -! D f = ------[ - 3 f + 4 f - f ] -! i 2dx i i+v i+2v -! -! where -! -! i -! |B | -! v = ----- -! i -! B -! -!----------------------------------------------------------------------------- -subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),Symmetry - real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz - - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs - real*8,dimension(3),intent(in) ::SoA - -!~~~~~~> local variables: -! note index -1,0, so we have 2 extra points - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: dX,dY,dZ - real*8 :: d2dx,d2dy,d2dz - real*8, parameter :: ZEO=0.d0,ONE=1.d0,TWO=2.d0,THR=3.d0,FOUR=4.d0 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - call symmetry_bd(2,ex,f,fh,SoA) - -! upper bound set ex-1 only for efficiency, -! the loop body will set ex 0 also - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(Sfx(i,j,k) >= ZEO)then - if( i+2 <= imax .and. i >= imin)then -! v -! D f = ------[ - 3 f + 4 f - f ] -! i 2dx i i+v i+2v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d2dx*(-THR*fh(i,j,k)+FOUR*fh(i+1,j,k)-fh(i+2,j,k)) - elseif(i+1 <= imax .and. i >= imin)then -! v -! D f = ------[ - f + f ] -! i dx i i+v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d2dx*(-fh(i,j,k)+fh(i+1,j,k)) - - endif - - elseif(Sfx(i,j,k) <= ZEO)then - if( i-2 >= imin .and. i <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d2dx*(-THR*fh(i,j,k)+FOUR*fh(i-1,j,k)-fh(i-2,j,k)) - elseif(i-1 >= imin .and. i <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d2dx*(-fh(i,j,k)+fh(i-1,j,k)) - endif - -! set imax and imin 0 - endif - -! y direction - if(Sfy(i,j,k) >= ZEO)then - if( j+2 <= jmax .and. j >= jmin)then -! v -! D f = ------[ - 3 f + 4 f - f ] -! i 2dx i i+v i+2v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d2dy*(-THR*fh(i,j,k)+FOUR*fh(i,j+1,k)-fh(i,j+2,k)) - elseif(j+1 <= jmax .and. j >= jmin)then -! v -! D f = ------[ - f + f ] -! i dx i i+v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d2dy*(-fh(i,j,k)+fh(i,j+1,k)) - endif - - elseif(Sfy(i,j,k) <= ZEO)then - if( j-2 >= jmin .and. j <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d2dy*(-THR*fh(i,j,k)+FOUR*fh(i,j-1,k)-fh(i,j-2,k)) - elseif(j-1 >= jmin .and. j <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d2dy*(-fh(i,j,k)+fh(i,j-1,k)) - endif - -! set jmin and jmax 0 - endif -!! z direction - if(Sfz(i,j,k) >= ZEO)then - if( k+2 <= kmax .and. k >= kmin)then -! v -! D f = ------[ - 3 f + 4 f - f ] -! i 2dx i i+v i+2v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d2dz*(-THR*fh(i,j,k)+FOUR*fh(i,j,k+1)-fh(i,j,k+2)) - elseif(k+1 <= kmax .and. k >= kmin)then -! v -! D f = ------[ - f + f ] -! i dx i i+v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d2dz*(-fh(i,j,k)+fh(i,j,k+1)) - endif - - elseif(Sfz(i,j,k) <= ZEO)then - if( k-2 >= kmin .and. k <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d2dz*(-THR*fh(i,j,k)+FOUR*fh(i,j,k-1)-fh(i,j,k-2)) - elseif(k-1 >= kmin .and. k <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d2dz*(-fh(i,j,k)+fh(i,j,k-1)) - endif - -! set kmin and kmax 0 - endif - - enddo - enddo - enddo - - return - - end subroutine lopsided - -#elif (ghost_width == 3) -! fourth order code - -!----------------------------------------------------------------------------- -! -! Compute advection terms in right hand sides of field equations -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v -! -! where -! -! i -! |B | -! v = ----- -! i -! B -! -!----------------------------------------------------------------------------- - -subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),Symmetry - real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz - - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs - real*8,dimension(3),intent(in) ::SoA - -!~~~~~~> local variables: -! note index -2,-1,0, so we have 3 extra points - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: dX,dY,dZ - real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F3=3.d0 - real*8, parameter :: TWO=2.d0,F6=6.0d0,F18=1.8d1 - real*8, parameter :: F12=1.2d1, F10=1.d1,EIT=8.d0 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - call symmetry_bd(3,ex,f,fh,SoA) - -! upper bound set ex-1 only for efficiency, -! the loop body will set ex 0 also - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -#if 0 -!! old code -! x direction - if(Sfx(i,j,k) >= ZEO .and. i+3 <= imax .and. i-1 >= imin)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & - -F6*fh(i+2,j,k)+ fh(i+3,j,k)) - - elseif(Sfx(i,j,k) <= ZEO .and. i-3 >= imin .and. i+1 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & - -F6*fh(i-2,j,k)+ fh(i-3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - f_rhs(i,j,k)=f_rhs(i,j,k) + Sfx(i,j,k)*d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - -! y direction - if(Sfy(i,j,k) >= ZEO .and. j+3 <= jmax .and. j-1 >= jmin)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & - -F6*fh(i,j+2,k)+ fh(i,j+3,k)) - - elseif(Sfy(i,j,k) <= ZEO .and. j-3 >= jmin .and. j+1 <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & - -F6*fh(i,j-2,k)+ fh(i,j-3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k) + Sfy(i,j,k)*d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) -! set jmin and jmax 0 - endif -!! z direction - if(Sfz(i,j,k) >= ZEO .and. k+3 <= kmax .and. k-1 >= kmin)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & - -F6*fh(i,j,k+2)+ fh(i,j,k+3)) - - elseif(Sfz(i,j,k) <= ZEO .and. k-3 >= kmin .and. k+1 <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & - -F6*fh(i,j,k-2)+ fh(i,j,k-3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+Sfz(i,j,k)*d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) -! set kmin and kmax 0 - endif -#else -!! new code, 2012dec27, based on bam -! x direction - if(Sfx(i,j,k) > ZEO)then - if(i+3 <= imax)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & - -F6*fh(i+2,j,k)+ fh(i+3,j,k)) - elseif(i+2 <= imax)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax)then -! v -! D f = ------[ 3f + 10f - 18f + 6f - f ] -! i 12dx i+v i i-v i-2v i-3v - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & - -F6*fh(i-2,j,k)+ fh(i-3,j,k)) -! set imax and imin 0 - endif - elseif(Sfx(i,j,k) < ZEO)then - if(i-3 >= imin)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & - -F6*fh(i-2,j,k)+ fh(i-3,j,k)) - elseif(i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i-1 >= imin)then -! v -! D f = ------[ 3f + 10f - 18f + 6f - f ] -! i 12dx i+v i i-v i-2v i-3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & - -F6*fh(i+2,j,k)+ fh(i+3,j,k)) -! set imax and imin 0 - endif - endif - -! y direction - if(Sfy(i,j,k) > ZEO)then - if(j+3 <= jmax)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & - -F6*fh(i,j+2,k)+ fh(i,j+3,k)) - elseif(j+2 <= jmax)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax)then -! v -! D f = ------[ 3f + 10f - 18f + 6f - f ] -! i 12dx i+v i i-v i-2v i-3v - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & - -F6*fh(i,j-2,k)+ fh(i,j-3,k)) -! set imax and imin 0 - endif - elseif(Sfy(i,j,k) < ZEO)then - if(j-3 >= jmin)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & - -F6*fh(i,j-2,k)+ fh(i,j-3,k)) - elseif(j-2 >= jmin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j-1 >= jmin)then -! v -! D f = ------[ 3f + 10f - 18f + 6f - f ] -! i 12dx i+v i i-v i-2v i-3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & - -F6*fh(i,j+2,k)+ fh(i,j+3,k)) -! set jmax and jmin 0 - endif - endif - -! z direction - if(Sfz(i,j,k) > ZEO)then - if(k+3 <= kmax)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & - -F6*fh(i,j,k+2)+ fh(i,j,k+3)) - elseif(k+2 <= kmax)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax)then -! v -! D f = ------[ 3f + 10f - 18f + 6f - f ] -! i 12dx i+v i i-v i-2v i-3v - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & - -F6*fh(i,j,k-2)+ fh(i,j,k-3)) -! set imax and imin 0 - endif - elseif(Sfz(i,j,k) < ZEO)then - if(k-3 >= kmin)then -! v -! D f = ------[ - 3f - 10f + 18f - 6f + f ] -! i 12dx i-v i i+v i+2v i+3v - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & - -F6*fh(i,j,k-2)+ fh(i,j,k-3)) - elseif(k-2 >= kmin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k-1 >= kmin)then -! v -! D f = ------[ 3f + 10f - 18f + 6f - f ] -! i 12dx i+v i i-v i-2v i-3v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & - -F6*fh(i,j,k+2)+ fh(i,j,k+3)) -! set kmax and kmin 0 - endif - endif -#endif - enddo - enddo - enddo - - return - - end subroutine lopsided - -!----------------------------------------------------------------------------- -! Combined advection (lopsided) + Kreiss-Oliger dissipation (kodis) -! Shares the symmetry_bd buffer fh, eliminating one full-grid copy per call. -! Mathematically identical to calling lopsided then kodis separately. -!----------------------------------------------------------------------------- -subroutine lopsided_kodis(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA,eps) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),Symmetry - real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz - - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs - real*8,dimension(3),intent(in) ::SoA - real*8,intent(in) :: eps - -!~~~~~~> local variables: -! note index -2,-1,0, so we have 3 extra points - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: dX,dY,dZ - real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F3=3.d0 - real*8, parameter :: TWO=2.d0,F6=6.0d0,F18=1.8d1 - real*8, parameter :: F12=1.2d1, F10=1.d1,EIT=8.d0 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 -! kodis parameters - real*8, parameter :: SIX=6.d0,FIT=1.5d1,TWT=2.d1 - real*8, parameter :: cof=6.4d1 ! 2^6 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - -! Single symmetry_bd call shared by both advection and dissipation - call symmetry_bd(3,ex,f,fh,SoA) - -! ---- Advection (lopsided) loop ---- -! upper bound set ex-1 only for efficiency, -! the loop body will set ex 0 also - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(Sfx(i,j,k) > ZEO)then - if(i+3 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & - -F6*fh(i+2,j,k)+ fh(i+3,j,k)) - elseif(i+2 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & - -F6*fh(i-2,j,k)+ fh(i-3,j,k)) - endif - elseif(Sfx(i,j,k) < ZEO)then - if(i-3 >= imin)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & - -F6*fh(i-2,j,k)+ fh(i-3,j,k)) - elseif(i-2 >= imin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i-1 >= imin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & - -F6*fh(i+2,j,k)+ fh(i+3,j,k)) - endif - endif - -! y direction - if(Sfy(i,j,k) > ZEO)then - if(j+3 <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & - -F6*fh(i,j+2,k)+ fh(i,j+3,k)) - elseif(j+2 <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & - -F6*fh(i,j-2,k)+ fh(i,j-3,k)) - endif - elseif(Sfy(i,j,k) < ZEO)then - if(j-3 >= jmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & - -F6*fh(i,j-2,k)+ fh(i,j-3,k)) - elseif(j-2 >= jmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j-1 >= jmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & - -F6*fh(i,j+2,k)+ fh(i,j+3,k)) - endif - endif - -! z direction - if(Sfz(i,j,k) > ZEO)then - if(k+3 <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & - -F6*fh(i,j,k+2)+ fh(i,j,k+3)) - elseif(k+2 <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & - -F6*fh(i,j,k-2)+ fh(i,j,k-3)) - endif - elseif(Sfz(i,j,k) < ZEO)then - if(k-3 >= kmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & - -F6*fh(i,j,k-2)+ fh(i,j,k-3)) - elseif(k-2 >= kmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k-1 >= kmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & - -F6*fh(i,j,k+2)+ fh(i,j,k+3)) - endif - endif - enddo - enddo - enddo - -! ---- Dissipation (kodis) loop ---- - if(eps > ZEO) then - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i-3 >= imin .and. i+3 <= imax .and. & - j-3 >= jmin .and. j+3 <= jmax .and. & - k-3 >= kmin .and. k+3 <= kmax) then - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/cof *( ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) )/dX + & - ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) )/dY + & - ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) )/dZ ) - endif - - enddo - enddo - enddo - endif - - return - - end subroutine lopsided_kodis - -#elif (ghost_width == 4) -! sixth order code -! Compute advection terms in right hand sides of field equations -! v -! D f = ------[ 2f - 24f - 35f + 80f - 30f + 8f - f ] -! i 60dx i-2v i-v i i+v i+2v i+3v i+4v -! -! where -! -! i -! |B | -! v = ----- -! i -! B -! -!----------------------------------------------------------------------------- -subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),Symmetry - real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz - - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs - real*8,dimension(3),intent(in) ::SoA - -!~~~~~~> local variables: - - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: dX,dY,dZ - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,F24=2.4d1,F35=3.5d1,F80=8.d1,F30=3.d1,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - real*8, parameter :: F10=1.d1,F77=7.7d1,F150=1.5d2,F100=1.d2,F50=5.d1,F15=1.5d1 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - call symmetry_bd(4,ex,f,fh,SoA) - -! upper bound set ex-1 only for efficiency, -! the loop body will set ex 0 also - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(Sfx(i,j,k) >= ZEO .and. i+4 <= imax .and. i-2 >= imin)then -! v -! D f = ------[ 2f - 24f - 35f + 80f - 30f + 8f - f ] -! i 60dx i-2v i-v i i+v i+2v i+3v i+4v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d60dx*(TWO*fh(i-2,j,k)-F24*fh(i-1,j,k)-F35*fh(i,j,k)+F80*fh(i+1,j,k) & - -F30*fh(i+2,j,k)+EIT*fh(i+3,j,k)- fh(i+4,j,k)) - elseif(Sfx(i,j,k) >= ZEO .and. i+5 <= imax .and. i-1 >= imin)then -! v -! D f = ------[-10f - 77f + 150f - 100f + 50f -15f + 2f ] -! i 60dx i-v i i+v i+2v i+3v i+4v i+5v - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d60dx*(-F10*fh(i-1,j,k)-F77*fh(i ,j,k)+F150*fh(i+1,j,k)-F100*fh(i+2,j,k) & - +F50*fh(i+3,j,k)-F15*fh(i+4,j,k)+ TWO*fh(i+5,j,k)) - - elseif(Sfx(i,j,k) <= ZEO .and. i-4 >= imin .and. i+2 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d60dx*(TWO*fh(i+2,j,k)-F24*fh(i+1,j,k)-F35*fh(i,j,k)+F80*fh(i-1,j,k) & - -F30*fh(i-2,j,k)+EIT*fh(i-3,j,k)- fh(i-4,j,k)) - elseif(Sfx(i,j,k) <= ZEO .and. i-5 >= imin .and. i+1 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d60dx*(-F10*fh(i+1,j,k)-F77*fh(i ,j,k)+F150*fh(i-1,j,k)-F100*fh(i-2,j,k) & - +F50*fh(i-3,j,k)-F15*fh(i-4,j,k)+ TWO*fh(i-5,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - f_rhs(i,j,k)=f_rhs(i,j,k) + Sfx(i,j,k)*d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - -! y direction - if(Sfy(i,j,k) >= ZEO .and. j+4 <= jmax .and. j-2 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d60dy*(TWO*fh(i,j-2,k)-F24*fh(i,j-1,k)-F35*fh(i,j,k)+F80*fh(i,j+1,k) & - -F30*fh(i,j+2,k)+EIT*fh(i,j+3,k)- fh(i,j+4,k)) - elseif(Sfy(i,j,k) >= ZEO .and. j+5 <= jmax .and. j-1 >= jmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d60dy*(-F10*fh(i,j-1,k)-F77*fh(i,j ,k)+F150*fh(i,j+1,k)-F100*fh(i,j+2,k) & - +F50*fh(i,j+3,k)-F15*fh(i,j+4,k)+ TWO*fh(i,j+5,k)) - - elseif(Sfy(i,j,k) <= ZEO .and. j-4 >= jmin .and. j+2 <= jmax)then - - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d60dy*(TWO*fh(i,j+2,k)-F24*fh(i,j+1,k)-F35*fh(i,j,k)+F80*fh(i,j-1,k) & - -F30*fh(i,j-2,k)+EIT*fh(i,j-3,k)- fh(i,j-4,k)) - - elseif(Sfy(i,j,k) <= ZEO .and. j-5 >= jmin .and. j+1 <= jmax)then - - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d60dy*(-F10*fh(i,j+1,k)-F77*fh(i,j ,k)+F150*fh(i,j-1,k)-F100*fh(i,j-2,k) & - +F50*fh(i,j-3,k)-F15*fh(i,j-4,k)+ TWO*fh(i,j-5,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k) + Sfy(i,j,k)*d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) -! set jmin and jmax 0 - endif -!! z direction - if(Sfz(i,j,k) >= ZEO .and. k+4 <= kmax .and. k-2 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d60dz*(TWO*fh(i,j,k-2)-F24*fh(i,j,k-1)-F35*fh(i,j,k)+F80*fh(i,j,k+1) & - -F30*fh(i,j,k+2)+EIT*fh(i,j,k+3)- fh(i,j,k+4)) - elseif(Sfz(i,j,k) >= ZEO .and. k+5 <= kmax .and. k-1 >= kmin)then - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d60dz*(-F10*fh(i,j,k-1)-F77*fh(i,j,k )+F150*fh(i,j,k+1)-F100*fh(i,j,k+2) & - +F50*fh(i,j,k+3)-F15*fh(i,j,k+4)+ TWO*fh(i,j,k+5)) - - elseif(Sfz(i,j,k) <= ZEO .and. k-4 >= kmin .and. k+2 <= kmax)then - - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d60dz*(TWO*fh(i,j,k+2)-F24*fh(i,j,k+1)-F35*fh(i,j,k)+F80*fh(i,j,k-1) & - -F30*fh(i,j,k-2)+EIT*fh(i,j,k-3)- fh(i,j,k-4)) - - elseif(Sfz(i,j,k) <= ZEO .and. k-5 >= kmin .and. k+1 <= kmax)then - - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d60dz*(-F10*fh(i,j,k+1)-F77*fh(i,j,k )+F150*fh(i,j,k-1)-F100*fh(i,j,k-2) & - +F50*fh(i,j,k-3)-F15*fh(i,j,k-4)+ TWO*fh(i,j,k-5)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+Sfz(i,j,k)*d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) -! set kmin and kmax 0 - endif - - enddo - enddo - enddo - - return - - end subroutine lopsided - -#elif (ghost_width == 5) -! eighth order code -!----------------------------------------------------------------------------- -! PRD 77, 024034 (2008) -! Compute advection terms in right hand sides of field equations -! v [ - 5 f(i-3v) + 60 f(i-2v) - 420 f(i-v) - 378 f(i) + 1050 f(i+v) - 420 f(i+2v) + 140 f(i+3v) - 30 f(i+4v) + 3 f(i+5v)] -! D f = -------------------------------------------------------------------------------------------------------------------------- -! i 840 dx -! -! where -! -! i -! |B | -! v = ----- -! i -! B -! -!----------------------------------------------------------------------------- -subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),Symmetry - real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz - - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs - real*8,dimension(3),intent(in) ::SoA - -!~~~~~~> local variables: - - real*8,dimension(-4:ex(1),-4:ex(2),-4:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: dX,dY,dZ - real*8 :: d840dx,d840dy,d840dz,d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,F30=3.d1,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F140=1.4d2,THR=3.d0 - real*8, parameter :: F840=8.4d2,F5=5.d0,F420=4.2d2,F378=3.78d2,F1050=1.05d3 - real*8, parameter :: F32=3.2d1,F168=1.68d2,F672=6.72d2 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - d840dx = ONE/F840/dX - d840dy = ONE/F840/dY - d840dz = ONE/F840/dZ - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -4 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -4 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -4 - - call symmetry_bd(5,ex,f,fh,SoA) - -! upper bound set ex-1 only for efficiency, -! the loop body will set ex 0 also - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(Sfx(i,j,k) >= ZEO .and. i+5 <= imax .and. i-3 >= imin)then -! v [ - 5 f(i-3v) + 60 f(i-2v) - 420 f(i-v) - 378 f(i) + 1050 f(i+v) - 420 f(i+2v) + 140 f(i+3v) - 30 f(i+4v) + 3 f(i+5v)] -! D f = -------------------------------------------------------------------------------------------------------------------------- -! i 840 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d840dx*(-F5*fh(i-3,j,k)+F60 *fh(i-2,j,k)-F420*fh(i-1,j,k)-F378*fh(i ,j,k) & - +F1050*fh(i+1,j,k)-F420*fh(i+2,j,k)+F140*fh(i+3,j,k)-F30 *fh(i+4,j,k)+THR*fh(i+5,j,k)) - - elseif(Sfx(i,j,k) <= ZEO .and. i-5 >= imin .and. i+3 <= imax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfx(i,j,k)*d840dx*(-F5*fh(i+3,j,k)+F60 *fh(i+2,j,k)-F420*fh(i+1,j,k)-F378*fh(i ,j,k) & - +F1050*fh(i-1,j,k)-F420*fh(i-2,j,k)+F140*fh(i-3,j,k)- F30*fh(i-4,j,k)+THR*fh(i-5,j,k)) - - elseif(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - f_rhs(i,j,k)=f_rhs(i,j,k) + Sfx(i,j,k)*d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - -! y direction - if(Sfy(i,j,k) >= ZEO .and. j+5 <= jmax .and. j-3 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d840dy*(-F5*fh(i,j-3,k)+F60 *fh(i,j-2,k)-F420*fh(i,j-1,k)-F378*fh(i,j ,k) & - +F1050*fh(i,j+1,k)-F420*fh(i,j+2,k)+F140*fh(i,j+3,k)-F30 *fh(i,j+4,k)+THR*fh(i,j+5,k)) - - elseif(Sfy(i,j,k) <= ZEO .and. j-5 >= jmin .and. j+3 <= jmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfy(i,j,k)*d840dy*(-F5*fh(i,j+3,k)+F60 *fh(i,j+2,k)-F420*fh(i,j+1,k)-F378*fh(i,j ,k) & - +F1050*fh(i,j-1,k)-F420*fh(i,j-2,k)+F140*fh(i,j-3,k)- F30*fh(i,j-4,k)+THR*fh(i,j-5,k)) - - elseif(j+4 <= jmax .and. j-4 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k) + Sfy(i,j,k)*d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) -! set jmin and jmax 0 - endif -!! z direction - if(Sfz(i,j,k) >= ZEO .and. k+5 <= kmax .and. k-3 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d840dz*(-F5*fh(i,j,k-3)+F60 *fh(i,j,k-2)-F420*fh(i,j,k-1)-F378*fh(i,j,k ) & - +F1050*fh(i,j,k+1)-F420*fh(i,j,k+2)+F140*fh(i,j,k+3)-F30 *fh(i,j,k+4)+THR*fh(i,j,k+5)) - - elseif(Sfz(i,j,k) <= ZEO .and. k-5 >= kmin .and. k+3 <= kmax)then - f_rhs(i,j,k)=f_rhs(i,j,k)- & - Sfz(i,j,k)*d840dz*(-F5*fh(i,j,k+3)+F60 *fh(i,j,k+2)-F420*fh(i,j,k+1)-F378*fh(i,j,k ) & - +F1050*fh(i,j,k-1)-F420*fh(i,j,k-2)+F140*fh(i,j,k-3)- F30*fh(i,j,k-4)+THR*fh(i,j,k-5)) - - elseif(k+4 <= kmax .and. k-4 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+ & - Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - f_rhs(i,j,k)=f_rhs(i,j,k)+Sfz(i,j,k)*d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) -! set kmin and kmax 0 - endif - - enddo - enddo - enddo - - return - - end subroutine lopsided - -#endif + +! Compute advection terms in right hand sides of field equations + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!----------------------------------------------------------------------------- +! v +! D f = ------[ - 3 f + 4 f - f ] +! i 2dx i i+v i+2v +! +! where +! +! i +! |B | +! v = ----- +! i +! B +! +!----------------------------------------------------------------------------- +subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),Symmetry + real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz + + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs + real*8,dimension(3),intent(in) ::SoA + +!~~~~~~> local variables: +! note index -1,0, so we have 2 extra points + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: dX,dY,dZ + real*8 :: d2dx,d2dy,d2dz + real*8, parameter :: ZEO=0.d0,ONE=1.d0,TWO=2.d0,THR=3.d0,FOUR=4.d0 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + call symmetry_bd(2,ex,f,fh,SoA) + +! upper bound set ex-1 only for efficiency, +! the loop body will set ex 0 also + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(Sfx(i,j,k) >= ZEO)then + if( i+2 <= imax .and. i >= imin)then +! v +! D f = ------[ - 3 f + 4 f - f ] +! i 2dx i i+v i+2v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d2dx*(-THR*fh(i,j,k)+FOUR*fh(i+1,j,k)-fh(i+2,j,k)) + elseif(i+1 <= imax .and. i >= imin)then +! v +! D f = ------[ - f + f ] +! i dx i i+v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d2dx*(-fh(i,j,k)+fh(i+1,j,k)) + + endif + + elseif(Sfx(i,j,k) <= ZEO)then + if( i-2 >= imin .and. i <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d2dx*(-THR*fh(i,j,k)+FOUR*fh(i-1,j,k)-fh(i-2,j,k)) + elseif(i-1 >= imin .and. i <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d2dx*(-fh(i,j,k)+fh(i-1,j,k)) + endif + +! set imax and imin 0 + endif + +! y direction + if(Sfy(i,j,k) >= ZEO)then + if( j+2 <= jmax .and. j >= jmin)then +! v +! D f = ------[ - 3 f + 4 f - f ] +! i 2dx i i+v i+2v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d2dy*(-THR*fh(i,j,k)+FOUR*fh(i,j+1,k)-fh(i,j+2,k)) + elseif(j+1 <= jmax .and. j >= jmin)then +! v +! D f = ------[ - f + f ] +! i dx i i+v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d2dy*(-fh(i,j,k)+fh(i,j+1,k)) + endif + + elseif(Sfy(i,j,k) <= ZEO)then + if( j-2 >= jmin .and. j <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d2dy*(-THR*fh(i,j,k)+FOUR*fh(i,j-1,k)-fh(i,j-2,k)) + elseif(j-1 >= jmin .and. j <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d2dy*(-fh(i,j,k)+fh(i,j-1,k)) + endif + +! set jmin and jmax 0 + endif +!! z direction + if(Sfz(i,j,k) >= ZEO)then + if( k+2 <= kmax .and. k >= kmin)then +! v +! D f = ------[ - 3 f + 4 f - f ] +! i 2dx i i+v i+2v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d2dz*(-THR*fh(i,j,k)+FOUR*fh(i,j,k+1)-fh(i,j,k+2)) + elseif(k+1 <= kmax .and. k >= kmin)then +! v +! D f = ------[ - f + f ] +! i dx i i+v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d2dz*(-fh(i,j,k)+fh(i,j,k+1)) + endif + + elseif(Sfz(i,j,k) <= ZEO)then + if( k-2 >= kmin .and. k <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d2dz*(-THR*fh(i,j,k)+FOUR*fh(i,j,k-1)-fh(i,j,k-2)) + elseif(k-1 >= kmin .and. k <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d2dz*(-fh(i,j,k)+fh(i,j,k-1)) + endif + +! set kmin and kmax 0 + endif + + enddo + enddo + enddo + + return + + end subroutine lopsided + +#elif (ghost_width == 3) +! fourth order code + +!----------------------------------------------------------------------------- +! +! Compute advection terms in right hand sides of field equations +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v +! +! where +! +! i +! |B | +! v = ----- +! i +! B +! +!----------------------------------------------------------------------------- + +subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),Symmetry + real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz + + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs + real*8,dimension(3),intent(in) ::SoA + +!~~~~~~> local variables: +! note index -2,-1,0, so we have 3 extra points + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: dX,dY,dZ + real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F3=3.d0 + real*8, parameter :: TWO=2.d0,F6=6.0d0,F18=1.8d1 + real*8, parameter :: F12=1.2d1, F10=1.d1,EIT=8.d0 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + call symmetry_bd(3,ex,f,fh,SoA) + +! upper bound set ex-1 only for efficiency, +! the loop body will set ex 0 also + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +#if 0 +!! old code +! x direction + if(Sfx(i,j,k) >= ZEO .and. i+3 <= imax .and. i-1 >= imin)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & + -F6*fh(i+2,j,k)+ fh(i+3,j,k)) + + elseif(Sfx(i,j,k) <= ZEO .and. i-3 >= imin .and. i+1 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & + -F6*fh(i-2,j,k)+ fh(i-3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + f_rhs(i,j,k)=f_rhs(i,j,k) + Sfx(i,j,k)*d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + +! y direction + if(Sfy(i,j,k) >= ZEO .and. j+3 <= jmax .and. j-1 >= jmin)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & + -F6*fh(i,j+2,k)+ fh(i,j+3,k)) + + elseif(Sfy(i,j,k) <= ZEO .and. j-3 >= jmin .and. j+1 <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & + -F6*fh(i,j-2,k)+ fh(i,j-3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k) + Sfy(i,j,k)*d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) +! set jmin and jmax 0 + endif +!! z direction + if(Sfz(i,j,k) >= ZEO .and. k+3 <= kmax .and. k-1 >= kmin)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & + -F6*fh(i,j,k+2)+ fh(i,j,k+3)) + + elseif(Sfz(i,j,k) <= ZEO .and. k-3 >= kmin .and. k+1 <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & + -F6*fh(i,j,k-2)+ fh(i,j,k-3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+Sfz(i,j,k)*d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) +! set kmin and kmax 0 + endif +#else +!! new code, 2012dec27, based on bam +! x direction + if(Sfx(i,j,k) > ZEO)then + if(i+3 <= imax)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & + -F6*fh(i+2,j,k)+ fh(i+3,j,k)) + elseif(i+2 <= imax)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax)then +! v +! D f = ------[ 3f + 10f - 18f + 6f - f ] +! i 12dx i+v i i-v i-2v i-3v + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & + -F6*fh(i-2,j,k)+ fh(i-3,j,k)) +! set imax and imin 0 + endif + elseif(Sfx(i,j,k) < ZEO)then + if(i-3 >= imin)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & + -F6*fh(i-2,j,k)+ fh(i-3,j,k)) + elseif(i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i-1 >= imin)then +! v +! D f = ------[ 3f + 10f - 18f + 6f - f ] +! i 12dx i+v i i-v i-2v i-3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & + -F6*fh(i+2,j,k)+ fh(i+3,j,k)) +! set imax and imin 0 + endif + endif + +! y direction + if(Sfy(i,j,k) > ZEO)then + if(j+3 <= jmax)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & + -F6*fh(i,j+2,k)+ fh(i,j+3,k)) + elseif(j+2 <= jmax)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax)then +! v +! D f = ------[ 3f + 10f - 18f + 6f - f ] +! i 12dx i+v i i-v i-2v i-3v + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & + -F6*fh(i,j-2,k)+ fh(i,j-3,k)) +! set imax and imin 0 + endif + elseif(Sfy(i,j,k) < ZEO)then + if(j-3 >= jmin)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & + -F6*fh(i,j-2,k)+ fh(i,j-3,k)) + elseif(j-2 >= jmin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j-1 >= jmin)then +! v +! D f = ------[ 3f + 10f - 18f + 6f - f ] +! i 12dx i+v i i-v i-2v i-3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & + -F6*fh(i,j+2,k)+ fh(i,j+3,k)) +! set jmax and jmin 0 + endif + endif + +! z direction + if(Sfz(i,j,k) > ZEO)then + if(k+3 <= kmax)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & + -F6*fh(i,j,k+2)+ fh(i,j,k+3)) + elseif(k+2 <= kmax)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax)then +! v +! D f = ------[ 3f + 10f - 18f + 6f - f ] +! i 12dx i+v i i-v i-2v i-3v + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & + -F6*fh(i,j,k-2)+ fh(i,j,k-3)) +! set imax and imin 0 + endif + elseif(Sfz(i,j,k) < ZEO)then + if(k-3 >= kmin)then +! v +! D f = ------[ - 3f - 10f + 18f - 6f + f ] +! i 12dx i-v i i+v i+2v i+3v + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & + -F6*fh(i,j,k-2)+ fh(i,j,k-3)) + elseif(k-2 >= kmin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k-1 >= kmin)then +! v +! D f = ------[ 3f + 10f - 18f + 6f - f ] +! i 12dx i+v i i-v i-2v i-3v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & + -F6*fh(i,j,k+2)+ fh(i,j,k+3)) +! set kmax and kmin 0 + endif + endif +#endif + enddo + enddo + enddo + + return + + end subroutine lopsided + +!----------------------------------------------------------------------------- +! Combined advection (lopsided) + Kreiss-Oliger dissipation (kodis) +! Shares the symmetry_bd buffer fh, eliminating one full-grid copy per call. +! Mathematically identical to calling lopsided then kodis separately. +!----------------------------------------------------------------------------- +subroutine lopsided_kodis(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA,eps) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),Symmetry + real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz + + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs + real*8,dimension(3),intent(in) ::SoA + real*8,intent(in) :: eps + +!~~~~~~> local variables: +! note index -2,-1,0, so we have 3 extra points + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: dX,dY,dZ + real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F3=3.d0 + real*8, parameter :: TWO=2.d0,F6=6.0d0,F18=1.8d1 + real*8, parameter :: F12=1.2d1, F10=1.d1,EIT=8.d0 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 +! kodis parameters + real*8, parameter :: SIX=6.d0,FIT=1.5d1,TWT=2.d1 + real*8, parameter :: cof=6.4d1 ! 2^6 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + +! Single symmetry_bd call shared by both advection and dissipation + call symmetry_bd(3,ex,f,fh,SoA) + +! ---- Advection (lopsided) loop ---- +! upper bound set ex-1 only for efficiency, +! the loop body will set ex 0 also + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(Sfx(i,j,k) > ZEO)then + if(i+3 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & + -F6*fh(i+2,j,k)+ fh(i+3,j,k)) + elseif(i+2 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & + -F6*fh(i-2,j,k)+ fh(i-3,j,k)) + endif + elseif(Sfx(i,j,k) < ZEO)then + if(i-3 >= imin)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d12dx*(-F3*fh(i+1,j,k)-F10*fh(i,j,k)+F18*fh(i-1,j,k) & + -F6*fh(i-2,j,k)+ fh(i-3,j,k)) + elseif(i-2 >= imin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i-1 >= imin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(-F3*fh(i-1,j,k)-F10*fh(i,j,k)+F18*fh(i+1,j,k) & + -F6*fh(i+2,j,k)+ fh(i+3,j,k)) + endif + endif + +! y direction + if(Sfy(i,j,k) > ZEO)then + if(j+3 <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & + -F6*fh(i,j+2,k)+ fh(i,j+3,k)) + elseif(j+2 <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & + -F6*fh(i,j-2,k)+ fh(i,j-3,k)) + endif + elseif(Sfy(i,j,k) < ZEO)then + if(j-3 >= jmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j+1,k)-F10*fh(i,j,k)+F18*fh(i,j-1,k) & + -F6*fh(i,j-2,k)+ fh(i,j-3,k)) + elseif(j-2 >= jmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j-1 >= jmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(-F3*fh(i,j-1,k)-F10*fh(i,j,k)+F18*fh(i,j+1,k) & + -F6*fh(i,j+2,k)+ fh(i,j+3,k)) + endif + endif + +! z direction + if(Sfz(i,j,k) > ZEO)then + if(k+3 <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & + -F6*fh(i,j,k+2)+ fh(i,j,k+3)) + elseif(k+2 <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & + -F6*fh(i,j,k-2)+ fh(i,j,k-3)) + endif + elseif(Sfz(i,j,k) < ZEO)then + if(k-3 >= kmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k+1)-F10*fh(i,j,k)+F18*fh(i,j,k-1) & + -F6*fh(i,j,k-2)+ fh(i,j,k-3)) + elseif(k-2 >= kmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k-1 >= kmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(-F3*fh(i,j,k-1)-F10*fh(i,j,k)+F18*fh(i,j,k+1) & + -F6*fh(i,j,k+2)+ fh(i,j,k+3)) + endif + endif + enddo + enddo + enddo + +! ---- Dissipation (kodis) loop ---- + if(eps > ZEO) then + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i-3 >= imin .and. i+3 <= imax .and. & + j-3 >= jmin .and. j+3 <= jmax .and. & + k-3 >= kmin .and. k+3 <= kmax) then + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/cof *( ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) )/dX + & + ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) )/dY + & + ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) )/dZ ) + endif + + enddo + enddo + enddo + endif + + return + + end subroutine lopsided_kodis + +#elif (ghost_width == 4) +! sixth order code +! Compute advection terms in right hand sides of field equations +! v +! D f = ------[ 2f - 24f - 35f + 80f - 30f + 8f - f ] +! i 60dx i-2v i-v i i+v i+2v i+3v i+4v +! +! where +! +! i +! |B | +! v = ----- +! i +! B +! +!----------------------------------------------------------------------------- +subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),Symmetry + real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz + + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs + real*8,dimension(3),intent(in) ::SoA + +!~~~~~~> local variables: + + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: dX,dY,dZ + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,F24=2.4d1,F35=3.5d1,F80=8.d1,F30=3.d1,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + real*8, parameter :: F10=1.d1,F77=7.7d1,F150=1.5d2,F100=1.d2,F50=5.d1,F15=1.5d1 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + call symmetry_bd(4,ex,f,fh,SoA) + +! upper bound set ex-1 only for efficiency, +! the loop body will set ex 0 also + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(Sfx(i,j,k) >= ZEO .and. i+4 <= imax .and. i-2 >= imin)then +! v +! D f = ------[ 2f - 24f - 35f + 80f - 30f + 8f - f ] +! i 60dx i-2v i-v i i+v i+2v i+3v i+4v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d60dx*(TWO*fh(i-2,j,k)-F24*fh(i-1,j,k)-F35*fh(i,j,k)+F80*fh(i+1,j,k) & + -F30*fh(i+2,j,k)+EIT*fh(i+3,j,k)- fh(i+4,j,k)) + elseif(Sfx(i,j,k) >= ZEO .and. i+5 <= imax .and. i-1 >= imin)then +! v +! D f = ------[-10f - 77f + 150f - 100f + 50f -15f + 2f ] +! i 60dx i-v i i+v i+2v i+3v i+4v i+5v + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d60dx*(-F10*fh(i-1,j,k)-F77*fh(i ,j,k)+F150*fh(i+1,j,k)-F100*fh(i+2,j,k) & + +F50*fh(i+3,j,k)-F15*fh(i+4,j,k)+ TWO*fh(i+5,j,k)) + + elseif(Sfx(i,j,k) <= ZEO .and. i-4 >= imin .and. i+2 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d60dx*(TWO*fh(i+2,j,k)-F24*fh(i+1,j,k)-F35*fh(i,j,k)+F80*fh(i-1,j,k) & + -F30*fh(i-2,j,k)+EIT*fh(i-3,j,k)- fh(i-4,j,k)) + elseif(Sfx(i,j,k) <= ZEO .and. i-5 >= imin .and. i+1 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d60dx*(-F10*fh(i+1,j,k)-F77*fh(i ,j,k)+F150*fh(i-1,j,k)-F100*fh(i-2,j,k) & + +F50*fh(i-3,j,k)-F15*fh(i-4,j,k)+ TWO*fh(i-5,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + f_rhs(i,j,k)=f_rhs(i,j,k) + Sfx(i,j,k)*d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + +! y direction + if(Sfy(i,j,k) >= ZEO .and. j+4 <= jmax .and. j-2 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d60dy*(TWO*fh(i,j-2,k)-F24*fh(i,j-1,k)-F35*fh(i,j,k)+F80*fh(i,j+1,k) & + -F30*fh(i,j+2,k)+EIT*fh(i,j+3,k)- fh(i,j+4,k)) + elseif(Sfy(i,j,k) >= ZEO .and. j+5 <= jmax .and. j-1 >= jmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d60dy*(-F10*fh(i,j-1,k)-F77*fh(i,j ,k)+F150*fh(i,j+1,k)-F100*fh(i,j+2,k) & + +F50*fh(i,j+3,k)-F15*fh(i,j+4,k)+ TWO*fh(i,j+5,k)) + + elseif(Sfy(i,j,k) <= ZEO .and. j-4 >= jmin .and. j+2 <= jmax)then + + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d60dy*(TWO*fh(i,j+2,k)-F24*fh(i,j+1,k)-F35*fh(i,j,k)+F80*fh(i,j-1,k) & + -F30*fh(i,j-2,k)+EIT*fh(i,j-3,k)- fh(i,j-4,k)) + + elseif(Sfy(i,j,k) <= ZEO .and. j-5 >= jmin .and. j+1 <= jmax)then + + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d60dy*(-F10*fh(i,j+1,k)-F77*fh(i,j ,k)+F150*fh(i,j-1,k)-F100*fh(i,j-2,k) & + +F50*fh(i,j-3,k)-F15*fh(i,j-4,k)+ TWO*fh(i,j-5,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k) + Sfy(i,j,k)*d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) +! set jmin and jmax 0 + endif +!! z direction + if(Sfz(i,j,k) >= ZEO .and. k+4 <= kmax .and. k-2 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d60dz*(TWO*fh(i,j,k-2)-F24*fh(i,j,k-1)-F35*fh(i,j,k)+F80*fh(i,j,k+1) & + -F30*fh(i,j,k+2)+EIT*fh(i,j,k+3)- fh(i,j,k+4)) + elseif(Sfz(i,j,k) >= ZEO .and. k+5 <= kmax .and. k-1 >= kmin)then + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d60dz*(-F10*fh(i,j,k-1)-F77*fh(i,j,k )+F150*fh(i,j,k+1)-F100*fh(i,j,k+2) & + +F50*fh(i,j,k+3)-F15*fh(i,j,k+4)+ TWO*fh(i,j,k+5)) + + elseif(Sfz(i,j,k) <= ZEO .and. k-4 >= kmin .and. k+2 <= kmax)then + + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d60dz*(TWO*fh(i,j,k+2)-F24*fh(i,j,k+1)-F35*fh(i,j,k)+F80*fh(i,j,k-1) & + -F30*fh(i,j,k-2)+EIT*fh(i,j,k-3)- fh(i,j,k-4)) + + elseif(Sfz(i,j,k) <= ZEO .and. k-5 >= kmin .and. k+1 <= kmax)then + + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d60dz*(-F10*fh(i,j,k+1)-F77*fh(i,j,k )+F150*fh(i,j,k-1)-F100*fh(i,j,k-2) & + +F50*fh(i,j,k-3)-F15*fh(i,j,k-4)+ TWO*fh(i,j,k-5)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+Sfz(i,j,k)*d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) +! set kmin and kmax 0 + endif + + enddo + enddo + enddo + + return + + end subroutine lopsided + +#elif (ghost_width == 5) +! eighth order code +!----------------------------------------------------------------------------- +! PRD 77, 024034 (2008) +! Compute advection terms in right hand sides of field equations +! v [ - 5 f(i-3v) + 60 f(i-2v) - 420 f(i-v) - 378 f(i) + 1050 f(i+v) - 420 f(i+2v) + 140 f(i+3v) - 30 f(i+4v) + 3 f(i+5v)] +! D f = -------------------------------------------------------------------------------------------------------------------------- +! i 840 dx +! +! where +! +! i +! |B | +! v = ----- +! i +! B +! +!----------------------------------------------------------------------------- +subroutine lopsided(ex,X,Y,Z,f,f_rhs,Sfx,Sfy,Sfz,Symmetry,SoA) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),Symmetry + real*8, intent(in) :: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8,dimension(ex(1),ex(2),ex(3)),intent(in) :: f,Sfx,Sfy,Sfz + + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout):: f_rhs + real*8,dimension(3),intent(in) ::SoA + +!~~~~~~> local variables: + + real*8,dimension(-4:ex(1),-4:ex(2),-4:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: dX,dY,dZ + real*8 :: d840dx,d840dy,d840dz,d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,F30=3.d1,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F140=1.4d2,THR=3.d0 + real*8, parameter :: F840=8.4d2,F5=5.d0,F420=4.2d2,F378=3.78d2,F1050=1.05d3 + real*8, parameter :: F32=3.2d1,F168=1.68d2,F672=6.72d2 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + d840dx = ONE/F840/dX + d840dy = ONE/F840/dY + d840dz = ONE/F840/dZ + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -4 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -4 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -4 + + call symmetry_bd(5,ex,f,fh,SoA) + +! upper bound set ex-1 only for efficiency, +! the loop body will set ex 0 also + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(Sfx(i,j,k) >= ZEO .and. i+5 <= imax .and. i-3 >= imin)then +! v [ - 5 f(i-3v) + 60 f(i-2v) - 420 f(i-v) - 378 f(i) + 1050 f(i+v) - 420 f(i+2v) + 140 f(i+3v) - 30 f(i+4v) + 3 f(i+5v)] +! D f = -------------------------------------------------------------------------------------------------------------------------- +! i 840 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d840dx*(-F5*fh(i-3,j,k)+F60 *fh(i-2,j,k)-F420*fh(i-1,j,k)-F378*fh(i ,j,k) & + +F1050*fh(i+1,j,k)-F420*fh(i+2,j,k)+F140*fh(i+3,j,k)-F30 *fh(i+4,j,k)+THR*fh(i+5,j,k)) + + elseif(Sfx(i,j,k) <= ZEO .and. i-5 >= imin .and. i+3 <= imax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfx(i,j,k)*d840dx*(-F5*fh(i+3,j,k)+F60 *fh(i+2,j,k)-F420*fh(i+1,j,k)-F378*fh(i ,j,k) & + +F1050*fh(i-1,j,k)-F420*fh(i-2,j,k)+F140*fh(i-3,j,k)- F30*fh(i-4,j,k)+THR*fh(i-5,j,k)) + + elseif(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfx(i,j,k)*d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + f_rhs(i,j,k)=f_rhs(i,j,k) + Sfx(i,j,k)*d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + +! y direction + if(Sfy(i,j,k) >= ZEO .and. j+5 <= jmax .and. j-3 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d840dy*(-F5*fh(i,j-3,k)+F60 *fh(i,j-2,k)-F420*fh(i,j-1,k)-F378*fh(i,j ,k) & + +F1050*fh(i,j+1,k)-F420*fh(i,j+2,k)+F140*fh(i,j+3,k)-F30 *fh(i,j+4,k)+THR*fh(i,j+5,k)) + + elseif(Sfy(i,j,k) <= ZEO .and. j-5 >= jmin .and. j+3 <= jmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfy(i,j,k)*d840dy*(-F5*fh(i,j+3,k)+F60 *fh(i,j+2,k)-F420*fh(i,j+1,k)-F378*fh(i,j ,k) & + +F1050*fh(i,j-1,k)-F420*fh(i,j-2,k)+F140*fh(i,j-3,k)- F30*fh(i,j-4,k)+THR*fh(i,j-5,k)) + + elseif(j+4 <= jmax .and. j-4 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfy(i,j,k)*d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k) + Sfy(i,j,k)*d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) +! set jmin and jmax 0 + endif +!! z direction + if(Sfz(i,j,k) >= ZEO .and. k+5 <= kmax .and. k-3 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d840dz*(-F5*fh(i,j,k-3)+F60 *fh(i,j,k-2)-F420*fh(i,j,k-1)-F378*fh(i,j,k ) & + +F1050*fh(i,j,k+1)-F420*fh(i,j,k+2)+F140*fh(i,j,k+3)-F30 *fh(i,j,k+4)+THR*fh(i,j,k+5)) + + elseif(Sfz(i,j,k) <= ZEO .and. k-5 >= kmin .and. k+3 <= kmax)then + f_rhs(i,j,k)=f_rhs(i,j,k)- & + Sfz(i,j,k)*d840dz*(-F5*fh(i,j,k+3)+F60 *fh(i,j,k+2)-F420*fh(i,j,k+1)-F378*fh(i,j,k ) & + +F1050*fh(i,j,k-1)-F420*fh(i,j,k-2)+F140*fh(i,j,k-3)- F30*fh(i,j,k-4)+THR*fh(i,j,k-5)) + + elseif(k+4 <= kmax .and. k-4 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+ & + Sfz(i,j,k)*d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + f_rhs(i,j,k)=f_rhs(i,j,k)+Sfz(i,j,k)*d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) +! set kmin and kmax 0 + endif + + enddo + enddo + enddo + + return + + end subroutine lopsided + +#endif diff --git a/AMSS_NCKU_source/prolongrestrict.f90 b/AMSS_NCKU_source/BSSN/prolongrestrict.f90 similarity index 97% rename from AMSS_NCKU_source/prolongrestrict.f90 rename to AMSS_NCKU_source/BSSN/prolongrestrict.f90 index 46d334c..537701b 100644 --- a/AMSS_NCKU_source/prolongrestrict.f90 +++ b/AMSS_NCKU_source/BSSN/prolongrestrict.f90 @@ -1,3554 +1,3554 @@ - - -! old code -#if 0 -! Because of overlap determination, source region is always larger than target -! region - -#include "microdef.fh" - -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif -!-------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! this routine is valid for all orders finite difference -! -! 1 2 3 4 -! *---*---*---* -! ^ -! COPY directly! -!-------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif -! it's possible a iolated point for target but not for source - FD = (uubf-llbf)/(extf-1) - CD = 2*FD - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4)+1 - ubrf = idint((uubr-base)/FD+0.4)+1 - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1).or.jmaxi.gt.extf(2).or.kmaxi.gt.extf(3))then - write(*,*)"error in restrict for" - write(*,*)"mino = ",imino,jmino,kmino - write(*,*)"maxo = ",imaxo,jmaxo,kmaxo - write(*,*)"extc = ",extc - write(*,*)"CD = ",CD - write(*,*)"mini = ",imini,jmini,kmini - write(*,*)"maxi = ",imaxi,jmaxi,kmaxi - write(*,*)"extf = ",extf - write(*,*)"FD = ",FD - write(*,*)"from" - write(*,*)lbf,ubf,extf - write(*,*)"to" - write(*,*)lbc,ubc,extc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - func(i,j,k)= funf(cxI(1),cxI(2),cxI(3)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -#endif -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! for different finite difference order usage -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -#if (ghost_width == 2) -! second order code -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 4 points, 3rd order interpolation -! 1 2 3 4 -! *---*---*---* -! ^ -! f=-1/16*f_1 + 9/16*f_2 -! -1/16*f_4 + 9/16*f_3 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - - real*8, parameter :: C1=-1.d0/16,C2=9.d0/16 - real*8, parameter :: C4=C1,C3=C2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| -! if(i/2*2 == i)then -! cxI(1) = (i+lbf(1)-1)/2 -! else -! cxI(1) = (i+lbf(1)-1)/2+1 -! endif -! if(j/2*2 == j)then -! cxI(2) = (j+lbf(2)-1)/2 -! else -! cxI(2) = (j+lbf(2)-1)/2+1 -! endif -! if(k/2*2 == k)then -! cxI(3) = (k+lbf(3)-1)/2 -! else -! cxI(3) = (k+lbf(3)-1)/2+1 -! endif -! above code segment is equivalent to - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+2 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,2) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= tmp2(:,2) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,2) - endif - tmp1= tmp2(:,2) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= tmp1(2) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,2) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= tmp1(2) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= tmp2(:,2) - funf(i,j,k)= tmp1(2) - else - funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#else -#ifdef Cell - -!-------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 4 points, 3rd order interpolation -! 1 2 3 4 -! *---*---*---* -! ^ -! f=-1/16*(f_1+f_4) + 9/16*(f_2+f_3) -!-------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-1.or.jmaxi.gt.extf(2)-1.or.kmaxi.gt.extf(3)-1)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - if(any(cxI+2 > extf)) write(*,*)"error in restrict" -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2))& - +C2*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) - func(i,j,k)= C1*(tmp1(1)+tmp1(4))+C2*(tmp1(2)+tmp1(3)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 4 points, 3rd order interpolation -! 1 2 3 4 -! *---*---*---* -! ^ -! f=-7/128*f_1 + 105/128*f_2 -! -5/128*f_4 + 35/128*f_3 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - - real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 - real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+2 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - - subroutine prolong3new(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - - real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 - real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - real*8,dimension(3,4) :: CC - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif -!~~~~~~> prolongation start... - do i=1,3 - if(lbp(i)/2*2 == lbp(i))then - CC(i,1) = C1 - CC(i,2) = C2 - CC(i,3) = C3 - CC(i,4) = C4 - else - CC(i,1) = C4 - CC(i,2) = C3 - CC(i,3) = C2 - CC(i,4) = C1 - endif - enddo - - do k = kmino,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - - do k = kmino,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - return - - end subroutine prolong3new -#else -#error Not define Vertex nor Cell -#endif -#endif - -#elif (ghost_width == 3) -! fourth order code -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 6 points, 5th order interpolation -! 1 2 3 4 5 6 -! *---*---*---*---*---* -! ^ -! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - - real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - real*8, dimension(-1:extc(1),-1:extc(2),-1:extc(3)) :: funcc - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif - - call symmetry_bd(2,extc,func,funcc,SoA) - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference v -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x===============x===============x| - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+3 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - else - tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - endif - else - if(kk/2*2==kk)then - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= tmp2(:,3) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - else - tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) - tmp1= tmp2(:,3) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= tmp1(3) - else - tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= tmp1(3) - endif - else - if(kk/2*2==kk)then - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= tmp2(:,3) - funf(i,j,k)= tmp1(3) - else - funf(i,j,k)= funcc(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 -#else -#ifdef Cell -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 6 points, 5th order interpolation -! 1 2 3 4 5 6 -! *---*---*---*---*---* -! ^ -! f=77/8192*f_1 - 693/8192*f_2 + 3465/4096*f_3 + -! 63/8192*f_6 - 495/8192*f_5 + 1155/4096*f_4 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc -! when if=1 -> ic=0, this is different to vertex center grid - real*8, dimension(-2:extc(1),-2:extc(2),-2:extc(3)) :: funcc - integer,dimension(3) :: cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - - real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 - real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif - - call symmetry_bd(3,extc,func,funcc,SoA) - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - if(any(cxI+3 > extc)) write(*,*)"error in prolong" - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - else - tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - endif - else - if(kk/2*2==kk)then - tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - else - tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - else - tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - endif - else - if(kk/2*2==kk)then - tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - else - tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 -!-------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 6 points, 5th order interpolation -! 1 2 3 4 5 6 -! *---*---*---*---*---* -! ^ -! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) -!-------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - real*8, dimension(-1:extf(1),-1:extf(2),-1:extf(3)):: funff - integer,dimension(3) :: cxI - integer :: i,j,k - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-2.or.jmaxi.gt.extf(2)-2.or.kmaxi.gt.extf(3)-2)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - - call symmetry_bd(2,extf,funf,funff,SoA) - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - if(any(cxI+3 > extf)) write(*,*)"error in restrict" - tmp2= C1*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - func(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -#else -#error Not define Vertex nor Cell -#endif -#endif - -#elif (ghost_width == 4) -! sixth order code -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 8 points, 7th order interpolation -! 1 2 3 4 5 6 7 8 -! *---*---*---*---*---*---*---* -! ^ -! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(8,8,8) :: ya - real*8, dimension(8,8) :: tmp2 - real*8, dimension(8) :: tmp1 - - real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference v -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x===============x===============x===============x===============x| - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+4 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= ya(:,:,4) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= tmp2(:,4) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= ya(:,:,4) - endif - tmp1= tmp2(:,4) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= tmp1(4) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= ya(:,:,4) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= tmp2(:,4) - funf(i,j,k)= tmp1(4) - else - funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#else -#ifdef Cell -!-------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 8 points, 7th order interpolation -! 1 2 3 4 5 6 7 8 -! *---*---*---*---*---*---*---* -! ^ -! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) -!-------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(8,8,8) :: ya - real*8, dimension(8,8) :: tmp2 - real*8, dimension(8) :: tmp1 - real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-3.or.jmaxi.gt.extf(2)-3.or.kmaxi.gt.extf(3)-3)then -!-3 is because -!|-x---x-|-x---x-|-x--- -!|- -*- -| - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - if(any(cxI+4 > extf)) write(*,*)"error in restrict" -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - func(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 8 points, 7th order interpolation -! 1 2 3 4 5 6 7 8 -! *---*---*---*---*---*---*---* -! ^ -! f=-495/262144*f_1 + 5005/262144*f_2 - 27027/262144*f_3 + 225225/262144*f_4 -! -429/262144*f_8 + 4095/262144*f_7 - 19305/262144*f_6 + 75075/262144*f_5 -!-------------------------------------------------------------------------- - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(8,8,8) :: ya - real*8, dimension(8,8) :: tmp2 - real*8, dimension(8) :: tmp1 - - real*8, parameter :: C1=-4.95d2/2.62144d5,C2=5.005d3/2.62144d5,C3=-2.7027d4/2.62144d5,C4=2.25225d5/2.62144d5 - real*8, parameter :: C8=-4.29d2/2.62144d5,C7=4.095d3/2.62144d5,C6=-1.9305d4/2.62144d5,C5=7.5075d4/2.62144d5 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - if(any(cxI+4 > extc)) write(*,*)"error in prolong" - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 -#else -#error Not define Vertex nor Cell -#endif -#endif - -#elif (ghost_width == 5) -! eighth order code -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 10 points, 9th order interpolation -! 1 2 3 4 5 6 7 8 9 10 -! *---*---*---*---*---*---*---*---*---* -! ^ -! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(10,10,10) :: ya - real*8, dimension(10,10) :: tmp2 - real*8, dimension(10) :: tmp1 - - real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 - real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+5 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,5) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= tmp2(:,5) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,5) - endif - tmp1= tmp2(:,5) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= tmp1(5) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,5) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= tmp1(5) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= tmp2(:,5) - funf(i,j,k)= tmp1(5) - else - funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#else -#ifdef Cell -!--------------------------------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 10 points, 9th order interpolation -! 1 2 3 4 5 6 7 8 9 10 -! *---*---*---*---*---*---*---*---*---* -! ^ -! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) -!--------------------------------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(10,10,10) :: ya - real*8, dimension(10,10) :: tmp2 - real*8, dimension(10) :: tmp1 - real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 - real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-4.or.jmaxi.gt.extf(2)-4.or.kmaxi.gt.extf(3)-4)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - if(any(cxI+5 > extf)) write(*,*)"error in restrict" -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - func(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 10 points, 9th order interpolation -! 1 2 3 4 5 6 7 8 9 10 -! *---*---*---*---*---*---*---*---*---* -! ^ -!f= 13585/33554432*f_1-159885/33554432*f_2+230945/8388608*f_3- 969969/8388608*f_4+14549535/16777216*f_5 -! +4849845/16777216*f_6- 692835/8388608*f_7+188955/8388608*f_8-138567/33554432*f_9+ 12155/33554432*f_10 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(10,10,10) :: ya - real*8, dimension(10,10) :: tmp2 - real*8, dimension(10) :: tmp1 - - real*8, parameter :: C1=1.3585d4/3.3554432d7,C2=-1.59885d5/3.3554432d7,C3=2.30945d5/8.388608d6 - real*8, parameter :: C4=-9.69969d5/8.388608d6,C5=1.4549535d7/1.6777216d7,C6=4.849845d6/1.6777216d7 - real*8, parameter :: C7=-6.92835d5/8.388608d6,C8=1.88955d5/8.388608d6,C9=-1.38567d5/3.3554432d7 - real*8, parameter :: C10=1.2155d4/3.3554432d7 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - if(any(cxI+5 > extc)) write(*,*)"error in prolong" - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+ C5*tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 -#else -#error Not define Vertex nor Cell -#endif - -#endif - -#endif - -#endif + + +! old code +#if 0 +! Because of overlap determination, source region is always larger than target +! region + +#include "microdef.fh" + +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif +!-------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! this routine is valid for all orders finite difference +! +! 1 2 3 4 +! *---*---*---* +! ^ +! COPY directly! +!-------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif +! it's possible a iolated point for target but not for source + FD = (uubf-llbf)/(extf-1) + CD = 2*FD + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4)+1 + ubrf = idint((uubr-base)/FD+0.4)+1 + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1).or.jmaxi.gt.extf(2).or.kmaxi.gt.extf(3))then + write(*,*)"error in restrict for" + write(*,*)"mino = ",imino,jmino,kmino + write(*,*)"maxo = ",imaxo,jmaxo,kmaxo + write(*,*)"extc = ",extc + write(*,*)"CD = ",CD + write(*,*)"mini = ",imini,jmini,kmini + write(*,*)"maxi = ",imaxi,jmaxi,kmaxi + write(*,*)"extf = ",extf + write(*,*)"FD = ",FD + write(*,*)"from" + write(*,*)lbf,ubf,extf + write(*,*)"to" + write(*,*)lbc,ubc,extc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + func(i,j,k)= funf(cxI(1),cxI(2),cxI(3)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +#endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! for different finite difference order usage +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#if (ghost_width == 2) +! second order code +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 4 points, 3rd order interpolation +! 1 2 3 4 +! *---*---*---* +! ^ +! f=-1/16*f_1 + 9/16*f_2 +! -1/16*f_4 + 9/16*f_3 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + + real*8, parameter :: C1=-1.d0/16,C2=9.d0/16 + real*8, parameter :: C4=C1,C3=C2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| +! if(i/2*2 == i)then +! cxI(1) = (i+lbf(1)-1)/2 +! else +! cxI(1) = (i+lbf(1)-1)/2+1 +! endif +! if(j/2*2 == j)then +! cxI(2) = (j+lbf(2)-1)/2 +! else +! cxI(2) = (j+lbf(2)-1)/2+1 +! endif +! if(k/2*2 == k)then +! cxI(3) = (k+lbf(3)-1)/2 +! else +! cxI(3) = (k+lbf(3)-1)/2+1 +! endif +! above code segment is equivalent to + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+2 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,2) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= tmp2(:,2) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,2) + endif + tmp1= tmp2(:,2) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= tmp1(2) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,2) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= tmp1(2) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= tmp2(:,2) + funf(i,j,k)= tmp1(2) + else + funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#else +#ifdef Cell + +!-------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 4 points, 3rd order interpolation +! 1 2 3 4 +! *---*---*---* +! ^ +! f=-1/16*(f_1+f_4) + 9/16*(f_2+f_3) +!-------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-1.or.jmaxi.gt.extf(2)-1.or.kmaxi.gt.extf(3)-1)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + if(any(cxI+2 > extf)) write(*,*)"error in restrict" +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2))& + +C2*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) + func(i,j,k)= C1*(tmp1(1)+tmp1(4))+C2*(tmp1(2)+tmp1(3)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 4 points, 3rd order interpolation +! 1 2 3 4 +! *---*---*---* +! ^ +! f=-7/128*f_1 + 105/128*f_2 +! -5/128*f_4 + 35/128*f_3 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + + real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 + real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+2 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + + subroutine prolong3new(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + + real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 + real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + real*8,dimension(3,4) :: CC + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif +!~~~~~~> prolongation start... + do i=1,3 + if(lbp(i)/2*2 == lbp(i))then + CC(i,1) = C1 + CC(i,2) = C2 + CC(i,3) = C3 + CC(i,4) = C4 + else + CC(i,1) = C4 + CC(i,2) = C3 + CC(i,3) = C2 + CC(i,4) = C1 + endif + enddo + + do k = kmino,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + + do k = kmino,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + return + + end subroutine prolong3new +#else +#error Not define Vertex nor Cell +#endif +#endif + +#elif (ghost_width == 3) +! fourth order code +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 6 points, 5th order interpolation +! 1 2 3 4 5 6 +! *---*---*---*---*---* +! ^ +! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + + real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + real*8, dimension(-1:extc(1),-1:extc(2),-1:extc(3)) :: funcc + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif + + call symmetry_bd(2,extc,func,funcc,SoA) + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference v +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x===============x===============x| + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+3 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + else + tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + endif + else + if(kk/2*2==kk)then + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= tmp2(:,3) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + else + tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) + tmp1= tmp2(:,3) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= tmp1(3) + else + tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= tmp1(3) + endif + else + if(kk/2*2==kk)then + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= tmp2(:,3) + funf(i,j,k)= tmp1(3) + else + funf(i,j,k)= funcc(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 +#else +#ifdef Cell +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 6 points, 5th order interpolation +! 1 2 3 4 5 6 +! *---*---*---*---*---* +! ^ +! f=77/8192*f_1 - 693/8192*f_2 + 3465/4096*f_3 + +! 63/8192*f_6 - 495/8192*f_5 + 1155/4096*f_4 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc +! when if=1 -> ic=0, this is different to vertex center grid + real*8, dimension(-2:extc(1),-2:extc(2),-2:extc(3)) :: funcc + integer,dimension(3) :: cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + + real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 + real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif + + call symmetry_bd(3,extc,func,funcc,SoA) + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + if(any(cxI+3 > extc)) write(*,*)"error in prolong" + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + else + tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + endif + else + if(kk/2*2==kk)then + tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + else + tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + else + tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + endif + else + if(kk/2*2==kk)then + tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + else + tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 +!-------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 6 points, 5th order interpolation +! 1 2 3 4 5 6 +! *---*---*---*---*---* +! ^ +! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) +!-------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + real*8, dimension(-1:extf(1),-1:extf(2),-1:extf(3)):: funff + integer,dimension(3) :: cxI + integer :: i,j,k + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-2.or.jmaxi.gt.extf(2)-2.or.kmaxi.gt.extf(3)-2)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + + call symmetry_bd(2,extf,funf,funff,SoA) + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + if(any(cxI+3 > extf)) write(*,*)"error in restrict" + tmp2= C1*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + func(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +#else +#error Not define Vertex nor Cell +#endif +#endif + +#elif (ghost_width == 4) +! sixth order code +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 8 points, 7th order interpolation +! 1 2 3 4 5 6 7 8 +! *---*---*---*---*---*---*---* +! ^ +! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(8,8,8) :: ya + real*8, dimension(8,8) :: tmp2 + real*8, dimension(8) :: tmp1 + + real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference v +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x===============x===============x===============x===============x| + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+4 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= ya(:,:,4) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= tmp2(:,4) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= ya(:,:,4) + endif + tmp1= tmp2(:,4) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= tmp1(4) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= ya(:,:,4) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= tmp2(:,4) + funf(i,j,k)= tmp1(4) + else + funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#else +#ifdef Cell +!-------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 8 points, 7th order interpolation +! 1 2 3 4 5 6 7 8 +! *---*---*---*---*---*---*---* +! ^ +! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) +!-------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(8,8,8) :: ya + real*8, dimension(8,8) :: tmp2 + real*8, dimension(8) :: tmp1 + real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-3.or.jmaxi.gt.extf(2)-3.or.kmaxi.gt.extf(3)-3)then +!-3 is because +!|-x---x-|-x---x-|-x--- +!|- -*- -| + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + if(any(cxI+4 > extf)) write(*,*)"error in restrict" +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + func(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 8 points, 7th order interpolation +! 1 2 3 4 5 6 7 8 +! *---*---*---*---*---*---*---* +! ^ +! f=-495/262144*f_1 + 5005/262144*f_2 - 27027/262144*f_3 + 225225/262144*f_4 +! -429/262144*f_8 + 4095/262144*f_7 - 19305/262144*f_6 + 75075/262144*f_5 +!-------------------------------------------------------------------------- + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(8,8,8) :: ya + real*8, dimension(8,8) :: tmp2 + real*8, dimension(8) :: tmp1 + + real*8, parameter :: C1=-4.95d2/2.62144d5,C2=5.005d3/2.62144d5,C3=-2.7027d4/2.62144d5,C4=2.25225d5/2.62144d5 + real*8, parameter :: C8=-4.29d2/2.62144d5,C7=4.095d3/2.62144d5,C6=-1.9305d4/2.62144d5,C5=7.5075d4/2.62144d5 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + if(any(cxI+4 > extc)) write(*,*)"error in prolong" + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 +#else +#error Not define Vertex nor Cell +#endif +#endif + +#elif (ghost_width == 5) +! eighth order code +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 10 points, 9th order interpolation +! 1 2 3 4 5 6 7 8 9 10 +! *---*---*---*---*---*---*---*---*---* +! ^ +! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(10,10,10) :: ya + real*8, dimension(10,10) :: tmp2 + real*8, dimension(10) :: tmp1 + + real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 + real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+5 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,5) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= tmp2(:,5) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,5) + endif + tmp1= tmp2(:,5) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= tmp1(5) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,5) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= tmp1(5) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= tmp2(:,5) + funf(i,j,k)= tmp1(5) + else + funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#else +#ifdef Cell +!--------------------------------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 10 points, 9th order interpolation +! 1 2 3 4 5 6 7 8 9 10 +! *---*---*---*---*---*---*---*---*---* +! ^ +! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) +!--------------------------------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(10,10,10) :: ya + real*8, dimension(10,10) :: tmp2 + real*8, dimension(10) :: tmp1 + real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 + real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-4.or.jmaxi.gt.extf(2)-4.or.kmaxi.gt.extf(3)-4)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + if(any(cxI+5 > extf)) write(*,*)"error in restrict" +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + func(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 10 points, 9th order interpolation +! 1 2 3 4 5 6 7 8 9 10 +! *---*---*---*---*---*---*---*---*---* +! ^ +!f= 13585/33554432*f_1-159885/33554432*f_2+230945/8388608*f_3- 969969/8388608*f_4+14549535/16777216*f_5 +! +4849845/16777216*f_6- 692835/8388608*f_7+188955/8388608*f_8-138567/33554432*f_9+ 12155/33554432*f_10 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(10,10,10) :: ya + real*8, dimension(10,10) :: tmp2 + real*8, dimension(10) :: tmp1 + + real*8, parameter :: C1=1.3585d4/3.3554432d7,C2=-1.59885d5/3.3554432d7,C3=2.30945d5/8.388608d6 + real*8, parameter :: C4=-9.69969d5/8.388608d6,C5=1.4549535d7/1.6777216d7,C6=4.849845d6/1.6777216d7 + real*8, parameter :: C7=-6.92835d5/8.388608d6,C8=1.88955d5/8.388608d6,C9=-1.38567d5/3.3554432d7 + real*8, parameter :: C10=1.2155d4/3.3554432d7 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + if(any(cxI+5 > extc)) write(*,*)"error in prolong" + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+ C5*tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 +#else +#error Not define Vertex nor Cell +#endif + +#endif + +#endif + +#endif diff --git a/AMSS_NCKU_source/prolongrestrict.h b/AMSS_NCKU_source/BSSN/prolongrestrict.h similarity index 95% rename from AMSS_NCKU_source/prolongrestrict.h rename to AMSS_NCKU_source/BSSN/prolongrestrict.h index 85fed60..2435ae0 100644 --- a/AMSS_NCKU_source/prolongrestrict.h +++ b/AMSS_NCKU_source/BSSN/prolongrestrict.h @@ -1,55 +1,55 @@ - -#ifndef PROLONGRESTRICT_H -#define PROLONGRESTRICT_H - -#ifdef fortran1 -#define f_prolong3 prolong3 -#define f_prolongmix3 prolongmix3 -#define f_prolongcopy3 prolongcopy3 -#define f_restrict3 restrict3 -#endif - -#ifdef fortran2 -#define f_prolong3 PROLONG3 -#define f_prolongmix3 PROLONGMIX3 -#define f_prolongcopy3 PROLONGCOPY3 -#define f_restrict3 RESTRICT3 -#endif - -#ifdef fortran3 -#define f_prolong3 prolong3_ -#define f_prolongmix3 prolongmix3_ -#define f_prolongcopy3 prolongcopy3_ -#define f_restrict3 restrict3_ -#endif - -extern "C" -{ - int f_prolong3(int &, double *, double *, int *, double *, - double *, double *, int *, double *, - double *, double *, double *, int &); -} - -extern "C" -{ - void f_restrict3(int &, double *, double *, int *, double *, - double *, double *, int *, double *, - double *, double *, double *, int &); -} - -extern "C" -{ - int f_prolongmix3(int &, double *, double *, int *, double *, - double *, double *, int *, double *, - double *, double *, double *, int &, - double *, double *); -} - -extern "C" -{ - int f_prolongcopy3(int &, double *, double *, int *, double *, - double *, double *, int *, double *, - double *, double *, double *, int &); -} - -#endif /* PROLONGRESTRICT_H */ + +#ifndef PROLONGRESTRICT_H +#define PROLONGRESTRICT_H + +#ifdef fortran1 +#define f_prolong3 prolong3 +#define f_prolongmix3 prolongmix3 +#define f_prolongcopy3 prolongcopy3 +#define f_restrict3 restrict3 +#endif + +#ifdef fortran2 +#define f_prolong3 PROLONG3 +#define f_prolongmix3 PROLONGMIX3 +#define f_prolongcopy3 PROLONGCOPY3 +#define f_restrict3 RESTRICT3 +#endif + +#ifdef fortran3 +#define f_prolong3 prolong3_ +#define f_prolongmix3 prolongmix3_ +#define f_prolongcopy3 prolongcopy3_ +#define f_restrict3 restrict3_ +#endif + +extern "C" +{ + int f_prolong3(int &, double *, double *, int *, double *, + double *, double *, int *, double *, + double *, double *, double *, int &); +} + +extern "C" +{ + void f_restrict3(int &, double *, double *, int *, double *, + double *, double *, int *, double *, + double *, double *, double *, int &); +} + +extern "C" +{ + int f_prolongmix3(int &, double *, double *, int *, double *, + double *, double *, int *, double *, + double *, double *, double *, int &, + double *, double *); +} + +extern "C" +{ + int f_prolongcopy3(int &, double *, double *, int *, double *, + double *, double *, int *, double *, + double *, double *, double *, int &); +} + +#endif /* PROLONGRESTRICT_H */ diff --git a/AMSS_NCKU_source/prolongrestrict_cell.f90 b/AMSS_NCKU_source/BSSN/prolongrestrict_cell.f90 similarity index 97% rename from AMSS_NCKU_source/prolongrestrict_cell.f90 rename to AMSS_NCKU_source/BSSN/prolongrestrict_cell.f90 index 9fefe48..6bb6643 100644 --- a/AMSS_NCKU_source/prolongrestrict_cell.f90 +++ b/AMSS_NCKU_source/BSSN/prolongrestrict_cell.f90 @@ -1,3745 +1,3745 @@ - - -! Because of overlap determination, source region is always larger than target -! region - -#include "macrodef.fh" - -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - -!-------------------------------------------------------------------------- -! -! Prepare the data on coarse level for prolong -! valid for all finite difference order -!-------------------------------------------------------------------------- - - subroutine prolongcopy3(wei,llbc,uubc,extc,func,& - llbf,uubf,exto,funo,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,exto - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func -! both bounds ghost_width - real*8, dimension(exto(1)+2*ghost_width,exto(2)+2*ghost_width,exto(3)+2*ghost_width),intent(out):: funo - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8,dimension(1-ghost_width:extc(1),1-ghost_width:extc(2),1-ghost_width:extc(3)) :: fh - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,cxI - integer :: i,j,k - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolongcopy3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/extc - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) -!sanity check -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| -! ^ ^ - imini=lbpc(1)-lbc(1) + 1 - ghost_width - imaxi=ubpc(1)-lbc(1) + 1 + ghost_width - jmini=lbpc(2)-lbc(2) + 1 - ghost_width - jmaxi=ubpc(2)-lbc(2) + 1 + ghost_width - kmini=lbpc(3)-lbc(3) + 1 - ghost_width - kmaxi=ubpc(3)-lbc(3) + 1 + ghost_width - - cxI(1) = imaxi-imini+1 - cxI(2) = jmaxi-jmini+1 - cxI(3) = kmaxi-kmini+1 - if(any(cxI.ne.exto+2*ghost_width).or. & - imaxi.gt.extc(1)+1.or.jmaxi.gt.extc(2)+1.or.kmaxi.gt.extc(3)+1)then - write(*,*)"error in prolongationcopy3 for" - if(any(cxI.ne.exto+2*ghost_width))then - write(*,*) cxI,exto+2*ghost_width - return - endif - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - return - endif - -! because some point needs 2*ghost_width -! while some point needs 2*ghost_width-1 -! so we use 0 to fill empty points - if(imini < 1.or.jmini < 1.or.kmini < 1)then - if(imini<1.and.dabs(llbp(1))>CD(1)) write(*,*)"prolongcopy3 warning: ",llbp(1) - if(jmini<1.and.dabs(llbp(2))>CD(2)) write(*,*)"prolongcopy3 warning: ",llbp(2) - if(kmini<1.and.dabs(llbp(3))>CD(3)) write(*,*)"prolongcopy3 warning: ",llbp(3) - call symmetry_bd(ghost_width,extc,func,fh,SoA) - if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then - funo = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - else - funo = 0.d0 - cxI = 0 - if(imaxi>extc(1))then - cxI(1) = 1 - imaxi = extc(1) - endif - if(jmaxi>extc(2))then - cxI(2) = 1 - jmaxi = extc(2) - endif - if(kmaxi>extc(3))then - cxI(3) = 1 - kmaxi = extc(3) - endif - funo(1:exto(1)+2*ghost_width-cxI(1), & - 1:exto(2)+2*ghost_width-cxI(2), & - 1:exto(3)+2*ghost_width-cxI(3)) = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - endif - else - if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then - funo = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - else - funo = 0.d0 - cxI = 0 - if(imaxi>extc(1))then - cxI(1) = 1 - imaxi = extc(1) - endif - if(jmaxi>extc(2))then - cxI(2) = 1 - jmaxi = extc(2) - endif - if(kmaxi>extc(3))then - cxI(3) = 1 - kmaxi = extc(3) - endif - funo(1:exto(1)+2*ghost_width-cxI(1), & - 1:exto(2)+2*ghost_width-cxI(2), & - 1:exto(3)+2*ghost_width-cxI(3)) = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - endif - endif - - return - - end subroutine prolongcopy3 -!================================================================================================= -#define MIX 0 -!-------------------------------------------------------------------------- -! -! Prolong data throug mix data of fine and coarse levels -!-------------------------------------------------------------------------- - - subroutine prolongmix3(wei,llbf,uubf,extf,funf,& - llbc,uubc,exti,funi,& - llbp,uubp,SoA,Symmetry, & - illb,iuub) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse fine (real inner points) - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp,illb,iuub - integer,dimension(3), intent(in) :: exti,extf - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout) :: funf -! lower bound ghost_width; upper bound ghost_width-1 - real*8, dimension(exti(1)+2*ghost_width,exti(2)+2*ghost_width,exti(3)+2*ghost_width),intent(in):: funi - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,ilb,iub - integer :: i,j,k,n,ii,jj,kk - - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - integer,dimension(3) :: cxI,cxB,cxT,fg - - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - real*8,dimension(2*ghost_width,2*ghost_width,2*ghost_width) :: ya - real*8,dimension(2*ghost_width) :: X,Y,Z - real*8, dimension(2*ghost_width,2*ghost_width) :: tmp2 - real*8, dimension(2*ghost_width) :: tmp1 - real*8 :: ddy - real*8,dimension(3) :: ccp - -#if (ghost_width == 2) - real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 - real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 -#elif (ghost_width == 3) - real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 - real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 -#elif (ghost_width == 4) - real*8, parameter :: C1=-4.95d2/2.62144d5,C2=5.005d3/2.62144d5,C3=-2.7027d4/2.62144d5,C4=2.25225d5/2.62144d5 - real*8, parameter :: C8=-4.29d2/2.62144d5,C7=4.095d3/2.62144d5,C6=-1.9305d4/2.62144d5,C5=7.5075d4/2.62144d5 -#elif (ghost_width == 5) - real*8, parameter :: C1=1.3585d4/3.3554432d7,C2=-1.59885d5/3.3554432d7,C3=2.30945d5/8.388608d6 - real*8, parameter :: C4=-9.69969d5/8.388608d6,C5=1.4549535d7/1.6777216d7,C6=4.849845d6/1.6777216d7 - real*8, parameter :: C7=-6.92835d5/8.388608d6,C8=1.88955d5/8.388608d6,C9=-1.38567d5/3.3554432d7 - real*8, parameter :: C10=1.2155d4/3.3554432d7 -#endif - - if(wei.ne.3)then - write(*,*)"prolongrestrict_cell.f90::prolongmix3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - FD = (uubf-llbf)/extf - CD = FD*2.d0 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - ilb = idint((illb-base)/FD+0.4)+1 - iub = idint((iuub-base)/FD+0.4) -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - -!sanity check -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| -! ^ ^ -! ghost_width for both sides - lbpc = lbpc - ghost_width - ubpc = ubpc + ghost_width -! index for real inner points - ilb = ilb - lbf+1 - iub = iub - lbf+1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3))then - write(*,*)"error in prolongmix3 for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)base,FD - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif - - do k=kmino,kmaxo - do j=jmino,jmaxo - do i=imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k - - ccp = llbf+(cxI-0.5d0)*FD - -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbpc + 1 - - ya = funi(cxI(1)-ghost_width+1:cxI(1)+ghost_width,cxI(2)-ghost_width+1:cxI(2)+ghost_width,cxI(3)-ghost_width+1:cxI(3)+ghost_width) - - fg = 0 - where((illb.lt.ccp).and.(iuub.gt.ccp)) fg = 1 - - if(sum(fg).eq.3)then - write(*,*)"1 error in in prolongmix3:" - write(*,*)ccp,illb,iuub - stop - endif - -! fix the wanted point at (0,0,0), set FD = 1 - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(sum(fg).eq.2)then - - cxI(1) = i - cxI(2) = j - cxI(3) = k - -!!!! set X - if(ii/2*2==ii)then -! v -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - do n=1,ghost_width - X(ghost_width-n+1) = -0.5d0-(n-1)*2 - X(ghost_width+n ) = 1.5d0+(n-1)*2 - enddo - if(cxI(1).gt.iub(1))then - cxB(1) = iub(1)-ghost_width+1+(cxI(1)-iub(1)+1-MIX)/2 - cxT(1) = iub(1) - elseif(cxI(1).lt.ilb(1))then - cxB(1) = ilb(1) - cxT(1) = ilb(1)+ghost_width-1-(ilb(1)-cxI(1)-MIX)/2 - elseif(fg(1).eq.0)then - write(*,*)"2 error in in prolongmix3:" - write(*,*)ccp(1),illb(1),iuub(1) - stop - endif - else -! v -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - do n=1,ghost_width - X(ghost_width-n+1) = -1.5d0-(n-1)*2 - X(ghost_width+n ) = 0.5d0+(n-1)*2 - enddo - if(cxI(1).gt.iub(1))then - cxB(1) = iub(1)-ghost_width+1+(cxI(1)-iub(1)-MIX)/2 - cxT(1) = iub(1) - elseif(cxI(1).lt.ilb(1))then - cxB(1) = ilb(1) - cxT(1) = ilb(1)+ghost_width-1-(ilb(1)-cxI(1)+1-MIX)/2 - elseif(fg(1).eq.0)then - write(*,*)"3 error in in prolongmix3:" - write(*,*)ccp(1),illb(1),iuub(1) - stop - endif - endif - -!!!! set Y - if(jj/2*2==jj)then - do n=1,ghost_width - Y(ghost_width-n+1) = -0.5d0-(n-1)*2 - Y(ghost_width+n ) = 1.5d0+(n-1)*2 - enddo - if(cxI(2).gt.iub(2))then - cxB(2) = iub(2)-ghost_width+1+(cxI(2)-iub(2)+1-MIX)/2 - cxT(2) = iub(2) - elseif(cxI(2).lt.ilb(2))then - cxB(2) = ilb(2) - cxT(2) = ilb(2)+ghost_width-1-(ilb(2)-cxI(2)-MIX)/2 - elseif(fg(2).eq.0)then - write(*,*)"4 error in in prolongmix3:" - write(*,*)ccp(2),illb(2),iuub(2) - stop - endif - else - do n=1,ghost_width - Y(ghost_width-n+1) = -1.5d0-(n-1)*2 - Y(ghost_width+n ) = 0.5d0+(n-1)*2 - enddo - if(cxI(2).gt.iub(2))then - cxB(2) = iub(2)-ghost_width+1+(cxI(2)-iub(2)-MIX)/2 - cxT(2) = iub(2) - elseif(cxI(2).lt.ilb(2))then - cxB(2) = ilb(2) - cxT(2) = ilb(2)+ghost_width-1-(ilb(2)-cxI(2)+1-MIX)/2 - elseif(fg(2).eq.0)then - write(*,*)"5 error in in prolongmix3:" - write(*,*)ccp(2),illb(2),iuub(2) - stop - endif - endif - -!!!! set Z - if(kk/2*2==kk)then - do n=1,ghost_width - Z(ghost_width-n+1) = -0.5d0-(n-1)*2 - Z(ghost_width+n ) = 1.5d0+(n-1)*2 - enddo - if(cxI(3).gt.iub(3))then - cxB(3) = iub(3)-ghost_width+1+(cxI(3)-iub(3)+1-MIX)/2 - cxT(3) = iub(3) - elseif(cxI(3).lt.ilb(3))then - cxB(3) = ilb(3) - cxT(3) = ilb(3)+ghost_width-1-(ilb(3)-cxI(3)-MIX)/2 - elseif(fg(3).eq.0)then - write(*,*)"6 error in in prolongmix3:" - write(*,*)ccp(3),illb(3),iuub(3) - stop - endif - else - do n=1,ghost_width - Z(ghost_width-n+1) = -1.5d0-(n-1)*2 - Z(ghost_width+n ) = 0.5d0+(n-1)*2 - enddo - if(cxI(3).gt.iub(3))then - cxB(3) = iub(3)-ghost_width+1+(cxI(3)-iub(3)-MIX)/2 - cxT(3) = iub(3) - elseif(cxI(3).lt.ilb(3))then - cxB(3) = ilb(3) - cxT(3) = ilb(3)+ghost_width-1-(ilb(3)-cxI(3)+1-MIX)/2 - elseif(fg(3).eq.0)then - write(*,*)"7 error in in prolongmix3:" - write(*,*)ccp(3),illb(3),iuub(3) - stop - endif - endif - - endif -! X, Y, and Z are possiblly not in order, I assume polint does not -! require this order -! because of the mismatch of points for fine level and coarse level -! we have to deal in this way - -! for x direction - if(sum(fg).eq.2.and.fg(1) .eq. 0.and. & - (((cxI(1).gt.iub(1)).and.(ghost_width-cxI(1)+cxB(1)+1.gt.0)).or. & - (cxI(1).lt.ilb(1)).and.(ghost_width-cxI(1)+cxT(1).le.2*ghost_width)))then - -#if (ghost_width == 2) - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - endif - endif -#elif (ghost_width == 3) - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - endif - endif -#elif (ghost_width == 4) - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - endif - endif -#elif (ghost_width == 5) - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - endif - endif -#endif - - if(cxI(1).gt.iub(1))then -! consistent to coarse level, always X(ghost_width+1) = 0 for left - do n=cxB(1),cxT(1) - X(ghost_width-cxI(1)+n+1) = dble(n-cxI(1)) - enddo - tmp1(ghost_width-cxI(1)+cxB(1)+1:ghost_width-cxI(1)+cxT(1)+1) = funf(cxB(1):cxT(1),j,k) - elseif(cxI(1).lt.ilb(1))then -! consistent to coarse level, always X(ghost_width ) = 0 for right - do n=cxB(1),cxT(1) - X(ghost_width-cxI(1)+n ) = dble(n-cxI(1)) - enddo - tmp1(ghost_width-cxI(1)+cxB(1) :ghost_width-cxI(1)+cxT(1) ) = funf(cxB(1):cxT(1),j,k) - endif - - call polint(X,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) - -! for y direction - elseif(sum(fg).eq.2.and.fg(2) .eq. 0.and. & - (((cxI(2).gt.iub(2)).and.(ghost_width-cxI(2)+cxB(2)+1.gt.0)).or. & - (cxI(2).lt.ilb(2)).and.(ghost_width-cxI(2)+cxT(2).le.2*ghost_width)))then - -#if (ghost_width == 2) - if(ii/2*2==ii)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) - endif - endif -#elif (ghost_width == 3) - if(ii/2*2==ii)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) - endif - endif -#elif (ghost_width == 4) - if(ii/2*2==ii)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& - C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& - C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& - C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& - C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) - endif - endif -#elif (ghost_width == 5) - if(ii/2*2==ii)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& - C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& - C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& - C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& - C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) - endif - endif -#endif - if(cxI(2).gt.iub(2))then -! consistent to coarse level, always Y(ghost_width+1) = 0 for left - do n=cxB(2),cxT(2) - Y(ghost_width-cxI(2)+n+1) = dble(n-cxI(2)) - enddo - tmp1(ghost_width-cxI(2)+cxB(2)+1:ghost_width-cxI(2)+cxT(2)+1) = funf(i,cxB(2):cxT(2),k) - elseif(cxI(2).lt.ilb(2))then -! consistent to coarse level, always Y(ghost_width ) = 0 for right - do n=cxB(2),cxT(2) - Y(ghost_width-cxI(2)+n ) = dble(n-cxI(2)) - enddo - tmp1(ghost_width-cxI(2)+cxB(2) :ghost_width-cxI(2)+cxT(2) ) = funf(i,cxB(2):cxT(2),k) - endif - - call polint(Y,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) - -! for z direction - elseif(sum(fg).eq.2.and.fg(3) .eq. 0.and. & - (((cxI(3).gt.iub(3)).and.(ghost_width-cxI(3)+cxB(3)+1.gt.0)).or. & - (cxI(3).lt.ilb(3)).and.(ghost_width-cxI(3)+cxT(3).le.2*ghost_width)))then - -#if (ghost_width == 2) - if(jj/2*2==jj)then - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) - else - tmp2= C4*ya(1,:,:)+C3*ya(2,:,:)+C2*ya(3,:,:)+C1*ya(4,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) - endif - else - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:) - tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) - else - tmp2= C4*ya(1,:,:)+C3*ya(2,:,:)+C2*ya(3,:,:)+C1*ya(4,:,:) - tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) - endif - endif -#elif (ghost_width == 3) - if(jj/2*2==jj)then - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5*ya(5,:,:)+C6*ya(6,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) - else - tmp2= C6*ya(1,:,:)+C5*ya(2,:,:)+C4*ya(3,:,:)+C3*ya(4,:,:)+C2*ya(5,:,:)+C1*ya(6,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) - endif - else - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5*ya(5,:,:)+C6*ya(6,:,:) - tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) - else - tmp2= C6*ya(1,:,:)+C5*ya(2,:,:)+C4*ya(3,:,:)+C3*ya(4,:,:)+C2*ya(5,:,:)+C1*ya(6,:,:) - tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) - endif - endif -#elif (ghost_width == 4) - if(jj/2*2==jj)then - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+& - C5*ya(5,:,:)+C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& - C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) - else - tmp2= C8*ya(1,:,:)+C7*ya(2,:,:)+C6*ya(3,:,:)+C5*ya(4,:,:)+& - C4*ya(5,:,:)+C3*ya(6,:,:)+C2*ya(7,:,:)+C1*ya(8,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& - C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) - endif - else - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+& - C5*ya(5,:,:)+C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:) - tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& - C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) - else - tmp2= C8*ya(1,:,:)+C7*ya(2,:,:)+C6*ya(3,:,:)+C5*ya(4,:,:)+& - C4*ya(5,:,:)+C3*ya(6,:,:)+C2*ya(7,:,:)+C1*ya(8,:,:) - tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& - C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) - endif - endif -#elif (ghost_width == 5) - if(jj/2*2==jj)then - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5 *ya( 5,:,:)+& - C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:)+C9*ya(9,:,:)+C10*ya(10,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& - C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) - else - tmp2= C10*ya(1,:,:)+C9*ya(2,:,:)+C8*ya(3,:,:)+C7*ya(4,:,:)+C6*ya( 5,:,:)+& - C5 *ya(6,:,:)+C4*ya(7,:,:)+C3*ya(8,:,:)+C2*ya(9,:,:)+C1*ya(10,:,:) - tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& - C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) - endif - else - if(ii/2*2==ii)then - tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5 *ya( 5,:,:)+& - C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:)+C9*ya(9,:,:)+C10*ya(10,:,:) - tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& - C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) - else - tmp2= C10*ya(1,:,:)+C9*ya(2,:,:)+C8*ya(3,:,:)+C7*ya(4,:,:)+C6*ya( 5,:,:)+& - C5 *ya(6,:,:)+C4*ya(7,:,:)+C3*ya(8,:,:)+C2*ya(9,:,:)+C1*ya(10,:,:) - tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& - C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) - endif - endif -#endif - -#if 1 - if(cxI(3).gt.iub(3))then -! consistent to coarse level, always Z(ghost_width+1) = 0 for left - do n=cxB(3),cxT(3) - Z(ghost_width-cxI(3)+n+1) = dble(n-cxI(3)) - enddo - tmp1(ghost_width-cxI(3)+cxB(3)+1:ghost_width-cxI(3)+cxT(3)+1) = funf(i,j,cxB(3):cxT(3)) - elseif(cxI(3).lt.ilb(3))then -! consistent to coarse level, always Z(ghost_width ) = 0 for right - do n=cxB(3),cxT(3) - Z(ghost_width-cxI(3)+n ) = dble(n-cxI(3)) - enddo - tmp1(ghost_width-cxI(3)+cxB(3) :ghost_width-cxI(3)+cxT(3) ) = funf(i,j,cxB(3):cxT(3)) - endif - - call polint(Z,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) - -#else - - if(kk/2*2==kk)then - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - else - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - endif -#endif - else - -#if (ghost_width == 2) - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - else - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - endif - endif - endif -#elif (ghost_width == 3) - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - else - tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - endif - endif - endif -#elif (ghost_width == 4) - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - else - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - endif - endif - endif -#elif (ghost_width == 5) - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+ C5*tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - endif - else - if(kk/2*2==kk)then - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - else - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - endif - endif - endif -#endif - endif - - enddo - enddo - enddo - - return - - end subroutine prolongmix3 -!/////////////////////////////////////////////////////////////////////////////////////////////// -! for different finite differnce order -#if (ghost_width == 2) -!-------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 4 points, 3rd order interpolation -! 1 2 3 4 -! *---*---*---* -! ^ -! f=-1/16*(f_1+f_4) + 9/16*(f_2+f_3) -!-------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-1.or.jmaxi.gt.extf(2)-1.or.kmaxi.gt.extf(3)-1)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - if(any(cxI+2 > extf)) write(*,*)"error in restrict" -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2))& - +C2*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) - func(i,j,k)= C1*(tmp1(1)+tmp1(4))+C2*(tmp1(2)+tmp1(3)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 4 points, 3rd order interpolation -! 1 2 3 4 -! *---*---*---* -! ^ -! f=-7/128*f_1 + 105/128*f_2 -! -5/128*f_4 + 35/128*f_3 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - - real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 - real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+2 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) - endif - tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) - funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - - subroutine prolong3new(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - - real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 - real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - real*8,dimension(3,4) :: CC - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif -!~~~~~~> prolongation start... - do i=1,3 - if(lbp(i)/2*2 == lbp(i))then - CC(i,1) = C1 - CC(i,2) = C2 - CC(i,3) = C3 - CC(i,4) = C4 - else - CC(i,1) = C4 - CC(i,2) = C3 - CC(i,3) = C2 - CC(i,4) = C1 - endif - enddo - - do k = kmino,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) - enddo - enddo - enddo - - do k = kmino,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - - do k = kmino,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - do k = kmino+1,kmaxo,2 - do j = jmino+1,jmaxo,2 - do i = imino+1,imaxo,2 - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) - endif - tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) - funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) - enddo - enddo - enddo - - return - - end subroutine prolong3new - -#elif (ghost_width == 3) -! fourth order code -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 6 points, 5th order interpolation -! 1 2 3 4 5 6 -! *---*---*---*---*---* -! ^ -! f=77/8192*f_1 - 693/8192*f_2 + 3465/4096*f_3 + -! 63/8192*f_6 - 495/8192*f_5 + 1155/4096*f_4 -!-------------------------------------------------------------------------- -#if 1 - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine fine - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc -! when if=1 -> ic=0, this is different to vertex center grid - real*8, dimension(-2:extc(1),-2:extc(2),-2:extc(3)) :: funcc - integer,dimension(3) :: cxI - integer :: i,j,k,ii,jj,kk,px,py,pz - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - integer, dimension(extf(1)) :: cix - integer, dimension(extf(2)) :: ciy - integer, dimension(extf(3)) :: ciz - integer, dimension(extf(1)) :: pix - integer, dimension(extf(2)) :: piy - integer, dimension(extf(3)) :: piz - - real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 - real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 - real*8, dimension(6,2), parameter :: WC = reshape((/& - C1,C2,C3,C4,C5,C6,& - C6,C5,C4,C3,C2,C1/), (/6,2/)) - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - integer::maxcx,maxcy,maxcz - - real*8,dimension(3) :: CD,FD - real*8 :: tmp_yz(extc(1), 6) ! 存储整条 X 线上 6 个 Y 轴偏置的 Z 向插值结果 - real*8 :: tmp_xyz_line(-2:extc(1)) ! 包含 X 向 6 点模板访问所需下界 - real*8 :: v1, v2, v3, v4, v5, v6 - integer :: ic, jc, kc, ix_offset,ix,iy,iz,jc_min,jc_max,ic_min,ic_max,kc_min,kc_max - integer :: i_lo, i_hi, j_lo, j_hi, k_lo, k_hi - logical :: need_full_symmetry - real*8 :: res_line - real*8 :: tmp_z_slab(-2:extc(1), -2:extc(2)) ! 包含 Y/X 向模板访问所需下界 - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - - if(any(dabs(CD-2*FD)>1.d-10))then - write(*,*)"prolong:",CD,FD - stop - endif - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 ! this is wrong, but not essential - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) ! this is wrong, but not essential - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif - - do i = imino,imaxo - ii = i + lbf(1) - 1 - cix(i) = ii/2 - lbc(1) + 1 - if(ii/2*2 == ii)then - pix(i) = 1 - else - pix(i) = 2 - endif - enddo - do j = jmino,jmaxo - jj = j + lbf(2) - 1 - ciy(j) = jj/2 - lbc(2) + 1 - if(jj/2*2 == jj)then - piy(j) = 1 - else - piy(j) = 2 - endif - enddo - do k = kmino,kmaxo - kk = k + lbf(3) - 1 - ciz(k) = kk/2 - lbc(3) + 1 - if(kk/2*2 == kk)then - piz(k) = 1 - else - piz(k) = 2 - endif - enddo - - ic_min = minval(cix(imino:imaxo)) - ic_max = maxval(cix(imino:imaxo)) - jc_min = minval(ciy(jmino:jmaxo)) - jc_max = maxval(ciy(jmino:jmaxo)) - kc_min = minval(ciz(kmino:kmaxo)) - kc_max = maxval(ciz(kmino:kmaxo)) - - maxcx = ic_max - maxcy = jc_max - maxcz = kc_max - if(maxcx+3 > extc(1) .or. maxcy+3 > extc(2) .or. maxcz+3 > extc(3))then - write(*,*)"error in prolong" - return - endif - - i_lo = ic_min - 2 - i_hi = ic_max + 3 - j_lo = jc_min - 2 - j_hi = jc_max + 3 - k_lo = kc_min - 2 - k_hi = kc_max + 3 - need_full_symmetry = (i_lo < 1) .or. (j_lo < 1) .or. (k_lo < 1) - if(need_full_symmetry)then - call symmetry_bd(3,extc,func,funcc,SoA) - else - funcc(i_lo:i_hi,j_lo:j_hi,k_lo:k_hi) = func(i_lo:i_hi,j_lo:j_hi,k_lo:k_hi) - endif - - ! 对每个 k（pz, kc 固定）预计算 Z 向插值的 2D 切片 - -do k = kmino, kmaxo - pz = piz(k); kc = ciz(k) - ! --- Pass 1: Z 方向，只算一次 --- - do iy = jc_min-2, jc_max+3 ! 仅需的 iy 范围（对应 jc-2:jc+3） - do ii = ic_min-2, ic_max+3 ! 仅需的 ii 范围（对应 cix-2:cix+3） - tmp_z_slab(ii, iy) = sum(WC(:,pz) * funcc(ii, iy, kc-2:kc+3)) - end do - end do - - do j = jmino, jmaxo - py = piy(j); jc = ciy(j) - ! --- Pass 2: Y 方向 --- - do ii = ic_min-2, ic_max+3 - tmp_xyz_line(ii) = sum(WC(:,py) * tmp_z_slab(ii, jc-2:jc+3)) - end do - ! --- Pass 3: X 方向 --- - do i = imino, imaxo - funf(i,j,k) = sum(WC(:,pix(i)) * tmp_xyz_line(cix(i)-2:cix(i)+3)) - end do - end do -end do - -!~~~~~~> prolongation start... -#if 0 - do k = kmino, kmaxo - pz = piz(k) - kc = ciz(k) - - do j = jmino, jmaxo - py = piy(j) - jc = ciy(j) - -! --- 步骤 1 & 2 融合：分段处理 X 轴，提升 Cache 命中率 --- - ! 我们将 ii 循环逻辑重组，减少对 funcc 的跨行重复访问 - do ii = 1, extc(1) - ! 1. 先做 Z 方向的 6 条线插值（针对当前的 ii 和当前的 6 个 iy） - ! 我们直接在这里把 Y 方向的加权也做了，省去 tmp_yz 数组 - ! 这样 funcc 的数据读进来后立即完成所有维度的贡献，不再写回内存 - - res_line = 0.0d0 - do jj = 1, 6 - iy = jc - 3 + jj - ! 这一行代码是核心：一次性完成 Z 插值并加上 Y 的权重 - ! 编译器会把 WC(jj, py) 存在寄存器里 - res_line = res_line + WC(jj, py) * ( & - WC(1, pz) * funcc(ii, iy, kc-2) + & - WC(2, pz) * funcc(ii, iy, kc-1) + & - WC(3, pz) * funcc(ii, iy, kc ) + & - WC(4, pz) * funcc(ii, iy, kc+1) + & - WC(5, pz) * funcc(ii, iy, kc+2) + & - WC(6, pz) * funcc(ii, iy, kc+3) ) - end do - tmp_xyz_line(ii) = res_line - end do - - - - - ! 3. 【降维：X 向】最后在最内层只处理 X 方向的 6 点加权 - ! 此时每个点的计算量从原来的 200+ 次乘法降到了仅 6 次 - do i = imino, imaxo - px = pix(i) - ic = cix(i) - - ! 直接从预计算好的 line 中读取连续的 6 个点 - ! ic-2 到 ic+3 对应原始 6 点算子 - funf(i,j,k) = WC(1,px)*tmp_xyz_line(ic-2) + & - WC(2,px)*tmp_xyz_line(ic-1) + & - WC(3,px)*tmp_xyz_line(ic ) + & - WC(4,px)*tmp_xyz_line(ic+1) + & - WC(5,px)*tmp_xyz_line(ic+2) + & - WC(6,px)*tmp_xyz_line(ic+3) - end do - end do - end do -#endif - return - - end subroutine prolong3 - -#else - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine fine - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(extc(1)) :: cX - real*8, dimension(extc(2)) :: cY - real*8, dimension(extc(3)) :: cZ - real*8, dimension(extf(1)) :: fX - real*8, dimension(extf(2)) :: fY - real*8, dimension(extf(3)) :: fZ -! when if=1 -> ic=0, this is different to vertex center grid - real*8, dimension(-2:extc(1),-2:extc(2),-2:extc(3)) :: funcc - integer,dimension(3) :: cxI - integer :: i,j,k - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - - real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 - real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - real*8 :: tr - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - - do i=1,extc(1) - cX(i) = llbc(1) + (i-0.5d0)*CD(1) - enddo - do i=1,extc(2) - cY(i) = llbc(2) + (i-0.5d0)*CD(2) - enddo - do i=1,extc(3) - cZ(i) = llbc(3) + (i-0.5d0)*CD(3) - enddo - - do i=1,extf(1) - fX(i) = llbf(1) + (i-0.5d0)*FD(1) - enddo - do i=1,extf(2) - fY(i) = llbf(2) + (i-0.5d0)*FD(2) - enddo - do i=1,extf(3) - fZ(i) = llbf(3) + (i-0.5d0)*FD(3) - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -!sanity check, 0.4 is for round off error - imino=idint((llbp(1)-fX(1))/FD(1)+0.5+0.4)+1 - imaxo=idint((uubp(1)-fX(1))/FD(1)-0.5+0.4)+1 - jmino=idint((llbp(2)-fY(1))/FD(2)+0.5+0.4)+1 - jmaxo=idint((uubp(2)-fY(1))/FD(2)-0.5+0.4)+1 - kmino=idint((llbp(3)-fZ(1))/FD(3)+0.5+0.4)+1 - kmaxo=idint((uubp(3)-fZ(1))/FD(3)-0.5+0.4)+1 - -! these are wrong, butnot essential - imini=idint((llbp(1)-cX(1))/CD(1)+0.5)+1 - imaxi=idint((uubp(1)-cX(1))/CD(1)-0.5)+1 - jmini=idint((llbp(2)-cY(1))/CD(2)+0.5)+1 - jmaxi=idint((uubp(2)-cY(1))/CD(2)-0.5)+1 - kmini=idint((llbp(3)-cZ(1))/CD(3)+0.5)+1 - kmaxi=idint((uubp(3)-cZ(1))/CD(3)-0.5)+1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)"want" - write(*,*)llbp,uubp - return - endif - - call symmetry_bd(3,extc,func,funcc,SoA) - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! floor(4.8)= 4,floor(-5.6)= - 6 - cxI(1) = floor((fX(i)-cX(1))/CD(1))+1 - cxI(2) = floor((fY(j)-cY(1))/CD(2))+1 - cxI(3) = floor((fZ(k)-cZ(1))/CD(3))+1 - - tr = cZ(1)+(cxI(3)-1)*CD(3) - if(fZ(k)-tr < FD(3))then - tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - else - tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& - C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& - C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& - C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& - C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& - C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) - endif - - tr = cY(1)+(cxI(2)-1)*CD(2) - if(fY(j)-tr < FD(2))then - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) - else - tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) - endif - - tr = cX(1)+(cxI(1)-1)*CD(1) - if(fX(i)-tr < FD(1))then - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) - else - funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) - endif - - enddo - enddo - enddo - - return - - end subroutine prolong3 -#endif -!-------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 6 points, 5th order interpolation -! 1 2 3 4 5 6 -! *---*---*---*---*---* -! ^ -! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) -!-------------------------------------------------------------------------- -#if 1 - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - real*8, dimension(-1:extf(1),-1:extf(2),-1:extf(3)):: funff - integer,dimension(3) :: cxI - integer :: i,j,k - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - - real*8 :: tmp_xz_plane(-1:extf(1), 6) - real*8 :: tmp_x_line(-1:extf(1)) - integer :: fi, fj, fk, ii, jj, kk - integer :: fi_min, fi_max, ii_lo, ii_hi - integer :: fj_min, fj_max, fk_min, fk_max, jj_lo, jj_hi, kk_lo, kk_hi - logical :: need_full_symmetry - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - - if(any(dabs(CD-2*FD)>1.d-10))then - write(*,*)"restrict:",CD,FD - stop - endif -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 !this is wrong but not essential - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) !this is wrong but not essential - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-2.or.jmaxi.gt.extf(2)-2.or.kmaxi.gt.extf(3)-2)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - - ! 仅计算 X 向最终写回所需的窗口： - ! func(i,j,k) 只访问 tmp_x_line(fi-2:fi+3) - fi_min = 2*(imino + lbc(1) - 1) - 1 - lbf(1) + 1 - fi_max = 2*(imaxo + lbc(1) - 1) - 1 - lbf(1) + 1 - fj_min = 2*(jmino + lbc(2) - 1) - 1 - lbf(2) + 1 - fj_max = 2*(jmaxo + lbc(2) - 1) - 1 - lbf(2) + 1 - fk_min = 2*(kmino + lbc(3) - 1) - 1 - lbf(3) + 1 - fk_max = 2*(kmaxo + lbc(3) - 1) - 1 - lbf(3) + 1 - ii_lo = fi_min - 2 - ii_hi = fi_max + 3 - jj_lo = fj_min - 2 - jj_hi = fj_max + 3 - kk_lo = fk_min - 2 - kk_hi = fk_max + 3 - if(ii_lo < -1 .or. ii_hi > extf(1) .or. & - jj_lo < -1 .or. jj_hi > extf(2) .or. & - kk_lo < -1 .or. kk_hi > extf(3))then - write(*,*)"restrict3: invalid stencil window" - write(*,*)"ii=",ii_lo,ii_hi," jj=",jj_lo,jj_hi," kk=",kk_lo,kk_hi - write(*,*)"extf=",extf - stop - endif - need_full_symmetry = (ii_lo < 1) .or. (jj_lo < 1) .or. (kk_lo < 1) - if(need_full_symmetry)then - call symmetry_bd(2,extf,funf,funff,SoA) - else - funff(ii_lo:ii_hi,jj_lo:jj_hi,kk_lo:kk_hi) = funf(ii_lo:ii_hi,jj_lo:jj_hi,kk_lo:kk_hi) - endif - -!~~~~~~> restriction start... -do k = kmino, kmaxo - fk = 2*(k + lbc(3) - 1) - 1 - lbf(3) + 1 - - do j = jmino, jmaxo - fj = 2*(j + lbc(2) - 1) - 1 - lbf(2) + 1 - - ! 优化点 1: 显式展开 Z 方向计算，减少循环开销 - ! 确保 ii 循环是最内层且连续访问 - !DIR$ VECTOR ALWAYS - do ii = ii_lo, ii_hi - ! 预计算当前 j 对应的 6 行在 Z 方向的压缩结果 - ! 这里直接硬编码 jj 的偏移，彻底消除一层循环 - tmp_xz_plane(ii, 1) = C1*(funff(ii,fj-2,fk-2)+funff(ii,fj-2,fk+3)) + & - C2*(funff(ii,fj-2,fk-1)+funff(ii,fj-2,fk+2)) + & - C3*(funff(ii,fj-2,fk )+funff(ii,fj-2,fk+1)) - tmp_xz_plane(ii, 2) = C1*(funff(ii,fj-1,fk-2)+funff(ii,fj-1,fk+3)) + & - C2*(funff(ii,fj-1,fk-1)+funff(ii,fj-1,fk+2)) + & - C3*(funff(ii,fj-1,fk )+funff(ii,fj-1,fk+1)) - tmp_xz_plane(ii, 3) = C1*(funff(ii,fj ,fk-2)+funff(ii,fj ,fk+3)) + & - C2*(funff(ii,fj ,fk-1)+funff(ii,fj ,fk+2)) + & - C3*(funff(ii,fj ,fk )+funff(ii,fj ,fk+1)) - tmp_xz_plane(ii, 4) = C1*(funff(ii,fj+1,fk-2)+funff(ii,fj+1,fk+3)) + & - C2*(funff(ii,fj+1,fk-1)+funff(ii,fj+1,fk+2)) + & - C3*(funff(ii,fj+1,fk )+funff(ii,fj+1,fk+1)) - tmp_xz_plane(ii, 5) = C1*(funff(ii,fj+2,fk-2)+funff(ii,fj+2,fk+3)) + & - C2*(funff(ii,fj+2,fk-1)+funff(ii,fj+2,fk+2)) + & - C3*(funff(ii,fj+2,fk )+funff(ii,fj+2,fk+1)) - tmp_xz_plane(ii, 6) = C1*(funff(ii,fj+3,fk-2)+funff(ii,fj+3,fk+3)) + & - C2*(funff(ii,fj+3,fk-1)+funff(ii,fj+3,fk+2)) + & - C3*(funff(ii,fj+3,fk )+funff(ii,fj+3,fk+1)) - end do - - ! 优化点 2: 同样向量化 Y 方向压缩 - !DIR$ VECTOR ALWAYS - do ii = ii_lo, ii_hi - tmp_x_line(ii) = C1*(tmp_xz_plane(ii, 1) + tmp_xz_plane(ii, 6)) + & - C2*(tmp_xz_plane(ii, 2) + tmp_xz_plane(ii, 5)) + & - C3*(tmp_xz_plane(ii, 3) + tmp_xz_plane(ii, 4)) - end do - - ! 优化点 3: 最终写入，利用已经缓存在 tmp_x_line 的数据 - do i = imino, imaxo - fi = 2*(i + lbc(1) - 1) - 1 - lbf(1) + 1 - func(i, j, k) = C1*(tmp_x_line(fi-2) + tmp_x_line(fi+3)) + & - C2*(tmp_x_line(fi-1) + tmp_x_line(fi+2)) + & - C3*(tmp_x_line(fi ) + tmp_x_line(fi+1)) - end do - end do -end do -#if 0 - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - if(any(cxI+3 > extf)) write(*,*)"error in restrict" - tmp2= C1*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - func(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - enddo - enddo - enddo -#endif - return - - end subroutine restrict3 -#else - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(extc(1)) :: cX - real*8, dimension(extc(2)) :: cY - real*8, dimension(extc(3)) :: cZ - real*8, dimension(extf(1)) :: fX - real*8, dimension(extf(2)) :: fY - real*8, dimension(extf(3)) :: fZ - real*8, dimension(-1:extf(1),-1:extf(2),-1:extf(3)):: funff - integer,dimension(3) :: cxI - integer :: i,j,k - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - - do i=1,extc(1) - cX(i) = llbc(1) + (i-0.5)*CD(1) - enddo - do i=1,extc(2) - cY(i) = llbc(2) + (i-0.5)*CD(2) - enddo - do i=1,extc(3) - cZ(i) = llbc(3) + (i-0.5)*CD(3) - enddo - - do i=1,extf(1) - fX(i) = llbf(1) + (i-0.5)*FD(1) - enddo - do i=1,extf(2) - fY(i) = llbf(2) + (i-0.5)*FD(2) - enddo - do i=1,extf(3) - fZ(i) = llbf(3) + (i-0.5)*FD(3) - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -!sanity check -!these are wrong but not essential - imini=idint((llbr(1)-fX(1))/FD(1)+0.5)+1 - imaxi=idint((uubr(1)-fX(1))/FD(1)-0.5)+1 - jmini=idint((llbr(2)-fY(1))/FD(2)+0.5)+1 - jmaxi=idint((uubr(2)-fY(1))/FD(2)-0.5)+1 - kmini=idint((llbr(3)-fZ(1))/FD(3)+0.5)+1 - kmaxi=idint((uubr(3)-fZ(1))/FD(3)-0.5)+1 - - imino=idint((llbr(1)-cX(1))/CD(1)+0.5+0.4)+1 - imaxo=idint((uubr(1)-cX(1))/CD(1)-0.5+0.4)+1 - jmino=idint((llbr(2)-cY(1))/CD(2)+0.5+0.4)+1 - jmaxo=idint((uubr(2)-cY(1))/CD(2)-0.5+0.4)+1 - kmino=idint((llbr(3)-cZ(1))/CD(3)+0.5+0.4)+1 - kmaxo=idint((uubr(3)-cZ(1))/CD(3)-0.5+0.4)+1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-2.or.jmaxi.gt.extf(2)-2.or.kmaxi.gt.extf(3)-2)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)llbf,uubf - write(*,*)"to" - write(*,*)llbc,uubc - write(*,*)"want" - write(*,*)llbr,uubr - stop - endif - - call symmetry_bd(2,extf,funf,funff,SoA) - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - -! floor(4.8)= 4,floor(-5.6)= - 6 - cxI(1) = floor((CX(i)-fX(1))/FD(1))+1 - cxI(2) = floor((CY(j)-fY(1))/FD(2))+1 - cxI(3) = floor((CZ(k)-fZ(1))/FD(3))+1 - - tmp2= C1*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - func(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -#endif -#elif (ghost_width == 4) -! sixth order code -!-------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 8 points, 7th order interpolation -! 1 2 3 4 5 6 7 8 -! *---*---*---*---*---*---*---* -! ^ -! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) -!-------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(8,8,8) :: ya - real*8, dimension(8,8) :: tmp2 - real*8, dimension(8) :: tmp1 - real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-3.or.jmaxi.gt.extf(2)-3.or.kmaxi.gt.extf(3)-3)then -!-3 is because -!|-x---x-|-x---x-|-x--- -!|- -*- -| - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - if(any(cxI+4 > extf)) write(*,*)"error in restrict" -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - func(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 8 points, 7th order interpolation -! 1 2 3 4 5 6 7 8 -! *---*---*---*---*---*---*---* -! ^ -! f=-495/262144*f_1 + 5005/262144*f_2 - 27027/262144*f_3 + 225225/262144*f_4 -! -429/262144*f_8 + 4095/262144*f_7 - 19305/262144*f_6 + 75075/262144*f_5 -!-------------------------------------------------------------------------- - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(8,8,8) :: ya - real*8, dimension(8,8) :: tmp2 - real*8, dimension(8) :: tmp1 - - real*8, parameter :: C1=-4.95d2/2.62144d5,C2=5.005d3/2.62144d5,C3=-2.7027d4/2.62144d5,C4=2.25225d5/2.62144d5 - real*8, parameter :: C8=-4.29d2/2.62144d5,C7=4.095d3/2.62144d5,C6=-1.9305d4/2.62144d5,C5=7.5075d4/2.62144d5 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - if(any(cxI+4 > extc)) write(*,*)"error in prolong" - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& - C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& - C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& - C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& - C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& - C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& - C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& - C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& - C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& - C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& - C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& - C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) - endif - tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& - C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) - funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& - C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#elif (ghost_width == 5) -! eighth order code -!--------------------------------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! -! 10 points, 9th order interpolation -! 1 2 3 4 5 6 7 8 9 10 -! *---*---*---*---*---*---*---*---*---* -! ^ -! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) -!--------------------------------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in)::wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(10,10,10) :: ya - real*8, dimension(10,10) :: tmp2 - real*8, dimension(10) :: tmp1 - real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 - real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - -! note say base = 0, llbf = 0, uubf = 2 -! llbf->1 and uubf->2 - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4) - ubrf = idint((uubr-base)/FD+0.4) - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1)-4.or.jmaxi.gt.extf(2)-4.or.kmaxi.gt.extf(3)-4)then - write(*,*)"error in restrict for" - write(*,*)"from" - write(*,*)lbf,ubf - write(*,*)"to" - write(*,*)lbc,ubc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - write(*,*)"base = ",base - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - if(any(cxI+5 > extf)) write(*,*)"error in restrict" -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - func(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 10 points, 9th order interpolation -! 1 2 3 4 5 6 7 8 9 10 -! *---*---*---*---*---*---*---*---*---* -! ^ -!f= 13585/33554432*f_1-159885/33554432*f_2+230945/8388608*f_3- 969969/8388608*f_4+14549535/16777216*f_5 -! +4849845/16777216*f_6- 692835/8388608*f_7+188955/8388608*f_8-138567/33554432*f_9+ 12155/33554432*f_10 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(10,10,10) :: ya - real*8, dimension(10,10) :: tmp2 - real*8, dimension(10) :: tmp1 - - real*8, parameter :: C1=1.3585d4/3.3554432d7,C2=-1.59885d5/3.3554432d7,C3=2.30945d5/8.388608d6 - real*8, parameter :: C4=-9.69969d5/8.388608d6,C5=1.4549535d7/1.6777216d7,C6=4.849845d6/1.6777216d7 - real*8, parameter :: C7=-6.92835d5/8.388608d6,C8=1.88955d5/8.388608d6,C9=-1.38567d5/3.3554432d7 - real*8, parameter :: C10=1.2155d4/3.3554432d7 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - CD = (uubc-llbc)/extc - FD = (uubf-llbf)/extf - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4) - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4) - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4) - ubpc = idint((uubp-base)/CD+0.4) - -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - return - endif - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to coarse level reference -!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| -!|=======x===============x===============x===============x=======| - cxI = (cxI+lbf-1)/2 -! change to array index - cxI = cxI - lbc + 1 - - if(any(cxI+5 > extc)) write(*,*)"error in prolong" - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+ C5*tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& - C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& - C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& - C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& - C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& - C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& - C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& - C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& - C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& - C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& - C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& - C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& - C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& - C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) - endif - tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& - C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) - funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& - C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 -#endif - -#else -#ifndef Vertex -#error Not define Vertex nor Cell -#endif -#endif + + +! Because of overlap determination, source region is always larger than target +! region + +#include "macrodef.fh" + +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + +!-------------------------------------------------------------------------- +! +! Prepare the data on coarse level for prolong +! valid for all finite difference order +!-------------------------------------------------------------------------- + + subroutine prolongcopy3(wei,llbc,uubc,extc,func,& + llbf,uubf,exto,funo,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,exto + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func +! both bounds ghost_width + real*8, dimension(exto(1)+2*ghost_width,exto(2)+2*ghost_width,exto(3)+2*ghost_width),intent(out):: funo + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8,dimension(1-ghost_width:extc(1),1-ghost_width:extc(2),1-ghost_width:extc(3)) :: fh + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,cxI + integer :: i,j,k + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolongcopy3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/extc + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) +!sanity check +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| +! ^ ^ + imini=lbpc(1)-lbc(1) + 1 - ghost_width + imaxi=ubpc(1)-lbc(1) + 1 + ghost_width + jmini=lbpc(2)-lbc(2) + 1 - ghost_width + jmaxi=ubpc(2)-lbc(2) + 1 + ghost_width + kmini=lbpc(3)-lbc(3) + 1 - ghost_width + kmaxi=ubpc(3)-lbc(3) + 1 + ghost_width + + cxI(1) = imaxi-imini+1 + cxI(2) = jmaxi-jmini+1 + cxI(3) = kmaxi-kmini+1 + if(any(cxI.ne.exto+2*ghost_width).or. & + imaxi.gt.extc(1)+1.or.jmaxi.gt.extc(2)+1.or.kmaxi.gt.extc(3)+1)then + write(*,*)"error in prolongationcopy3 for" + if(any(cxI.ne.exto+2*ghost_width))then + write(*,*) cxI,exto+2*ghost_width + return + endif + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + return + endif + +! because some point needs 2*ghost_width +! while some point needs 2*ghost_width-1 +! so we use 0 to fill empty points + if(imini < 1.or.jmini < 1.or.kmini < 1)then + if(imini<1.and.dabs(llbp(1))>CD(1)) write(*,*)"prolongcopy3 warning: ",llbp(1) + if(jmini<1.and.dabs(llbp(2))>CD(2)) write(*,*)"prolongcopy3 warning: ",llbp(2) + if(kmini<1.and.dabs(llbp(3))>CD(3)) write(*,*)"prolongcopy3 warning: ",llbp(3) + call symmetry_bd(ghost_width,extc,func,fh,SoA) + if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then + funo = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + else + funo = 0.d0 + cxI = 0 + if(imaxi>extc(1))then + cxI(1) = 1 + imaxi = extc(1) + endif + if(jmaxi>extc(2))then + cxI(2) = 1 + jmaxi = extc(2) + endif + if(kmaxi>extc(3))then + cxI(3) = 1 + kmaxi = extc(3) + endif + funo(1:exto(1)+2*ghost_width-cxI(1), & + 1:exto(2)+2*ghost_width-cxI(2), & + 1:exto(3)+2*ghost_width-cxI(3)) = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + endif + else + if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then + funo = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + else + funo = 0.d0 + cxI = 0 + if(imaxi>extc(1))then + cxI(1) = 1 + imaxi = extc(1) + endif + if(jmaxi>extc(2))then + cxI(2) = 1 + jmaxi = extc(2) + endif + if(kmaxi>extc(3))then + cxI(3) = 1 + kmaxi = extc(3) + endif + funo(1:exto(1)+2*ghost_width-cxI(1), & + 1:exto(2)+2*ghost_width-cxI(2), & + 1:exto(3)+2*ghost_width-cxI(3)) = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + endif + endif + + return + + end subroutine prolongcopy3 +!================================================================================================= +#define MIX 0 +!-------------------------------------------------------------------------- +! +! Prolong data throug mix data of fine and coarse levels +!-------------------------------------------------------------------------- + + subroutine prolongmix3(wei,llbf,uubf,extf,funf,& + llbc,uubc,exti,funi,& + llbp,uubp,SoA,Symmetry, & + illb,iuub) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse fine (real inner points) + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp,illb,iuub + integer,dimension(3), intent(in) :: exti,extf + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout) :: funf +! lower bound ghost_width; upper bound ghost_width-1 + real*8, dimension(exti(1)+2*ghost_width,exti(2)+2*ghost_width,exti(3)+2*ghost_width),intent(in):: funi + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,ilb,iub + integer :: i,j,k,n,ii,jj,kk + + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + integer,dimension(3) :: cxI,cxB,cxT,fg + + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + real*8,dimension(2*ghost_width,2*ghost_width,2*ghost_width) :: ya + real*8,dimension(2*ghost_width) :: X,Y,Z + real*8, dimension(2*ghost_width,2*ghost_width) :: tmp2 + real*8, dimension(2*ghost_width) :: tmp1 + real*8 :: ddy + real*8,dimension(3) :: ccp + +#if (ghost_width == 2) + real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 + real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 +#elif (ghost_width == 3) + real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 + real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 +#elif (ghost_width == 4) + real*8, parameter :: C1=-4.95d2/2.62144d5,C2=5.005d3/2.62144d5,C3=-2.7027d4/2.62144d5,C4=2.25225d5/2.62144d5 + real*8, parameter :: C8=-4.29d2/2.62144d5,C7=4.095d3/2.62144d5,C6=-1.9305d4/2.62144d5,C5=7.5075d4/2.62144d5 +#elif (ghost_width == 5) + real*8, parameter :: C1=1.3585d4/3.3554432d7,C2=-1.59885d5/3.3554432d7,C3=2.30945d5/8.388608d6 + real*8, parameter :: C4=-9.69969d5/8.388608d6,C5=1.4549535d7/1.6777216d7,C6=4.849845d6/1.6777216d7 + real*8, parameter :: C7=-6.92835d5/8.388608d6,C8=1.88955d5/8.388608d6,C9=-1.38567d5/3.3554432d7 + real*8, parameter :: C10=1.2155d4/3.3554432d7 +#endif + + if(wei.ne.3)then + write(*,*)"prolongrestrict_cell.f90::prolongmix3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + FD = (uubf-llbf)/extf + CD = FD*2.d0 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + ilb = idint((illb-base)/FD+0.4)+1 + iub = idint((iuub-base)/FD+0.4) +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + +!sanity check +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| +! ^ ^ +! ghost_width for both sides + lbpc = lbpc - ghost_width + ubpc = ubpc + ghost_width +! index for real inner points + ilb = ilb - lbf+1 + iub = iub - lbf+1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3))then + write(*,*)"error in prolongmix3 for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)base,FD + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif + + do k=kmino,kmaxo + do j=jmino,jmaxo + do i=imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k + + ccp = llbf+(cxI-0.5d0)*FD + +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbpc + 1 + + ya = funi(cxI(1)-ghost_width+1:cxI(1)+ghost_width,cxI(2)-ghost_width+1:cxI(2)+ghost_width,cxI(3)-ghost_width+1:cxI(3)+ghost_width) + + fg = 0 + where((illb.lt.ccp).and.(iuub.gt.ccp)) fg = 1 + + if(sum(fg).eq.3)then + write(*,*)"1 error in in prolongmix3:" + write(*,*)ccp,illb,iuub + stop + endif + +! fix the wanted point at (0,0,0), set FD = 1 + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(sum(fg).eq.2)then + + cxI(1) = i + cxI(2) = j + cxI(3) = k + +!!!! set X + if(ii/2*2==ii)then +! v +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + do n=1,ghost_width + X(ghost_width-n+1) = -0.5d0-(n-1)*2 + X(ghost_width+n ) = 1.5d0+(n-1)*2 + enddo + if(cxI(1).gt.iub(1))then + cxB(1) = iub(1)-ghost_width+1+(cxI(1)-iub(1)+1-MIX)/2 + cxT(1) = iub(1) + elseif(cxI(1).lt.ilb(1))then + cxB(1) = ilb(1) + cxT(1) = ilb(1)+ghost_width-1-(ilb(1)-cxI(1)-MIX)/2 + elseif(fg(1).eq.0)then + write(*,*)"2 error in in prolongmix3:" + write(*,*)ccp(1),illb(1),iuub(1) + stop + endif + else +! v +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + do n=1,ghost_width + X(ghost_width-n+1) = -1.5d0-(n-1)*2 + X(ghost_width+n ) = 0.5d0+(n-1)*2 + enddo + if(cxI(1).gt.iub(1))then + cxB(1) = iub(1)-ghost_width+1+(cxI(1)-iub(1)-MIX)/2 + cxT(1) = iub(1) + elseif(cxI(1).lt.ilb(1))then + cxB(1) = ilb(1) + cxT(1) = ilb(1)+ghost_width-1-(ilb(1)-cxI(1)+1-MIX)/2 + elseif(fg(1).eq.0)then + write(*,*)"3 error in in prolongmix3:" + write(*,*)ccp(1),illb(1),iuub(1) + stop + endif + endif + +!!!! set Y + if(jj/2*2==jj)then + do n=1,ghost_width + Y(ghost_width-n+1) = -0.5d0-(n-1)*2 + Y(ghost_width+n ) = 1.5d0+(n-1)*2 + enddo + if(cxI(2).gt.iub(2))then + cxB(2) = iub(2)-ghost_width+1+(cxI(2)-iub(2)+1-MIX)/2 + cxT(2) = iub(2) + elseif(cxI(2).lt.ilb(2))then + cxB(2) = ilb(2) + cxT(2) = ilb(2)+ghost_width-1-(ilb(2)-cxI(2)-MIX)/2 + elseif(fg(2).eq.0)then + write(*,*)"4 error in in prolongmix3:" + write(*,*)ccp(2),illb(2),iuub(2) + stop + endif + else + do n=1,ghost_width + Y(ghost_width-n+1) = -1.5d0-(n-1)*2 + Y(ghost_width+n ) = 0.5d0+(n-1)*2 + enddo + if(cxI(2).gt.iub(2))then + cxB(2) = iub(2)-ghost_width+1+(cxI(2)-iub(2)-MIX)/2 + cxT(2) = iub(2) + elseif(cxI(2).lt.ilb(2))then + cxB(2) = ilb(2) + cxT(2) = ilb(2)+ghost_width-1-(ilb(2)-cxI(2)+1-MIX)/2 + elseif(fg(2).eq.0)then + write(*,*)"5 error in in prolongmix3:" + write(*,*)ccp(2),illb(2),iuub(2) + stop + endif + endif + +!!!! set Z + if(kk/2*2==kk)then + do n=1,ghost_width + Z(ghost_width-n+1) = -0.5d0-(n-1)*2 + Z(ghost_width+n ) = 1.5d0+(n-1)*2 + enddo + if(cxI(3).gt.iub(3))then + cxB(3) = iub(3)-ghost_width+1+(cxI(3)-iub(3)+1-MIX)/2 + cxT(3) = iub(3) + elseif(cxI(3).lt.ilb(3))then + cxB(3) = ilb(3) + cxT(3) = ilb(3)+ghost_width-1-(ilb(3)-cxI(3)-MIX)/2 + elseif(fg(3).eq.0)then + write(*,*)"6 error in in prolongmix3:" + write(*,*)ccp(3),illb(3),iuub(3) + stop + endif + else + do n=1,ghost_width + Z(ghost_width-n+1) = -1.5d0-(n-1)*2 + Z(ghost_width+n ) = 0.5d0+(n-1)*2 + enddo + if(cxI(3).gt.iub(3))then + cxB(3) = iub(3)-ghost_width+1+(cxI(3)-iub(3)-MIX)/2 + cxT(3) = iub(3) + elseif(cxI(3).lt.ilb(3))then + cxB(3) = ilb(3) + cxT(3) = ilb(3)+ghost_width-1-(ilb(3)-cxI(3)+1-MIX)/2 + elseif(fg(3).eq.0)then + write(*,*)"7 error in in prolongmix3:" + write(*,*)ccp(3),illb(3),iuub(3) + stop + endif + endif + + endif +! X, Y, and Z are possiblly not in order, I assume polint does not +! require this order +! because of the mismatch of points for fine level and coarse level +! we have to deal in this way + +! for x direction + if(sum(fg).eq.2.and.fg(1) .eq. 0.and. & + (((cxI(1).gt.iub(1)).and.(ghost_width-cxI(1)+cxB(1)+1.gt.0)).or. & + (cxI(1).lt.ilb(1)).and.(ghost_width-cxI(1)+cxT(1).le.2*ghost_width)))then + +#if (ghost_width == 2) + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + endif + endif +#elif (ghost_width == 3) + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + endif + endif +#elif (ghost_width == 4) + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + endif + endif +#elif (ghost_width == 5) + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + endif + endif +#endif + + if(cxI(1).gt.iub(1))then +! consistent to coarse level, always X(ghost_width+1) = 0 for left + do n=cxB(1),cxT(1) + X(ghost_width-cxI(1)+n+1) = dble(n-cxI(1)) + enddo + tmp1(ghost_width-cxI(1)+cxB(1)+1:ghost_width-cxI(1)+cxT(1)+1) = funf(cxB(1):cxT(1),j,k) + elseif(cxI(1).lt.ilb(1))then +! consistent to coarse level, always X(ghost_width ) = 0 for right + do n=cxB(1),cxT(1) + X(ghost_width-cxI(1)+n ) = dble(n-cxI(1)) + enddo + tmp1(ghost_width-cxI(1)+cxB(1) :ghost_width-cxI(1)+cxT(1) ) = funf(cxB(1):cxT(1),j,k) + endif + + call polint(X,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) + +! for y direction + elseif(sum(fg).eq.2.and.fg(2) .eq. 0.and. & + (((cxI(2).gt.iub(2)).and.(ghost_width-cxI(2)+cxB(2)+1.gt.0)).or. & + (cxI(2).lt.ilb(2)).and.(ghost_width-cxI(2)+cxT(2).le.2*ghost_width)))then + +#if (ghost_width == 2) + if(ii/2*2==ii)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) + endif + endif +#elif (ghost_width == 3) + if(ii/2*2==ii)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) + endif + endif +#elif (ghost_width == 4) + if(ii/2*2==ii)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& + C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& + C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& + C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& + C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) + endif + endif +#elif (ghost_width == 5) + if(ii/2*2==ii)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& + C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& + C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& + C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& + C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) + endif + endif +#endif + if(cxI(2).gt.iub(2))then +! consistent to coarse level, always Y(ghost_width+1) = 0 for left + do n=cxB(2),cxT(2) + Y(ghost_width-cxI(2)+n+1) = dble(n-cxI(2)) + enddo + tmp1(ghost_width-cxI(2)+cxB(2)+1:ghost_width-cxI(2)+cxT(2)+1) = funf(i,cxB(2):cxT(2),k) + elseif(cxI(2).lt.ilb(2))then +! consistent to coarse level, always Y(ghost_width ) = 0 for right + do n=cxB(2),cxT(2) + Y(ghost_width-cxI(2)+n ) = dble(n-cxI(2)) + enddo + tmp1(ghost_width-cxI(2)+cxB(2) :ghost_width-cxI(2)+cxT(2) ) = funf(i,cxB(2):cxT(2),k) + endif + + call polint(Y,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) + +! for z direction + elseif(sum(fg).eq.2.and.fg(3) .eq. 0.and. & + (((cxI(3).gt.iub(3)).and.(ghost_width-cxI(3)+cxB(3)+1.gt.0)).or. & + (cxI(3).lt.ilb(3)).and.(ghost_width-cxI(3)+cxT(3).le.2*ghost_width)))then + +#if (ghost_width == 2) + if(jj/2*2==jj)then + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) + else + tmp2= C4*ya(1,:,:)+C3*ya(2,:,:)+C2*ya(3,:,:)+C1*ya(4,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:) + endif + else + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:) + tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) + else + tmp2= C4*ya(1,:,:)+C3*ya(2,:,:)+C2*ya(3,:,:)+C1*ya(4,:,:) + tmp1= C4*tmp2(1,:)+C3*tmp2(2,:)+C2*tmp2(3,:)+C1*tmp2(4,:) + endif + endif +#elif (ghost_width == 3) + if(jj/2*2==jj)then + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5*ya(5,:,:)+C6*ya(6,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) + else + tmp2= C6*ya(1,:,:)+C5*ya(2,:,:)+C4*ya(3,:,:)+C3*ya(4,:,:)+C2*ya(5,:,:)+C1*ya(6,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5*tmp2(5,:)+C6*tmp2(6,:) + endif + else + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5*ya(5,:,:)+C6*ya(6,:,:) + tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) + else + tmp2= C6*ya(1,:,:)+C5*ya(2,:,:)+C4*ya(3,:,:)+C3*ya(4,:,:)+C2*ya(5,:,:)+C1*ya(6,:,:) + tmp1= C6*tmp2(1,:)+C5*tmp2(2,:)+C4*tmp2(3,:)+C3*tmp2(4,:)+C2*tmp2(5,:)+C1*tmp2(6,:) + endif + endif +#elif (ghost_width == 4) + if(jj/2*2==jj)then + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+& + C5*ya(5,:,:)+C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& + C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) + else + tmp2= C8*ya(1,:,:)+C7*ya(2,:,:)+C6*ya(3,:,:)+C5*ya(4,:,:)+& + C4*ya(5,:,:)+C3*ya(6,:,:)+C2*ya(7,:,:)+C1*ya(8,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+& + C5*tmp2(5,:)+C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:) + endif + else + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+& + C5*ya(5,:,:)+C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:) + tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& + C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) + else + tmp2= C8*ya(1,:,:)+C7*ya(2,:,:)+C6*ya(3,:,:)+C5*ya(4,:,:)+& + C4*ya(5,:,:)+C3*ya(6,:,:)+C2*ya(7,:,:)+C1*ya(8,:,:) + tmp1= C8*tmp2(1,:)+C7*tmp2(2,:)+C6*tmp2(3,:)+C5*tmp2(4,:)+& + C4*tmp2(5,:)+C3*tmp2(6,:)+C2*tmp2(7,:)+C1*tmp2(8,:) + endif + endif +#elif (ghost_width == 5) + if(jj/2*2==jj)then + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5 *ya( 5,:,:)+& + C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:)+C9*ya(9,:,:)+C10*ya(10,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& + C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) + else + tmp2= C10*ya(1,:,:)+C9*ya(2,:,:)+C8*ya(3,:,:)+C7*ya(4,:,:)+C6*ya( 5,:,:)+& + C5 *ya(6,:,:)+C4*ya(7,:,:)+C3*ya(8,:,:)+C2*ya(9,:,:)+C1*ya(10,:,:) + tmp1= C1*tmp2(1,:)+C2*tmp2(2,:)+C3*tmp2(3,:)+C4*tmp2(4,:)+C5 *tmp2( 5,:)+& + C6*tmp2(6,:)+C7*tmp2(7,:)+C8*tmp2(8,:)+C9*tmp2(9,:)+C10*tmp2(10,:) + endif + else + if(ii/2*2==ii)then + tmp2= C1*ya(1,:,:)+C2*ya(2,:,:)+C3*ya(3,:,:)+C4*ya(4,:,:)+C5 *ya( 5,:,:)+& + C6*ya(6,:,:)+C7*ya(7,:,:)+C8*ya(8,:,:)+C9*ya(9,:,:)+C10*ya(10,:,:) + tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& + C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) + else + tmp2= C10*ya(1,:,:)+C9*ya(2,:,:)+C8*ya(3,:,:)+C7*ya(4,:,:)+C6*ya( 5,:,:)+& + C5 *ya(6,:,:)+C4*ya(7,:,:)+C3*ya(8,:,:)+C2*ya(9,:,:)+C1*ya(10,:,:) + tmp1= C10*tmp2(1,:)+C9*tmp2(2,:)+C8*tmp2(3,:)+C7*tmp2(4,:)+C6*tmp2( 5,:)+& + C5 *tmp2(6,:)+C4*tmp2(7,:)+C3*tmp2(8,:)+C2*tmp2(9,:)+C1*tmp2(10,:) + endif + endif +#endif + +#if 1 + if(cxI(3).gt.iub(3))then +! consistent to coarse level, always Z(ghost_width+1) = 0 for left + do n=cxB(3),cxT(3) + Z(ghost_width-cxI(3)+n+1) = dble(n-cxI(3)) + enddo + tmp1(ghost_width-cxI(3)+cxB(3)+1:ghost_width-cxI(3)+cxT(3)+1) = funf(i,j,cxB(3):cxT(3)) + elseif(cxI(3).lt.ilb(3))then +! consistent to coarse level, always Z(ghost_width ) = 0 for right + do n=cxB(3),cxT(3) + Z(ghost_width-cxI(3)+n ) = dble(n-cxI(3)) + enddo + tmp1(ghost_width-cxI(3)+cxB(3) :ghost_width-cxI(3)+cxT(3) ) = funf(i,j,cxB(3):cxT(3)) + endif + + call polint(Z,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) + +#else + + if(kk/2*2==kk)then + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + else + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + endif +#endif + else + +#if (ghost_width == 2) + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + else + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + endif + endif + endif +#elif (ghost_width == 3) + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5*ya(:,:,5)+C6*ya(:,:,6) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + else + tmp2= C6*ya(:,:,1)+C5*ya(:,:,2)+C4*ya(:,:,3)+C3*ya(:,:,4)+C2*ya(:,:,5)+C1*ya(:,:,6) + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + endif + endif + endif +#elif (ghost_width == 4) + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + else + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + endif + endif + endif +#elif (ghost_width == 5) + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+ C5*tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + endif + else + if(kk/2*2==kk)then + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + else + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + endif + endif + endif +#endif + endif + + enddo + enddo + enddo + + return + + end subroutine prolongmix3 +!/////////////////////////////////////////////////////////////////////////////////////////////// +! for different finite differnce order +#if (ghost_width == 2) +!-------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 4 points, 3rd order interpolation +! 1 2 3 4 +! *---*---*---* +! ^ +! f=-1/16*(f_1+f_4) + 9/16*(f_2+f_3) +!-------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-1.or.jmaxi.gt.extf(2)-1.or.kmaxi.gt.extf(3)-1)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + if(any(cxI+2 > extf)) write(*,*)"error in restrict" +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2))& + +C2*(funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+funf(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) + func(i,j,k)= C1*(tmp1(1)+tmp1(4))+C2*(tmp1(2)+tmp1(3)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 4 points, 3rd order interpolation +! 1 2 3 4 +! *---*---*---* +! ^ +! f=-7/128*f_1 + 105/128*f_2 +! -5/128*f_4 + 35/128*f_3 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + + real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 + real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+2 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C4*ya(:,:,1)+C3*ya(:,:,2)+C2*ya(:,:,3)+C1*ya(:,:,4) + endif + tmp1= C4*tmp2(:,1)+C3*tmp2(:,2)+C2*tmp2(:,3)+C1*tmp2(:,4) + funf(i,j,k)= C4*tmp1(1)+C3*tmp1(2)+C2*tmp1(3)+C1*tmp1(4) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + + subroutine prolong3new(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + + real*8, parameter :: C1=-7.d0/1.28d2,C2=1.05d2/1.28d2 + real*8, parameter :: C4=-5.d0/1.28d2,C3= 3.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + real*8,dimension(3,4) :: CC + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif +!~~~~~~> prolongation start... + do i=1,3 + if(lbp(i)/2*2 == lbp(i))then + CC(i,1) = C1 + CC(i,2) = C2 + CC(i,3) = C3 + CC(i,4) = C4 + else + CC(i,1) = C4 + CC(i,2) = C3 + CC(i,3) = C2 + CC(i,4) = C1 + endif + enddo + + do k = kmino,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,1)*tmp1(1)+CC(1,2)*tmp1(2)+CC(1,3)*tmp1(3)+CC(1,4)*tmp1(4) + enddo + enddo + enddo + + do k = kmino,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,1)*tmp2(:,1)+CC(2,2)*tmp2(:,2)+CC(2,3)*tmp2(:,3)+CC(2,4)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + + do k = kmino,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,1)*ya(:,:,1)+CC(3,2)*ya(:,:,2)+CC(3,3)*ya(:,:,3)+CC(3,4)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + do k = kmino+1,kmaxo,2 + do j = jmino+1,jmaxo,2 + do i = imino+1,imaxo,2 + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= CC(3,4)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + CC(3,3)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + CC(3,2)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + CC(3,1)*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= CC(3,4)*ya(:,:,1)+CC(3,3)*ya(:,:,2)+CC(3,2)*ya(:,:,3)+CC(3,1)*ya(:,:,4) + endif + tmp1= CC(2,4)*tmp2(:,1)+CC(2,3)*tmp2(:,2)+CC(2,2)*tmp2(:,3)+CC(2,1)*tmp2(:,4) + funf(i,j,k)= CC(1,4)*tmp1(1)+CC(1,3)*tmp1(2)+CC(1,2)*tmp1(3)+CC(1,1)*tmp1(4) + enddo + enddo + enddo + + return + + end subroutine prolong3new + +#elif (ghost_width == 3) +! fourth order code +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 6 points, 5th order interpolation +! 1 2 3 4 5 6 +! *---*---*---*---*---* +! ^ +! f=77/8192*f_1 - 693/8192*f_2 + 3465/4096*f_3 + +! 63/8192*f_6 - 495/8192*f_5 + 1155/4096*f_4 +!-------------------------------------------------------------------------- +#if 1 + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine fine + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc +! when if=1 -> ic=0, this is different to vertex center grid + real*8, dimension(-2:extc(1),-2:extc(2),-2:extc(3)) :: funcc + integer,dimension(3) :: cxI + integer :: i,j,k,ii,jj,kk,px,py,pz + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + integer, dimension(extf(1)) :: cix + integer, dimension(extf(2)) :: ciy + integer, dimension(extf(3)) :: ciz + integer, dimension(extf(1)) :: pix + integer, dimension(extf(2)) :: piy + integer, dimension(extf(3)) :: piz + + real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 + real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 + real*8, dimension(6,2), parameter :: WC = reshape((/& + C1,C2,C3,C4,C5,C6,& + C6,C5,C4,C3,C2,C1/), (/6,2/)) + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + integer::maxcx,maxcy,maxcz + + real*8,dimension(3) :: CD,FD + real*8 :: tmp_yz(extc(1), 6) ! 存储整条 X 线上 6 个 Y 轴偏置的 Z 向插值结果 + real*8 :: tmp_xyz_line(-2:extc(1)) ! 包含 X 向 6 点模板访问所需下界 + real*8 :: v1, v2, v3, v4, v5, v6 + integer :: ic, jc, kc, ix_offset,ix,iy,iz,jc_min,jc_max,ic_min,ic_max,kc_min,kc_max + integer :: i_lo, i_hi, j_lo, j_hi, k_lo, k_hi + logical :: need_full_symmetry + real*8 :: res_line + real*8 :: tmp_z_slab(-2:extc(1), -2:extc(2)) ! 包含 Y/X 向模板访问所需下界 + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + + if(any(dabs(CD-2*FD)>1.d-10))then + write(*,*)"prolong:",CD,FD + stop + endif + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 ! this is wrong, but not essential + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) ! this is wrong, but not essential + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif + + do i = imino,imaxo + ii = i + lbf(1) - 1 + cix(i) = ii/2 - lbc(1) + 1 + if(ii/2*2 == ii)then + pix(i) = 1 + else + pix(i) = 2 + endif + enddo + do j = jmino,jmaxo + jj = j + lbf(2) - 1 + ciy(j) = jj/2 - lbc(2) + 1 + if(jj/2*2 == jj)then + piy(j) = 1 + else + piy(j) = 2 + endif + enddo + do k = kmino,kmaxo + kk = k + lbf(3) - 1 + ciz(k) = kk/2 - lbc(3) + 1 + if(kk/2*2 == kk)then + piz(k) = 1 + else + piz(k) = 2 + endif + enddo + + ic_min = minval(cix(imino:imaxo)) + ic_max = maxval(cix(imino:imaxo)) + jc_min = minval(ciy(jmino:jmaxo)) + jc_max = maxval(ciy(jmino:jmaxo)) + kc_min = minval(ciz(kmino:kmaxo)) + kc_max = maxval(ciz(kmino:kmaxo)) + + maxcx = ic_max + maxcy = jc_max + maxcz = kc_max + if(maxcx+3 > extc(1) .or. maxcy+3 > extc(2) .or. maxcz+3 > extc(3))then + write(*,*)"error in prolong" + return + endif + + i_lo = ic_min - 2 + i_hi = ic_max + 3 + j_lo = jc_min - 2 + j_hi = jc_max + 3 + k_lo = kc_min - 2 + k_hi = kc_max + 3 + need_full_symmetry = (i_lo < 1) .or. (j_lo < 1) .or. (k_lo < 1) + if(need_full_symmetry)then + call symmetry_bd(3,extc,func,funcc,SoA) + else + funcc(i_lo:i_hi,j_lo:j_hi,k_lo:k_hi) = func(i_lo:i_hi,j_lo:j_hi,k_lo:k_hi) + endif + + ! 对每个 k（pz, kc 固定）预计算 Z 向插值的 2D 切片 + +do k = kmino, kmaxo + pz = piz(k); kc = ciz(k) + ! --- Pass 1: Z 方向，只算一次 --- + do iy = jc_min-2, jc_max+3 ! 仅需的 iy 范围（对应 jc-2:jc+3） + do ii = ic_min-2, ic_max+3 ! 仅需的 ii 范围（对应 cix-2:cix+3） + tmp_z_slab(ii, iy) = sum(WC(:,pz) * funcc(ii, iy, kc-2:kc+3)) + end do + end do + + do j = jmino, jmaxo + py = piy(j); jc = ciy(j) + ! --- Pass 2: Y 方向 --- + do ii = ic_min-2, ic_max+3 + tmp_xyz_line(ii) = sum(WC(:,py) * tmp_z_slab(ii, jc-2:jc+3)) + end do + ! --- Pass 3: X 方向 --- + do i = imino, imaxo + funf(i,j,k) = sum(WC(:,pix(i)) * tmp_xyz_line(cix(i)-2:cix(i)+3)) + end do + end do +end do + +!~~~~~~> prolongation start... +#if 0 + do k = kmino, kmaxo + pz = piz(k) + kc = ciz(k) + + do j = jmino, jmaxo + py = piy(j) + jc = ciy(j) + +! --- 步骤 1 & 2 融合：分段处理 X 轴，提升 Cache 命中率 --- + ! 我们将 ii 循环逻辑重组，减少对 funcc 的跨行重复访问 + do ii = 1, extc(1) + ! 1. 先做 Z 方向的 6 条线插值（针对当前的 ii 和当前的 6 个 iy） + ! 我们直接在这里把 Y 方向的加权也做了，省去 tmp_yz 数组 + ! 这样 funcc 的数据读进来后立即完成所有维度的贡献，不再写回内存 + + res_line = 0.0d0 + do jj = 1, 6 + iy = jc - 3 + jj + ! 这一行代码是核心：一次性完成 Z 插值并加上 Y 的权重 + ! 编译器会把 WC(jj, py) 存在寄存器里 + res_line = res_line + WC(jj, py) * ( & + WC(1, pz) * funcc(ii, iy, kc-2) + & + WC(2, pz) * funcc(ii, iy, kc-1) + & + WC(3, pz) * funcc(ii, iy, kc ) + & + WC(4, pz) * funcc(ii, iy, kc+1) + & + WC(5, pz) * funcc(ii, iy, kc+2) + & + WC(6, pz) * funcc(ii, iy, kc+3) ) + end do + tmp_xyz_line(ii) = res_line + end do + + + + + ! 3. 【降维：X 向】最后在最内层只处理 X 方向的 6 点加权 + ! 此时每个点的计算量从原来的 200+ 次乘法降到了仅 6 次 + do i = imino, imaxo + px = pix(i) + ic = cix(i) + + ! 直接从预计算好的 line 中读取连续的 6 个点 + ! ic-2 到 ic+3 对应原始 6 点算子 + funf(i,j,k) = WC(1,px)*tmp_xyz_line(ic-2) + & + WC(2,px)*tmp_xyz_line(ic-1) + & + WC(3,px)*tmp_xyz_line(ic ) + & + WC(4,px)*tmp_xyz_line(ic+1) + & + WC(5,px)*tmp_xyz_line(ic+2) + & + WC(6,px)*tmp_xyz_line(ic+3) + end do + end do + end do +#endif + return + + end subroutine prolong3 + +#else + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine fine + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(extc(1)) :: cX + real*8, dimension(extc(2)) :: cY + real*8, dimension(extc(3)) :: cZ + real*8, dimension(extf(1)) :: fX + real*8, dimension(extf(2)) :: fY + real*8, dimension(extf(3)) :: fZ +! when if=1 -> ic=0, this is different to vertex center grid + real*8, dimension(-2:extc(1),-2:extc(2),-2:extc(3)) :: funcc + integer,dimension(3) :: cxI + integer :: i,j,k + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + + real*8, parameter :: C1=7.7d1/8.192d3,C2=-6.93d2/8.192d3,C3=3.465d3/4.096d3 + real*8, parameter :: C6=6.3d1/8.192d3,C5=-4.95d2/8.192d3,C4=1.155d3/4.096d3 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + real*8 :: tr + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + + do i=1,extc(1) + cX(i) = llbc(1) + (i-0.5d0)*CD(1) + enddo + do i=1,extc(2) + cY(i) = llbc(2) + (i-0.5d0)*CD(2) + enddo + do i=1,extc(3) + cZ(i) = llbc(3) + (i-0.5d0)*CD(3) + enddo + + do i=1,extf(1) + fX(i) = llbf(1) + (i-0.5d0)*FD(1) + enddo + do i=1,extf(2) + fY(i) = llbf(2) + (i-0.5d0)*FD(2) + enddo + do i=1,extf(3) + fZ(i) = llbf(3) + (i-0.5d0)*FD(3) + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +!sanity check, 0.4 is for round off error + imino=idint((llbp(1)-fX(1))/FD(1)+0.5+0.4)+1 + imaxo=idint((uubp(1)-fX(1))/FD(1)-0.5+0.4)+1 + jmino=idint((llbp(2)-fY(1))/FD(2)+0.5+0.4)+1 + jmaxo=idint((uubp(2)-fY(1))/FD(2)-0.5+0.4)+1 + kmino=idint((llbp(3)-fZ(1))/FD(3)+0.5+0.4)+1 + kmaxo=idint((uubp(3)-fZ(1))/FD(3)-0.5+0.4)+1 + +! these are wrong, butnot essential + imini=idint((llbp(1)-cX(1))/CD(1)+0.5)+1 + imaxi=idint((uubp(1)-cX(1))/CD(1)-0.5)+1 + jmini=idint((llbp(2)-cY(1))/CD(2)+0.5)+1 + jmaxi=idint((uubp(2)-cY(1))/CD(2)-0.5)+1 + kmini=idint((llbp(3)-cZ(1))/CD(3)+0.5)+1 + kmaxi=idint((uubp(3)-cZ(1))/CD(3)-0.5)+1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)"want" + write(*,*)llbp,uubp + return + endif + + call symmetry_bd(3,extc,func,funcc,SoA) + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! floor(4.8)= 4,floor(-5.6)= - 6 + cxI(1) = floor((fX(i)-cX(1))/CD(1))+1 + cxI(2) = floor((fY(j)-cY(1))/CD(2))+1 + cxI(3) = floor((fZ(k)-cZ(1))/CD(3))+1 + + tr = cZ(1)+(cxI(3)-1)*CD(3) + if(fZ(k)-tr < FD(3))then + tmp2= C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + else + tmp2= C6*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+& + C5*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+& + C4*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+& + C3*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)+& + C2*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2)+& + C1*funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3) + endif + + tr = cY(1)+(cxI(2)-1)*CD(2) + if(fY(j)-tr < FD(2))then + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5*tmp2(:,5)+C6*tmp2(:,6) + else + tmp1= C6*tmp2(:,1)+C5*tmp2(:,2)+C4*tmp2(:,3)+C3*tmp2(:,4)+C2*tmp2(:,5)+C1*tmp2(:,6) + endif + + tr = cX(1)+(cxI(1)-1)*CD(1) + if(fX(i)-tr < FD(1))then + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5*tmp1(5)+C6*tmp1(6) + else + funf(i,j,k)= C6*tmp1(1)+C5*tmp1(2)+C4*tmp1(3)+C3*tmp1(4)+C2*tmp1(5)+C1*tmp1(6) + endif + + enddo + enddo + enddo + + return + + end subroutine prolong3 +#endif +!-------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 6 points, 5th order interpolation +! 1 2 3 4 5 6 +! *---*---*---*---*---* +! ^ +! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) +!-------------------------------------------------------------------------- +#if 1 + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + real*8, dimension(-1:extf(1),-1:extf(2),-1:extf(3)):: funff + integer,dimension(3) :: cxI + integer :: i,j,k + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + + real*8 :: tmp_xz_plane(-1:extf(1), 6) + real*8 :: tmp_x_line(-1:extf(1)) + integer :: fi, fj, fk, ii, jj, kk + integer :: fi_min, fi_max, ii_lo, ii_hi + integer :: fj_min, fj_max, fk_min, fk_max, jj_lo, jj_hi, kk_lo, kk_hi + logical :: need_full_symmetry + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + + if(any(dabs(CD-2*FD)>1.d-10))then + write(*,*)"restrict:",CD,FD + stop + endif +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 !this is wrong but not essential + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) !this is wrong but not essential + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-2.or.jmaxi.gt.extf(2)-2.or.kmaxi.gt.extf(3)-2)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + + ! 仅计算 X 向最终写回所需的窗口： + ! func(i,j,k) 只访问 tmp_x_line(fi-2:fi+3) + fi_min = 2*(imino + lbc(1) - 1) - 1 - lbf(1) + 1 + fi_max = 2*(imaxo + lbc(1) - 1) - 1 - lbf(1) + 1 + fj_min = 2*(jmino + lbc(2) - 1) - 1 - lbf(2) + 1 + fj_max = 2*(jmaxo + lbc(2) - 1) - 1 - lbf(2) + 1 + fk_min = 2*(kmino + lbc(3) - 1) - 1 - lbf(3) + 1 + fk_max = 2*(kmaxo + lbc(3) - 1) - 1 - lbf(3) + 1 + ii_lo = fi_min - 2 + ii_hi = fi_max + 3 + jj_lo = fj_min - 2 + jj_hi = fj_max + 3 + kk_lo = fk_min - 2 + kk_hi = fk_max + 3 + if(ii_lo < -1 .or. ii_hi > extf(1) .or. & + jj_lo < -1 .or. jj_hi > extf(2) .or. & + kk_lo < -1 .or. kk_hi > extf(3))then + write(*,*)"restrict3: invalid stencil window" + write(*,*)"ii=",ii_lo,ii_hi," jj=",jj_lo,jj_hi," kk=",kk_lo,kk_hi + write(*,*)"extf=",extf + stop + endif + need_full_symmetry = (ii_lo < 1) .or. (jj_lo < 1) .or. (kk_lo < 1) + if(need_full_symmetry)then + call symmetry_bd(2,extf,funf,funff,SoA) + else + funff(ii_lo:ii_hi,jj_lo:jj_hi,kk_lo:kk_hi) = funf(ii_lo:ii_hi,jj_lo:jj_hi,kk_lo:kk_hi) + endif + +!~~~~~~> restriction start... +do k = kmino, kmaxo + fk = 2*(k + lbc(3) - 1) - 1 - lbf(3) + 1 + + do j = jmino, jmaxo + fj = 2*(j + lbc(2) - 1) - 1 - lbf(2) + 1 + + ! 优化点 1: 显式展开 Z 方向计算，减少循环开销 + ! 确保 ii 循环是最内层且连续访问 + !DIR$ VECTOR ALWAYS + do ii = ii_lo, ii_hi + ! 预计算当前 j 对应的 6 行在 Z 方向的压缩结果 + ! 这里直接硬编码 jj 的偏移，彻底消除一层循环 + tmp_xz_plane(ii, 1) = C1*(funff(ii,fj-2,fk-2)+funff(ii,fj-2,fk+3)) + & + C2*(funff(ii,fj-2,fk-1)+funff(ii,fj-2,fk+2)) + & + C3*(funff(ii,fj-2,fk )+funff(ii,fj-2,fk+1)) + tmp_xz_plane(ii, 2) = C1*(funff(ii,fj-1,fk-2)+funff(ii,fj-1,fk+3)) + & + C2*(funff(ii,fj-1,fk-1)+funff(ii,fj-1,fk+2)) + & + C3*(funff(ii,fj-1,fk )+funff(ii,fj-1,fk+1)) + tmp_xz_plane(ii, 3) = C1*(funff(ii,fj ,fk-2)+funff(ii,fj ,fk+3)) + & + C2*(funff(ii,fj ,fk-1)+funff(ii,fj ,fk+2)) + & + C3*(funff(ii,fj ,fk )+funff(ii,fj ,fk+1)) + tmp_xz_plane(ii, 4) = C1*(funff(ii,fj+1,fk-2)+funff(ii,fj+1,fk+3)) + & + C2*(funff(ii,fj+1,fk-1)+funff(ii,fj+1,fk+2)) + & + C3*(funff(ii,fj+1,fk )+funff(ii,fj+1,fk+1)) + tmp_xz_plane(ii, 5) = C1*(funff(ii,fj+2,fk-2)+funff(ii,fj+2,fk+3)) + & + C2*(funff(ii,fj+2,fk-1)+funff(ii,fj+2,fk+2)) + & + C3*(funff(ii,fj+2,fk )+funff(ii,fj+2,fk+1)) + tmp_xz_plane(ii, 6) = C1*(funff(ii,fj+3,fk-2)+funff(ii,fj+3,fk+3)) + & + C2*(funff(ii,fj+3,fk-1)+funff(ii,fj+3,fk+2)) + & + C3*(funff(ii,fj+3,fk )+funff(ii,fj+3,fk+1)) + end do + + ! 优化点 2: 同样向量化 Y 方向压缩 + !DIR$ VECTOR ALWAYS + do ii = ii_lo, ii_hi + tmp_x_line(ii) = C1*(tmp_xz_plane(ii, 1) + tmp_xz_plane(ii, 6)) + & + C2*(tmp_xz_plane(ii, 2) + tmp_xz_plane(ii, 5)) + & + C3*(tmp_xz_plane(ii, 3) + tmp_xz_plane(ii, 4)) + end do + + ! 优化点 3: 最终写入，利用已经缓存在 tmp_x_line 的数据 + do i = imino, imaxo + fi = 2*(i + lbc(1) - 1) - 1 - lbf(1) + 1 + func(i, j, k) = C1*(tmp_x_line(fi-2) + tmp_x_line(fi+3)) + & + C2*(tmp_x_line(fi-1) + tmp_x_line(fi+2)) + & + C3*(tmp_x_line(fi ) + tmp_x_line(fi+1)) + end do + end do +end do +#if 0 + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + if(any(cxI+3 > extf)) write(*,*)"error in restrict" + tmp2= C1*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + func(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + enddo + enddo + enddo +#endif + return + + end subroutine restrict3 +#else + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(extc(1)) :: cX + real*8, dimension(extc(2)) :: cY + real*8, dimension(extc(3)) :: cZ + real*8, dimension(extf(1)) :: fX + real*8, dimension(extf(2)) :: fY + real*8, dimension(extf(3)) :: fZ + real*8, dimension(-1:extf(1),-1:extf(2),-1:extf(3)):: funff + integer,dimension(3) :: cxI + integer :: i,j,k + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + + do i=1,extc(1) + cX(i) = llbc(1) + (i-0.5)*CD(1) + enddo + do i=1,extc(2) + cY(i) = llbc(2) + (i-0.5)*CD(2) + enddo + do i=1,extc(3) + cZ(i) = llbc(3) + (i-0.5)*CD(3) + enddo + + do i=1,extf(1) + fX(i) = llbf(1) + (i-0.5)*FD(1) + enddo + do i=1,extf(2) + fY(i) = llbf(2) + (i-0.5)*FD(2) + enddo + do i=1,extf(3) + fZ(i) = llbf(3) + (i-0.5)*FD(3) + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +!sanity check +!these are wrong but not essential + imini=idint((llbr(1)-fX(1))/FD(1)+0.5)+1 + imaxi=idint((uubr(1)-fX(1))/FD(1)-0.5)+1 + jmini=idint((llbr(2)-fY(1))/FD(2)+0.5)+1 + jmaxi=idint((uubr(2)-fY(1))/FD(2)-0.5)+1 + kmini=idint((llbr(3)-fZ(1))/FD(3)+0.5)+1 + kmaxi=idint((uubr(3)-fZ(1))/FD(3)-0.5)+1 + + imino=idint((llbr(1)-cX(1))/CD(1)+0.5+0.4)+1 + imaxo=idint((uubr(1)-cX(1))/CD(1)-0.5+0.4)+1 + jmino=idint((llbr(2)-cY(1))/CD(2)+0.5+0.4)+1 + jmaxo=idint((uubr(2)-cY(1))/CD(2)-0.5+0.4)+1 + kmino=idint((llbr(3)-cZ(1))/CD(3)+0.5+0.4)+1 + kmaxo=idint((uubr(3)-cZ(1))/CD(3)-0.5+0.4)+1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-2.or.jmaxi.gt.extf(2)-2.or.kmaxi.gt.extf(3)-2)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)llbf,uubf + write(*,*)"to" + write(*,*)llbc,uubc + write(*,*)"want" + write(*,*)llbr,uubr + stop + endif + + call symmetry_bd(2,extf,funf,funff,SoA) + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + +! floor(4.8)= 4,floor(-5.6)= - 6 + cxI(1) = floor((CX(i)-fX(1))/FD(1))+1 + cxI(2) = floor((CY(j)-fY(1))/FD(2))+1 + cxI(3) = floor((CZ(k)-fZ(1))/FD(3))+1 + + tmp2= C1*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funff(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + func(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +#endif +#elif (ghost_width == 4) +! sixth order code +!-------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 8 points, 7th order interpolation +! 1 2 3 4 5 6 7 8 +! *---*---*---*---*---*---*---* +! ^ +! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) +!-------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(8,8,8) :: ya + real*8, dimension(8,8) :: tmp2 + real*8, dimension(8) :: tmp1 + real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-3.or.jmaxi.gt.extf(2)-3.or.kmaxi.gt.extf(3)-3)then +!-3 is because +!|-x---x-|-x---x-|-x--- +!|- -*- -| + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + if(any(cxI+4 > extf)) write(*,*)"error in restrict" +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+funf(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + func(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 8 points, 7th order interpolation +! 1 2 3 4 5 6 7 8 +! *---*---*---*---*---*---*---* +! ^ +! f=-495/262144*f_1 + 5005/262144*f_2 - 27027/262144*f_3 + 225225/262144*f_4 +! -429/262144*f_8 + 4095/262144*f_7 - 19305/262144*f_6 + 75075/262144*f_5 +!-------------------------------------------------------------------------- + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(8,8,8) :: ya + real*8, dimension(8,8) :: tmp2 + real*8, dimension(8) :: tmp1 + + real*8, parameter :: C1=-4.95d2/2.62144d5,C2=5.005d3/2.62144d5,C3=-2.7027d4/2.62144d5,C4=2.25225d5/2.62144d5 + real*8, parameter :: C8=-4.29d2/2.62144d5,C7=4.095d3/2.62144d5,C6=-1.9305d4/2.62144d5,C5=7.5075d4/2.62144d5 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + if(any(cxI+4 > extc)) write(*,*)"error in prolong" + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+& + C5*tmp1(5)+C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+& + C5*tmp2(:,5)+C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+& + C5*ya(:,:,5)+C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C8*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+& + C7*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+& + C6*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+& + C5*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+& + C4*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)+& + C3*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2)+& + C2*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3)+& + C1*func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-0.5)*FD(1),llbf(2)+(j-0.5)*FD(2),llbf(3)+(k-0.5)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= C8*ya(:,:,1)+C7*ya(:,:,2)+C6*ya(:,:,3)+C5*ya(:,:,4)+& + C4*ya(:,:,5)+C3*ya(:,:,6)+C2*ya(:,:,7)+C1*ya(:,:,8) + endif + tmp1= C8*tmp2(:,1)+C7*tmp2(:,2)+C6*tmp2(:,3)+C5*tmp2(:,4)+& + C4*tmp2(:,5)+C3*tmp2(:,6)+C2*tmp2(:,7)+C1*tmp2(:,8) + funf(i,j,k)= C8*tmp1(1)+C7*tmp1(2)+C6*tmp1(3)+C5*tmp1(4)+& + C4*tmp1(5)+C3*tmp1(6)+C2*tmp1(7)+C1*tmp1(8) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#elif (ghost_width == 5) +! eighth order code +!--------------------------------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! +! 10 points, 9th order interpolation +! 1 2 3 4 5 6 7 8 9 10 +! *---*---*---*---*---*---*---*---*---* +! ^ +! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) +!--------------------------------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in)::wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(10,10,10) :: ya + real*8, dimension(10,10) :: tmp2 + real*8, dimension(10) :: tmp1 + real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 + real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + +! note say base = 0, llbf = 0, uubf = 2 +! llbf->1 and uubf->2 + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4) + ubrf = idint((uubr-base)/FD+0.4) + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1)-4.or.jmaxi.gt.extf(2)-4.or.kmaxi.gt.extf(3)-4)then + write(*,*)"error in restrict for" + write(*,*)"from" + write(*,*)lbf,ubf + write(*,*)"to" + write(*,*)lbc,ubc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + write(*,*)"base = ",base + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + if(any(cxI+5 > extf)) write(*,*)"error in restrict" +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+funf(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extf,funf,funf,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"restrict3 position index: ",i+lbc(1)-1,j+lbc(2)-1,k+lbc(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + func(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 10 points, 9th order interpolation +! 1 2 3 4 5 6 7 8 9 10 +! *---*---*---*---*---*---*---*---*---* +! ^ +!f= 13585/33554432*f_1-159885/33554432*f_2+230945/8388608*f_3- 969969/8388608*f_4+14549535/16777216*f_5 +! +4849845/16777216*f_6- 692835/8388608*f_7+188955/8388608*f_8-138567/33554432*f_9+ 12155/33554432*f_10 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(10,10,10) :: ya + real*8, dimension(10,10) :: tmp2 + real*8, dimension(10) :: tmp1 + + real*8, parameter :: C1=1.3585d4/3.3554432d7,C2=-1.59885d5/3.3554432d7,C3=2.30945d5/8.388608d6 + real*8, parameter :: C4=-9.69969d5/8.388608d6,C5=1.4549535d7/1.6777216d7,C6=4.849845d6/1.6777216d7 + real*8, parameter :: C7=-6.92835d5/8.388608d6,C8=1.88955d5/8.388608d6,C9=-1.38567d5/3.3554432d7 + real*8, parameter :: C10=1.2155d4/3.3554432d7 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + CD = (uubc-llbc)/extc + FD = (uubf-llbf)/extf + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4) + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4) + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4) + ubpc = idint((uubp-base)/CD+0.4) + +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + return + endif + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to coarse level reference +!|---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*---| +!|=======x===============x===============x===============x=======| + cxI = (cxI+lbf-1)/2 +! change to array index + cxI = cxI - lbc + 1 + + if(any(cxI+5 > extc)) write(*,*)"error in prolong" + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+ C5*tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4)+C5 *tmp1( 5)+& + C6*tmp1(6)+C7*tmp1(7)+C8*tmp1(8)+C9*tmp1(9)+C10*tmp1(10) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4)+C5 *tmp2(:, 5)+& + C6*tmp2(:,6)+C7*tmp2(:,7)+C8*tmp2(:,8)+C9*tmp2(:,9)+C10*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4)+C5 *ya(:,:, 5)+& + C6*ya(:,:,6)+C7*ya(:,:,7)+C8*ya(:,:,8)+C9*ya(:,:,9)+C10*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C10*func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+& + C9 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+& + C8 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+& + C7 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+& + C6 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+& + C5 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)+& + C4 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2)+& + C3 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3)+& + C2 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4)+& + C1 *func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C10*ya(:,:,1)+C9*ya(:,:,2)+C8*ya(:,:,3)+C7*ya(:,:,4)+C6*ya(:,:, 5)+& + C5 *ya(:,:,6)+C4*ya(:,:,7)+C3*ya(:,:,8)+C2*ya(:,:,9)+C1*ya(:,:,10) + endif + tmp1= C10*tmp2(:,1)+C9*tmp2(:,2)+C8*tmp2(:,3)+C7*tmp2(:,4)+C6*tmp2(:, 5)+& + C5 *tmp2(:,6)+C4*tmp2(:,7)+C3*tmp2(:,8)+C2*tmp2(:,9)+C1*tmp2(:,10) + funf(i,j,k)= C10*tmp1(1)+C9*tmp1(2)+C8*tmp1(3)+C7*tmp1(4)+C6*tmp1( 5)+& + C5 *tmp1(6)+C4*tmp1(7)+C3*tmp1(8)+C2*tmp1(9)+C1*tmp1(10) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 +#endif + +#else +#ifndef Vertex +#error Not define Vertex nor Cell +#endif +#endif diff --git a/AMSS_NCKU_source/prolongrestrict_vertex.f90 b/AMSS_NCKU_source/BSSN/prolongrestrict_vertex.f90 similarity index 97% rename from AMSS_NCKU_source/prolongrestrict_vertex.f90 rename to AMSS_NCKU_source/BSSN/prolongrestrict_vertex.f90 index 5cfb1f9..70f1b8f 100644 --- a/AMSS_NCKU_source/prolongrestrict_vertex.f90 +++ b/AMSS_NCKU_source/BSSN/prolongrestrict_vertex.f90 @@ -1,1925 +1,1925 @@ - - -! Because of overlap determination, source region is always larger than target -! region - -#include "macrodef.fh" - -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - -!-------------------------------------------------------------------------- -! -! Prepare the data on coarse level for prolong -! valid for all finite difference order -!-------------------------------------------------------------------------- - - subroutine prolongcopy3(wei,llbc,uubc,extc,func,& - llbf,uubf,exto,funo,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,exto - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func -! both bounds ghost_width - real*8, dimension(exto(1)+2*ghost_width,exto(2)+2*ghost_width,exto(3)+2*ghost_width),intent(out):: funo - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8,dimension(1-ghost_width:extc(1),1-ghost_width:extc(2),1-ghost_width:extc(3)) :: fh - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,cxI - integer :: i,j,k - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolongcopy3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| -! ^ ^ - imini=lbpc(1)-lbc(1) + 1 - ghost_width - imaxi=ubpc(1)-lbc(1) + 1 + ghost_width - jmini=lbpc(2)-lbc(2) + 1 - ghost_width - jmaxi=ubpc(2)-lbc(2) + 1 + ghost_width - kmini=lbpc(3)-lbc(3) + 1 - ghost_width - kmaxi=ubpc(3)-lbc(3) + 1 + ghost_width - - cxI(1) = imaxi-imini+1 - cxI(2) = jmaxi-jmini+1 - cxI(3) = kmaxi-kmini+1 - if(any(cxI.ne.exto+2*ghost_width).or. & - imaxi.gt.extc(1)+1.or.jmaxi.gt.extc(2)+1.or.kmaxi.gt.extc(3)+1)then - write(*,*)"error in prolongationcopy3 for" - if(any(cxI.ne.exto+2*ghost_width))then - write(*,*) cxI,exto+2*ghost_width - return - endif - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - return - endif - -! because some point needs 2*ghost_width -! while some point needs 2*ghost_width-1 -! so we use 0 to fill empty points - if(imini < 1.or.jmini < 1.or.kmini < 1)then - if(imini<1.and.dabs(llbp(1))>CD(1)) write(*,*)"prolongcopy3 warning: ",llbp(1) - if(jmini<1.and.dabs(llbp(2))>CD(2)) write(*,*)"prolongcopy3 warning: ",llbp(2) - if(kmini<1.and.dabs(llbp(3))>CD(3)) write(*,*)"prolongcopy3 warning: ",llbp(3) - call symmetry_bd(ghost_width,extc,func,fh,SoA) - if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then - funo = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - else - funo = 0.d0 - cxI = 0 - if(imaxi>extc(1))then - cxI(1) = 1 - imaxi = extc(1) - endif - if(jmaxi>extc(2))then - cxI(2) = 1 - jmaxi = extc(2) - endif - if(kmaxi>extc(3))then - cxI(3) = 1 - kmaxi = extc(3) - endif - funo(1:exto(1)+2*ghost_width-cxI(1), & - 1:exto(2)+2*ghost_width-cxI(2), & - 1:exto(3)+2*ghost_width-cxI(3)) = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - endif - else - if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then - funo = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - else - funo = 0.d0 - cxI = 0 - if(imaxi>extc(1))then - cxI(1) = 1 - imaxi = extc(1) - endif - if(jmaxi>extc(2))then - cxI(2) = 1 - jmaxi = extc(2) - endif - if(kmaxi>extc(3))then - cxI(3) = 1 - kmaxi = extc(3) - endif - funo(1:exto(1)+2*ghost_width-cxI(1), & - 1:exto(2)+2*ghost_width-cxI(2), & - 1:exto(3)+2*ghost_width-cxI(3)) = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) - endif - endif - - return - - end subroutine prolongcopy3 -!================================================================================================= -!-------------------------------------------------------------------------- -! -! Prolong data throug mix data of fine and coarse levels -!-------------------------------------------------------------------------- - - subroutine prolongmix3(wei,llbf,uubf,extf,funf,& - llbc,uubc,exti,funi,& - llbp,uubp,SoA,Symmetry, & - illb,iuub) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse fine (real inner points) - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp,illb,iuub - integer,dimension(3), intent(in) :: exti,extf - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout) :: funf -! lower bound ghost_width; upper bound ghost_width-1 - real*8, dimension(exti(1)+2*ghost_width,exti(2)+2*ghost_width,exti(3)+2*ghost_width),intent(in):: funi - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8,dimension(1-ghost_width:extf(1),1-ghost_width:extf(2),1-ghost_width:extf(3)) :: fh - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,ilb,iub - integer :: i,j,k,n,ii,jj,kk - - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - - real*8,dimension(3) :: CD,FD - integer,dimension(3) :: cxI,cxB,cxT,fg - - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - real*8,dimension(2*ghost_width,2*ghost_width,2*ghost_width) :: ya - real*8,dimension(2*ghost_width) :: X,Y,Z - real*8, dimension(2*ghost_width,2*ghost_width) :: tmp2 - real*8, dimension(2*ghost_width) :: tmp1 - real*8 :: ddy - -#if (ghost_width == 2) - real*8, parameter :: C1=-1.d0/16,C2=9.d0/16 -#elif (ghost_width == 3) - real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 -#elif (ghost_width == 4) - real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 -#elif (ghost_width == 5) - real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 - real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 -#endif - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolongmix3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - FD = (uubf-llbf)/(extf-1) - CD = FD*2.d0 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 - ilb = idint((illb-base)/FD+0.4)+1 - iub = idint((iuub-base)/FD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - -!sanity check -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x===============x===============x| -! ^ ^ -! ghost_width for both sides - lbpc = lbpc - ghost_width - ubpc = ubpc + ghost_width -! index for real inner points - ilb = ilb - lbf+1 - iub = iub - lbf+1 - -! because of domain division by parallelization - ilb = max(ilb,1) - iub = min(iub,extf) - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3))then - write(*,*)"error in prolongmix3 for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)base,FD - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif - - if(Symmetry > NO_SYMM .and. dabs(illb(3)) < FD(3)) ilb(3) = 1-ghost_width - if(Symmetry > EQ_SYMM .and. dabs(illb(1)) < FD(1)) ilb(1) = 1-ghost_width - if(Symmetry > EQ_SYMM .and. dabs(illb(2)) < FD(2)) ilb(2) = 1-ghost_width - - if(any(ilb<1))then - call symmetry_bd(ghost_width,extf,funf,fh,SoA) - else - fh(1:extf(1),1:extf(2),1:extf(3)) = funf - endif - - do k=kmino,kmaxo - do j=jmino,jmaxo - do i=imino,imaxo - cxI(1) = i - cxI(2) = j - cxI(3) = k - -! for fine level we use cxI-ghost_width,....cxI,....cxI+ghost_width-1 - cxB = max(cxI-ghost_width ,ilb) - cxT = min(cxI+ghost_width-1,iub) -! change to coarse level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x===============x===============x| - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbpc + 1 - - ya = funi(cxI(1)-ghost_width+1:cxI(1)+ghost_width,cxI(2)-ghost_width+1:cxI(2)+ghost_width,cxI(3)-ghost_width+1:cxI(3)+ghost_width) - - fg = 0 - if(cxT(1)>=i.and.cxB(1)<=i) fg(1) = 1 - if(cxT(2)>=j.and.cxB(2)<=j) fg(2) = 1 - if(cxT(3)>=k.and.cxB(3)<=k) fg(3) = 1 - - if(cxT(1)>=cxB(1) .and. cxT(2)>=cxB(2) .and. cxT(3)>=cxB(3).and. sum(fg).eq.2)then - if(any(cxB<1-ghost_width).or.any(cxT>extf))then - write(*,*) "error in prolongmix3: " - if(any(cxB<1-ghost_width)) write(*,*) cxB,1-ghost_width - if(any(cxT>extf) ) write(*,*) cxT,extf,iuub,uubf - stop - endif - -! fix the wanted point at (0,0,0), set FD = 1 - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(ii/2*2==ii)then - do n=1,ghost_width - X(ghost_width-n+1) = -1.d0-(n-1)*2 - X(ghost_width+n ) = 1.d0+(n-1)*2 - enddo - else - do n=1,ghost_width - X(ghost_width-n+1) = -(n-1)*2.d0 - X(ghost_width+n ) = n *2.d0 - enddo - endif - - if(jj/2*2==jj)then - do n=1,ghost_width - Y(ghost_width-n+1) = -1.d0-(n-1)*2 - Y(ghost_width+n ) = 1.d0+(n-1)*2 - enddo - else - do n=1,ghost_width - Y(ghost_width-n+1) = -(n-1)*2.d0 - Y(ghost_width+n ) = n *2.d0 - enddo - endif - - if(kk/2*2==kk)then - do n=1,ghost_width - Z(ghost_width-n+1) = -1.d0-(n-1)*2 - Z(ghost_width+n ) = 1.d0+(n-1)*2 - enddo - else - do n=1,ghost_width - Z(ghost_width-n+1) = -(n-1)*2.d0 - Z(ghost_width+n ) = n *2.d0 - enddo - endif - -! i=>(ghost_width,0), i-ghost_width=>(1,1-ghost_width) - do n=cxB(1)+ghost_width-i+1,cxT(1)+ghost_width-i+1 - X(n) = n-ghost_width - enddo - - do n=cxB(2)+ghost_width-j+1,cxT(2)+ghost_width-j+1 - Y(n) = n-ghost_width - enddo - - do n=cxB(3)+ghost_width-k+1,cxT(3)+ghost_width-k+1 - Z(n) = n-ghost_width - enddo - -! because of the mismatch of points for fine level and coarse level -! we have to deal in this way - -! for x direction - if(fg(1) .eq. 0)then - -#if (ghost_width == 2) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) - else - tmp2= ya(:,:,2) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) - else - tmp1= tmp2(:,2) - endif -#elif (ghost_width == 3) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,6))+C2*(ya(:,:,2)+ya(:,:,5))+C3*(ya(:,:,3)+ya(:,:,4)) - else - tmp2= ya(:,:,3) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - else - tmp1= tmp2(:,3) - endif -#elif (ghost_width == 4) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7)) & - +C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - else - tmp2= ya(:,:,4) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7)) & - +C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - else - tmp1= tmp2(:,4) - endif -#elif (ghost_width == 5) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9)) & - +C3*(ya(:,:,3)+ya(:,:,8 ))+C4*(ya(:,:,4)+ya(:,:,7)) & - +C5*(ya(:,:,5)+ya(:,:,6 )) - else - tmp2= ya(:,:,5) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9)) & - +C3*(tmp2(:,3)+tmp2(:,8 ))+C4*(tmp2(:,4)+tmp2(:,7)) & - +C5*(tmp2(:,5)+tmp2(:,6 )) - else - tmp1= tmp2(:,5) - endif -#endif - - tmp1(cxB(1)+ghost_width-i+1:cxT(1)+ghost_width-i+1) = fh(cxB(1):cxT(1),j,k) - - call polint(X,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) - -! for y direction - elseif (fg(2) .eq. 0)then - -#if (ghost_width == 2) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) - else - tmp2= ya(:,:,2) - endif - if(ii/2*2==ii)then - tmp1= C1*(tmp2(1,:)+tmp2(4,:))+C2*(tmp2(2,:)+tmp2(3,:)) - else - tmp1= tmp2(2,:) - endif -#elif (ghost_width == 3) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,6))+C2*(ya(:,:,2)+ya(:,:,5))+C3*(ya(:,:,3)+ya(:,:,4)) - else - tmp2= ya(:,:,3) - endif - if(ii/2*2==ii)then - tmp1= C1*(tmp2(1,:)+tmp2(6,:))+C2*(tmp2(2,:)+tmp2(5,:))+C3*(tmp2(3,:)+tmp2(4,:)) - else - tmp1= tmp2(3,:) - endif -#elif (ghost_width == 4) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7)) & - +C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - else - tmp2= ya(:,:,4) - endif - if(ii/2*2==ii)then - tmp1= C1*(tmp2(1,:)+tmp2(8,:))+C2*(tmp2(2,:)+tmp2(7,:)) & - +C3*(tmp2(3,:)+tmp2(6,:))+C4*(tmp2(4,:)+tmp2(5,:)) - else - tmp1= tmp2(4,:) - endif -#elif (ghost_width == 5) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9)) & - +C3*(ya(:,:,3)+ya(:,:,8 ))+C4*(ya(:,:,4)+ya(:,:,7)) & - +C5*(ya(:,:,5)+ya(:,:,6 )) - else - tmp2= ya(:,:,5) - endif - if(ii/2*2==ii)then - tmp1= C1*(tmp2(1,:)+tmp2(10,:))+C2*(tmp2(2,:)+tmp2(9,:)) & - +C3*(tmp2(3,:)+tmp2(8 ,:))+C4*(tmp2(4,:)+tmp2(7,:)) & - +C5*(tmp2(5,:)+tmp2(6 ,:)) - else - tmp1= tmp2(5,:) - endif -#endif - - tmp1(cxB(2)+ghost_width-j+1:cxT(2)+ghost_width-j+1) = fh(i,cxB(2):cxT(2),k) - - call polint(Y,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) - -! for z direction - else - -#if (ghost_width == 2) - if(ii/2*2==ii)then - tmp2= C1*(ya(1,:,:)+ya(4,:,:))+C2*(ya(2,:,:)+ya(3,:,:)) - else - tmp2= ya(2,:,:) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(1,:)+tmp2(4,:))+C2*(tmp2(2,:)+tmp2(3,:)) - else - tmp1= tmp2(2,:) - endif -#elif (ghost_width == 3) - if(ii/2*2==ii)then - tmp2= C1*(ya(1,:,:)+ya(6,:,:))+C2*(ya(6,:,:)+ya(5,:,:))+C3*(ya(3,:,:)+ya(4,:,:)) - else - tmp2= ya(3,:,:) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(1,:)+tmp2(6,:))+C2*(tmp2(2,:)+tmp2(5,:))+C3*(tmp2(3,:)+tmp2(4,:)) - else - tmp1= tmp2(3,:) - endif -#elif (ghost_width == 4) - if(ii/2*2==ii)then - tmp2= C1*(ya(1,:,:)+ya(8,:,:))+C2*(ya(2,:,:)+ya(7,:,:)) & - +C3*(ya(3,:,:)+ya(6,:,:))+C4*(ya(4,:,:)+ya(5,:,:)) - else - tmp2= ya(4,:,:) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(1,:)+tmp2(8,:))+C2*(tmp2(2,:)+tmp2(7,:)) & - +C3*(tmp2(3,:)+tmp2(6,:))+C4*(tmp2(4,:)+tmp2(5,:)) - else - tmp1= tmp2(4,:) - endif -#elif (ghost_width == 5) - if(ii/2*2==ii)then - tmp2= C1*(ya(1,:,:)+ya(10,:,:))+C2*(ya(2,:,:)+ya(9,:,:)) & - +C3*(ya(3,:,:)+ya(8 ,:,:))+C4*(ya(4,:,:)+ya(7,:,:)) & - +C5*(ya(5,:,:)+ya(6 ,:,:)) - else - tmp2= ya(5,:,:) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(1,:)+tmp2(10,:))+C2*(tmp2(2,:)+tmp2(9,:)) & - +C3*(tmp2(3,:)+tmp2(8 ,:))+C4*(tmp2(4,:)+tmp2(7,:)) & - +C5*(tmp2(5,:)+tmp2(6 ,:)) - else - tmp1= tmp2(5,:) - endif -#endif - - tmp1(cxB(3)+ghost_width-k+1:cxT(3)+ghost_width-k+1) = fh(i,j,cxB(3):cxT(3)) - - call polint(Z,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) - - endif - - else - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - -#if (ghost_width == 2) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) - else - tmp2= ya(:,:,2) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) - else - tmp1= tmp2(:,2) - endif - if(ii/2*2==ii)then - funf(i,j,k)= C1*(tmp1(1)+tmp1(4))+C2*(tmp1(2)+tmp1(3)) - else - funf(i,j,k)= tmp1(2) - endif -#elif (ghost_width == 3) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,6))+C2*(ya(:,:,2)+ya(:,:,5))+C3*(ya(:,:,3)+ya(:,:,4)) - else - tmp2= ya(:,:,3) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - else - tmp1= tmp2(:,3) - endif - if(ii/2*2==ii)then - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - else - funf(i,j,k)= tmp1(3) - endif -#elif (ghost_width == 4) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7)) & - +C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - else - tmp2= ya(:,:,4) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7)) & - +C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - else - tmp1= tmp2(:,4) - endif - if(ii/2*2==ii)then - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7)) & - +C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - else - funf(i,j,k)= tmp1(4) - endif -#elif (ghost_width == 5) - if(kk/2*2==kk)then - tmp2= C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9)) & - +C3*(ya(:,:,3)+ya(:,:,8 ))+C4*(ya(:,:,4)+ya(:,:,7)) & - +C5*(ya(:,:,5)+ya(:,:,6 )) - else - tmp2= ya(:,:,5) - endif - if(jj/2*2==jj)then - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9)) & - +C3*(tmp2(:,3)+tmp2(:,8 ))+C4*(tmp2(:,4)+tmp2(:,7)) & - +C5*(tmp2(:,5)+tmp2(:,6 )) - else - tmp1= tmp2(:,5) - endif - if(ii/2*2==ii)then - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9)) & - +C3*(tmp1(3)+tmp1(8 ))+C4*(tmp1(4)+tmp1(7)) & - +C5*(tmp1(5)+tmp1(6 )) - else - funf(i,j,k)= tmp1(5) - endif -#endif - endif - - enddo - enddo - enddo - - return - - end subroutine prolongmix3 -!/////////////////////////////////////////////////////////////////////////////////////////////// -!-------------------------------------------------------------------------------------- -! -! Restrict from finner grids to coarser grids ignore the boundary point -! this routine is valid for all orders finite difference -! -! 1 2 3 4 -! *---*---*---* -! ^ -! COPY directly! -!-------------------------------------------------------------------------------------- - - subroutine restrict3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbr,uubr,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif -! it's possible a iolated point for target but not for source - FD = (uubf-llbf)/(extf-1) - CD = 2*FD - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbr = idint((llbr-base)/CD+0.4)+1 - lbrf = idint((llbr-base)/FD+0.4)+1 - ubr = idint((uubr-base)/CD+0.4)+1 - ubrf = idint((uubr-base)/FD+0.4)+1 - -!sanity check - imino=lbr(1)-lbc(1) + 1 - imaxo=ubr(1)-lbc(1) + 1 - jmino=lbr(2)-lbc(2) + 1 - jmaxo=ubr(2)-lbc(2) + 1 - kmino=lbr(3)-lbc(3) + 1 - kmaxo=ubr(3)-lbc(3) + 1 - - imini=lbrf(1)-lbf(1) + 1 - imaxi=ubrf(1)-lbf(1) + 1 - jmini=lbrf(2)-lbf(2) + 1 - jmaxi=ubrf(2)-lbf(2) + 1 - kmini=lbrf(3)-lbf(3) + 1 - kmaxi=ubrf(3)-lbf(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& - imaxi.gt.extf(1).or.jmaxi.gt.extf(2).or.kmaxi.gt.extf(3))then - write(*,*)"error in restrict for" - write(*,*)"mino = ",imino,jmino,kmino - write(*,*)"maxo = ",imaxo,jmaxo,kmaxo - write(*,*)"extc = ",extc - write(*,*)"CD = ",CD - write(*,*)"mini = ",imini,jmini,kmini - write(*,*)"maxi = ",imaxi,jmaxi,kmaxi - write(*,*)"extf = ",extf - write(*,*)"FD = ",FD - write(*,*)"from" - write(*,*)lbf,ubf,extf - write(*,*)"to" - write(*,*)lbc,ubc,extc - write(*,*)"want" - write(*,*)lbr,ubr,lbrf,ubrf - write(*,*)"llbf = ",llbf - write(*,*)"uubf = ",uubf - write(*,*)"llbc = ",llbc - write(*,*)"uubc = ",uubc - write(*,*)"llbr = ",llbr - write(*,*)"uubr = ",uubr - stop - endif - -!~~~~~~> restriction start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo - - cxI(1) = i - cxI(2) = j - cxI(3) = k -! change to fine level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| - cxI = 2*(cxI+lbc-1) - 1 -! change to array index - cxI = cxI - lbf + 1 - - func(i,j,k)= funf(cxI(1),cxI(2),cxI(3)) - enddo - enddo - enddo - - return - - end subroutine restrict3 -!=========================================================================================== - -! for different finite differnce order -#if (ghost_width == 2) -! 2nd order -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 4 points, 3rd order interpolation -! 1 2 3 4 -! *---*---*---* -! ^ -! f=-1/16*f_1 + 9/16*f_2 -! -1/16*f_4 + 9/16*f_3 -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(4,4,4) :: ya - real*8, dimension(4,4) :: tmp2 - real*8, dimension(4) :: tmp1 - - real*8, parameter :: C1=-1.d0/16,C2=9.d0/16 - real*8, parameter :: C4=C1,C3=C2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| -! if(i/2*2 == i)then -! cxI(1) = (i+lbf(1)-1)/2 -! else -! cxI(1) = (i+lbf(1)-1)/2+1 -! endif -! if(j/2*2 == j)then -! cxI(2) = (j+lbf(2)-1)/2 -! else -! cxI(2) = (j+lbf(2)-1)/2+1 -! endif -! if(k/2*2 == k)then -! cxI(3) = (k+lbf(3)-1)/2 -! else -! cxI(3) = (k+lbf(3)-1)/2+1 -! endif -! above code segment is equivalent to - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+2 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,2) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= tmp2(:,2) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,2) - endif - tmp1= tmp2(:,2) - funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= tmp1(2) - else - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,2) - endif - tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) - funf(i,j,k)= tmp1(2) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then - tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& - C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& - C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& - C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) - else - cxB=cxI-1 - cxT=cxI+2 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) - endif - tmp1= tmp2(:,2) - funf(i,j,k)= tmp1(2) - else - funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#elif (ghost_width == 3) -! fourth order code -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 6 points, 5th order interpolation -! 1 2 3 4 5 6 -! *---*---*---*---*---* -! ^ -! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(6,6) :: tmp2 - real*8, dimension(6) :: tmp1 - - real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - real*8, dimension(-1:extc(1),-1:extc(2),-1:extc(3)) :: funcc - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif - - call symmetry_bd(2,extc,func,funcc,SoA) - -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference v -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x===============x===============x| - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+3 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - else - tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - endif - else - if(kk/2*2==kk)then - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= tmp2(:,3) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - else - tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) - tmp1= tmp2(:,3) - funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= tmp1(3) - else - tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) - tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) - funf(i,j,k)= tmp1(3) - endif - else - if(kk/2*2==kk)then - tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& - +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& - +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) - tmp1= tmp2(:,3) - funf(i,j,k)= tmp1(3) - else - funf(i,j,k)= funcc(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#elif (ghost_width == 4) -! sixth order code -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 8 points, 7th order interpolation -! 1 2 3 4 5 6 7 8 -! *---*---*---*---*---*---*---* -! ^ -! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(8,8,8) :: ya - real*8, dimension(8,8) :: tmp2 - real*8, dimension(8) :: tmp1 - - real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference v -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x===============x===============x===============x===============x| - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+4 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= ya(:,:,4) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= tmp2(:,4) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= ya(:,:,4) - endif - tmp1= tmp2(:,4) - funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= tmp1(4) - else - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2= ya(:,:,4) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) - funf(i,j,k)= tmp1(4) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then - tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& - +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& - +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& - +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) - else - cxB=cxI-3 - cxT=cxI+4 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then - write(*,*)"prolong3 position: " - write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) - write(*,*)"llbf = ",llbf - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) - endif - tmp1= tmp2(:,4) - funf(i,j,k)= tmp1(4) - else - funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 - -#elif (ghost_width == 5) -! eighth order code -!-------------------------------------------------------------------------- -! -! Prolongation from coarser grids to finer grids -! 10 points, 9th order interpolation -! 1 2 3 4 5 6 7 8 9 10 -! *---*---*---*---*---*---*---*---*---* -! ^ -! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) -!-------------------------------------------------------------------------- - - subroutine prolong3(wei,llbc,uubc,extc,func,& - llbf,uubf,extf,funf,& - llbp,uubp,SoA,Symmetry) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: wei -! coarse fine coarse - real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp - integer,dimension(3), intent(in) :: extc,extf - real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func - real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf - real*8, dimension(1:3), intent(in) :: SoA - integer,intent(in)::Symmetry - -!~~~~~~> local variables - - real*8, dimension(1:3) :: base - integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc - integer,dimension(3) :: cxB,cxT,cxI - integer :: i,j,k,ii,jj,kk - real*8, dimension(10,10,10) :: ya - real*8, dimension(10,10) :: tmp2 - real*8, dimension(10) :: tmp1 - - real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 - real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 - - integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi - integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo - logical::decide3d - - real*8,dimension(3) :: CD,FD - - if(wei.ne.3)then - write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -! it's possible a iolated point for target but not for source - CD = (uubc-llbc)/(extc-1) - FD = CD/2 - -!take care the mismatch of the two segments of grid - do i=1,3 - if(llbc(i) <= llbf(i))then - base(i) = llbc(i) - else - j=idint((llbc(i)-llbf(i))/FD(i)+0.4) - if(j/2*2 == j)then - base(i) = llbf(i) - else - base(i) = llbf(i) - CD(i)/2 - endif - endif - enddo - -!!! function idint: -!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, -!then INT(A) equals the largest integer that does not exceed the range of A -!and whose sign is the same as the sign of A. - - lbf = idint((llbf-base)/FD+0.4)+1 - ubf = idint((uubf-base)/FD+0.4)+1 - lbc = idint((llbc-base)/CD+0.4)+1 - ubc = idint((uubc-base)/CD+0.4)+1 - lbp = idint((llbp-base)/FD+0.4)+1 - lbpc = idint((llbp-base)/CD+0.4)+1 - ubp = idint((uubp-base)/FD+0.4)+1 - ubpc = idint((uubp-base)/CD+0.4)+1 -!sanity check - imino=lbp(1)-lbf(1) + 1 - imaxo=ubp(1)-lbf(1) + 1 - jmino=lbp(2)-lbf(2) + 1 - jmaxo=ubp(2)-lbf(2) + 1 - kmino=lbp(3)-lbf(3) + 1 - kmaxo=ubp(3)-lbf(3) + 1 - - imini=lbpc(1)-lbc(1) + 1 - imaxi=ubpc(1)-lbc(1) + 1 - jmini=lbpc(2)-lbc(2) + 1 - jmaxi=ubpc(2)-lbc(2) + 1 - kmini=lbpc(3)-lbc(3) + 1 - kmaxi=ubpc(3)-lbc(3) + 1 - - if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& - imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& - imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& - imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then - write(*,*)"error in prolongation for" - write(*,*)"from" - write(*,*)llbc,uubc - write(*,*)lbc,ubc - write(*,*)"to" - write(*,*)llbf,uubf - write(*,*)lbf,ubf - write(*,*)"want" - write(*,*)llbp,uubp - write(*,*)lbp,ubp,lbpc,ubpc - if(imini.lt.1) write(*,*)"imini = ",imini - if(jmini.lt.1) write(*,*)"jmini = ",jmini - if(kmini.lt.1) write(*,*)"kmini = ",kmini - if(imino.lt.1) write(*,*)"imino = ",imino - if(jmino.lt.1) write(*,*)"jmino = ",jmino - if(kmino.lt.1) write(*,*)"kmino = ",kmino - if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) - if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) - if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) - if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) - if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) - if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) - return - endif -!~~~~~~> prolongation start... - do k = kmino,kmaxo - do j = jmino,jmaxo - do i = imino,imaxo -! change to coarse level reference -!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| -!|x===============x===============x===============x========| - cxI(1) = i - cxI(2) = j - cxI(3) = k - cxI = (cxI+lbf)/2 -! change to array index - cxI = cxI - lbc + 1 - - ii=i+lbf(1)-1 - jj=j+lbf(2)-1 - kk=k+lbf(3)-1 - - if(any(cxI+5 > extc)) write(*,*)"error in prolong" - if(ii/2*2==ii)then - if(jj/2*2==jj)then - if(kk/2*2==kk)then -! due to ghost zone, we can deal with symmetry boundary like this - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - stop - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,5) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= tmp2(:,5) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,5) - endif - tmp1= tmp2(:,5) - funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & - +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) - endif - endif - else - if(jj/2*2==jj)then - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= tmp1(5) - else - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2= ya(:,:,5) - endif - tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & - +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) - funf(i,j,k)= tmp1(5) - endif - else - if(kk/2*2==kk)then - if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then - tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& - +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& - +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& - +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& - +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) - else - cxB=cxI-4 - cxT=cxI+5 - if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then - write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 - return - endif - tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & - +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) - endif - tmp1= tmp2(:,5) - funf(i,j,k)= tmp1(5) - else - funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) - endif - endif - endif - enddo - enddo - enddo - - return - - end subroutine prolong3 -#endif - -#else -#ifndef Cell -#error Not define Vertex nor Cell -#endif -#endif + + +! Because of overlap determination, source region is always larger than target +! region + +#include "macrodef.fh" + +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + +!-------------------------------------------------------------------------- +! +! Prepare the data on coarse level for prolong +! valid for all finite difference order +!-------------------------------------------------------------------------- + + subroutine prolongcopy3(wei,llbc,uubc,extc,func,& + llbf,uubf,exto,funo,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,exto + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func +! both bounds ghost_width + real*8, dimension(exto(1)+2*ghost_width,exto(2)+2*ghost_width,exto(3)+2*ghost_width),intent(out):: funo + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8,dimension(1-ghost_width:extc(1),1-ghost_width:extc(2),1-ghost_width:extc(3)) :: fh + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,cxI + integer :: i,j,k + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolongcopy3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| +! ^ ^ + imini=lbpc(1)-lbc(1) + 1 - ghost_width + imaxi=ubpc(1)-lbc(1) + 1 + ghost_width + jmini=lbpc(2)-lbc(2) + 1 - ghost_width + jmaxi=ubpc(2)-lbc(2) + 1 + ghost_width + kmini=lbpc(3)-lbc(3) + 1 - ghost_width + kmaxi=ubpc(3)-lbc(3) + 1 + ghost_width + + cxI(1) = imaxi-imini+1 + cxI(2) = jmaxi-jmini+1 + cxI(3) = kmaxi-kmini+1 + if(any(cxI.ne.exto+2*ghost_width).or. & + imaxi.gt.extc(1)+1.or.jmaxi.gt.extc(2)+1.or.kmaxi.gt.extc(3)+1)then + write(*,*)"error in prolongationcopy3 for" + if(any(cxI.ne.exto+2*ghost_width))then + write(*,*) cxI,exto+2*ghost_width + return + endif + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + return + endif + +! because some point needs 2*ghost_width +! while some point needs 2*ghost_width-1 +! so we use 0 to fill empty points + if(imini < 1.or.jmini < 1.or.kmini < 1)then + if(imini<1.and.dabs(llbp(1))>CD(1)) write(*,*)"prolongcopy3 warning: ",llbp(1) + if(jmini<1.and.dabs(llbp(2))>CD(2)) write(*,*)"prolongcopy3 warning: ",llbp(2) + if(kmini<1.and.dabs(llbp(3))>CD(3)) write(*,*)"prolongcopy3 warning: ",llbp(3) + call symmetry_bd(ghost_width,extc,func,fh,SoA) + if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then + funo = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + else + funo = 0.d0 + cxI = 0 + if(imaxi>extc(1))then + cxI(1) = 1 + imaxi = extc(1) + endif + if(jmaxi>extc(2))then + cxI(2) = 1 + jmaxi = extc(2) + endif + if(kmaxi>extc(3))then + cxI(3) = 1 + kmaxi = extc(3) + endif + funo(1:exto(1)+2*ghost_width-cxI(1), & + 1:exto(2)+2*ghost_width-cxI(2), & + 1:exto(3)+2*ghost_width-cxI(3)) = fh(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + endif + else + if(imaxi<=extc(1).and.jmaxi<=extc(2).and.kmaxi<=extc(3))then + funo = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + else + funo = 0.d0 + cxI = 0 + if(imaxi>extc(1))then + cxI(1) = 1 + imaxi = extc(1) + endif + if(jmaxi>extc(2))then + cxI(2) = 1 + jmaxi = extc(2) + endif + if(kmaxi>extc(3))then + cxI(3) = 1 + kmaxi = extc(3) + endif + funo(1:exto(1)+2*ghost_width-cxI(1), & + 1:exto(2)+2*ghost_width-cxI(2), & + 1:exto(3)+2*ghost_width-cxI(3)) = func(imini:imaxi,jmini:jmaxi,kmini:kmaxi) + endif + endif + + return + + end subroutine prolongcopy3 +!================================================================================================= +!-------------------------------------------------------------------------- +! +! Prolong data throug mix data of fine and coarse levels +!-------------------------------------------------------------------------- + + subroutine prolongmix3(wei,llbf,uubf,extf,funf,& + llbc,uubc,exti,funi,& + llbp,uubp,SoA,Symmetry, & + illb,iuub) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse fine (real inner points) + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp,illb,iuub + integer,dimension(3), intent(in) :: exti,extf + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout) :: funf +! lower bound ghost_width; upper bound ghost_width-1 + real*8, dimension(exti(1)+2*ghost_width,exti(2)+2*ghost_width,exti(3)+2*ghost_width),intent(in):: funi + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8,dimension(1-ghost_width:extf(1),1-ghost_width:extf(2),1-ghost_width:extf(3)) :: fh + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc,ilb,iub + integer :: i,j,k,n,ii,jj,kk + + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + + real*8,dimension(3) :: CD,FD + integer,dimension(3) :: cxI,cxB,cxT,fg + + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + real*8,dimension(2*ghost_width,2*ghost_width,2*ghost_width) :: ya + real*8,dimension(2*ghost_width) :: X,Y,Z + real*8, dimension(2*ghost_width,2*ghost_width) :: tmp2 + real*8, dimension(2*ghost_width) :: tmp1 + real*8 :: ddy + +#if (ghost_width == 2) + real*8, parameter :: C1=-1.d0/16,C2=9.d0/16 +#elif (ghost_width == 3) + real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 +#elif (ghost_width == 4) + real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 +#elif (ghost_width == 5) + real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 + real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 +#endif + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolongmix3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + FD = (uubf-llbf)/(extf-1) + CD = FD*2.d0 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 + ilb = idint((illb-base)/FD+0.4)+1 + iub = idint((iuub-base)/FD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + +!sanity check +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x===============x===============x| +! ^ ^ +! ghost_width for both sides + lbpc = lbpc - ghost_width + ubpc = ubpc + ghost_width +! index for real inner points + ilb = ilb - lbf+1 + iub = iub - lbf+1 + +! because of domain division by parallelization + ilb = max(ilb,1) + iub = min(iub,extf) + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3))then + write(*,*)"error in prolongmix3 for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)base,FD + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif + + if(Symmetry > NO_SYMM .and. dabs(illb(3)) < FD(3)) ilb(3) = 1-ghost_width + if(Symmetry > EQ_SYMM .and. dabs(illb(1)) < FD(1)) ilb(1) = 1-ghost_width + if(Symmetry > EQ_SYMM .and. dabs(illb(2)) < FD(2)) ilb(2) = 1-ghost_width + + if(any(ilb<1))then + call symmetry_bd(ghost_width,extf,funf,fh,SoA) + else + fh(1:extf(1),1:extf(2),1:extf(3)) = funf + endif + + do k=kmino,kmaxo + do j=jmino,jmaxo + do i=imino,imaxo + cxI(1) = i + cxI(2) = j + cxI(3) = k + +! for fine level we use cxI-ghost_width,....cxI,....cxI+ghost_width-1 + cxB = max(cxI-ghost_width ,ilb) + cxT = min(cxI+ghost_width-1,iub) +! change to coarse level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x===============x===============x| + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbpc + 1 + + ya = funi(cxI(1)-ghost_width+1:cxI(1)+ghost_width,cxI(2)-ghost_width+1:cxI(2)+ghost_width,cxI(3)-ghost_width+1:cxI(3)+ghost_width) + + fg = 0 + if(cxT(1)>=i.and.cxB(1)<=i) fg(1) = 1 + if(cxT(2)>=j.and.cxB(2)<=j) fg(2) = 1 + if(cxT(3)>=k.and.cxB(3)<=k) fg(3) = 1 + + if(cxT(1)>=cxB(1) .and. cxT(2)>=cxB(2) .and. cxT(3)>=cxB(3).and. sum(fg).eq.2)then + if(any(cxB<1-ghost_width).or.any(cxT>extf))then + write(*,*) "error in prolongmix3: " + if(any(cxB<1-ghost_width)) write(*,*) cxB,1-ghost_width + if(any(cxT>extf) ) write(*,*) cxT,extf,iuub,uubf + stop + endif + +! fix the wanted point at (0,0,0), set FD = 1 + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(ii/2*2==ii)then + do n=1,ghost_width + X(ghost_width-n+1) = -1.d0-(n-1)*2 + X(ghost_width+n ) = 1.d0+(n-1)*2 + enddo + else + do n=1,ghost_width + X(ghost_width-n+1) = -(n-1)*2.d0 + X(ghost_width+n ) = n *2.d0 + enddo + endif + + if(jj/2*2==jj)then + do n=1,ghost_width + Y(ghost_width-n+1) = -1.d0-(n-1)*2 + Y(ghost_width+n ) = 1.d0+(n-1)*2 + enddo + else + do n=1,ghost_width + Y(ghost_width-n+1) = -(n-1)*2.d0 + Y(ghost_width+n ) = n *2.d0 + enddo + endif + + if(kk/2*2==kk)then + do n=1,ghost_width + Z(ghost_width-n+1) = -1.d0-(n-1)*2 + Z(ghost_width+n ) = 1.d0+(n-1)*2 + enddo + else + do n=1,ghost_width + Z(ghost_width-n+1) = -(n-1)*2.d0 + Z(ghost_width+n ) = n *2.d0 + enddo + endif + +! i=>(ghost_width,0), i-ghost_width=>(1,1-ghost_width) + do n=cxB(1)+ghost_width-i+1,cxT(1)+ghost_width-i+1 + X(n) = n-ghost_width + enddo + + do n=cxB(2)+ghost_width-j+1,cxT(2)+ghost_width-j+1 + Y(n) = n-ghost_width + enddo + + do n=cxB(3)+ghost_width-k+1,cxT(3)+ghost_width-k+1 + Z(n) = n-ghost_width + enddo + +! because of the mismatch of points for fine level and coarse level +! we have to deal in this way + +! for x direction + if(fg(1) .eq. 0)then + +#if (ghost_width == 2) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) + else + tmp2= ya(:,:,2) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) + else + tmp1= tmp2(:,2) + endif +#elif (ghost_width == 3) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,6))+C2*(ya(:,:,2)+ya(:,:,5))+C3*(ya(:,:,3)+ya(:,:,4)) + else + tmp2= ya(:,:,3) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + else + tmp1= tmp2(:,3) + endif +#elif (ghost_width == 4) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7)) & + +C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + else + tmp2= ya(:,:,4) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7)) & + +C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + else + tmp1= tmp2(:,4) + endif +#elif (ghost_width == 5) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9)) & + +C3*(ya(:,:,3)+ya(:,:,8 ))+C4*(ya(:,:,4)+ya(:,:,7)) & + +C5*(ya(:,:,5)+ya(:,:,6 )) + else + tmp2= ya(:,:,5) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9)) & + +C3*(tmp2(:,3)+tmp2(:,8 ))+C4*(tmp2(:,4)+tmp2(:,7)) & + +C5*(tmp2(:,5)+tmp2(:,6 )) + else + tmp1= tmp2(:,5) + endif +#endif + + tmp1(cxB(1)+ghost_width-i+1:cxT(1)+ghost_width-i+1) = fh(cxB(1):cxT(1),j,k) + + call polint(X,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) + +! for y direction + elseif (fg(2) .eq. 0)then + +#if (ghost_width == 2) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) + else + tmp2= ya(:,:,2) + endif + if(ii/2*2==ii)then + tmp1= C1*(tmp2(1,:)+tmp2(4,:))+C2*(tmp2(2,:)+tmp2(3,:)) + else + tmp1= tmp2(2,:) + endif +#elif (ghost_width == 3) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,6))+C2*(ya(:,:,2)+ya(:,:,5))+C3*(ya(:,:,3)+ya(:,:,4)) + else + tmp2= ya(:,:,3) + endif + if(ii/2*2==ii)then + tmp1= C1*(tmp2(1,:)+tmp2(6,:))+C2*(tmp2(2,:)+tmp2(5,:))+C3*(tmp2(3,:)+tmp2(4,:)) + else + tmp1= tmp2(3,:) + endif +#elif (ghost_width == 4) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7)) & + +C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + else + tmp2= ya(:,:,4) + endif + if(ii/2*2==ii)then + tmp1= C1*(tmp2(1,:)+tmp2(8,:))+C2*(tmp2(2,:)+tmp2(7,:)) & + +C3*(tmp2(3,:)+tmp2(6,:))+C4*(tmp2(4,:)+tmp2(5,:)) + else + tmp1= tmp2(4,:) + endif +#elif (ghost_width == 5) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9)) & + +C3*(ya(:,:,3)+ya(:,:,8 ))+C4*(ya(:,:,4)+ya(:,:,7)) & + +C5*(ya(:,:,5)+ya(:,:,6 )) + else + tmp2= ya(:,:,5) + endif + if(ii/2*2==ii)then + tmp1= C1*(tmp2(1,:)+tmp2(10,:))+C2*(tmp2(2,:)+tmp2(9,:)) & + +C3*(tmp2(3,:)+tmp2(8 ,:))+C4*(tmp2(4,:)+tmp2(7,:)) & + +C5*(tmp2(5,:)+tmp2(6 ,:)) + else + tmp1= tmp2(5,:) + endif +#endif + + tmp1(cxB(2)+ghost_width-j+1:cxT(2)+ghost_width-j+1) = fh(i,cxB(2):cxT(2),k) + + call polint(Y,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) + +! for z direction + else + +#if (ghost_width == 2) + if(ii/2*2==ii)then + tmp2= C1*(ya(1,:,:)+ya(4,:,:))+C2*(ya(2,:,:)+ya(3,:,:)) + else + tmp2= ya(2,:,:) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(1,:)+tmp2(4,:))+C2*(tmp2(2,:)+tmp2(3,:)) + else + tmp1= tmp2(2,:) + endif +#elif (ghost_width == 3) + if(ii/2*2==ii)then + tmp2= C1*(ya(1,:,:)+ya(6,:,:))+C2*(ya(6,:,:)+ya(5,:,:))+C3*(ya(3,:,:)+ya(4,:,:)) + else + tmp2= ya(3,:,:) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(1,:)+tmp2(6,:))+C2*(tmp2(2,:)+tmp2(5,:))+C3*(tmp2(3,:)+tmp2(4,:)) + else + tmp1= tmp2(3,:) + endif +#elif (ghost_width == 4) + if(ii/2*2==ii)then + tmp2= C1*(ya(1,:,:)+ya(8,:,:))+C2*(ya(2,:,:)+ya(7,:,:)) & + +C3*(ya(3,:,:)+ya(6,:,:))+C4*(ya(4,:,:)+ya(5,:,:)) + else + tmp2= ya(4,:,:) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(1,:)+tmp2(8,:))+C2*(tmp2(2,:)+tmp2(7,:)) & + +C3*(tmp2(3,:)+tmp2(6,:))+C4*(tmp2(4,:)+tmp2(5,:)) + else + tmp1= tmp2(4,:) + endif +#elif (ghost_width == 5) + if(ii/2*2==ii)then + tmp2= C1*(ya(1,:,:)+ya(10,:,:))+C2*(ya(2,:,:)+ya(9,:,:)) & + +C3*(ya(3,:,:)+ya(8 ,:,:))+C4*(ya(4,:,:)+ya(7,:,:)) & + +C5*(ya(5,:,:)+ya(6 ,:,:)) + else + tmp2= ya(5,:,:) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(1,:)+tmp2(10,:))+C2*(tmp2(2,:)+tmp2(9,:)) & + +C3*(tmp2(3,:)+tmp2(8 ,:))+C4*(tmp2(4,:)+tmp2(7,:)) & + +C5*(tmp2(5,:)+tmp2(6 ,:)) + else + tmp1= tmp2(5,:) + endif +#endif + + tmp1(cxB(3)+ghost_width-k+1:cxT(3)+ghost_width-k+1) = fh(i,j,cxB(3):cxT(3)) + + call polint(Z,tmp1,0.d0,funf(i,j,k),ddy,2*ghost_width) + + endif + + else + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + +#if (ghost_width == 2) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,4))+C2*(ya(:,:,2)+ya(:,:,3)) + else + tmp2= ya(:,:,2) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,4))+C2*(tmp2(:,2)+tmp2(:,3)) + else + tmp1= tmp2(:,2) + endif + if(ii/2*2==ii)then + funf(i,j,k)= C1*(tmp1(1)+tmp1(4))+C2*(tmp1(2)+tmp1(3)) + else + funf(i,j,k)= tmp1(2) + endif +#elif (ghost_width == 3) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,6))+C2*(ya(:,:,2)+ya(:,:,5))+C3*(ya(:,:,3)+ya(:,:,4)) + else + tmp2= ya(:,:,3) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + else + tmp1= tmp2(:,3) + endif + if(ii/2*2==ii)then + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + else + funf(i,j,k)= tmp1(3) + endif +#elif (ghost_width == 4) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7)) & + +C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + else + tmp2= ya(:,:,4) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7)) & + +C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + else + tmp1= tmp2(:,4) + endif + if(ii/2*2==ii)then + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7)) & + +C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + else + funf(i,j,k)= tmp1(4) + endif +#elif (ghost_width == 5) + if(kk/2*2==kk)then + tmp2= C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9)) & + +C3*(ya(:,:,3)+ya(:,:,8 ))+C4*(ya(:,:,4)+ya(:,:,7)) & + +C5*(ya(:,:,5)+ya(:,:,6 )) + else + tmp2= ya(:,:,5) + endif + if(jj/2*2==jj)then + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9)) & + +C3*(tmp2(:,3)+tmp2(:,8 ))+C4*(tmp2(:,4)+tmp2(:,7)) & + +C5*(tmp2(:,5)+tmp2(:,6 )) + else + tmp1= tmp2(:,5) + endif + if(ii/2*2==ii)then + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9)) & + +C3*(tmp1(3)+tmp1(8 ))+C4*(tmp1(4)+tmp1(7)) & + +C5*(tmp1(5)+tmp1(6 )) + else + funf(i,j,k)= tmp1(5) + endif +#endif + endif + + enddo + enddo + enddo + + return + + end subroutine prolongmix3 +!/////////////////////////////////////////////////////////////////////////////////////////////// +!-------------------------------------------------------------------------------------- +! +! Restrict from finner grids to coarser grids ignore the boundary point +! this routine is valid for all orders finite difference +! +! 1 2 3 4 +! *---*---*---* +! ^ +! COPY directly! +!-------------------------------------------------------------------------------------- + + subroutine restrict3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbr,uubr,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbr,uubr + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(inout):: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(in):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbr,ubr,lbrf,ubrf + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + real*8, parameter :: C1=-1.d0/1.6d1,C2=9.d0/1.6d1 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::restrict3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif +! it's possible a iolated point for target but not for source + FD = (uubf-llbf)/(extf-1) + CD = 2*FD + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbr = idint((llbr-base)/CD+0.4)+1 + lbrf = idint((llbr-base)/FD+0.4)+1 + ubr = idint((uubr-base)/CD+0.4)+1 + ubrf = idint((uubr-base)/FD+0.4)+1 + +!sanity check + imino=lbr(1)-lbc(1) + 1 + imaxo=ubr(1)-lbc(1) + 1 + jmino=lbr(2)-lbc(2) + 1 + jmaxo=ubr(2)-lbc(2) + 1 + kmino=lbr(3)-lbc(3) + 1 + kmaxo=ubr(3)-lbc(3) + 1 + + imini=lbrf(1)-lbf(1) + 1 + imaxi=ubrf(1)-lbf(1) + 1 + jmini=lbrf(2)-lbf(2) + 1 + jmaxi=ubrf(2)-lbf(2) + 1 + kmini=lbrf(3)-lbf(3) + 1 + kmaxi=ubrf(3)-lbf(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extc(1).or.jmaxo.gt.extc(2).or.kmaxo.gt.extc(3).or.& + imaxi.gt.extf(1).or.jmaxi.gt.extf(2).or.kmaxi.gt.extf(3))then + write(*,*)"error in restrict for" + write(*,*)"mino = ",imino,jmino,kmino + write(*,*)"maxo = ",imaxo,jmaxo,kmaxo + write(*,*)"extc = ",extc + write(*,*)"CD = ",CD + write(*,*)"mini = ",imini,jmini,kmini + write(*,*)"maxi = ",imaxi,jmaxi,kmaxi + write(*,*)"extf = ",extf + write(*,*)"FD = ",FD + write(*,*)"from" + write(*,*)lbf,ubf,extf + write(*,*)"to" + write(*,*)lbc,ubc,extc + write(*,*)"want" + write(*,*)lbr,ubr,lbrf,ubrf + write(*,*)"llbf = ",llbf + write(*,*)"uubf = ",uubf + write(*,*)"llbc = ",llbc + write(*,*)"uubc = ",uubc + write(*,*)"llbr = ",llbr + write(*,*)"uubr = ",uubr + stop + endif + +!~~~~~~> restriction start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo + + cxI(1) = i + cxI(2) = j + cxI(3) = k +! change to fine level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| + cxI = 2*(cxI+lbc-1) - 1 +! change to array index + cxI = cxI - lbf + 1 + + func(i,j,k)= funf(cxI(1),cxI(2),cxI(3)) + enddo + enddo + enddo + + return + + end subroutine restrict3 +!=========================================================================================== + +! for different finite differnce order +#if (ghost_width == 2) +! 2nd order +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 4 points, 3rd order interpolation +! 1 2 3 4 +! *---*---*---* +! ^ +! f=-1/16*f_1 + 9/16*f_2 +! -1/16*f_4 + 9/16*f_3 +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(4,4,4) :: ya + real*8, dimension(4,4) :: tmp2 + real*8, dimension(4) :: tmp1 + + real*8, parameter :: C1=-1.d0/16,C2=9.d0/16 + real*8, parameter :: C4=C1,C3=C2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-1.or.jmaxi.gt.extc(2)-1.or.kmaxi.gt.extc(3)-1)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| +! if(i/2*2 == i)then +! cxI(1) = (i+lbf(1)-1)/2 +! else +! cxI(1) = (i+lbf(1)-1)/2+1 +! endif +! if(j/2*2 == j)then +! cxI(2) = (j+lbf(2)-1)/2 +! else +! cxI(2) = (j+lbf(2)-1)/2+1 +! endif +! if(k/2*2 == k)then +! cxI(3) = (k+lbf(3)-1)/2 +! else +! cxI(3) = (k+lbf(3)-1)/2+1 +! endif +! above code segment is equivalent to + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+2 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,2) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= tmp2(:,2) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,2) + endif + tmp1= tmp2(:,2) + funf(i,j,k)= C1*tmp1(1)+C2*tmp1(2)+C3*tmp1(3)+C4*tmp1(4) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= tmp1(2) + else + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,2) + endif + tmp1= C1*tmp2(:,1)+C2*tmp2(:,2)+C3*tmp2(:,3)+C4*tmp2(:,4) + funf(i,j,k)= tmp1(2) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>1.and.cxI(2)>1.and.cxI(3)>1)then + tmp2= C1*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)-1)+& + C2*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3) )+& + C3*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+1)+& + C4*func(cxI(1)-1:cxI(1)+2,cxI(2)-1:cxI(2)+2,cxI(3)+2) + else + cxB=cxI-1 + cxT=cxI+2 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,4,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= C1*ya(:,:,1)+C2*ya(:,:,2)+C3*ya(:,:,3)+C4*ya(:,:,4) + endif + tmp1= tmp2(:,2) + funf(i,j,k)= tmp1(2) + else + funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#elif (ghost_width == 3) +! fourth order code +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 6 points, 5th order interpolation +! 1 2 3 4 5 6 +! *---*---*---*---*---* +! ^ +! f=3/256*(f_1+f_6) - 25/256*(f_2+f_5) + 75/128*(f_3+f_4) +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(6,6) :: tmp2 + real*8, dimension(6) :: tmp1 + + real*8, parameter :: C1=3.d0/2.56d2,C2=-2.5d1/2.56d2,C3=7.5d1/1.28d2 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + real*8, dimension(-1:extc(1),-1:extc(2),-1:extc(3)) :: funcc + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-2.or.jmaxi.gt.extc(2)-2.or.kmaxi.gt.extc(3)-2)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif + + call symmetry_bd(2,extc,func,funcc,SoA) + +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference v +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x===============x===============x| + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+3 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + else + tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + endif + else + if(kk/2*2==kk)then + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= tmp2(:,3) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + else + tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) + tmp1= tmp2(:,3) + funf(i,j,k)= C1*(tmp1(1)+tmp1(6))+C2*(tmp1(2)+tmp1(5))+C3*(tmp1(3)+tmp1(4)) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= tmp1(3) + else + tmp2= funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)) + tmp1= C1*(tmp2(:,1)+tmp2(:,6))+C2*(tmp2(:,2)+tmp2(:,5))+C3*(tmp2(:,3)+tmp2(:,4)) + funf(i,j,k)= tmp1(3) + endif + else + if(kk/2*2==kk)then + tmp2= C1*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-2)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+3))& + +C2*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)-1)+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+2))& + +C3*(funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3) )+funcc(cxI(1)-2:cxI(1)+3,cxI(2)-2:cxI(2)+3,cxI(3)+1)) + tmp1= tmp2(:,3) + funf(i,j,k)= tmp1(3) + else + funf(i,j,k)= funcc(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#elif (ghost_width == 4) +! sixth order code +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 8 points, 7th order interpolation +! 1 2 3 4 5 6 7 8 +! *---*---*---*---*---*---*---* +! ^ +! f=-5/2048*(f_1+f_8) + 49/2048*(f_2+f_7) - 245/2048*(f_3+f_6) + 1225/2048*(f_4+f_5) +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(8,8,8) :: ya + real*8, dimension(8,8) :: tmp2 + real*8, dimension(8) :: tmp1 + + real*8, parameter :: C1=-5.d0/2.048d3,C2=4.9d1/2.048d3,C3=-2.45d2/2.048d3,C4=1.225d3/2.048d3 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-3.or.jmaxi.gt.extc(2)-3.or.kmaxi.gt.extc(3)-3)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference v +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x===============x===============x===============x===============x| + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+4 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= ya(:,:,4) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= tmp2(:,4) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= ya(:,:,4) + endif + tmp1= tmp2(:,4) + funf(i,j,k)= C1*(tmp1(1)+tmp1(8))+C2*(tmp1(2)+tmp1(7))+C3*(tmp1(3)+tmp1(6))+C4*(tmp1(4)+tmp1(5)) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= tmp1(4) + else + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2= ya(:,:,4) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,8))+C2*(tmp2(:,2)+tmp2(:,7))+C3*(tmp2(:,3)+tmp2(:,6))+C4*(tmp2(:,4)+tmp2(:,5)) + funf(i,j,k)= tmp1(4) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>3.and.cxI(2)>3.and.cxI(3)>3)then + tmp2= C1*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-3)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+4))& + +C2*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-2)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+3))& + +C3*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)-1)+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+2))& + +C4*(func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3) )+func(cxI(1)-3:cxI(1)+4,cxI(2)-3:cxI(2)+4,cxI(3)+1)) + else + cxB=cxI-3 + cxT=cxI+4 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,8,Symmetry))then + write(*,*)"prolong3 position: " + write(*,*)llbf(1)+(i-1)*FD(1),llbf(2)+(j-1)*FD(2),llbf(3)+(k-1)*FD(3) + write(*,*)"llbf = ",llbf + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,8))+C2*(ya(:,:,2)+ya(:,:,7))+C3*(ya(:,:,3)+ya(:,:,6))+C4*(ya(:,:,4)+ya(:,:,5)) + endif + tmp1= tmp2(:,4) + funf(i,j,k)= tmp1(4) + else + funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 + +#elif (ghost_width == 5) +! eighth order code +!-------------------------------------------------------------------------- +! +! Prolongation from coarser grids to finer grids +! 10 points, 9th order interpolation +! 1 2 3 4 5 6 7 8 9 10 +! *---*---*---*---*---*---*---*---*---* +! ^ +! f=35/65536(f_1+f_10)-405/65536*(f_2+f_9) + 567/16384*(f_3+f_8) - 2205/16384*(f_4+f_7) + 19845/32768*(f_5+f_6) +!-------------------------------------------------------------------------- + + subroutine prolong3(wei,llbc,uubc,extc,func,& + llbf,uubf,extf,funf,& + llbp,uubp,SoA,Symmetry) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: wei +! coarse fine coarse + real*8,dimension(3), intent(in) :: llbc,uubc,llbf,uubf,llbp,uubp + integer,dimension(3), intent(in) :: extc,extf + real*8, dimension(extc(1),extc(2),extc(3)),intent(in) :: func + real*8, dimension(extf(1),extf(2),extf(3)),intent(inout):: funf + real*8, dimension(1:3), intent(in) :: SoA + integer,intent(in)::Symmetry + +!~~~~~~> local variables + + real*8, dimension(1:3) :: base + integer,dimension(3) :: lbc,ubc,lbf,ubf,lbp,ubp,lbpc,ubpc + integer,dimension(3) :: cxB,cxT,cxI + integer :: i,j,k,ii,jj,kk + real*8, dimension(10,10,10) :: ya + real*8, dimension(10,10) :: tmp2 + real*8, dimension(10) :: tmp1 + + real*8, parameter :: C1=3.5d1/6.5536d4,C2=-4.05d2/6.5536d4,C3=5.67d2/1.6384d4 + real*8, parameter :: C4=-2.205d3/1.6384d4,C5=1.9845d4/3.2768d4 + + integer::imini,imaxi,jmini,jmaxi,kmini,kmaxi + integer::imino,imaxo,jmino,jmaxo,kmino,kmaxo + logical::decide3d + + real*8,dimension(3) :: CD,FD + + if(wei.ne.3)then + write(*,*)"prolongrestrict.f90::prolong3: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +! it's possible a iolated point for target but not for source + CD = (uubc-llbc)/(extc-1) + FD = CD/2 + +!take care the mismatch of the two segments of grid + do i=1,3 + if(llbc(i) <= llbf(i))then + base(i) = llbc(i) + else + j=idint((llbc(i)-llbf(i))/FD(i)+0.4) + if(j/2*2 == j)then + base(i) = llbf(i) + else + base(i) = llbf(i) - CD(i)/2 + endif + endif + enddo + +!!! function idint: +!If A is of type REAL and |A| < 1, INT(A) equals 0. If |A| \geq 1, +!then INT(A) equals the largest integer that does not exceed the range of A +!and whose sign is the same as the sign of A. + + lbf = idint((llbf-base)/FD+0.4)+1 + ubf = idint((uubf-base)/FD+0.4)+1 + lbc = idint((llbc-base)/CD+0.4)+1 + ubc = idint((uubc-base)/CD+0.4)+1 + lbp = idint((llbp-base)/FD+0.4)+1 + lbpc = idint((llbp-base)/CD+0.4)+1 + ubp = idint((uubp-base)/FD+0.4)+1 + ubpc = idint((uubp-base)/CD+0.4)+1 +!sanity check + imino=lbp(1)-lbf(1) + 1 + imaxo=ubp(1)-lbf(1) + 1 + jmino=lbp(2)-lbf(2) + 1 + jmaxo=ubp(2)-lbf(2) + 1 + kmino=lbp(3)-lbf(3) + 1 + kmaxo=ubp(3)-lbf(3) + 1 + + imini=lbpc(1)-lbc(1) + 1 + imaxi=ubpc(1)-lbc(1) + 1 + jmini=lbpc(2)-lbc(2) + 1 + jmaxi=ubpc(2)-lbc(2) + 1 + kmini=lbpc(3)-lbc(3) + 1 + kmaxi=ubpc(3)-lbc(3) + 1 + + if(imino.lt.1.or.jmino.lt.1.or.kmino.lt.1.or.& + imini.lt.1.or.jmini.lt.1.or.kmini.lt.1.or.& + imaxo.gt.extf(1).or.jmaxo.gt.extf(2).or.kmaxo.gt.extf(3).or.& + imaxi.gt.extc(1)-4.or.jmaxi.gt.extc(2)-4.or.kmaxi.gt.extc(3)-4)then + write(*,*)"error in prolongation for" + write(*,*)"from" + write(*,*)llbc,uubc + write(*,*)lbc,ubc + write(*,*)"to" + write(*,*)llbf,uubf + write(*,*)lbf,ubf + write(*,*)"want" + write(*,*)llbp,uubp + write(*,*)lbp,ubp,lbpc,ubpc + if(imini.lt.1) write(*,*)"imini = ",imini + if(jmini.lt.1) write(*,*)"jmini = ",jmini + if(kmini.lt.1) write(*,*)"kmini = ",kmini + if(imino.lt.1) write(*,*)"imino = ",imino + if(jmino.lt.1) write(*,*)"jmino = ",jmino + if(kmino.lt.1) write(*,*)"kmino = ",kmino + if(imaxi.gt.extc(1)) write(*,*)"imaxi = ",imaxi,"extc(1) = ",extc(1) + if(jmaxi.gt.extc(2)) write(*,*)"jmaxi = ",jmaxi,"extc(2) = ",extc(2) + if(kmaxi.gt.extc(3)) write(*,*)"kmaxi = ",kmaxi,"extc(3) = ",extc(3) + if(imaxo.gt.extf(1)) write(*,*)"imaxo = ",imaxo,"extf(1) = ",extf(1) + if(jmaxo.gt.extf(2)) write(*,*)"jmaxo = ",jmaxo,"extf(2) = ",extf(2) + if(kmaxo.gt.extf(3)) write(*,*)"kmaxo = ",kmaxo,"extf(3) = ",extf(3) + return + endif +!~~~~~~> prolongation start... + do k = kmino,kmaxo + do j = jmino,jmaxo + do i = imino,imaxo +! change to coarse level reference +!|*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*--- ---*| +!|x===============x===============x===============x========| + cxI(1) = i + cxI(2) = j + cxI(3) = k + cxI = (cxI+lbf)/2 +! change to array index + cxI = cxI - lbc + 1 + + ii=i+lbf(1)-1 + jj=j+lbf(2)-1 + kk=k+lbf(3)-1 + + if(any(cxI+5 > extc)) write(*,*)"error in prolong" + if(ii/2*2==ii)then + if(jj/2*2==jj)then + if(kk/2*2==kk)then +! due to ghost zone, we can deal with symmetry boundary like this + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + stop + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,5) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= tmp2(:,5) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,5) + endif + tmp1= tmp2(:,5) + funf(i,j,k)= C1*(tmp1(1)+tmp1(10))+C2*(tmp1(2)+tmp1(9))+C3*(tmp1(3)+tmp1(8)) & + +C4*(tmp1(4)+tmp1( 7))+C5*(tmp1(5)+tmp1(6)) + endif + endif + else + if(jj/2*2==jj)then + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= tmp1(5) + else + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2= ya(:,:,5) + endif + tmp1= C1*(tmp2(:,1)+tmp2(:,10))+C2*(tmp2(:,2)+tmp2(:,9))+C3*(tmp2(:,3)+tmp2(:,8)) & + +C4*(tmp2(:,4)+tmp2(:, 7))+C5*(tmp2(:,5)+tmp2(:,6)) + funf(i,j,k)= tmp1(5) + endif + else + if(kk/2*2==kk)then + if(cxI(1)>4.and.cxI(2)>4.and.cxI(3)>4)then + tmp2= C1*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-4)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+5))& + +C2*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-3)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+4))& + +C3*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-2)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+3))& + +C4*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)-1)+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+2))& + +C5*(func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3) )+func(cxI(1)-4:cxI(1)+5,cxI(2)-4:cxI(2)+5,cxI(3)+1)) + else + cxB=cxI-4 + cxT=cxI+5 + if(decide3d(extc,func,func,cxB,cxT,SoA,ya,10,Symmetry))then + write(*,*)"prolong3 position index: ",i+lbf(1)-1,j+lbf(2)-1,k+lbf(3)-1 + return + endif + tmp2=C1*(ya(:,:,1)+ya(:,:,10))+C2*(ya(:,:,2)+ya(:,:,9))+C3*(ya(:,:,3)+ya(:,:,8)) & + +C4*(ya(:,:,4)+ya(:,:, 7))+C5*(ya(:,:,5)+ya(:,:,6)) + endif + tmp1= tmp2(:,5) + funf(i,j,k)= tmp1(5) + else + funf(i,j,k)= func(cxI(1),cxI(2),cxI(3)) + endif + endif + endif + enddo + enddo + enddo + + return + + end subroutine prolong3 +#endif + +#else +#ifndef Cell +#error Not define Vertex nor Cell +#endif +#endif diff --git a/AMSS_NCKU_source/sommerfeld_rout.f90 b/AMSS_NCKU_source/BSSN/sommerfeld_rout.f90 similarity index 96% rename from AMSS_NCKU_source/sommerfeld_rout.f90 rename to AMSS_NCKU_source/BSSN/sommerfeld_rout.f90 index 5bd8361..f072fe4 100644 --- a/AMSS_NCKU_source/sommerfeld_rout.f90 +++ b/AMSS_NCKU_source/BSSN/sommerfeld_rout.f90 @@ -1,647 +1,647 @@ - - -#include "macrodef.fh" - -! Update outer boundaries with Sommerfeld boundary condition -! -!----------------------------------------------------------------------------- -!5th order interpolation - subroutine sommerfeld_rout(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,dT,chi0,& - Lap0,f0,f,SoA,Symmetry,precor) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,precor - real*8, dimension(ex(1)) :: X - real*8, dimension(ex(2)) :: Y - real*8, dimension(ex(3)) :: Z - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,dT - real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::chi0,Lap0,f0 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f - real*8, dimension(3),intent(in) ::SoA -!~~~~~~> Other variables: - real*8 :: dX,dY,dZ,r,fac - integer :: i, j, k,m - logical :: gont,nouse - integer,dimension(3) :: cxB,cxT - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer,parameter::ordn = 6, CORRECTSTEP=1 - real*8 :: ddy - real*8, dimension(1:ordn) :: xa - real*8, dimension(1:3) :: cx - real*8, dimension(1:ordn,1:ordn,1:ordn) :: ya - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, SYM = 1.d0, ANT = -1.d0 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 -!~~~~~~> Interface - - interface - - function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont) - implicit none - - integer, intent(in) :: ORDN,Symmetry - integer,dimension(1:3) , intent(in) :: ex,cxB,cxT - real*8, dimension(1:3) , intent(in) :: SoA - real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi - real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya - logical::gont - end function decide3d - - end interface - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(X(ex(1))-xmax) < dX)then - layer(1,1) = ex(1) - layer(2,1) = 1 - layer(3,1) = 1 - layer(4,1) = ex(1) - layer(5,1) = ex(2) - layer(6,1) = ex(3) -endif - -if(dabs(Y(ex(2))-ymax) < dY)then - layer(1,2) = 1 - layer(2,2) = ex(2) - layer(3,2) = 1 - layer(4,2) = ex(1) - layer(5,2) = ex(2) - layer(6,2) = ex(3) -endif - - -if(dabs(Z(ex(3))-zmax) < dZ)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(3,3) = ex(3) - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(6,3) = ex(3) -endif -! lower boundary but not symmetry boundary -if(dabs(X(1)-xmin) < dX .and. (.not.(Symmetry==OCTANT.and.dabs(xmin)NO_SYMM.and.dabs(zmin) boundary calculations start... - if( precor == CORRECTSTEP ) then - - do gp = 1, 6, 1 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp), 1 - do j = layer(2,gp), layer(5,gp), 1 - do i = layer(1,gp), layer(4,gp), 1 - - f(i,j,k) = f0(i,j,k) - - enddo - enddo - enddo - endif - enddo - - else - - do gp = 1, 6 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -! tc/sc*dT/r - r = (Lap0(i,j,k) + ONE)*dsqrt(ONE+chi0(i,j,k))*dT/dsqrt(X(i)**2+Y(j)**2+Z(k)**2) - fac=ONE-r - cx(1) = r*X(i)/dX - cx(2) = r*Y(j)/dY - cx(3) = r*Z(k)/dZ - if(cx(1)>ZEO)then - cxB(1) = i-dint(cx(1))-ordn/2 - else - cxB(1) = i-dint(cx(1))-ordn/2+1 - endif - if(cx(2)>ZEO)then - cxB(2) = j-dint(cx(2))-ordn/2 - else - cxB(2) = j-dint(cx(2))-ordn/2+1 - endif - if(cx(3)>ZEO)then - cxB(3) = k-dint(cx(3))-ordn/2 - else - cxB(3) = k-dint(cx(3))-ordn/2+1 - endif - - where(cx>ZEO) - cx = dint(cx)-cx+ordn/2 - elsewhere - cx = dint(cx)-cx+ordn/2-1 - end where - - cxT = cxB+ordn-1 - - if(Symmetry==NO_SYMM.and.cxB(3)<1)then - cx(3)=cx(3)+(cxB(3)-1) - cxT(3)=cxT(3)-(cxB(3)-1) - cxB(3)=1 - endif - if(Symmetryex(m))then - cx(m)=cx(m)+(cxT(m)-ex(m)) - cxB(m)=cxB(m)-(cxT(m)-ex(m)) - cxT(m)=ex(m) - endif - enddo - -!~~~~~~> Interpolate - nouse=decide3d(ex,f0,f0,cxB,cxT,SoA,ya,ordn,Symmetry) - call polin3(xa,xa,xa,ya,cx(1),cx(2),cx(3),r,ddy,ordn) - f(i,j,k)=r*fac - - enddo - enddo - enddo - endif - enddo - - endif - - return - - end subroutine sommerfeld_rout -!sommerfeld condition following BAM code - subroutine sommerfeld_routbam(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f_rhs,& - f0,velocity,SoA,Symmetry) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry - real*8, intent(in) :: velocity - real*8, dimension(ex(1)) :: X - real*8, dimension(ex(2)) :: Y - real*8, dimension(ex(3)) :: Z - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::f0 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f_rhs - real*8,dimension(3),intent(in) ::SoA -!~~~~~~> Other variables: - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - logical :: gont - real*8 :: dX,dY,dZ,R - integer :: i, j, k - real*8 :: d2dx,d2dy,d2dz - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: fx,fy,fz - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - - real*8 :: wx,wy,wz - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - call symmetry_bd(1,ex,f0,fh,SoA) - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(X(ex(1))-xmax) < dX)then - layer(1,1) = ex(1) - layer(2,1) = 1 - layer(3,1) = 1 - layer(4,1) = ex(1) - layer(5,1) = ex(2) - layer(6,1) = ex(3) -endif - -if(dabs(Y(ex(2))-ymax) < dY)then - layer(1,2) = 1 - layer(2,2) = ex(2) - layer(3,2) = 1 - layer(4,2) = ex(1) - layer(5,2) = ex(2) - layer(6,2) = ex(3) -endif - -if(dabs(Z(ex(3))-zmax) < dZ)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(3,3) = ex(3) - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(6,3) = ex(3) -endif -! lower boundary but not symmetry boundary -if(dabs(X(1)-xmin) < dX .and. (.not.(Symmetry==OCTANT.and.dabs(xmin)NO_SYMM.and.dabs(zmin)= imin)then - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx=(-fh(i,j,k)+fh(i+1,j,k))/dX - - elseif(i==imax)then - fx=(-fh(i-1,j,k)+fh(i,j,k))/dX - - endif -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy=(-fh(i,j,k)+fh(i,j+1,k))/dY - - elseif(j==jmax)then - fy=(-fh(i,j-1,k)+fh(i,j,k))/dY - - endif -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz=(-fh(i,j,k)+fh(i,j,k+1))/dZ - - elseif(k==kmax)then - fz=(-fh(i,j,k-1)+fh(i,j,k))/dZ - - endif - - R = dsqrt(X(i)**2+Y(j)**2+Z(k)**2) - f_rhs(i,j,k) = -velocity*(fx*X(i) + fy*Y(j) + fz*Z(k) + f0(i,j,k))/R -#else -!! new code, 2012dec26, based on bam -!! we always assume var0 = 0 - R = dsqrt(X(i)**2+Y(j)**2+Z(k)**2) - wx = velocity*X(i)/R - wy = velocity*Y(j)/R - wz = velocity*Z(k)/R - if(wx > 0)then - if(i-2>=imin)then - fx = d2dx*(3*fh(i,j,k)-4*fh(i-1,j,k)+fh(i-2,j,k)) - elseif(i-1>=imin)then - fx = d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - else - fx = d2dx*(-fh(i+2,j,k)+4*fh(i+1,j,k)-3*fh(i,j,k)) - endif - elseif(wx < 0)then - if(i+2<=imax)then - fx = d2dx*(-fh(i+2,j,k)+4*fh(i+1,j,k)-3*fh(i,j,k)) - elseif(i+1<=imax)then - fx = d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - else - fx = d2dx*(3*fh(i,j,k)-4*fh(i-1,j,k)+fh(i-2,j,k)) - endif - endif - - if(wy > 0)then - if(j-2>=jmin)then - fy = d2dy*(3*fh(i,j,k)-4*fh(i,j-1,k)+fh(i,j-2,k)) - elseif(j-1>=jmin)then - fy = d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - else - fy = d2dy*(-fh(i,j+2,k)+4*fh(i,j+1,k)-3*fh(i,j,k)) - endif - elseif(wy < 0)then - if(j+2<=jmax)then - fy = d2dy*(-fh(i,j+2,k)+4*fh(i,j+1,k)-3*fh(i,j,k)) - elseif(j+1<=jmax)then - fy = d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - else - fy = d2dy*(3*fh(i,j,k)-4*fh(i,j-1,k)+fh(i,j-2,k)) - endif - endif - - if(wz > 0)then - if(k-2>=kmin)then - fz = d2dz*(3*fh(i,j,k)-4*fh(i,j,k-1)+fh(i,j,k-2)) - elseif(k-1>=kmin)then - fz = d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - else - fz = d2dz*(-fh(i,j,k+2)+4*fh(i,j,k+1)-3*fh(i,j,k)) - endif - elseif(wz < 0)then - if(k+2<=kmax)then - fz = d2dz*(-fh(i,j,k+2)+4*fh(i,j,k+1)-3*fh(i,j,k)) - elseif(k+1<=kmax)then - fz = d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - else - fz = d2dz*(3*fh(i,j,k)-4*fh(i,j,k-1)+fh(i,j,k-2)) - endif - endif - - f_rhs(i,j,k) = -velocity*(fx*X(i) + fy*Y(j) + fz*Z(k) + f0(i,j,k))/R -#endif - enddo - enddo - enddo - endif - enddo - - return - - end subroutine sommerfeld_routbam -!sommerfeld condition following BAM code for shell - subroutine sommerfeld_routbam_ss(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f_rhs,& - f0,velocity,SoA,Symmetry) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry - real*8, intent(in) :: velocity - real*8, dimension(ex(1)) :: X - real*8, dimension(ex(2)) :: Y -! Z-> R - real*8, dimension(ex(3)) :: Z - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::f0 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f_rhs - real*8,dimension(3),intent(in) ::SoA -!~~~~~~> Other variables: - logical :: gont - real*8 :: dZ - integer :: i, j, k - real*8 :: d2dz - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8 :: fz - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - - dZ = Z(2) - Z(1) - - d2dz = ONE/TWO/dZ - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(Z(ex(3))-zmax) < dZ)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) -#if 1 -! do not consider buffer points near boundary - layer(3,3) = ex(3) - layer(6,3) = ex(3) -#else -! consider buffer points near boundary - layer(3,3) = ex(3) - ghost_width - layer(6,3) = ex(3) - ghost_width -#endif -endif - -if(dabs(Z(1)-zmin) < dZ)then - layer(1,6) = 1 - layer(2,6) = 1 - layer(3,6) = 1 - layer(4,6) = ex(1) - layer(5,6) = ex(2) - layer(6,6) = 1 -endif - -! outgoing BD - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -#if 0 -!! old code -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - fz=d2dz*(-f0(i,j,k-1)+f0(i,j,k+1)) - - elseif(k==kmin)then - fz=(-f0(i,j,k)+f0(i,j,k+1))/dZ - - elseif(k==kmax)then - fz=(-f0(i,j,k-1)+f0(i,j,k))/dZ - - endif -#else -!! new code, 2012dec16, based on bam - if(velocity > 0)then - if(k-2>=kmin)then - fz = d2dz*(3*f0(i,j,k)-4*f0(i,j,k-1)+f0(i,j,k-2)) - elseif(k-1>=kmin)then - fz = d2dz*(-f0(i,j,k-1)+f0(i,j,k+1)) - else - fz = d2dz*(-f0(i,j,k+2)+4*f0(i,j,k+1)-3*f0(i,j,k)) - endif - elseif(velocity < 0)then - if(k+2<=kmax)then - fz = d2dz*(-f0(i,j,k+2)+4*f0(i,j,k+1)-3*f0(i,j,k)) - elseif(k+1<=kmax)then - fz = d2dz*(-f0(i,j,k-1)+f0(i,j,k+1)) - else - fz = d2dz*(3*f0(i,j,k)-4*f0(i,j,k-1)+f0(i,j,k-2)) - endif - endif -#endif - f_rhs(i,j,k) = -velocity*(fz+f0(i,j,k)/Z(k)) - enddo - enddo - enddo - endif - -! fix BD - gp = 6 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -! z direction - f_rhs(i,j,k) = ZEO - enddo - enddo - enddo - endif - - return - - end subroutine sommerfeld_routbam_ss -! falloff boundary condition - subroutine falloff_ss(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f,n,SoA,Symmetry) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,n - real*8, dimension(ex(1)) :: X - real*8, dimension(ex(2)) :: Y -! Z-> R - real*8, dimension(ex(3)) :: Z - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f - real*8,dimension(3),intent(in) ::SoA -!~~~~~~> Other variables: - logical :: gont - real*8 :: dZ - integer :: i, j, k - real*8 :: d2dz - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8 :: fz - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - - dZ = Z(2) - Z(1) - - d2dz = ONE/TWO/dZ - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(Z(ex(3))-zmax) < dZ)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(3,3) = ex(3) - layer(6,3) = ex(3) -endif - -! falloff BD - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -! z direction - f(i,j,k) = f(i,j,k-1)*((Z(k)+Z(k-1))/n/dZ-1)/((Z(k)+Z(k-1))/n/dZ+1) - enddo - enddo - enddo - endif - - return - - end subroutine falloff_ss + + +#include "macrodef.fh" + +! Update outer boundaries with Sommerfeld boundary condition +! +!----------------------------------------------------------------------------- +!5th order interpolation + subroutine sommerfeld_rout(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,dT,chi0,& + Lap0,f0,f,SoA,Symmetry,precor) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,precor + real*8, dimension(ex(1)) :: X + real*8, dimension(ex(2)) :: Y + real*8, dimension(ex(3)) :: Z + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,dT + real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::chi0,Lap0,f0 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f + real*8, dimension(3),intent(in) ::SoA +!~~~~~~> Other variables: + real*8 :: dX,dY,dZ,r,fac + integer :: i, j, k,m + logical :: gont,nouse + integer,dimension(3) :: cxB,cxT + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer,parameter::ordn = 6, CORRECTSTEP=1 + real*8 :: ddy + real*8, dimension(1:ordn) :: xa + real*8, dimension(1:3) :: cx + real*8, dimension(1:ordn,1:ordn,1:ordn) :: ya + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, SYM = 1.d0, ANT = -1.d0 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 +!~~~~~~> Interface + + interface + + function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont) + implicit none + + integer, intent(in) :: ORDN,Symmetry + integer,dimension(1:3) , intent(in) :: ex,cxB,cxT + real*8, dimension(1:3) , intent(in) :: SoA + real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi + real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya + logical::gont + end function decide3d + + end interface + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(X(ex(1))-xmax) < dX)then + layer(1,1) = ex(1) + layer(2,1) = 1 + layer(3,1) = 1 + layer(4,1) = ex(1) + layer(5,1) = ex(2) + layer(6,1) = ex(3) +endif + +if(dabs(Y(ex(2))-ymax) < dY)then + layer(1,2) = 1 + layer(2,2) = ex(2) + layer(3,2) = 1 + layer(4,2) = ex(1) + layer(5,2) = ex(2) + layer(6,2) = ex(3) +endif + + +if(dabs(Z(ex(3))-zmax) < dZ)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(3,3) = ex(3) + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(6,3) = ex(3) +endif +! lower boundary but not symmetry boundary +if(dabs(X(1)-xmin) < dX .and. (.not.(Symmetry==OCTANT.and.dabs(xmin)NO_SYMM.and.dabs(zmin) boundary calculations start... + if( precor == CORRECTSTEP ) then + + do gp = 1, 6, 1 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp), 1 + do j = layer(2,gp), layer(5,gp), 1 + do i = layer(1,gp), layer(4,gp), 1 + + f(i,j,k) = f0(i,j,k) + + enddo + enddo + enddo + endif + enddo + + else + + do gp = 1, 6 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +! tc/sc*dT/r + r = (Lap0(i,j,k) + ONE)*dsqrt(ONE+chi0(i,j,k))*dT/dsqrt(X(i)**2+Y(j)**2+Z(k)**2) + fac=ONE-r + cx(1) = r*X(i)/dX + cx(2) = r*Y(j)/dY + cx(3) = r*Z(k)/dZ + if(cx(1)>ZEO)then + cxB(1) = i-dint(cx(1))-ordn/2 + else + cxB(1) = i-dint(cx(1))-ordn/2+1 + endif + if(cx(2)>ZEO)then + cxB(2) = j-dint(cx(2))-ordn/2 + else + cxB(2) = j-dint(cx(2))-ordn/2+1 + endif + if(cx(3)>ZEO)then + cxB(3) = k-dint(cx(3))-ordn/2 + else + cxB(3) = k-dint(cx(3))-ordn/2+1 + endif + + where(cx>ZEO) + cx = dint(cx)-cx+ordn/2 + elsewhere + cx = dint(cx)-cx+ordn/2-1 + end where + + cxT = cxB+ordn-1 + + if(Symmetry==NO_SYMM.and.cxB(3)<1)then + cx(3)=cx(3)+(cxB(3)-1) + cxT(3)=cxT(3)-(cxB(3)-1) + cxB(3)=1 + endif + if(Symmetryex(m))then + cx(m)=cx(m)+(cxT(m)-ex(m)) + cxB(m)=cxB(m)-(cxT(m)-ex(m)) + cxT(m)=ex(m) + endif + enddo + +!~~~~~~> Interpolate + nouse=decide3d(ex,f0,f0,cxB,cxT,SoA,ya,ordn,Symmetry) + call polin3(xa,xa,xa,ya,cx(1),cx(2),cx(3),r,ddy,ordn) + f(i,j,k)=r*fac + + enddo + enddo + enddo + endif + enddo + + endif + + return + + end subroutine sommerfeld_rout +!sommerfeld condition following BAM code + subroutine sommerfeld_routbam(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f_rhs,& + f0,velocity,SoA,Symmetry) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry + real*8, intent(in) :: velocity + real*8, dimension(ex(1)) :: X + real*8, dimension(ex(2)) :: Y + real*8, dimension(ex(3)) :: Z + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::f0 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f_rhs + real*8,dimension(3),intent(in) ::SoA +!~~~~~~> Other variables: + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + logical :: gont + real*8 :: dX,dY,dZ,R + integer :: i, j, k + real*8 :: d2dx,d2dy,d2dz + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: fx,fy,fz + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + + real*8 :: wx,wy,wz + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + call symmetry_bd(1,ex,f0,fh,SoA) + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(X(ex(1))-xmax) < dX)then + layer(1,1) = ex(1) + layer(2,1) = 1 + layer(3,1) = 1 + layer(4,1) = ex(1) + layer(5,1) = ex(2) + layer(6,1) = ex(3) +endif + +if(dabs(Y(ex(2))-ymax) < dY)then + layer(1,2) = 1 + layer(2,2) = ex(2) + layer(3,2) = 1 + layer(4,2) = ex(1) + layer(5,2) = ex(2) + layer(6,2) = ex(3) +endif + +if(dabs(Z(ex(3))-zmax) < dZ)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(3,3) = ex(3) + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(6,3) = ex(3) +endif +! lower boundary but not symmetry boundary +if(dabs(X(1)-xmin) < dX .and. (.not.(Symmetry==OCTANT.and.dabs(xmin)NO_SYMM.and.dabs(zmin)= imin)then + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx=(-fh(i,j,k)+fh(i+1,j,k))/dX + + elseif(i==imax)then + fx=(-fh(i-1,j,k)+fh(i,j,k))/dX + + endif +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy=(-fh(i,j,k)+fh(i,j+1,k))/dY + + elseif(j==jmax)then + fy=(-fh(i,j-1,k)+fh(i,j,k))/dY + + endif +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz=(-fh(i,j,k)+fh(i,j,k+1))/dZ + + elseif(k==kmax)then + fz=(-fh(i,j,k-1)+fh(i,j,k))/dZ + + endif + + R = dsqrt(X(i)**2+Y(j)**2+Z(k)**2) + f_rhs(i,j,k) = -velocity*(fx*X(i) + fy*Y(j) + fz*Z(k) + f0(i,j,k))/R +#else +!! new code, 2012dec26, based on bam +!! we always assume var0 = 0 + R = dsqrt(X(i)**2+Y(j)**2+Z(k)**2) + wx = velocity*X(i)/R + wy = velocity*Y(j)/R + wz = velocity*Z(k)/R + if(wx > 0)then + if(i-2>=imin)then + fx = d2dx*(3*fh(i,j,k)-4*fh(i-1,j,k)+fh(i-2,j,k)) + elseif(i-1>=imin)then + fx = d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + else + fx = d2dx*(-fh(i+2,j,k)+4*fh(i+1,j,k)-3*fh(i,j,k)) + endif + elseif(wx < 0)then + if(i+2<=imax)then + fx = d2dx*(-fh(i+2,j,k)+4*fh(i+1,j,k)-3*fh(i,j,k)) + elseif(i+1<=imax)then + fx = d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + else + fx = d2dx*(3*fh(i,j,k)-4*fh(i-1,j,k)+fh(i-2,j,k)) + endif + endif + + if(wy > 0)then + if(j-2>=jmin)then + fy = d2dy*(3*fh(i,j,k)-4*fh(i,j-1,k)+fh(i,j-2,k)) + elseif(j-1>=jmin)then + fy = d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + else + fy = d2dy*(-fh(i,j+2,k)+4*fh(i,j+1,k)-3*fh(i,j,k)) + endif + elseif(wy < 0)then + if(j+2<=jmax)then + fy = d2dy*(-fh(i,j+2,k)+4*fh(i,j+1,k)-3*fh(i,j,k)) + elseif(j+1<=jmax)then + fy = d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + else + fy = d2dy*(3*fh(i,j,k)-4*fh(i,j-1,k)+fh(i,j-2,k)) + endif + endif + + if(wz > 0)then + if(k-2>=kmin)then + fz = d2dz*(3*fh(i,j,k)-4*fh(i,j,k-1)+fh(i,j,k-2)) + elseif(k-1>=kmin)then + fz = d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + else + fz = d2dz*(-fh(i,j,k+2)+4*fh(i,j,k+1)-3*fh(i,j,k)) + endif + elseif(wz < 0)then + if(k+2<=kmax)then + fz = d2dz*(-fh(i,j,k+2)+4*fh(i,j,k+1)-3*fh(i,j,k)) + elseif(k+1<=kmax)then + fz = d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + else + fz = d2dz*(3*fh(i,j,k)-4*fh(i,j,k-1)+fh(i,j,k-2)) + endif + endif + + f_rhs(i,j,k) = -velocity*(fx*X(i) + fy*Y(j) + fz*Z(k) + f0(i,j,k))/R +#endif + enddo + enddo + enddo + endif + enddo + + return + + end subroutine sommerfeld_routbam +!sommerfeld condition following BAM code for shell + subroutine sommerfeld_routbam_ss(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f_rhs,& + f0,velocity,SoA,Symmetry) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry + real*8, intent(in) :: velocity + real*8, dimension(ex(1)) :: X + real*8, dimension(ex(2)) :: Y +! Z-> R + real*8, dimension(ex(3)) :: Z + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::f0 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f_rhs + real*8,dimension(3),intent(in) ::SoA +!~~~~~~> Other variables: + logical :: gont + real*8 :: dZ + integer :: i, j, k + real*8 :: d2dz + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8 :: fz + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + + dZ = Z(2) - Z(1) + + d2dz = ONE/TWO/dZ + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(Z(ex(3))-zmax) < dZ)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) +#if 1 +! do not consider buffer points near boundary + layer(3,3) = ex(3) + layer(6,3) = ex(3) +#else +! consider buffer points near boundary + layer(3,3) = ex(3) - ghost_width + layer(6,3) = ex(3) - ghost_width +#endif +endif + +if(dabs(Z(1)-zmin) < dZ)then + layer(1,6) = 1 + layer(2,6) = 1 + layer(3,6) = 1 + layer(4,6) = ex(1) + layer(5,6) = ex(2) + layer(6,6) = 1 +endif + +! outgoing BD + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +#if 0 +!! old code +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + fz=d2dz*(-f0(i,j,k-1)+f0(i,j,k+1)) + + elseif(k==kmin)then + fz=(-f0(i,j,k)+f0(i,j,k+1))/dZ + + elseif(k==kmax)then + fz=(-f0(i,j,k-1)+f0(i,j,k))/dZ + + endif +#else +!! new code, 2012dec16, based on bam + if(velocity > 0)then + if(k-2>=kmin)then + fz = d2dz*(3*f0(i,j,k)-4*f0(i,j,k-1)+f0(i,j,k-2)) + elseif(k-1>=kmin)then + fz = d2dz*(-f0(i,j,k-1)+f0(i,j,k+1)) + else + fz = d2dz*(-f0(i,j,k+2)+4*f0(i,j,k+1)-3*f0(i,j,k)) + endif + elseif(velocity < 0)then + if(k+2<=kmax)then + fz = d2dz*(-f0(i,j,k+2)+4*f0(i,j,k+1)-3*f0(i,j,k)) + elseif(k+1<=kmax)then + fz = d2dz*(-f0(i,j,k-1)+f0(i,j,k+1)) + else + fz = d2dz*(3*f0(i,j,k)-4*f0(i,j,k-1)+f0(i,j,k-2)) + endif + endif +#endif + f_rhs(i,j,k) = -velocity*(fz+f0(i,j,k)/Z(k)) + enddo + enddo + enddo + endif + +! fix BD + gp = 6 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +! z direction + f_rhs(i,j,k) = ZEO + enddo + enddo + enddo + endif + + return + + end subroutine sommerfeld_routbam_ss +! falloff boundary condition + subroutine falloff_ss(ex,X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,f,n,SoA,Symmetry) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,n + real*8, dimension(ex(1)) :: X + real*8, dimension(ex(2)) :: Y +! Z-> R + real*8, dimension(ex(3)) :: Z + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::f + real*8,dimension(3),intent(in) ::SoA +!~~~~~~> Other variables: + logical :: gont + real*8 :: dZ + integer :: i, j, k + real*8 :: d2dz + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8 :: fz + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + + dZ = Z(2) - Z(1) + + d2dz = ONE/TWO/dZ + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(Z(ex(3))-zmax) < dZ)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(3,3) = ex(3) + layer(6,3) = ex(3) +endif + +! falloff BD + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +! z direction + f(i,j,k) = f(i,j,k-1)*((Z(k)+Z(k-1))/n/dZ-1)/((Z(k)+Z(k-1))/n/dZ+1) + enddo + enddo + enddo + endif + + return + + end subroutine falloff_ss diff --git a/AMSS_NCKU_source/sommerfeld_rout.h b/AMSS_NCKU_source/BSSN/sommerfeld_rout.h similarity index 96% rename from AMSS_NCKU_source/sommerfeld_rout.h rename to AMSS_NCKU_source/BSSN/sommerfeld_rout.h index 1331a9f..d19fd6b 100644 --- a/AMSS_NCKU_source/sommerfeld_rout.h +++ b/AMSS_NCKU_source/BSSN/sommerfeld_rout.h @@ -1,53 +1,53 @@ - -#ifndef SOMMERFELD_ROUT_H -#define SOMMERFELD_ROUT_H - -#ifdef fortran1 -#define f_sommerfeld_rout sommerfeld_rout -#define f_sommerfeld_routbam sommerfeld_routbam -#define f_sommerfeld_routbam_ss sommerfeld_routbam_ss -#define f_falloff_ss falloff_ss -#endif -#ifdef fortran2 -#define f_sommerfeld_rout SOMMERFELD_ROUT -#define f_sommerfeld_rout SOMMERFELD_ROUTBAM -#define f_sommerfeld_rout_ss SOMMERFELD_ROUTBAM_SS -#define f_falloff_ss FALLOFF_SS -#endif -#ifdef fortran3 -#define f_sommerfeld_rout sommerfeld_rout_ -#define f_sommerfeld_routbam sommerfeld_routbam_ -#define f_sommerfeld_routbam_ss sommerfeld_routbam_ss_ -#define f_falloff_ss falloff_ss_ -#endif - -extern "C" -{ - void f_sommerfeld_rout(int *, double *, double *, double *, - double &, double &, double &, double &, double &, double &, double &, double *, - double *, double *, double *, double *, - int &, int &); -} - -extern "C" -{ - void f_sommerfeld_routbam(int *, double *, double *, double *, - double &, double &, double &, double &, double &, double &, double *, - double *, double &, double *, int &); -} - -extern "C" -{ - void f_sommerfeld_routbam_ss(int *, double *, double *, double *, - double &, double &, double &, double &, double &, double &, double *, - double *, double &, double *, int &); -} - -extern "C" -{ - void f_falloff_ss(int *, double *, double *, double *, - double &, double &, double &, double &, double &, double &, double *, - int &, double *, int &); -} - -#endif /* SOMMERFELD_ROUT_H */ + +#ifndef SOMMERFELD_ROUT_H +#define SOMMERFELD_ROUT_H + +#ifdef fortran1 +#define f_sommerfeld_rout sommerfeld_rout +#define f_sommerfeld_routbam sommerfeld_routbam +#define f_sommerfeld_routbam_ss sommerfeld_routbam_ss +#define f_falloff_ss falloff_ss +#endif +#ifdef fortran2 +#define f_sommerfeld_rout SOMMERFELD_ROUT +#define f_sommerfeld_rout SOMMERFELD_ROUTBAM +#define f_sommerfeld_rout_ss SOMMERFELD_ROUTBAM_SS +#define f_falloff_ss FALLOFF_SS +#endif +#ifdef fortran3 +#define f_sommerfeld_rout sommerfeld_rout_ +#define f_sommerfeld_routbam sommerfeld_routbam_ +#define f_sommerfeld_routbam_ss sommerfeld_routbam_ss_ +#define f_falloff_ss falloff_ss_ +#endif + +extern "C" +{ + void f_sommerfeld_rout(int *, double *, double *, double *, + double &, double &, double &, double &, double &, double &, double &, double *, + double *, double *, double *, double *, + int &, int &); +} + +extern "C" +{ + void f_sommerfeld_routbam(int *, double *, double *, double *, + double &, double &, double &, double &, double &, double &, double *, + double *, double &, double *, int &); +} + +extern "C" +{ + void f_sommerfeld_routbam_ss(int *, double *, double *, double *, + double &, double &, double &, double &, double &, double &, double *, + double *, double &, double *, int &); +} + +extern "C" +{ + void f_falloff_ss(int *, double *, double *, double *, + double &, double &, double &, double &, double &, double &, double *, + int &, double *, int &); +} + +#endif /* SOMMERFELD_ROUT_H */ diff --git a/AMSS_NCKU_source/transpbh.C b/AMSS_NCKU_source/BSSN/transpbh.C similarity index 94% rename from AMSS_NCKU_source/transpbh.C rename to AMSS_NCKU_source/BSSN/transpbh.C index 33ed1d4..1ffd69c 100644 --- a/AMSS_NCKU_source/transpbh.C +++ b/AMSS_NCKU_source/BSSN/transpbh.C @@ -1,74 +1,74 @@ -// $Id: transpbh.C,v 1.2 2013/04/19 03:49:25 zjcao Exp $ -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include "macrodef.h" - -// transmit black hole's position from bssn class - -int BHN; -double Mass[3]; -double PBH[9]; - -void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN) -{ - BHN = Mymax(iBHN, rBHN); - for (int i = 0; i < iBHN; i++) - { - for (int j = 0; j < 3; j++) - PBH[3 * i + j] = iPBH[i][j]; - Mass[i] = iMass[i]; - } - if (BHN < rBHN) - { - if (rBHN > 2) - cout << "error in transpbh.C: something wrong." << endl; - else - { - for (int j = 0; j < 3; j++) - PBH[3 + j] = -iPBH[0][j]; - - Mass[1] = Mass[0]; - } - } -} -extern "C" -{ - -#ifdef fortran1 - void getpbh -#endif -#ifdef fortran2 - void GETPBH -#endif -#ifdef fortran3 - void - getpbh_ -#endif - (int &oBHN, double *oPBH, double *oMass) - { - oBHN = BHN; - for (int i = 0; i < BHN; i++) - oMass[i] = Mass[i]; - for (int i = 0; i < 3 * BHN; i++) - oPBH[i] = PBH[i]; - - // printf("have set BH_num = %d\n",oBHN); - } -} +// $Id: transpbh.C,v 1.2 2013/04/19 03:49:25 zjcao Exp $ +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include "macrodef.h" + +// transmit black hole's position from bssn class + +int BHN; +double Mass[3]; +double PBH[9]; + +void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN) +{ + BHN = Mymax(iBHN, rBHN); + for (int i = 0; i < iBHN; i++) + { + for (int j = 0; j < 3; j++) + PBH[3 * i + j] = iPBH[i][j]; + Mass[i] = iMass[i]; + } + if (BHN < rBHN) + { + if (rBHN > 2) + cout << "error in transpbh.C: something wrong." << endl; + else + { + for (int j = 0; j < 3; j++) + PBH[3 + j] = -iPBH[0][j]; + + Mass[1] = Mass[0]; + } + } +} +extern "C" +{ + +#ifdef fortran1 + void getpbh +#endif +#ifdef fortran2 + void GETPBH +#endif +#ifdef fortran3 + void + getpbh_ +#endif + (int &oBHN, double *oPBH, double *oMass) + { + oBHN = BHN; + for (int i = 0; i < BHN; i++) + oMass[i] = Mass[i]; + for (int i = 0; i < 3 * BHN; i++) + oPBH[i] = PBH[i]; + + // printf("have set BH_num = %d\n",oBHN); + } +} diff --git a/AMSS_NCKU_source/bssn_gpu.cu b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu.cu similarity index 98% rename from AMSS_NCKU_source/bssn_gpu.cu rename to AMSS_NCKU_source/BSSN_GPU/bssn_gpu.cu index e67ae18..bba4438 100644 --- a/AMSS_NCKU_source/bssn_gpu.cu +++ b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu.cu @@ -1,2908 +1,2908 @@ -// includes, system -#include -#include -#include -#include -#include -#include -#include -//#include "cutil.h" -#include -#include -using namespace std; - -//includes, bssn -#include "gpu_mem.h" -#include "bssn_gpu.h" -#ifdef RESULT_CHECK -#include -#endif - -void compare_result_gpu(int ftag1,double * datac,int data_num){ - double * data = (double*)malloc(sizeof(double)*data_num); - cudaMemcpy(data, datac, data_num * sizeof(double), cudaMemcpyDeviceToHost); - compare_result(ftag1,data,data_num); - free(data); -} - -__global__ void test_const_address(double * testd){ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - if(_t == 0) - testd[0] = F1o3; -} - -__global__ void enforce_ga(double * trA){ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - //int ps; //TOTRY: i,j,k; double value; - - while(_t < _3D_SIZE[0]) - { - M_ gxx[_t] = M_ dxx[_t] + 1; - M_ gyy[_t] = M_ dyy[_t] + 1; - M_ gzz[_t] = M_ dzz[_t] + 1; - // for M_ g; - M_ gupzz[_t] = M_ gxx[_t] * M_ gyy[_t] * M_ gzz[_t] + M_ gxy[_t] * M_ gyz[_t] * M_ gxz[_t] + M_ gxz[_t] * M_ gxy[_t] * M_ gyz[_t] - - M_ gxz[_t] * M_ gyy[_t] * M_ gxz[_t] - M_ gxy[_t] * M_ gxy[_t] * M_ gzz[_t] - M_ gxx[_t] * M_ gyz[_t] * M_ gyz[_t]; - - M_ gupzz[_t] = 1.0 / pow( M_ gupzz[_t] , F1o3 ) ; - - M_ gxx[_t] = M_ gxx[_t] * M_ gupzz[_t]; - M_ gxy[_t] = M_ gxy[_t] * M_ gupzz[_t]; - M_ gxz[_t] = M_ gxz[_t] * M_ gupzz[_t]; - M_ gyy[_t] = M_ gyy[_t] * M_ gupzz[_t]; - M_ gyz[_t] = M_ gyz[_t] * M_ gupzz[_t]; - M_ gzz[_t] = M_ gzz[_t] * M_ gupzz[_t]; - - M_ dxx[_t] = M_ gxx[_t] - 1; - M_ dyy[_t] = M_ gyy[_t] - 1; - M_ dzz[_t] = M_ gzz[_t] - 1; - // for A ; - - M_ gupxx[_t] = ( M_ gyy[_t] * M_ gzz[_t] - M_ gyz[_t] * M_ gyz[_t] ); - M_ gupxy[_t] = - ( M_ gxy[_t] * M_ gzz[_t] - M_ gyz[_t] * M_ gxz[_t] ); - M_ gupxz[_t] = ( M_ gxy[_t] * M_ gyz[_t] - M_ gyy[_t] * M_ gxz[_t] ); - M_ gupyy[_t] = ( M_ gxx[_t] * M_ gzz[_t] - M_ gxz[_t] * M_ gxz[_t] ); - M_ gupyz[_t] = - ( M_ gxx[_t] * M_ gyz[_t] - M_ gxy[_t] * M_ gxz[_t] ); - M_ gupzz[_t] = ( M_ gxx[_t] * M_ gyy[_t] - M_ gxy[_t] * M_ gxy[_t] ); - - trA[_t] = M_ gupxx[_t] *M_ Axx[_t] + M_ gupyy[_t] * M_ Ayy[_t] + M_ gupzz[_t] * M_ Azz[_t] - + 2 * (M_ gupxy[_t] *M_ Axy[_t] + M_ gupxz[_t] *M_ Axz[_t] + M_ gupyz[_t] * M_ Ayz[_t]); - - M_ Axx[_t] = M_ Axx[_t] - F1o3 * M_ gxx[_t] * trA[_t]; - M_ Axy[_t] = M_ Axy[_t] - F1o3 * M_ gxy[_t] * trA[_t]; - M_ Axz[_t] = M_ Axz[_t] - F1o3 * M_ gxz[_t] * trA[_t]; - M_ Ayy[_t] = M_ Ayy[_t] - F1o3 * M_ gyy[_t] * trA[_t]; - M_ Ayz[_t] = M_ Ayz[_t] - F1o3 * M_ gyz[_t] * trA[_t]; - M_ Azz[_t] = M_ Azz[_t] - F1o3 * M_ gzz[_t] * trA[_t]; - //------------------- - _t += STEP_SIZE; - } -} - -inline void sub_enforce_ga(int matrix_size){ - double * trA = M_ chin1; - enforce_ga<<>>(trA); - cudaMemset(trA,0,matrix_size * sizeof(double)); - cudaThreadSynchronize(); - - //cudaMemset(Mh_ gupxx,0,matrix_size * sizeof(double)); - //trA gxx,gyy,gzz gupxx,gupxy,gupxz,gupyy,gupyz,gupzz - -} -__device__ volatile unsigned int global_count = 0; -__global__ void test_init_matrix(){ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int curr = tid; - while(curr < _3D_SIZE[2]) - { - metac.fh[curr] = 0; - curr += STEP_SIZE; - } - curr = tid; - while(curr < _3D_SIZE[0]) - { - metac.betaxx[curr] = 0; - metac.betaxy[curr] = 0; - metac.betaxz[curr] = 0; - curr += STEP_SIZE; - } -} -__global__ void init_matrix(double * mat){ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int curr = tid; - while(curr < _3D_SIZE[0]) - { - mat[curr] = 0; - curr += STEP_SIZE; - } -} -__global__ void init_3_matrixs(double * mat1,double* mat2,double *mat3){ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int curr = tid; - while(curr < _3D_SIZE[0]) - { - mat1[curr] = 0; - mat2[curr] = 0; - mat3[curr] = 0; - curr += STEP_SIZE; - } -} -__global__ void init_matrix_fh(double * mat){ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int curr = tid; - while(curr < _3D_SIZE[2]) - { - mat[curr] = 0; - curr += STEP_SIZE; - } -} - - -__global__ void sub_symmetry_bd_partF(int ord, double * func, double *funcc) -{ - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(curr < _3D_SIZE[0]) - { - int k = curr / _2D_SIZE[0]; - ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); //= ps % ex_c[0]; - - funcc[i+ ord + (ord +j)* _1D_SIZE[ord] + (k + ord) * _2D_SIZE[ord]] = func[curr]; - - curr += STEP_SIZE; - } - -} - -#ifdef Vertex -__global__ void sub_symmetry_bd_partI(int ord, double * func, double * funcc,double S1){ - //for i - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; - int m; - while(curr < (ex_c[1]+ord)*(ex_c[2]+ord) ){ - m = ord * 2; - ps = curr * _1D_SIZE[ord]; - for(int i = 0;i < ord; ++i){ - funcc[ps] = funcc [ps + m] * S1; - ps ++; - m -= 2; - } - curr+= STEP_SIZE; - } - __syncthreads(); -} -__global__ void sub_symmetry_bd_partJ(int ord,double * func, double * funcc,double S2){ - //for j - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; - int m; - - while(curr < (ex_c[0]+ord)*(ex_c[2]+ord)) - { - m = 2 * ord; - ps = (curr/_1D_SIZE[ord])*_2D_SIZE[ord] + (curr % _1D_SIZE[ord]); - for(int i = 0;i>>(ord,func,funcc); - cudaThreadSynchronize(); - sub_symmetry_bd_partI<<>>(ord,func,funcc,SoA[0]); - cudaThreadSynchronize(); - sub_symmetry_bd_partJ<<>>(ord,func,funcc,SoA[1]); - cudaThreadSynchronize(); - sub_symmetry_bd_partK<<>>(ord,func,funcc,SoA[2]); - cudaThreadSynchronize(); -} - - -__global__ void sub_fdderivs_part1(double * f,double *fh,double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz) - { - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(curr < _3D_SIZE[0]) - { - int k = curr / _2D_SIZE[0]; - ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k == ex_c[2]-1 || i == ex_c[0]-1 || j == ex_c[1]-1){ - curr += STEP_SIZE; - continue; - } - else - { - //xx - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]){ - fxx[curr] = Fdxdx*(-_FH2_(i,(j+2),(k+2))+16*_FH2_((i+1),(j+2),(k+2))-30*_FH2_((i+2),(j+2),(k+2)) - -_FH2_((i+4),(j+2),(k+2))+16*_FH2_((i+3),(j+2),(k+2)) ); - - } - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]){ - fxx[curr] = Sdxdx*(_FH2_((i+1),(j+2),(k+2))-2*_FH2_((i+2),(j+2),(k+2)) - +_FH2_(i+3,(j+2),(k+2)) ); - } - //zz-- - if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]){ - fzz[curr] = Fdzdz * (-_FH2_((i+2),(j+2),k) + 16 *_FH2_((i+2),(j+2),(k+1))- 30*_FH2_((i+2),(j+2),(k+2)) - -_FH2_((i+2),(j+2),(k+4))+ 16*_FH2_((i+2),(j+2),(k+3)) ); - } - else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]){ - fzz[curr] = Sdzdz*(_FH2_((i+2),(j+2),(k+1))- 2 * _FH2_((i+2),(j+2),(k+2)) - + _FH2_((i+2),(j+2),(k+3)) ); - } - - //yy-- - if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]){ - fyy[curr] = Fdydy*(-_FH2_((i+2),j,(k+2))+16*_FH2_((i+2),(j+1),(k+2))-30*_FH2_((i+2),(j+2),(k+2)) - -_FH2_((i+2),(j+4),(k+2))+16*_FH2_((i+2),(j+3),(k+2)) ); - } - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]){ - fyy[curr] = Sdydy*(_FH2_((i+2),(j+1),(k+2))-2*_FH2_((i+2),(j+2),(k+2)) - +_FH2_((i+2),(j+3),(k+2)) ); - } - - - - //xy - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) - fxy[curr] = Fdxdy*((_FH2_(i,j,(k+2))-8*_FH2_((i+1),j,(k+2))+8*_FH2_((i+3),j,(k+2))-_FH2_((i+4),j,(k+2))) - -8 *(_FH2_(i,(j+1),(k+2))-8*_FH2_((i+1),(j+1),(k+2))+8*_FH2_((i+3),(j+1),(k+2))-_FH2_((i+4),(j+1),(k+2))) - +8 *(_FH2_(i,(j+3),(k+2))-8*_FH2_((i+1),(j+3),(k+2))+8*_FH2_((i+3),(j+3),(k+2))-_FH2_((i+4),(j+3),(k+2))) - - (_FH2_(i,(j+4),(k+2))-8*_FH2_((i+1),(j+4),(k+2))+8*_FH2_((i+3),(j+4),(k+2))-_FH2_((i+4),(j+4),(k+2)))); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) - - fxy[curr] = Sdxdy*(_FH2_((i+1),(j+1),(k+2))-_FH2_((i+3),(j+1),(k+2))-_FH2_((i+1),(j+3),(k+2))+_FH2_((i+3),(j+3),(k+2))); - //xz - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) - fxz[curr] = Fdxdz*( (_FH2_(i,(j+2),k)-8*_FH2_((i+1),(j+2),k)+8*_FH2_((i+3),(j+2),k)-_FH2_((i+4),(j+2),k)) - -8 *(_FH2_(i,(j+2),(k+1))-8*_FH2_((i+1),(j+2),(k+1))+8*_FH2_((i+3),(j+2),(k+1))-_FH2_((i+4),(j+2),(k+1))) - +8 *(_FH2_(i,(j+2),(k+3))-8*_FH2_((i+1),(j+2),(k+3))+8*_FH2_((i+3),(j+2),(k+3))-_FH2_((i+4),(j+2),(k+3))) - - (_FH2_(i,(j+2),(k+4))-8*_FH2_((i+1),(j+2),(k+4))+8*_FH2_((i+3),(j+2),(k+4))-_FH2_((i+4),(j+2),(k+4)))); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) - fxz[curr] = Sdxdz*(_FH2_((i+1),(j+2),(k+1))-_FH2_((i+3),(j+2),(k+1))-_FH2_((i+1),(j+2),(k+3))+_FH2_((i+3),(j+2),(k+3))); - //yz - if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) - fyz[curr] = Fdydz*( (_FH2_((i+2),j,k)-8*_FH2_((i+2),(j+1),k)+8*_FH2_((i+2),(j+3),k)-_FH2_((i+2),(j+4),k)) - -8 *(_FH2_((i+2),j,(k+1))-8*_FH2_((i+2),(j+1),(k+1))+8*_FH2_((i+2),(j+3),(k+1))-_FH2_((i+2),(j+4),(k+1))) - +8 *(_FH2_((i+2),j,(k+3))-8*_FH2_((i+2),(j+1),(k+3))+8*_FH2_((i+2),(j+3),(k+3))-_FH2_((i+2),(j+4),(k+3))) - - (_FH2_((i+2),j,(k+4))-8*_FH2_((i+2),(j+1),(k+4))+8*_FH2_((i+2),(j+3),(k+4))-_FH2_((i+2),(j+4),(k+4)))); - - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) - fyz[curr] = Sdydz*(_FH2_((i+2),(j+1),(k+1))-_FH2_((i+2),(j+3),(k+1))-_FH2_((i+2),(j+1),(k+3))+_FH2_((i+2),(j+3),(k+3))); - - curr += STEP_SIZE; - } - } - - __syncthreads(); - } - -inline void sub_fdderivs(double * f,double *fh,double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz,double* SoA) -{ - sub_symmetry_bd(2,f,fh,SoA); - cudaMemset(fxx,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fxy,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fxz,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fyy,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fyz,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fzz,0,_3D_SIZE[0] * sizeof(double)); - cudaThreadSynchronize(); - sub_fdderivs_part1<<>>(f,fh,fxx,fxy,fxz,fyy,fyz,fzz); - cudaThreadSynchronize(); -} - -__global__ void sub_fderivs_part1(double * f,double * fh,double *fx,double *fy,double *fz ) - { - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(curr < _3D_SIZE[0]) - { - int k = curr / _2D_SIZE[0]; - ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k == ex_c[2]-1 || i == ex_c[0]-1 || j == ex_c[1]-1){ - curr += STEP_SIZE; - continue; - } - - //X-- - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]) - fx[curr] = d12dxyz[0]*(fh[i+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] - - 8*fh[i+1+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + - 8*fh[i+3+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] - - fh[i+4+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] ); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]) - fx[curr] = d2dxyz[0]*(-fh[i+1+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + - fh[i+3+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] ); - //Y-- - if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) - fy[curr]=d12dxyz[1]*(fh[i+2+j*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]- - 8*fh[i+2+(j+1)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + - 8*fh[i+2+(j+3)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] - - fh[i+2+(j+4)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]); - - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) - fy[curr]=d2dxyz[1]*(-fh[i+2+(j+1)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + - fh[i+2+(j+3)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]); - //Z-- - - if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) - fz[curr]=d12dxyz[2]*( fh[i+2+(j+2)*_1D_SIZE[2]+k *_2D_SIZE[2]] - - 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]] + - 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k+3)*_2D_SIZE[2]] - - fh[i+2+(j+2)*_1D_SIZE[2]+(k+4)*_2D_SIZE[2]]); - - else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) - fz[curr]=d2dxyz[2]*(-fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]]+ - fh[i+2+(j+2)*_1D_SIZE[2]+(k+3)*_2D_SIZE[2]]); - - curr += STEP_SIZE; - - } - } - -inline void sub_fderivs(double * f,double * fh,double *fx,double *fy,double *fz,double * SoA) -{ - sub_symmetry_bd(2,f,fh,SoA); - - cudaMemset(fx,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fy,0,_3D_SIZE[0] * sizeof(double)); - cudaMemset(fz,0,_3D_SIZE[0] * sizeof(double)); - - cudaThreadSynchronize(); - sub_fderivs_part1<<>>(f,fh,fx,fy,fz); - cudaThreadSynchronize(); -} - -__global__ void computeRicci_part1(double * dst) -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - dst[_t] = M_ gupxx [_t]* M_ fxx [_t]+ M_ gupyy[_t]* M_ fyy[_t]+ M_ gupzz[_t]* M_ fzz[_t]+ - ( M_ gupxy[_t]* M_ fxy[_t]+ M_ gupxz[_t]* M_ fxz[_t]+ M_ gupyz[_t]* M_ fyz[_t]) * 2; - - _t += STEP_SIZE; - } -} - - inline void computeRicci(double * src,double* dst,double * SoA, Meta* meta) -{ - sub_fdderivs(src,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,SoA); - cudaThreadSynchronize(); - computeRicci_part1<<>>(dst); - cudaThreadSynchronize(); - -}/*Exception*/ - -__global__ void sub_kodis_part1(double *f,double *fh,double *f_rhs) -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - double inc_f_rhs; - while(_t < _3D_SIZE[0]) - { - int k = _t / _2D_SIZE[0]; - ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k == ex_c[2]-1 && i == ex_c[0]-1 && j == ex_c[1]-1){ - _t += STEP_SIZE; - continue; - } - - if(i-3 >= ijk_min3[0] && i+3 <= ijk_max[0] && - j-3 >= ijk_min3[1] && j+3 <= ijk_max[1] && - k-3 >= ijk_min3[2] && k+3 <= ijk_max[2]) - { - // x direction - inc_f_rhs = ( (_FH3_(i,(j+3),(k+3))+_FH3_((i+6),(j+3),(k+3))) - - 6*(_FH3_((i+1),(j+3),(k+3))+_FH3_((i+5),(j+3),(k+3))) + - 15*(_FH3_((i+2),(j+3),(k+3))+_FH3_((i+4),(j+3),(k+3))) - - 20* _FH3_((i+3),(j+3),(k+3)) ) /dX; - - - // y direction - - inc_f_rhs += ( (_FH3_((i+3),j,(k+3))+_FH3_((i+3),(j+6),(k+3))) - - 6*(_FH3_((i+3),(j+1),(k+3))+_FH3_((i+3),(j+5),(k+3))) + - 15*(_FH3_((i+3),(j+2),(k+3))+_FH3_((i+3),(j+4),(k+3))) - - 20* _FH3_((i+3),(j+3),(k+3)) )/dY; - - // z direction - - inc_f_rhs += ( (_FH3_((i+3),(j+3),k)+_FH3_((i+3),(j+3),(k+6))) - - 6*(_FH3_((i+3),(j+3),(k+1))+_FH3_((i+3),(j+3),(k+5))) + - 15*(_FH3_((i+3),(j+3),(k+2))+_FH3_((i+3),(j+3),(k+4))) - - 20* _FH3_((i+3),(j+3),(k+3)) )/dZ; - inc_f_rhs *= eps_c; - inc_f_rhs /= 64; - f_rhs[_t] += inc_f_rhs; //be careful the mark is "+=" not "==" ! - } - - _t += STEP_SIZE; - } -} - -inline void sub_kodis(double *f,double *fh,double *f_rhs,double *SoA) -{ - sub_symmetry_bd(3,f,fh,SoA); - cudaThreadSynchronize(); - sub_kodis_part1<<>>(f,fh,f_rhs); - cudaThreadSynchronize(); -} - -__global__ void sub_lopsided_part1(double *f,double* fh,double *f_rhs,double *Sfx,double *Sfy,double *Sfz) -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(_t < _3D_SIZE[0]) - { - int k = _t / _2D_SIZE[0]; - ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k < ex_c[2]-1 && i < ex_c[0]-1 && j < ex_c[1]-1){ - // x direction - if(Sfx[_t] >= 0 && i+3 <= ijk_max[0] && i-1 >= ijk_min2[0]) - f_rhs[_t]=f_rhs[_t]+ - Sfx[_t]*d12dxyz[0]*(-3*_FH3_((i+2),(j+3),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+4),(j+3),(k+3)) - -6*_FH3_((i+5),(j+3),(k+3))+ _FH3_((i+6),(j+3),(k+3))); - - else if(Sfx[_t] <= 0 && i-3 >= ijk_min2[0] && i+1 <= ijk_max[0]) - f_rhs[_t]=f_rhs[_t]- - Sfx[_t]*d12dxyz[0]*(-3*_FH3_((i+4),(j+3),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+2),(j+3),(k+3)) - -6*_FH3_((i+1),(j+3),(k+3))+ _FH3_(i,(j+3),(k+3))); - - else if(i+2 <= ijk_max[0] && i-2 >= ijk_min2[0]) - - - f_rhs[_t]=f_rhs[_t]+ - Sfx[_t]*d12dxyz[0]*(_FH3_((i+1),(j+3),(k+3))-8*_FH3_((i+2),(j+3),(k+3))+8*_FH3_((i+4),(j+3),(k+3))-_FH3_((i+5),(j+3),(k+3))); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min2[0]) - - f_rhs[_t]=f_rhs[_t] + Sfx[_t]*d2dxyz[0]*(-_FH3_((i+2),(j+3),(k+3))+_FH3_((i+4),(j+3),(k+3))); - - - // y direction - if(Sfy[_t] >= 0 && j+3 <= ijk_max[1] && j-1 >= ijk_min2[1]) - - f_rhs[_t]=f_rhs[_t]+ - Sfy[_t]*d12dxyz[1]*(-3*_FH3_((i+3),(j+2),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+4),(k+3)) - -6*_FH3_((i+3),(j+5),(k+3))+ _FH3_((i+3),(j+6),(k+3))); - - else if(Sfy[_t] <= 0 && j-3 >= ijk_min2[1] && j+1 <= ijk_max[1]) - f_rhs[_t]=f_rhs[_t]- - Sfy[_t]*d12dxyz[1]*(-3*_FH3_((i+3),(j+4),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+2),(k+3)) - -6*_FH3_((i+3),(j+1),(k+3))+ _FH3_((i+3),j,(k+3))); - - else if(j+2 <= ijk_max[1] && j-2 >= ijk_min2[1]) - - f_rhs[_t]=f_rhs[_t]+ - Sfy[_t]*d12dxyz[1]*(_FH3_((i+3),(j+1),(k+3))-8*_FH3_((i+3),(j+2),(k+3))+8*_FH3_((i+3),(j+4),(k+3))-_FH3_((i+3),(j+5),(k+3))); - - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min2[1]) - - f_rhs[_t]=f_rhs[_t] + Sfy[_t]*d2dxyz[1]*(-_FH3_((i+3),(j+2),(k+3))+_FH3_((i+3),(j+4),(k+3))); - - - // z direction - if(Sfz[_t] >= 0 && k+3 <= ijk_max[2] && k-1 >= ijk_min2[2]) - // v - // D f = ------[ - 3f - 10f + 18f - 6f + f ] - // i 12dx i-v i i+v i+2v i+3v - f_rhs[_t]=f_rhs[_t]+ - Sfz[_t]*d12dxyz[2]*(-3*_FH3_((i+3),(j+3),(k+2))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+3),(k+4)) - -6*_FH3_((i+3),(j+3),(k+5))+ _FH3_((i+3),(j+3),(k+6))); - - else if(Sfz[_t] <= 0 && k-3 >= ijk_min2[2] && k+1 <= ijk_max[2]) - f_rhs[_t]=f_rhs[_t]- - Sfz[_t]*d12dxyz[2]*(-3*_FH3_((i+3),(j+3),(k+4))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+3),(k+2)) - -6*_FH3_((i+3),(j+3),(k+1))+ _FH3_((i+3),(j+3),k)); - - else if(k+2 <= ijk_max[2] && k-2 >= ijk_min2[2]) - - f_rhs[_t]=f_rhs[_t]+ - Sfz[_t]*d12dxyz[2]*(_FH3_((i+3),(j+3),(k+1))-8*_FH3_((i+3),(j+3),(k+2))+8*_FH3_((i+3),(j+3),(k+4))-_FH3_((i+3),(j+3),(k+5))); - - else if(k+1 <= ijk_max[2] && k-1 >= ijk_min2[2]) - - f_rhs[_t]=f_rhs[_t]+Sfz[_t]*d2dxyz[2]*(-_FH3_((i+3),(j+3),(k+2))+_FH3_((i+3),(j+3),(k+4))); - } - //------------------- - _t += STEP_SIZE; - } -} - - -inline void sub_lopsided(double *f,double*fh,double *f_rhs,double *Sfx,double *Sfy,double *Sfz,double *SoA){ - sub_symmetry_bd(3,f,fh,SoA); - cudaThreadSynchronize(); - sub_lopsided_part1<<>>(f,fh,f_rhs,Sfx,Sfy,Sfz); - cudaThreadSynchronize(); -} - -__global__ void compute_rhs_bssn_part1() -{ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int curr = tid; - while(curr < _3D_SIZE[0]) - { - metac.alpn1[curr] = metac.Lap[curr] + 1; - metac.chin1[curr] = metac.chi[curr] + 1; - metac.gxx[curr] = metac.dxx[curr] + 1; - metac.gyy[curr] = metac.dyy[curr] + 1; - metac.gzz[curr] = metac.dzz[curr] + 1; - - curr += STEP_SIZE; - } -} - -__global__ void compute_rhs_bssn_part2() -{ - //__shared__ int judge = 1; - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - - M_ div_beta[_t] = M_ betaxx[_t] + M_ betayy[_t] + M_ betazz[_t]; - M_ chi_rhs[_t] = F2o3 *M_ chin1[_t]*( M_ alpn1[_t] * M_ trK[_t] - M_ div_beta[_t] ); //rhs[_t] for M_ chi - - M_ gxx_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axx[_t] - F2o3 * M_ gxx[_t]* M_ div_beta[_t] + - 2 *( M_ gxx[_t]* M_ betaxx[_t]+ M_ gxy[_t]* M_ betayx[_t]+ M_ gxz[_t]* M_ betazx[_t]); - M_ gyy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayy[_t] - F2o3 * M_ gyy[_t]* M_ div_beta[_t] + - 2 *( M_ gxy[_t]* M_ betaxy[_t]+ M_ gyy[_t]* M_ betayy[_t]+ M_ gyz[_t]* M_ betazy[_t]); - - M_ gzz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Azz[_t] - F2o3 * M_ gzz[_t]* M_ div_beta[_t] + - 2 *( M_ gxz[_t]* M_ betaxz[_t]+ M_ gyz[_t]* M_ betayz[_t]+ M_ gzz[_t]* M_ betazz[_t]); - - M_ gxy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axy[_t] + F1o3 * M_ gxy[_t] * M_ div_beta[_t] + - M_ gxx[_t]* M_ betaxy[_t] + M_ gxz[_t]* M_ betazy[_t]+ - M_ gyy[_t]* M_ betayx[_t]+ M_ gyz[_t]* M_ betazx[_t] - - M_ gxy[_t]* M_ betazz[_t]; - - M_ gyz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayz[_t] + F1o3 * M_ gyz[_t] * M_ div_beta[_t] + - M_ gxy[_t]* M_ betaxz[_t]+ M_ gyy[_t]* M_ betayz[_t] + - M_ gxz[_t]* M_ betaxy[_t] + M_ gzz[_t]* M_ betazy[_t] - - M_ gyz[_t]* M_ betaxx[_t]; - - M_ gxz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axz[_t] + F1o3 * M_ gxz[_t] * M_ div_beta[_t] + - M_ gxx[_t]* M_ betaxz[_t]+ M_ gxy[_t]* M_ betayz[_t] + - M_ gyz[_t]* M_ betayx[_t]+ M_ gzz[_t]* M_ betazx[_t] - - M_ gxz[_t]* M_ betayy[_t]; //rhs[_t] for gij - - // invert tilted metric - M_ gupzz[_t]= M_ gxx[_t]* M_ gyy[_t]* M_ gzz[_t]+ M_ gxy[_t]* M_ gyz[_t]* M_ gxz[_t]+ M_ gxz[_t]* M_ gxy[_t]* M_ gyz[_t]- - M_ gxz[_t]* M_ gyy[_t]* M_ gxz[_t]- M_ gxy[_t]* M_ gxy[_t]* M_ gzz[_t]- M_ gxx[_t]* M_ gyz[_t]* M_ gyz[_t]; - M_ gupxx[_t]= ( M_ gyy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gyz[_t]) / M_ gupzz[_t]; - M_ gupxy[_t]= - ( M_ gxy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupxz[_t]= ( M_ gxy[_t]* M_ gyz[_t]- M_ gyy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupyy[_t]= ( M_ gxx[_t]* M_ gzz[_t]- M_ gxz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupyz[_t]= - ( M_ gxx[_t]* M_ gyz[_t]- M_ gxy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupzz[_t]= ( M_ gxx[_t]* M_ gyy[_t]- M_ gxy[_t]* M_ gxy[_t]) / M_ gupzz[_t]; - //if(threadIdx.x == 0){ - // judge = co_c; - //} - //__syncthreads(); - - if(co_c == 0) - { - // M_ Gam^i_Res = M_ Gam^i + M_ gup^ij_,j - M_ Gmx_Res[_t] = M_ Gamx[_t] - (M_ gupxx[_t]*(M_ gupxx[_t]*M_ gxxx[_t]+M_ gupxy[_t]*M_ gxyx[_t]+M_ gupxz[_t]*M_ gxzx[_t]) - +M_ gupxy[_t]*(M_ gupxx[_t]*M_ gxyx[_t]+M_ gupxy[_t]*M_ gyyx[_t]+M_ gupxz[_t]*M_ gyzx[_t]) - +M_ gupxz[_t]*(M_ gupxx[_t]*M_ gxzx[_t]+M_ gupxy[_t]*M_ gyzx[_t]+M_ gupxz[_t]*M_ gzzx[_t]) - +M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) - +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) - +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) - +M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) - +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); - M_ Gmy_Res[_t] = M_ Gamy[_t] - (M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxx[_t]+M_ gupyy[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gxzx[_t]) - +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyx[_t]+M_ gupyy[_t]*M_ gyyx[_t]+M_ gupyz[_t]*M_ gyzx[_t]) - +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzx[_t]+M_ gupyy[_t]*M_ gyzx[_t]+M_ gupyz[_t]*M_ gzzx[_t]) - +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) - +M_ gupyy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) - +M_ gupyz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) - +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) - +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); - M_ Gmz_Res[_t] = M_ Gamz[_t] - (M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxx[_t]+M_ gupyz[_t]*M_ gxyx[_t]+M_ gupzz[_t]*M_ gxzx[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gyyx[_t]+M_ gupzz[_t]*M_ gyzx[_t]) - +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzx[_t]+M_ gupyz[_t]*M_ gyzx[_t]+M_ gupzz[_t]*M_ gzzx[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxy[_t]+M_ gupyz[_t]*M_ gxyy[_t]+M_ gupzz[_t]*M_ gxzy[_t]) - +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gyyy[_t]+M_ gupzz[_t]*M_ gyzy[_t]) - +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzy[_t]+M_ gupyz[_t]*M_ gyzy[_t]+M_ gupzz[_t]*M_ gzzy[_t]) - +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) - +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) - +M_ gupzz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); - }//if(co == 0) - - // second kind of connection - M_ Gamxxx[_t]=HALF*( M_ gupxx[_t]*M_ gxxx[_t]+ M_ gupxy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupxz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); - M_ Gamyxx[_t]=HALF*( M_ gupxy[_t]*M_ gxxx[_t]+ M_ gupyy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupyz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); - M_ Gamzxx[_t]=HALF*( M_ gupxz[_t]*M_ gxxx[_t]+ M_ gupyz[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupzz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); - - M_ Gamxyy[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupxy[_t]*M_ gyyy[_t]+ M_ gupxz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); - M_ Gamyyy[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupyz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); - M_ Gamzyy[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyz[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); - - M_ Gamxzz[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupxy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupxz[_t]*M_ gzzz[_t]); - M_ Gamyzz[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupyz[_t]*M_ gzzz[_t]); - M_ Gamzzz[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyz[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupzz[_t]*M_ gzzz[_t]); - - M_ Gamxxy[_t]=HALF*( M_ gupxx[_t]*M_ gxxy[_t]+ M_ gupxy[_t]*M_ gyyx[_t]+ M_ gupxz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); - M_ Gamyxy[_t]=HALF*( M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupyy[_t]*M_ gyyx[_t]+ M_ gupyz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); - M_ Gamzxy[_t]=HALF*( M_ gupxz[_t]*M_ gxxy[_t]+ M_ gupyz[_t]*M_ gyyx[_t]+ M_ gupzz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); - - M_ Gamxxz[_t]=HALF*( M_ gupxx[_t]*M_ gxxz[_t]+ M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupxz[_t]*M_ gzzx[_t]); - M_ Gamyxz[_t]=HALF*( M_ gupxy[_t]*M_ gxxz[_t]+ M_ gupyy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupyz[_t]*M_ gzzx[_t]); - M_ Gamzxz[_t]=HALF*( M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupzz[_t]*M_ gzzx[_t]); - - M_ Gamxyz[_t]=HALF*( M_ gupxx[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupxy[_t]*M_ gyyz[_t]+ M_ gupxz[_t]*M_ gzzy[_t]); - M_ Gamyyz[_t]=HALF*( M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyy[_t]*M_ gyyz[_t]+ M_ gupyz[_t]*M_ gzzy[_t]); - M_ Gamzyz[_t]=HALF*( M_ gupxz[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyz[_t]*M_ gyyz[_t]+ M_ gupzz[_t]*M_ gzzy[_t]); - // Raise indices of \tilde A_{ij} and store in R_ij - - M_ Rxx[_t]= M_ gupxx[_t]* M_ gupxx[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupxy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupxz[_t]* M_ Azz[_t]+ - 2*(M_ gupxx[_t]* M_ gupxy[_t]* M_ Axy[_t]+ M_ gupxx[_t]* M_ gupxz[_t]* M_ Axz[_t]+ M_ gupxy[_t]* M_ gupxz[_t]* M_ Ayz[_t]); - - M_ Ryy[_t]= M_ gupxy[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ - 2*(M_ gupxy[_t]* M_ gupyy[_t]* M_ Axy[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayz[_t]); - - M_ Rzz[_t]= M_ gupxz[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ - 2*(M_ gupxz[_t]* M_ gupyz[_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Ayz[_t]); - - M_ Rxy[_t]= M_ gupxx[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ - (M_ gupxx[_t]* M_ gupyy[_t] + M_ gupxy[_t]* M_ gupxy[_t])* M_ Axy[_t] + - (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupxy[_t])* M_ Axz[_t] + - (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupyy[_t])* M_ Ayz[_t]; - - M_ Rxz[_t]= M_ gupxx[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ - (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxy[_t]* M_ gupxz[_t])* M_ Axy[_t] + - (M_ gupxx[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupxz[_t])* M_ Axz[_t] + - (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; - - M_ Ryz[_t]= M_ gupxy[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ - (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupyy[_t]* M_ gupxz[_t])* M_ Axy[_t] + - (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupxz[_t])* M_ Axz[_t] + - (M_ gupyy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; - - // Right hand side for M_ Gam^i without shift terms... - - M_ Gamx_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxx[_t]+ M_ Lapy[_t] * M_ Rxy[_t]+ M_ Lapz[_t] * M_ Rxz[_t]) + - 2 * M_ alpn1[_t] * ( - -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxx[_t]+ M_ chiy[_t] * M_ Rxy[_t]+ M_ chiz[_t] * M_ Rxz[_t]) - - M_ gupxx[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - - M_ gupxy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - - M_ gupxz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + - M_ Gamxxx[_t]* M_ Rxx[_t]+ M_ Gamxyy[_t]* M_ Ryy[_t]+ M_ Gamxzz[_t]* M_ Rzz[_t] + - 2 * ( M_ Gamxxy[_t]* M_ Rxy[_t]+ M_ Gamxxz[_t]* M_ Rxz[_t]+ M_ Gamxyz[_t]* M_ Ryz[_t]) ); - - M_ Gamy_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxy[_t]+ M_ Lapy[_t] * M_ Ryy[_t]+ M_ Lapz[_t] * M_ Ryz[_t]) + - 2 * M_ alpn1[_t] * ( - -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxy[_t]+ M_ chiy[_t] * M_ Ryy[_t]+ M_ chiz[_t] * M_ Ryz[_t]) - - M_ gupxy[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - - M_ gupyy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - - M_ gupyz[_t]* ( F2o3 * M_ Kz [_t] + 8 * PI * M_ Sz[_t] ) + - M_ Gamyxx[_t]* M_ Rxx[_t]+ M_ Gamyyy[_t]* M_ Ryy[_t]+ M_ Gamyzz[_t]* M_ Rzz[_t] + - 2 * ( M_ Gamyxy[_t]* M_ Rxy[_t]+ M_ Gamyxz[_t]* M_ Rxz[_t]+ M_ Gamyyz[_t]* M_ Ryz[_t]) ); - - M_ Gamz_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxz[_t]+ M_ Lapy[_t] * M_ Ryz[_t]+ M_ Lapz[_t] * M_ Rzz[_t]) + - 2 * M_ alpn1[_t] * ( - -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxz[_t]+ M_ chiy[_t] * M_ Ryz[_t]+ M_ chiz[_t] * M_ Rzz[_t]) - - M_ gupxz[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - - M_ gupyz[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - - M_ gupzz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + - M_ Gamzxx[_t]* M_ Rxx[_t]+ M_ Gamzyy[_t]* M_ Ryy[_t]+ M_ Gamzzz[_t]* M_ Rzz[_t] + - 2 * ( M_ Gamzxy[_t]* M_ Rxy[_t]+ M_ Gamzxz[_t]* M_ Rxz[_t]+ M_ Gamzyz[_t]* M_ Ryz[_t]) ); - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_bssn_part3() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ fxx [_t]= M_ gxxx[_t]+ M_ gxyy[_t]+ M_ gxzz[_t]; - M_ fxy[_t]= M_ gxyx[_t]+ M_ gyyy[_t]+ M_ gyzz[_t]; - M_ fxz[_t]= M_ gxzx[_t]+ M_ gyzy[_t]+ M_ gzzz[_t]; - - M_ Gamxa[_t]= M_ gupxx [_t]* M_ Gamxxx [_t]+ M_ gupyy[_t]* M_ Gamxyy[_t]+ M_ gupzz[_t]* M_ Gamxzz[_t]+ - 2*( M_ gupxy[_t]* M_ Gamxxy[_t]+ M_ gupxz[_t]* M_ Gamxxz[_t]+ M_ gupyz[_t]* M_ Gamxyz[_t]); - M_ Gamya[_t]= M_ gupxx [_t]* M_ Gamyxx [_t]+ M_ gupyy[_t]* M_ Gamyyy[_t]+ M_ gupzz[_t]* M_ Gamyzz[_t]+ - 2*( M_ gupxy[_t]* M_ Gamyxy[_t]+ M_ gupxz[_t]* M_ Gamyxz[_t]+ M_ gupyz[_t]* M_ Gamyyz[_t]); - M_ Gamza[_t]= M_ gupxx [_t]* M_ Gamzxx [_t]+ M_ gupyy[_t]* M_ Gamzyy[_t]+ M_ gupzz[_t]* M_ Gamzzz[_t]+ - 2*( M_ gupxy[_t]* M_ Gamzxy[_t]+ M_ gupxz[_t]* M_ Gamzxz[_t]+ M_ gupyz[_t]* M_ Gamzyz[_t]); - - - - M_ Gamx_rhs[_t] = M_ Gamx_rhs[_t] + F2o3 * M_ Gamxa[_t]* M_ div_beta[_t] - - M_ Gamxa[_t]* M_ betaxx [_t]- M_ Gamya[_t]* M_ betaxy[_t]- M_ Gamza[_t]* M_ betaxz[_t] + - F1o3 * (M_ gupxx [_t]* M_ fxx [_t] + M_ gupxy[_t]* M_ fxy[_t] + M_ gupxz[_t]* M_ fxz[_t] ) + - M_ gupxx [_t]* M_ gxxx [_t] + M_ gupyy[_t]* M_ gyyx [_t] + M_ gupzz[_t]* M_ gzzx [_t] + - 2 * (M_ gupxy[_t]* M_ gxyx [_t] + M_ gupxz[_t]* M_ gxzx [_t] + M_ gupyz[_t]* M_ gyzx [_t] ); - - M_ Gamy_rhs[_t] = M_ Gamy_rhs[_t] + F2o3 * M_ Gamya[_t]* M_ div_beta[_t] - - M_ Gamxa[_t]* M_ betayx [_t]- M_ Gamya[_t]* M_ betayy[_t]- M_ Gamza[_t]* M_ betayz[_t] + - F1o3 * (M_ gupxy[_t]* M_ fxx [_t] + M_ gupyy[_t]* M_ fxy[_t] + M_ gupyz[_t]* M_ fxz[_t] ) + - M_ gupxx [_t]* M_ gxxy[_t] + M_ gupyy[_t]* M_ gyyy[_t] + M_ gupzz[_t]* M_ gzzy[_t] + - 2 * (M_ gupxy[_t]* M_ gxyy[_t] + M_ gupxz[_t]* M_ gxzy[_t] + M_ gupyz[_t]* M_ gyzy[_t] ); - - M_ Gamz_rhs[_t] = M_ Gamz_rhs[_t] + F2o3 * M_ Gamza[_t]* M_ div_beta[_t] - - M_ Gamxa[_t]* M_ betazx [_t]- M_ Gamya[_t]* M_ betazy[_t]- M_ Gamza[_t]* M_ betazz[_t] + - F1o3 * (M_ gupxz[_t]* M_ fxx [_t] + M_ gupyz[_t]* M_ fxy[_t] + M_ gupzz[_t]* M_ fxz[_t] ) + - M_ gupxx [_t]* M_ gxxz[_t] + M_ gupyy[_t]* M_ gyyz[_t] + M_ gupzz[_t]* M_ gzzz[_t] + - 2 * (M_ gupxy[_t]* M_ gxyz[_t] + M_ gupxz[_t]* M_ gxzz[_t] + M_ gupyz[_t]* M_ gyzz[_t] ) ; //rhs M_ for M_ Gam^i - - //first kind of connection stored in M_ gij,k - M_ gxxx [_t]= M_ gxx [_t]* M_ Gamxxx [_t]+ M_ gxy[_t]* M_ Gamyxx [_t]+ M_ gxz[_t]* M_ Gamzxx[_t]; - M_ gxyx [_t]= M_ gxx [_t]* M_ Gamxxy[_t]+ M_ gxy[_t]* M_ Gamyxy[_t]+ M_ gxz[_t]* M_ Gamzxy[_t]; - M_ gxzx [_t]= M_ gxx [_t]* M_ Gamxxz[_t]+ M_ gxy[_t]* M_ Gamyxz[_t]+ M_ gxz[_t]* M_ Gamzxz[_t]; - M_ gyyx [_t]= M_ gxx [_t]* M_ Gamxyy[_t]+ M_ gxy[_t]* M_ Gamyyy[_t]+ M_ gxz[_t]* M_ Gamzyy[_t]; - M_ gyzx [_t]= M_ gxx [_t]* M_ Gamxyz[_t]+ M_ gxy[_t]* M_ Gamyyz[_t]+ M_ gxz[_t]* M_ Gamzyz[_t]; - M_ gzzx [_t]= M_ gxx [_t]* M_ Gamxzz[_t]+ M_ gxy[_t]* M_ Gamyzz[_t]+ M_ gxz[_t]* M_ Gamzzz[_t]; - M_ gxxy[_t]= M_ gxy[_t]* M_ Gamxxx [_t]+ M_ gyy[_t]* M_ Gamyxx [_t]+ M_ gyz[_t]* M_ Gamzxx[_t]; - M_ gxyy[_t]= M_ gxy[_t]* M_ Gamxxy[_t]+ M_ gyy[_t]* M_ Gamyxy[_t]+ M_ gyz[_t]* M_ Gamzxy[_t]; - M_ gxzy[_t]= M_ gxy[_t]* M_ Gamxxz[_t]+ M_ gyy[_t]* M_ Gamyxz[_t]+ M_ gyz[_t]* M_ Gamzxz[_t]; - M_ gyyy[_t]= M_ gxy[_t]* M_ Gamxyy[_t]+ M_ gyy[_t]* M_ Gamyyy[_t]+ M_ gyz[_t]* M_ Gamzyy[_t]; - M_ gyzy[_t]= M_ gxy[_t]* M_ Gamxyz[_t]+ M_ gyy[_t]* M_ Gamyyz[_t]+ M_ gyz[_t]* M_ Gamzyz[_t]; - M_ gzzy[_t]= M_ gxy[_t]* M_ Gamxzz[_t]+ M_ gyy[_t]* M_ Gamyzz[_t]+ M_ gyz[_t]* M_ Gamzzz[_t]; - M_ gxxz[_t]= M_ gxz[_t]* M_ Gamxxx [_t]+ M_ gyz[_t]* M_ Gamyxx [_t]+ M_ gzz[_t]* M_ Gamzxx[_t]; - M_ gxyz[_t]= M_ gxz[_t]* M_ Gamxxy[_t]+ M_ gyz[_t]* M_ Gamyxy[_t]+ M_ gzz[_t]* M_ Gamzxy[_t]; - M_ gxzz[_t]= M_ gxz[_t]* M_ Gamxxz[_t]+ M_ gyz[_t]* M_ Gamyxz[_t]+ M_ gzz[_t]* M_ Gamzxz[_t]; - M_ gyyz[_t]= M_ gxz[_t]* M_ Gamxyy[_t]+ M_ gyz[_t]* M_ Gamyyy[_t]+ M_ gzz[_t]* M_ Gamzyy[_t]; - M_ gyzz[_t]= M_ gxz[_t]* M_ Gamxyz[_t]+ M_ gyz[_t]* M_ Gamyyz[_t]+ M_ gzz[_t]* M_ Gamzyz[_t]; - M_ gzzz[_t]= M_ gxz[_t]* M_ Gamxzz[_t]+ M_ gyz[_t]* M_ Gamyzz[_t]+ M_ gzz[_t]* M_ Gamzzz[_t]; - - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_bssn_part4() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ Rxx [_t]= - HALF *M_ Rxx [_t] + - M_ gxx [_t]* M_ Gamxx[_t] +M_ gxy[_t]* M_ Gamyx [_t] + M_ gxz[_t]* M_ Gamzx [_t]+ - M_ Gamxa[_t]*M_ gxxx [_t]+ M_ Gamya[_t]*M_ gxyx [_t]+ M_ Gamza[_t]*M_ gxzx [_t] + - M_ gupxx [_t]*( - 2*(M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxyx [_t]+ M_ Gamzxx [_t]*M_ gxzx[_t]) + - M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxxy[_t]+ M_ Gamzxx [_t]*M_ gxxz[_t])+ - M_ gupxy[_t]*( - 2*(M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gyyx [_t]+ M_ Gamzxx [_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx[_t]) + - M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxxy[_t]+ M_ Gamzxy[_t]*M_ gxxz[_t] + - M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ - M_ gupxz[_t]*( - 2*(M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gyzx [_t]+ M_ Gamzxx [_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx[_t]) + - M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxxy[_t]+ M_ Gamzxz[_t]*M_ gxxz[_t] + - M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ - M_ gupyy[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx[_t]) + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ - M_ gupyz[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx[_t]) + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ - M_ gupzz[_t]*( - 2*(M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx[_t]) + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]); - - M_ Ryy[_t]= - HALF *M_ Ryy[_t] + - M_ gxy[_t]* M_ Gamxy[_t]+ M_ gyy[_t]* M_ Gamyy[_t] + M_ gyz[_t]* M_ Gamzy[_t] + - M_ Gamxa[_t]*M_ gxyy[_t]+ M_ Gamya[_t]*M_ gyyy[_t]+ M_ Gamza[_t]*M_ gyzy[_t] + - M_ gupxx [_t]*( - 2*(M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t]) + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ - M_ gupxy[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gxxy[_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxzy[_t]) + - M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ - M_ gupxz[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t]) + - M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupyy[_t]*( - 2*(M_ Gamxyy[_t]*M_ gxyy[_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyzy[_t]) + - M_ Gamxyy[_t]*M_ gyyx [_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyyz[_t])+ - M_ gupyz[_t]*( - 2*(M_ Gamxyy[_t]*M_ gxzy[_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t]) + - M_ Gamxyz[_t]*M_ gyyx [_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyyz[_t] + - M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ - M_ gupzz[_t]*( - 2*(M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t]) + - M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]); - - M_ Rzz[_t]= - HALF *M_ Rzz[_t] + - M_ gxz[_t]* M_ Gamxz[_t] +M_ gyz[_t]* M_ Gamyz[_t] + M_ gzz[_t]* M_ Gamzz[_t] + - M_ Gamxa[_t]*M_ gxzz[_t]+ M_ Gamya[_t]*M_ gyzz[_t]+ M_ Gamza[_t]*M_ gzzz[_t] + - M_ gupxx [_t]*( - 2*(M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]) + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t])+ - M_ gupxy[_t]*( - 2*(M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t]) + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t])+ - M_ gupxz[_t]*( - 2*(M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxxz[_t]+ M_ Gamyzz[_t]*M_ gxyz[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t]) + - M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gxzy[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t])+ - M_ gupyy[_t]*( - 2*(M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]) + - M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t])+ - M_ gupyz[_t]*( - 2*(M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxyz[_t]+ M_ Gamyzz[_t]*M_ gyyz[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t]) + - M_ Gamxzz[_t]*M_ gyzx [_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t])+ - M_ gupzz[_t]*( - 2*(M_ Gamxzz[_t]*M_ gxzz[_t]+ M_ Gamyzz[_t]*M_ gyzz[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]) + - M_ Gamxzz[_t]*M_ gzzx [_t]+ M_ Gamyzz[_t]*M_ gzzy[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]); - - M_ Rxy[_t]= HALF*( -M_ Rxy[_t] + - M_ gxx [_t]* M_ Gamxy[_t]+ M_ gxy[_t]* M_ Gamyy[_t]+M_ gxz[_t]* M_ Gamzy[_t] + - M_ gxy[_t]* M_ Gamxx [_t]+ M_ gyy[_t]* M_ Gamyx [_t]+M_ gyz[_t]* M_ Gamzx [_t] + - M_ Gamxa[_t]*M_ gxyx [_t]+ M_ Gamya[_t]*M_ gyyx [_t]+ M_ Gamza[_t]*M_ gyzx [_t] + - M_ Gamxa[_t]*M_ gxxy[_t]+ M_ Gamya[_t]*M_ gxyy[_t]+ M_ Gamza[_t]*M_ gxzy[_t])+ - M_ gupxx [_t]*( - M_ Gamxxx [_t]*M_ gxxy[_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ - M_ gupxy[_t]*( - M_ Gamxxx [_t]*M_ gxyy[_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyzy[_t] + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t] + - M_ Gamxyy[_t]*M_ gxxx [_t]+ M_ Gamyyy[_t]*M_ gxyx [_t]+ M_ Gamzyy[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gyyx [_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyyz[_t])+ - M_ gupxz[_t]*( - M_ Gamxxx [_t]*M_ gxzy[_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gzzy[_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + - M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + - M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ - M_ gupyy[_t]*( - M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gyyx [_t]+ M_ Gamzyy[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ - M_ gupyz[_t]*( - M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + - M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gyzx [_t]+ M_ Gamzyy[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gyyx [_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyyz[_t] + - M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + - M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupzz[_t]*( - M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t]); - - M_ Rxz[_t]= HALF*( -M_ Rxz[_t] + - M_ gxx [_t]* M_ Gamxz[_t]+ M_ gxy[_t]* M_ Gamyz[_t]+M_ gxz[_t]* M_ Gamzz[_t] + - M_ gxz[_t]* M_ Gamxx [_t]+ M_ gyz[_t]* M_ Gamyx [_t]+M_ gzz[_t]* M_ Gamzx [_t] + - M_ Gamxa[_t]*M_ gxzx [_t]+ M_ Gamya[_t]*M_ gyzx [_t]+ M_ Gamza[_t]*M_ gzzx [_t] + - M_ Gamxa[_t]*M_ gxxz[_t]+ M_ Gamya[_t]*M_ gxyz[_t]+ M_ Gamza[_t]*M_ gxzz[_t])+ - M_ gupxx [_t]*( - M_ Gamxxx [_t]*M_ gxxz[_t]+ M_ Gamyxx [_t]*M_ gxyz[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ - M_ gupxy[_t]*( - M_ Gamxxx [_t]*M_ gxyz[_t]+ M_ Gamyxx [_t]*M_ gyyz[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t] + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + - M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + - M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ - M_ gupxz[_t]*( - M_ Gamxxx [_t]*M_ gxzz[_t]+ M_ Gamyxx [_t]*M_ gyzz[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t] + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + - M_ Gamxzz[_t]*M_ gxxx [_t]+ M_ Gamyzz[_t]*M_ gxyx [_t]+ M_ Gamzzz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gzzx [_t]+ M_ Gamyxx [_t]*M_ gzzy[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t])+ - M_ gupyy[_t]*( - M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupyz[_t]*( - M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + - M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + - M_ Gamxzz[_t]*M_ gxyx [_t]+ M_ Gamyzz[_t]*M_ gyyx [_t]+ M_ Gamzzz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ - M_ gupzz[_t]*( - M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gyzx [_t]+ M_ Gamzzz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t]); - - M_ Ryz[_t]= HALF*( -M_ Ryz[_t] + - M_ gxy[_t]* M_ Gamxz[_t]+M_ gyy[_t]* M_ Gamyz[_t]+M_ gyz[_t]* M_ Gamzz[_t] + - M_ gxz[_t]* M_ Gamxy[_t]+M_ gyz[_t]* M_ Gamyy[_t]+M_ gzz[_t]* M_ Gamzy[_t] + - M_ Gamxa[_t]*M_ gxzy[_t]+ M_ Gamya[_t]*M_ gyzy[_t]+ M_ Gamza[_t]*M_ gzzy[_t] + - M_ Gamxa[_t]*M_ gxyz[_t]+ M_ Gamya[_t]*M_ gyyz[_t]+ M_ Gamza[_t]*M_ gyzz[_t])+ - M_ gupxx [_t]*( - M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ - M_ gupxy[_t]*( - M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + - M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gxzy[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + - M_ Gamxyy[_t]*M_ gxxz[_t]+ M_ Gamyyy[_t]*M_ gxyz[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + - M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupxz[_t]*( - M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + - M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + - M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + - M_ Gamxzz[_t]*M_ gxxy[_t]+ M_ Gamyzz[_t]*M_ gxyy[_t]+ M_ Gamzzz[_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ - M_ gupyy[_t]*( - M_ Gamxyy[_t]*M_ gxyz[_t]+ M_ Gamyyy[_t]*M_ gyyz[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ - M_ gupyz[_t]*( - M_ Gamxyy[_t]*M_ gxzz[_t]+ M_ Gamyyy[_t]*M_ gyzz[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t] + - M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + - M_ Gamxzz[_t]*M_ gxyy[_t]+ M_ Gamyzz[_t]*M_ gyyy[_t]+ M_ Gamzzz[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gzzx [_t]+ M_ Gamyyy[_t]*M_ gzzy[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t])+ - M_ gupzz[_t]*( - M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxzy[_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t]); - - _t += STEP_SIZE; - } -} -__global__ void compute_rhs_bssn_part5() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx [_t]* M_ chix [_t]- M_ Gamyxx [_t]* M_ chiy[_t]- M_ Gamzxx [_t]* M_ chiz[_t]; - M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]* M_ chix [_t]- M_ Gamyxy[_t]* M_ chiy[_t]- M_ Gamzxy[_t]* M_ chiz[_t]; - M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]* M_ chix [_t]- M_ Gamyxz[_t]* M_ chiy[_t]- M_ Gamzxz[_t]* M_ chiz[_t]; - M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]* M_ chix [_t]- M_ Gamyyy[_t]* M_ chiy[_t]- M_ Gamzyy[_t]* M_ chiz[_t]; - M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]* M_ chix [_t]- M_ Gamyyz[_t]* M_ chiy[_t]- M_ Gamzyz[_t]* M_ chiz[_t]; - M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]* M_ chix [_t]- M_ Gamyzz[_t]* M_ chiy[_t]- M_ Gamzzz[_t]* M_ chiz[_t]; - // M_ Store D^l D_l M_ chi - 3/(2*M_ chi) D^l M_ chi D_l M_ chi inM_ f[_t] - - M_ f[_t] = M_ gupxx [_t]* (M_ fxx [_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chix [_t]) + - M_ gupyy[_t]* (M_ fyy[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiy[_t]) + - M_ gupzz[_t]* (M_ fzz[_t]- F3o2/M_ chin1[_t] * M_ chiz[_t]* M_ chiz[_t]) + - 2 *M_ gupxy[_t]* (M_ fxy[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiy[_t]) + - 2 *M_ gupxz[_t]* (M_ fxz[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiz[_t]) + - 2 *M_ gupyz[_t]* (M_ fyz[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiz[_t]); - // M_ Add M_ chi part toM_ Ricci tensor: - - M_ Rxx [_t]=M_ Rxx [_t]+ (M_ fxx [_t]- M_ chix[_t]*M_ chix[_t]/M_ chin1[_t]/2 +M_ gxx [_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Ryy[_t]=M_ Ryy[_t]+ (M_ fyy[_t]- M_ chiy[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gyy[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Rzz[_t]=M_ Rzz[_t]+ (M_ fzz[_t]- M_ chiz[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gzz[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Rxy[_t]=M_ Rxy[_t]+ (M_ fxy[_t]- M_ chix[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gxy[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Rxz[_t]=M_ Rxz[_t]+ (M_ fxz[_t]- M_ chix[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gxz[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Ryz[_t]=M_ Ryz[_t]+ (M_ fyz[_t]- M_ chiy[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gyz[_t]*M_ f[_t])/M_ chin1[_t]/2; - - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_bssn_part6() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ gxxx [_t]= (M_ gupxx [_t]* M_ chix [_t]+M_ gupxy[_t]* M_ chiy[_t]+M_ gupxz[_t]* M_ chiz[_t])/M_ chin1[_t]; - M_ gxxy[_t]= (M_ gupxy[_t]* M_ chix [_t]+M_ gupyy[_t]* M_ chiy[_t]+M_ gupyz[_t]* M_ chiz[_t])/M_ chin1[_t]; - M_ gxxz[_t]= (M_ gupxz[_t]* M_ chix [_t]+M_ gupyz[_t]* M_ chiy[_t]+M_ gupzz[_t]* M_ chiz[_t])/M_ chin1[_t]; - // nowM_ get physical second kind of connection - M_ Gamxxx [_t]= M_ Gamxxx [_t]- ( (M_ chix [_t]+ M_ chix[_t])/M_ chin1[_t] -M_ gxx [_t]*M_ gxxx [_t])*HALF; - M_ Gamyxx [_t]= M_ Gamyxx [_t]- ( -M_ gxx [_t]*M_ gxxy[_t])*HALF; - M_ Gamzxx [_t]= M_ Gamzxx [_t]- ( -M_ gxx [_t]*M_ gxxz[_t])*HALF; - M_ Gamxyy[_t]= M_ Gamxyy[_t]- ( -M_ gyy[_t]*M_ gxxx [_t])*HALF; - M_ Gamyyy[_t]= M_ Gamyyy[_t]- ( (M_ chiy[_t]+ M_ chiy[_t])/M_ chin1[_t] -M_ gyy[_t]*M_ gxxy[_t])*HALF; - M_ Gamzyy[_t]= M_ Gamzyy[_t]- ( -M_ gyy[_t]*M_ gxxz[_t])*HALF; - M_ Gamxzz[_t]= M_ Gamxzz[_t]- ( -M_ gzz[_t]*M_ gxxx [_t])*HALF; - M_ Gamyzz[_t]= M_ Gamyzz[_t]- ( -M_ gzz[_t]*M_ gxxy[_t])*HALF; - M_ Gamzzz[_t]= M_ Gamzzz[_t]- ( (M_ chiz[_t]+ M_ chiz[_t])/M_ chin1[_t] -M_ gzz[_t]*M_ gxxz[_t])*HALF; - M_ Gamxxy[_t]= M_ Gamxxy[_t]- ( M_ chiy[_t] /M_ chin1[_t] -M_ gxy[_t]*M_ gxxx [_t])*HALF; - M_ Gamyxy[_t]= M_ Gamyxy[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxy[_t]*M_ gxxy[_t])*HALF; - M_ Gamzxy[_t]= M_ Gamzxy[_t]- ( -M_ gxy[_t]*M_ gxxz[_t])*HALF; - M_ Gamxxz[_t]= M_ Gamxxz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gxz[_t]*M_ gxxx [_t])*HALF; - M_ Gamyxz[_t]= M_ Gamyxz[_t]- ( -M_ gxz[_t]*M_ gxxy[_t])*HALF; - M_ Gamzxz[_t]= M_ Gamzxz[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxz[_t]*M_ gxxz[_t])*HALF; - M_ Gamxyz[_t]= M_ Gamxyz[_t]- ( -M_ gyz[_t]*M_ gxxx [_t])*HALF; - M_ Gamyyz[_t]= M_ Gamyyz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gyz[_t]*M_ gxxy[_t])*HALF; - M_ Gamzyz[_t]= M_ Gamzyz[_t]- ( M_ chiy[_t]/M_ chin1[_t] -M_ gyz[_t]*M_ gxxz[_t])*HALF; - - M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx[_t]*M_ Lapx [_t]- M_ Gamyxx[_t]*M_ Lapy[_t]- M_ Gamzxx[_t]*M_ Lapz[_t]; - M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]*M_ Lapx [_t]- M_ Gamyyy[_t]*M_ Lapy[_t]- M_ Gamzyy[_t]*M_ Lapz[_t]; - M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]*M_ Lapx [_t]- M_ Gamyzz[_t]*M_ Lapy[_t]- M_ Gamzzz[_t]*M_ Lapz[_t]; - M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]*M_ Lapx [_t]- M_ Gamyxy[_t]*M_ Lapy[_t]- M_ Gamzxy[_t]*M_ Lapz[_t]; - M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]*M_ Lapx [_t]- M_ Gamyxz[_t]*M_ Lapy[_t]- M_ Gamzxz[_t]*M_ Lapz[_t]; - M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]*M_ Lapx [_t]- M_ Gamyyz[_t]*M_ Lapy[_t]- M_ Gamzyz[_t]*M_ Lapz[_t]; - - // store D^i D_i Lap in M_ trK_rhs[_t] upto M_ chi - M_ trK_rhs[_t] = M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ - 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]); - // M_ Add lapse and M_ S_ij parts toM_ Ricci tensor: - - //follow bam code - M_ S[_t] = M_ chin1[_t] * ( M_ gupxx[_t] * M_ Sxx[_t] + M_ gupyy[_t] * M_ Syy[_t] + M_ gupzz[_t] * M_ Szz[_t] + - - 2 * ( M_ gupxy[_t] * M_ Sxy[_t] + M_ gupxz[_t] * M_ Sxz[_t] + M_ gupyz[_t] * M_ Syz[_t] ) ); - - -M_ f[_t] = F2o3 * M_ trK[_t] * M_ trK[_t] -( - - M_ gupxx[_t] * ( - - M_ gupxx[_t] * M_ Axx[_t] * M_ Axx[_t] + M_ gupyy[_t] * M_ Axy[_t] * M_ Axy[_t] + M_ gupzz[_t] * M_ Axz[_t] * M_ Axz[_t] + - - 2 * (M_ gupxy[_t] * M_ Axx[_t] * M_ Axy[_t] + M_ gupxz[_t] * M_ Axx[_t] * M_ Axz[_t] + M_ gupyz[_t] * M_ Axy[_t] * M_ Axz[_t]) ) + - - M_ gupyy[_t] * ( - - M_ gupxx[_t] * M_ Axy[_t] * M_ Axy[_t] + M_ gupyy[_t] * M_ Ayy[_t] * M_ Ayy[_t] + M_ gupzz[_t] * M_ Ayz[_t] * M_ Ayz[_t] + - - 2 * (M_ gupxy[_t] * M_ Axy[_t] * M_ Ayy[_t] + M_ gupxz[_t] * M_ Axy[_t] * M_ Ayz[_t] + M_ gupyz[_t] * M_ Ayy[_t] * M_ Ayz[_t]) ) + - - M_ gupzz[_t] * ( - - M_ gupxx[_t] * M_ Axz[_t] * M_ Axz[_t] + M_ gupyy[_t] * M_ Ayz[_t] * M_ Ayz[_t] + M_ gupzz[_t] * M_ Azz[_t] * M_ Azz[_t] + - - 2 * (M_ gupxy[_t] * M_ Axz[_t] * M_ Ayz[_t] + M_ gupxz[_t] * M_ Axz[_t] * M_ Azz[_t] + M_ gupyz[_t] * M_ Ayz[_t] * M_ Azz[_t]) ) + - - 2 * ( - - M_ gupxy[_t] * ( - - M_ gupxx[_t] * M_ Axx[_t] * M_ Axy[_t] + M_ gupyy[_t] * M_ Axy[_t] * M_ Ayy[_t] + M_ gupzz[_t] * M_ Axz[_t] * M_ Ayz[_t] + - - M_ gupxy[_t] * (M_ Axx[_t] * M_ Ayy[_t] + M_ Axy[_t] * M_ Axy[_t]) + - - M_ gupxz[_t] * (M_ Axx[_t] * M_ Ayz[_t] + M_ Axz[_t] * M_ Axy[_t]) + - - M_ gupyz[_t] * (M_ Axy[_t] * M_ Ayz[_t] + M_ Axz[_t] * M_ Ayy[_t]) ) + - - M_ gupxz[_t] * ( - - M_ gupxx[_t] * M_ Axx[_t] * M_ Axz[_t] + M_ gupyy[_t] * M_ Axy[_t] * M_ Ayz[_t] + M_ gupzz[_t] * M_ Axz[_t] * M_ Azz[_t] + - - M_ gupxy[_t] * (M_ Axx[_t] * M_ Ayz[_t] + M_ Axy[_t] * M_ Axz[_t]) + - - M_ gupxz[_t] * (M_ Axx[_t] * M_ Azz[_t] + M_ Axz[_t] * M_ Axz[_t]) + - - M_ gupyz[_t] * (M_ Axy[_t] * M_ Azz[_t] + M_ Axz[_t] * M_ Ayz[_t]) ) + - - M_ gupyz[_t] * ( - - M_ gupxx[_t] * M_ Axy[_t] * M_ Axz[_t] + M_ gupyy[_t] * M_ Ayy[_t] * M_ Ayz[_t] + M_ gupzz[_t] * M_ Ayz[_t] * M_ Azz[_t] + - - M_ gupxy[_t] * (M_ Axy[_t] * M_ Ayz[_t] + M_ Ayy[_t] * M_ Axz[_t]) + - - M_ gupxz[_t] * (M_ Axy[_t] * M_ Azz[_t] + M_ Ayz[_t] * M_ Axz[_t]) + - - M_ gupyz[_t] * (M_ Ayy[_t] * M_ Azz[_t] + M_ Ayz[_t] * M_ Ayz[_t]) ) )) -16 * PI * M_ rho[_t] + 8 * PI * M_ S[_t]; - - - M_ f[_t] = - F1o3 *( M_ gupxx[_t] * M_ fxx[_t] + M_ gupyy[_t] * M_ fyy[_t] + M_ gupzz[_t] * M_ fzz[_t] + - - 2* ( M_ gupxy[_t] * M_ fxy[_t] + M_ gupxz[_t] * M_ fxz[_t] + M_ gupyz[_t] * M_ fyz[_t] ) + M_ alpn1[_t] / M_ chin1[_t] * M_ f[_t]); - - - - M_ fxx[_t] = M_ alpn1[_t] * (M_ Rxx[_t] - 8 * PI * M_ Sxx[_t]) - M_ fxx[_t]; - - M_ fxy[_t] = M_ alpn1[_t] * (M_ Rxy[_t] - 8 * PI * M_ Sxy[_t]) - M_ fxy[_t]; - - M_ fxz[_t] = M_ alpn1[_t] * (M_ Rxz[_t] - 8 * PI * M_ Sxz[_t]) - M_ fxz[_t]; - - M_ fyy[_t] = M_ alpn1[_t] * (M_ Ryy[_t] - 8 * PI * M_ Syy[_t]) - M_ fyy[_t]; - - M_ fyz[_t] = M_ alpn1[_t] * (M_ Ryz[_t] - 8 * PI * M_ Syz[_t]) - M_ fyz[_t]; - - M_ fzz[_t] = M_ alpn1[_t] * (M_ Rzz[_t] - 8 * PI * M_ Szz[_t]) - M_ fzz[_t]; - /* - M_ fxx [_t]= M_ alpn1[_t]* (M_ Rxx [_t]- 8 * PI * M_ Sxx[_t]) -M_ fxx[_t]; - M_ fxy[_t]= M_ alpn1[_t]* (M_ Rxy[_t]- 8 * PI * M_ Sxy[_t]) -M_ fxy[_t]; - M_ fxz[_t]= M_ alpn1[_t]* (M_ Rxz[_t]- 8 * PI * M_ Sxz[_t]) -M_ fxz[_t]; - M_ fyy[_t]= M_ alpn1[_t]* (M_ Ryy[_t]- 8 * PI * M_ Syy[_t]) -M_ fyy[_t]; - M_ fyz[_t]= M_ alpn1[_t]* (M_ Ryz[_t]- 8 * PI * M_ Syz[_t]) -M_ fyz[_t]; - M_ fzz[_t]= M_ alpn1[_t]* (M_ Rzz[_t]- 8 * PI * M_ Szz[_t]) -M_ fzz[_t]; - - // Compute trace-free part (note: M_ chi^-1 and M_ chi cancel//): - - M_ f[_t] = F1o3 *( M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ - 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) ); - */ - M_ Axx_rhs[_t] =M_ fxx [_t]-M_ gxx [_t]*M_ f[_t]; - M_ Ayy_rhs[_t] =M_ fyy[_t]-M_ gyy[_t]*M_ f[_t]; - M_ Azz_rhs[_t] =M_ fzz[_t]-M_ gzz[_t]*M_ f[_t]; - M_ Axy_rhs[_t] =M_ fxy[_t]-M_ gxy[_t]*M_ f[_t]; - M_ Axz_rhs[_t] =M_ fxz[_t]-M_ gxz[_t]*M_ f[_t]; - M_ Ayz_rhs[_t] =M_ fyz[_t]-M_ gyz[_t]*M_ f[_t]; - - // Now: store M_ A_il M_ A^l_j intoM_ fij: - - M_ fxx [_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]); - - M_ fyy[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]); - - M_ fzz[_t]= M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]); - - M_ fxy[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ - M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + - M_ gupxz[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + - M_ gupyz[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]); - M_ fxz[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]*(M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]); - M_ fyz[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]*(M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]); - - M_ f[_t] = M_ chin1[_t]; - // store D^i D_i Lap in M_ trK_rhs[_t] - M_ trK_rhs[_t] =M_ f[_t]*M_ trK_rhs[_t]; - - M_ Axx_rhs[_t] = M_ f[_t] * M_ Axx_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Axx [_t]- 2 *M_ fxx[_t]) + - 2 * ( M_ Axx [_t]* M_ betaxx [_t]+ M_ Axy[_t]* M_ betayx [_t]+ M_ Axz[_t]* M_ betazx [_t])- - F2o3 * M_ Axx [_t]* M_ div_beta[_t]; - - M_ Ayy_rhs[_t] = M_ f[_t] * M_ Ayy_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Ayy[_t]- 2 *M_ fyy[_t]) + - 2 * ( M_ Axy[_t]* M_ betaxy[_t]+ M_ Ayy[_t]* M_ betayy[_t]+ M_ Ayz[_t]* M_ betazy[_t])- - F2o3 * M_ Ayy[_t]* M_ div_beta[_t]; - - M_ Azz_rhs[_t] = M_ f[_t] * M_ Azz_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Azz[_t]- 2 *M_ fzz[_t]) + - 2 * ( M_ Axz[_t]* M_ betaxz[_t]+ M_ Ayz[_t]* M_ betayz[_t]+ M_ Azz[_t]* M_ betazz[_t])- - F2o3 * M_ Azz[_t]* M_ div_beta[_t]; - - M_ Axy_rhs[_t] = M_ f[_t] * M_ Axy_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axy[_t] - 2 *M_ fxy[_t])+ - M_ Axx [_t]* M_ betaxy[_t] + M_ Axz[_t]* M_ betazy[_t] + - M_ Ayy[_t]* M_ betayx [_t]+ M_ Ayz[_t]* M_ betazx [_t] + - F1o3 * M_ Axy[_t]* M_ div_beta[_t] - M_ Axy[_t]* M_ betazz[_t]; - - M_ Ayz_rhs[_t] = M_ f[_t] * M_ Ayz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Ayz[_t] - 2 *M_ fyz[_t])+ - M_ Axy[_t]* M_ betaxz[_t]+ M_ Ayy[_t]* M_ betayz[_t] + - M_ Axz[_t]* M_ betaxy[_t] + M_ Azz[_t]* M_ betazy[_t] + - F1o3 * M_ Ayz[_t]* M_ div_beta[_t] - M_ Ayz[_t]* M_ betaxx[_t]; - - M_ Axz_rhs[_t] = M_ f[_t] * M_ Axz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axz[_t] - 2 *M_ fxz[_t])+ - M_ Axx [_t]* M_ betaxz[_t]+ M_ Axy[_t]* M_ betayz[_t] + - M_ Ayz[_t]* M_ betayx [_t]+ M_ Azz[_t]* M_ betazx [_t] + - F1o3 * M_ Axz[_t]* M_ div_beta[_t] - M_ Axz[_t]* M_ betayy[_t] ; //rhsM_ for M_ Aij - - // Compute trace of M_ S_ij - - M_ S[_t] = M_ f[_t] * (M_ gupxx [_t]* M_ Sxx [_t]+M_ gupyy[_t]* M_ Syy[_t]+M_ gupzz[_t]* M_ Szz[_t]+ - 2 * (M_ gupxy[_t]* M_ Sxy[_t]+M_ gupxz[_t]* M_ Sxz[_t]+M_ gupyz[_t]* M_ Syz[_t]) ); - - M_ trK_rhs[_t] = - M_ trK_rhs[_t] + M_ alpn1[_t]*( F1o3 * M_ trK[_t]* M_ trK[_t] + - M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t] + - 2 * (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) + - 4 * PI * ( M_ rho[_t] + M_ S[_t] )) ; //rhsM_ for M_ trK[_t] - - ////////M_ gauge variable part - - M_ Lap_rhs[_t] = -2*M_ alpn1[_t] * M_ trK[_t]; - -#if (GAUGE == 0) - M_ betax_rhs[_t] =0.75*M_ dtSfx[_t]; - M_ betay_rhs[_t] =0.75*M_ dtSfy[_t]; - M_ betaz_rhs[_t] =0.75*M_ dtSfz[_t]; - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] -2*M_ dtSfx[_t]; - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] -2*M_ dtSfy[_t]; - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] -2*M_ dtSfz[_t]; - -#elif (GAUGE == 1) - M_ betax_rhs[_t] =M_ Gamx[_t] - 2 * M_ betax[_t] ; - - M_ betay_rhs[_t] =M_ Gamy[_t] - 2 * M_ betay[_t] ; - - M_ betaz_rhs[_t] =M_ Gamz[_t] - 2 * M_ betaz[_t] ; - - M_ dtSfx_rhs[_t] = 0; - M_ dtSfy_rhs[_t] = 0; - M_ dtSfz_rhs[_t] = 0; - -#elif (GAUGE == 2 || GAUGE == 3) - - M_ betax_rhs[_t] = 0.75* M_ dtSfx[_t]; - - M_ betay_rhs[_t] = 0.75* M_ dtSfy[_t]; - - M_ betaz_rhs[_t] = 0.75* M_ dtSfz[_t]; - -#elif (GAUGE == 6) - if(BHN==2) - { - int k = _t / _2D_SIZE[0]; - int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - r1 = ( pow2((Porg[0]-X[i]))+ pow2((Porg[1]-Y[j]))+ pow2((Porg[2]-Z[k])) ) / - - ( pow2((Porg[0]-Porg[3]))+ pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ - - ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - reta[i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1/(1 + 12 * r1) + C2/(1 + 12 *r2); - }//BHN == 2 - - M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; - - M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; - - M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; - - - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t] * M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t] * M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t] * M_ dtSfz[_t]; - -#elif (GAUGE == 7) - if(BHN==2){ - int k = _t / _2D_SIZE[0]; - int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - r1 = ( pow2((Porg[0]-X[i])) + pow2((Porg[1]-Y[j])) + pow2((Porg[2]-Z[k])) )/ - - ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ - - ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - M_ reta[_t][i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1* exp(-12 *r1) + C2*exp(- 12*r2); - }//BHN ==2 - - M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; - - M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; - - M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; - - - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]*M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]*M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]*M_ dtSfz[_t]; - -#endif //if (GAUGE == ?) - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_bssn_part6_gauge() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { -#if (GAUGE == 2) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow2( ( 1-sqrt(M_ chin1[_t]) ) ); - - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; - -#elif (GAUGE == 3) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] - + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + - M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + - M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13/2 * sqrt( M_ reta[_t]/ M_ chin1[_t])/ pow2((1-M_ chin1[_t])); - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; - -#elif (GAUGE == 4) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * - M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * - M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow( (1-sqrt(M_ chin1[_t]))); - - - M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; - - M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; - - M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; - -#elif (GAUGE == 5) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1)/ pow( (1-M_ chin1[_t]) ); - - M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; - - M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; - - M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; - - - - M_ dtSfx_rhs[_t] = 0; - - M_ dtSfy_rhs[_t] = 0; - - M_ dtSfz_rhs[_t] = 0; -#endif - _t += STEP_SIZE; - } -} -__global__ void compute_rhs_bssn_part7() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ ham_Res[_t] = M_ gupxx [_t]* M_ Rxx [_t]+ M_ gupyy[_t]* M_ Ryy[_t]+ M_ gupzz[_t]* M_ Rzz[_t]+ - 2* ( M_ gupxy[_t]* M_ Rxy[_t]+ M_ gupxz[_t]* M_ Rxz[_t]+ M_ gupyz[_t]* M_ Ryz[_t]); - - M_ ham_Res[_t] = M_ chin1[_t]*M_ ham_Res[_t] + F2o3 * M_ trK[_t] * M_ trK[_t] -( - M_ gupxx [_t]* ( - M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]) ) + - M_ gupyy[_t]* ( - M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]) ) + - M_ gupzz[_t]* ( - M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+ M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+ M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]) ) + - 2 * ( - M_ gupxy[_t]* ( - M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ - M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + - M_ gupxz[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + - M_ gupyz[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]) ) + - M_ gupxz[_t]* ( - M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]* (M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]) ) + - M_ gupyz[_t]* ( - M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]* (M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]) ) ))- 16 * PI * M_ rho[_t]; - - _t += STEP_SIZE; - } -} -__global__ void compute_rhs_bssn_part8() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ gxxx [_t]= M_ gxxx [_t]- ( M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t] - + M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t]) - M_ chix[_t]*M_ Axx[_t]/M_ chin1[_t]; - - M_ gxyx [_t]= M_ gxyx [_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] - + M_ Gamxxx [_t]* M_ Axy[_t]+ M_ Gamyxx [_t]* M_ Ayy[_t]+ M_ Gamzxx [_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Axy[_t]/M_ chin1[_t]; - - M_ gxzx [_t]= M_ gxzx [_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] - + M_ Gamxxx [_t]* M_ Axz[_t]+ M_ Gamyxx [_t]* M_ Ayz[_t]+ M_ Gamzxx [_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Axz[_t]/M_ chin1[_t]; - - M_ gyyx [_t]= M_ gyyx [_t]- ( M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t] - + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Ayy[_t]/M_ chin1[_t]; - - M_ gyzx [_t]= M_ gyzx [_t]- ( M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t] - + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Ayz[_t]/M_ chin1[_t]; - - M_ gzzx [_t]= M_ gzzx [_t]- ( M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t] - + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Azz[_t]/M_ chin1[_t]; - - M_ gxxy[_t]= M_ gxxy[_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] - + M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t]) - M_ chiy[_t]*M_ Axx[_t]/M_ chin1[_t]; - - M_ gxyy[_t]= M_ gxyy[_t]- ( M_ Gamxyy[_t]* M_ Axx [_t]+ M_ Gamyyy[_t]* M_ Axy[_t]+ M_ Gamzyy[_t]* M_ Axz[_t] - + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Axy[_t]/M_ chin1[_t]; - - M_ gxzy[_t]= M_ gxzy[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] - + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Axz[_t]/M_ chin1[_t]; - - M_ gyyy[_t]= M_ gyyy[_t]- ( M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t] - + M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Ayy[_t]/M_ chin1[_t]; - - M_ gyzy[_t]= M_ gyzy[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] - + M_ Gamxyy[_t]* M_ Axz[_t]+ M_ Gamyyy[_t]* M_ Ayz[_t]+ M_ Gamzyy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Ayz[_t]/M_ chin1[_t]; - - M_ gzzy[_t]= M_ gzzy[_t]- ( M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t] - + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Azz[_t]/M_ chin1[_t]; - - M_ gxxz[_t]= M_ gxxz[_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] - + M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t]) - M_ chiz[_t]*M_ Axx[_t]/M_ chin1[_t]; - - M_ gxyz[_t]= M_ gxyz[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] - + M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Axy[_t]/M_ chin1[_t]; - - M_ gxzz[_t]= M_ gxzz[_t]- ( M_ Gamxzz[_t]* M_ Axx [_t]+ M_ Gamyzz[_t]* M_ Axy[_t]+ M_ Gamzzz[_t]* M_ Axz[_t] - + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Axz[_t]/M_ chin1[_t]; - - M_ gyyz[_t]= M_ gyyz[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] - + M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Ayy[_t]/M_ chin1[_t]; - - M_ gyzz[_t]= M_ gyzz[_t]- ( M_ Gamxzz[_t]* M_ Axy[_t]+ M_ Gamyzz[_t]* M_ Ayy[_t]+ M_ Gamzzz[_t]* M_ Ayz[_t] - + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Ayz[_t]/M_ chin1[_t]; - - M_ gzzz[_t]= M_ gzzz[_t]- ( M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t] - + M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Azz[_t]/M_ chin1[_t]; - - M_ movx_Res[_t] = M_ gupxx[_t]*M_ gxxx [_t]+ M_ gupyy[_t]*M_ gxyy[_t]+ M_ gupzz[_t]*M_ gxzz[_t] - +M_ gupxy[_t]*M_ gxyx [_t]+ M_ gupxz[_t]*M_ gxzx [_t]+ M_ gupyz[_t]*M_ gxzy[_t] - +M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*M_ gxyz[_t]; - M_ movy_Res[_t] = M_ gupxx[_t]*M_ gxyx [_t]+ M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*M_ gyzz[_t] - +M_ gupxy[_t]*M_ gyyx [_t]+ M_ gupxz[_t]*M_ gyzx [_t]+ M_ gupyz[_t]*M_ gyzy[_t] - +M_ gupxy[_t]*M_ gxyy[_t]+ M_ gupxz[_t]*M_ gxyz[_t]+ M_ gupyz[_t]*M_ gyyz[_t]; - - M_ movz_Res[_t] = M_ gupxx[_t]*M_ gxzx [_t]+ M_ gupyy[_t]*M_ gyzy[_t]+ M_ gupzz[_t]*M_ gzzz[_t] - +M_ gupxy[_t]*M_ gyzx [_t]+ M_ gupxz[_t]*M_ gzzx [_t]+ M_ gupyz[_t]*M_ gzzy[_t] - +M_ gupxy[_t]*M_ gxzy[_t]+ M_ gupxz[_t]*M_ gxzz[_t]+ M_ gupyz[_t]*M_ gyzz[_t]; - - M_ movx_Res[_t] = M_ movx_Res[_t] - F2o3*M_ Kx [_t]- 8*PI*M_ Sx[_t]; - M_ movy_Res[_t] = M_ movy_Res[_t] - F2o3*M_ Ky[_t]- 8*PI*M_ Sy[_t]; - M_ movz_Res[_t] = M_ movz_Res[_t] - F2o3*M_ Kz[_t]- 8*PI*M_ Sz[_t]; - - _t += STEP_SIZE; - } -} - - - -__global__ void device_test(double * result, double * Xt){ - /*result[0] = MAXSIZE; - result[1] = STEP; - result[2] = ex_c[0]; - result[3] = ex_c[1]; - result[4] = ex_c[2]; - result[5] = Xt[0]; - result[6] = Xt[1]; - result[7] = metac.X[0]; - result[8] = metac.X[1]; */ - - result[0] = metac.gzz[0]; - result[1] = metac.gzz[1]; - result[2] = metac.gzz[2]; - result[3] = metac.gyy[0]; - result[4] = metac.gyy[1]; - result[5] = metac.gyy[2]; - result[6] = _3D_SIZE[0]; - result[7] = STEP_SIZE; - result[8] = blockDim.x * gridDim.x; -} - -void destroy_meta(Meta *meta) -{ - /* - if(Mh_ X) CUDA_SAFE_CALL(cudaFree(Mh_ X)); - if(Mh_ Y) CUDA_SAFE_CALL(cudaFree(Mh_ Y)); - if(Mh_ Z) CUDA_SAFE_CALL(cudaFree(Mh_ Z)); - if(Mh_ chi) CUDA_SAFE_CALL(cudaFree(Mh_ chi)); - if(Mh_ dxx) CUDA_SAFE_CALL(cudaFree(Mh_ dxx)); - if(Mh_ dyy) CUDA_SAFE_CALL(cudaFree(Mh_ dyy)); - if(Mh_ dzz) CUDA_SAFE_CALL(cudaFree(Mh_ dzz)); - if(Mh_ trK) CUDA_SAFE_CALL(cudaFree(Mh_ trK)); - if(Mh_ gxy) CUDA_SAFE_CALL(cudaFree(Mh_ gxy)); - if(Mh_ gxz) CUDA_SAFE_CALL(cudaFree(Mh_ gxz)); - if(Mh_ gyz) CUDA_SAFE_CALL(cudaFree(Mh_ gyz)); - if(Mh_ Axx) CUDA_SAFE_CALL(cudaFree(Mh_ Axx)); - if(Mh_ Axy) CUDA_SAFE_CALL(cudaFree(Mh_ Axy)); - if(Mh_ Axz) CUDA_SAFE_CALL(cudaFree(Mh_ Axz)); - if(Mh_ Ayz) CUDA_SAFE_CALL(cudaFree(Mh_ Ayz)); - if(Mh_ Ayy) CUDA_SAFE_CALL(cudaFree(Mh_ Ayy)); - if(Mh_ Azz) CUDA_SAFE_CALL(cudaFree(Mh_ Azz)); - if(Mh_ Gamx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamx)); - if(Mh_ Gamy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamy)); - if(Mh_ Gamz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamz)); - if(Mh_ Lap) CUDA_SAFE_CALL(cudaFree(Mh_ Lap)); - if(Mh_ betax) CUDA_SAFE_CALL(cudaFree(Mh_ betax)); - if(Mh_ betay) CUDA_SAFE_CALL(cudaFree(Mh_ betay)); - if(Mh_ betaz) CUDA_SAFE_CALL(cudaFree(Mh_ betaz)); - if(Mh_ dtSfx) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfx)); - if(Mh_ dtSfy) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfy)); - if(Mh_ dtSfz) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfz)); - if(Mh_ chi_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ chi_rhs)); - if(Mh_ trK_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ trK_rhs)); - if(Mh_ gxy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gxy_rhs)); - if(Mh_ gxz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gxz_rhs)); - if(Mh_ gyz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gyz_rhs)); - if(Mh_ Axx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Axx_rhs)); - if(Mh_ Axy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Axy_rhs)); - if(Mh_ Axz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Axz_rhs)); - if(Mh_ Ayz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Ayz_rhs)); - if(Mh_ Ayy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Ayy_rhs)); - if(Mh_ Azz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Azz_rhs)); - if(Mh_ Gamx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Gamx_rhs)); - if(Mh_ Gamy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Gamy_rhs)); - if(Mh_ Gamz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Gamz_rhs)); - if(Mh_ Lap_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Lap_rhs)); - if(Mh_ betax_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ betax_rhs)); - if(Mh_ betay_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ betay_rhs)); - if(Mh_ betaz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ betaz_rhs)); - if(Mh_ dtSfx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfx_rhs)); - if(Mh_ dtSfy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfy_rhs)); - if(Mh_ dtSfz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfz_rhs)); - if(Mh_ rho) CUDA_SAFE_CALL(cudaFree(Mh_ rho)); - if(Mh_ Sx) CUDA_SAFE_CALL(cudaFree(Mh_ Sx)); - if(Mh_ Sy) CUDA_SAFE_CALL(cudaFree(Mh_ Sy)); - if(Mh_ Sz) CUDA_SAFE_CALL(cudaFree(Mh_ Sz)); - if(Mh_ Sxx) CUDA_SAFE_CALL(cudaFree(Mh_ Sxx)); - if(Mh_ Sxy) CUDA_SAFE_CALL(cudaFree(Mh_ Sxy)); - if(Mh_ Sxz) CUDA_SAFE_CALL(cudaFree(Mh_ Sxz)); - if(Mh_ Syz) CUDA_SAFE_CALL(cudaFree(Mh_ Syz)); - if(Mh_ Syy) CUDA_SAFE_CALL(cudaFree(Mh_ Syy)); - if(Mh_ Szz) CUDA_SAFE_CALL(cudaFree(Mh_ Szz)); - if(Mh_ Gamxxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxxx)); - if(Mh_ Gamxxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxxy)); - if(Mh_ Gamxxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxxz)); - if(Mh_ Gamxyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxyy)); - if(Mh_ Gamxyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxyz)); - if(Mh_ Gamxzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxzz)); - if(Mh_ Gamyxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyxx)); - if(Mh_ Gamyxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyxy)); - if(Mh_ Gamyxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyxz)); - if(Mh_ Gamyyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyyy)); - if(Mh_ Gamyyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyyz)); - if(Mh_ Gamyzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyzz)); - if(Mh_ Gamzxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzxx)); - if(Mh_ Gamzxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzxy)); - if(Mh_ Gamzxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzxz)); - if(Mh_ Gamzyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzyz)); - if(Mh_ Gamzyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzyy)); - if(Mh_ Gamzzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzzz)); - if(Mh_ Rxx) CUDA_SAFE_CALL(cudaFree(Mh_ Rxx)); - if(Mh_ Rxy) CUDA_SAFE_CALL(cudaFree(Mh_ Rxy)); - if(Mh_ Rxz) CUDA_SAFE_CALL(cudaFree(Mh_ Rxz)); - if(Mh_ Ryy) CUDA_SAFE_CALL(cudaFree(Mh_ Ryy)); - if(Mh_ Ryz) CUDA_SAFE_CALL(cudaFree(Mh_ Ryz)); - if(Mh_ Rzz) CUDA_SAFE_CALL(cudaFree(Mh_ Rzz)); - if(Mh_ ham_Res) CUDA_SAFE_CALL(cudaFree(Mh_ ham_Res)); - if(Mh_ movx_Res) CUDA_SAFE_CALL(cudaFree(Mh_ movx_Res)); - if(Mh_ movy_Res) CUDA_SAFE_CALL(cudaFree(Mh_ movy_Res)); - if(Mh_ movz_Res) CUDA_SAFE_CALL(cudaFree(Mh_ movz_Res)); - if(Mh_ Gmx_Res) CUDA_SAFE_CALL(cudaFree(Mh_ Gmx_Res)); - if(Mh_ Gmy_Res) CUDA_SAFE_CALL(cudaFree(Mh_ Gmy_Res)); - if(Mh_ Gmz_Res) CUDA_SAFE_CALL(cudaFree(Mh_ Gmz_Res)); - if(Mh_ gxx) CUDA_SAFE_CALL(cudaFree(Mh_ gxx)); - if(Mh_ gyy) CUDA_SAFE_CALL(cudaFree(Mh_ gyy)); - if(Mh_ gzz) CUDA_SAFE_CALL(cudaFree(Mh_ gzz)); - if(Mh_ chix) CUDA_SAFE_CALL(cudaFree(Mh_ chix)); - if(Mh_ chiy) CUDA_SAFE_CALL(cudaFree(Mh_ chiy)); - if(Mh_ chiz) CUDA_SAFE_CALL(cudaFree(Mh_ chiz)); - if(Mh_ gxxx) CUDA_SAFE_CALL(cudaFree(Mh_ gxxx)); - if(Mh_ gxyx) CUDA_SAFE_CALL(cudaFree(Mh_ gxyx)); - if(Mh_ gxzx) CUDA_SAFE_CALL(cudaFree(Mh_ gxzx)); - if(Mh_ gyyx) CUDA_SAFE_CALL(cudaFree(Mh_ gyyx)); - if(Mh_ gyzx) CUDA_SAFE_CALL(cudaFree(Mh_ gyzx)); - if(Mh_ gzzx) CUDA_SAFE_CALL(cudaFree(Mh_ gzzx)); - if(Mh_ gxxy) CUDA_SAFE_CALL(cudaFree(Mh_ gxxy)); - if(Mh_ gxyy) CUDA_SAFE_CALL(cudaFree(Mh_ gxyy)); - if(Mh_ gxzy) CUDA_SAFE_CALL(cudaFree(Mh_ gxzy)); - if(Mh_ gyyy) CUDA_SAFE_CALL(cudaFree(Mh_ gyyy)); - if(Mh_ gyzy) CUDA_SAFE_CALL(cudaFree(Mh_ gyzy)); - if(Mh_ gzzy) CUDA_SAFE_CALL(cudaFree(Mh_ gzzy)); - if(Mh_ gxxz) CUDA_SAFE_CALL(cudaFree(Mh_ gxxz)); - if(Mh_ gxyz) CUDA_SAFE_CALL(cudaFree(Mh_ gxyz)); - if(Mh_ gxzz) CUDA_SAFE_CALL(cudaFree(Mh_ gxzz)); - if(Mh_ gyyz) CUDA_SAFE_CALL(cudaFree(Mh_ gyyz)); - if(Mh_ gyzz) CUDA_SAFE_CALL(cudaFree(Mh_ gyzz)); - if(Mh_ gzzz) CUDA_SAFE_CALL(cudaFree(Mh_ gzzz)); - if(Mh_ Lapx) CUDA_SAFE_CALL(cudaFree(Mh_ Lapx)); - if(Mh_ Lapy) CUDA_SAFE_CALL(cudaFree(Mh_ Lapy)); - if(Mh_ Lapz) CUDA_SAFE_CALL(cudaFree(Mh_ Lapz)); - if(Mh_ betaxx) CUDA_SAFE_CALL(cudaFree(Mh_ betaxx)); - if(Mh_ betaxy) CUDA_SAFE_CALL(cudaFree(Mh_ betaxy)); - if(Mh_ betaxz) CUDA_SAFE_CALL(cudaFree(Mh_ betaxz)); - if(Mh_ betayy) CUDA_SAFE_CALL(cudaFree(Mh_ betayy)); - if(Mh_ betayz) CUDA_SAFE_CALL(cudaFree(Mh_ betayz)); - if(Mh_ betazz) CUDA_SAFE_CALL(cudaFree(Mh_ betazz)); - if(Mh_ betayx) CUDA_SAFE_CALL(cudaFree(Mh_ betayx)); - if(Mh_ betazy) CUDA_SAFE_CALL(cudaFree(Mh_ betazy)); - if(Mh_ betazx) CUDA_SAFE_CALL(cudaFree(Mh_ betazx)); - if(Mh_ Kx) CUDA_SAFE_CALL(cudaFree(Mh_ Kx)); - if(Mh_ Ky) CUDA_SAFE_CALL(cudaFree(Mh_ Ky)); - if(Mh_ Kz) CUDA_SAFE_CALL(cudaFree(Mh_ Kz)); - if(Mh_ Gamxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxx)); - if(Mh_ Gamxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxy)); - if(Mh_ Gamxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxz)); - if(Mh_ Gamyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyy)); - if(Mh_ Gamyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyz)); - if(Mh_ Gamzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzz)); - if(Mh_ Gamyx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyx)); - if(Mh_ Gamzy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzy)); - if(Mh_ Gamzx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzx)); - if(Mh_ div_beta) CUDA_SAFE_CALL(cudaFree(Mh_ div_beta)); - if(Mh_ S) CUDA_SAFE_CALL(cudaFree(Mh_ S)); - if(Mh_ f) CUDA_SAFE_CALL(cudaFree(Mh_ f)); - if(Mh_ fxx) CUDA_SAFE_CALL(cudaFree(Mh_ fxx)); - if(Mh_ fxy) CUDA_SAFE_CALL(cudaFree(Mh_ fxy)); - if(Mh_ fxz) CUDA_SAFE_CALL(cudaFree(Mh_ fxz)); - if(Mh_ fyy) CUDA_SAFE_CALL(cudaFree(Mh_ fyy)); - if(Mh_ fyz) CUDA_SAFE_CALL(cudaFree(Mh_ fyz)); - if(Mh_ fzz) CUDA_SAFE_CALL(cudaFree(Mh_ fzz)); - if(Mh_ gupxx) CUDA_SAFE_CALL(cudaFree(Mh_ gupxx)); - if(Mh_ gupxy) CUDA_SAFE_CALL(cudaFree(Mh_ gupxy)); - if(Mh_ gupxz) CUDA_SAFE_CALL(cudaFree(Mh_ gupxz)); - if(Mh_ gupyy) CUDA_SAFE_CALL(cudaFree(Mh_ gupyy)); - if(Mh_ gupyz) CUDA_SAFE_CALL(cudaFree(Mh_ gupyz)); - if(Mh_ gupzz) CUDA_SAFE_CALL(cudaFree(Mh_ gupzz)); - if(Mh_ Gamxa) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxa)); - if(Mh_ Gamya) CUDA_SAFE_CALL(cudaFree(Mh_ Gamya)); - if(Mh_ Gamza) CUDA_SAFE_CALL(cudaFree(Mh_ Gamza)); - if(Mh_ alpn1) CUDA_SAFE_CALL(cudaFree(Mh_ alpn1)); - if(Mh_ chin1) CUDA_SAFE_CALL(cudaFree(Mh_ chin1)); - if(Mh_ fh) CUDA_SAFE_CALL(cudaFree(Mh_ fh)); - if(Mh_ fh2) CUDA_SAFE_CALL(cudaFree(Mh_ fh2)); - if(Mh_ gxx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gxx_rhs)); - if(Mh_ gyy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gyy_rhs)); - if(Mh_ gzz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gzz_rhs)); - */ - - if(Mh_ X) cudaFree(Mh_ X); - if(Mh_ Y) cudaFree(Mh_ Y); - if(Mh_ Z) cudaFree(Mh_ Z); - if(Mh_ chi) cudaFree(Mh_ chi); - if(Mh_ dxx) cudaFree(Mh_ dxx); - if(Mh_ dyy) cudaFree(Mh_ dyy); - if(Mh_ dzz) cudaFree(Mh_ dzz); - if(Mh_ trK) cudaFree(Mh_ trK); - if(Mh_ gxy) cudaFree(Mh_ gxy); - if(Mh_ gxz) cudaFree(Mh_ gxz); - if(Mh_ gyz) cudaFree(Mh_ gyz); - if(Mh_ Axx) cudaFree(Mh_ Axx); - if(Mh_ Axy) cudaFree(Mh_ Axy); - if(Mh_ Axz) cudaFree(Mh_ Axz); - if(Mh_ Ayz) cudaFree(Mh_ Ayz); - if(Mh_ Ayy) cudaFree(Mh_ Ayy); - if(Mh_ Azz) cudaFree(Mh_ Azz); - if(Mh_ Gamx) cudaFree(Mh_ Gamx); - if(Mh_ Gamy) cudaFree(Mh_ Gamy); - if(Mh_ Gamz) cudaFree(Mh_ Gamz); - if(Mh_ Lap) cudaFree(Mh_ Lap); - if(Mh_ betax) cudaFree(Mh_ betax); - if(Mh_ betay) cudaFree(Mh_ betay); - if(Mh_ betaz) cudaFree(Mh_ betaz); - if(Mh_ dtSfx) cudaFree(Mh_ dtSfx); - if(Mh_ dtSfy) cudaFree(Mh_ dtSfy); - if(Mh_ dtSfz) cudaFree(Mh_ dtSfz); - if(Mh_ chi_rhs) cudaFree(Mh_ chi_rhs); - if(Mh_ trK_rhs) cudaFree(Mh_ trK_rhs); - if(Mh_ gxy_rhs) cudaFree(Mh_ gxy_rhs); - if(Mh_ gxz_rhs) cudaFree(Mh_ gxz_rhs); - if(Mh_ gyz_rhs) cudaFree(Mh_ gyz_rhs); - if(Mh_ Axx_rhs) cudaFree(Mh_ Axx_rhs); - if(Mh_ Axy_rhs) cudaFree(Mh_ Axy_rhs); - if(Mh_ Axz_rhs) cudaFree(Mh_ Axz_rhs); - if(Mh_ Ayz_rhs) cudaFree(Mh_ Ayz_rhs); - if(Mh_ Ayy_rhs) cudaFree(Mh_ Ayy_rhs); - if(Mh_ Azz_rhs) cudaFree(Mh_ Azz_rhs); - if(Mh_ Gamx_rhs) cudaFree(Mh_ Gamx_rhs); - if(Mh_ Gamy_rhs) cudaFree(Mh_ Gamy_rhs); - if(Mh_ Gamz_rhs) cudaFree(Mh_ Gamz_rhs); - if(Mh_ Lap_rhs) cudaFree(Mh_ Lap_rhs); - if(Mh_ betax_rhs) cudaFree(Mh_ betax_rhs); - if(Mh_ betay_rhs) cudaFree(Mh_ betay_rhs); - if(Mh_ betaz_rhs) cudaFree(Mh_ betaz_rhs); - if(Mh_ dtSfx_rhs) cudaFree(Mh_ dtSfx_rhs); - if(Mh_ dtSfy_rhs) cudaFree(Mh_ dtSfy_rhs); - if(Mh_ dtSfz_rhs) cudaFree(Mh_ dtSfz_rhs); - if(Mh_ rho) cudaFree(Mh_ rho); - if(Mh_ Sx) cudaFree(Mh_ Sx); - if(Mh_ Sy) cudaFree(Mh_ Sy); - if(Mh_ Sz) cudaFree(Mh_ Sz); - if(Mh_ Sxx) cudaFree(Mh_ Sxx); - if(Mh_ Sxy) cudaFree(Mh_ Sxy); - if(Mh_ Sxz) cudaFree(Mh_ Sxz); - if(Mh_ Syz) cudaFree(Mh_ Syz); - if(Mh_ Syy) cudaFree(Mh_ Syy); - if(Mh_ Szz) cudaFree(Mh_ Szz); - if(Mh_ Gamxxx) cudaFree(Mh_ Gamxxx); - if(Mh_ Gamxxy) cudaFree(Mh_ Gamxxy); - if(Mh_ Gamxxz) cudaFree(Mh_ Gamxxz); - if(Mh_ Gamxyy) cudaFree(Mh_ Gamxyy); - if(Mh_ Gamxyz) cudaFree(Mh_ Gamxyz); - if(Mh_ Gamxzz) cudaFree(Mh_ Gamxzz); - if(Mh_ Gamyxx) cudaFree(Mh_ Gamyxx); - if(Mh_ Gamyxy) cudaFree(Mh_ Gamyxy); - if(Mh_ Gamyxz) cudaFree(Mh_ Gamyxz); - if(Mh_ Gamyyy) cudaFree(Mh_ Gamyyy); - if(Mh_ Gamyyz) cudaFree(Mh_ Gamyyz); - if(Mh_ Gamyzz) cudaFree(Mh_ Gamyzz); - if(Mh_ Gamzxx) cudaFree(Mh_ Gamzxx); - if(Mh_ Gamzxy) cudaFree(Mh_ Gamzxy); - if(Mh_ Gamzxz) cudaFree(Mh_ Gamzxz); - if(Mh_ Gamzyz) cudaFree(Mh_ Gamzyz); - if(Mh_ Gamzyy) cudaFree(Mh_ Gamzyy); - if(Mh_ Gamzzz) cudaFree(Mh_ Gamzzz); - if(Mh_ Rxx) cudaFree(Mh_ Rxx); - if(Mh_ Rxy) cudaFree(Mh_ Rxy); - if(Mh_ Rxz) cudaFree(Mh_ Rxz); - if(Mh_ Ryy) cudaFree(Mh_ Ryy); - if(Mh_ Ryz) cudaFree(Mh_ Ryz); - if(Mh_ Rzz) cudaFree(Mh_ Rzz); - if(Mh_ ham_Res) cudaFree(Mh_ ham_Res); - if(Mh_ movx_Res) cudaFree(Mh_ movx_Res); - if(Mh_ movy_Res) cudaFree(Mh_ movy_Res); - if(Mh_ movz_Res) cudaFree(Mh_ movz_Res); - if(Mh_ Gmx_Res) cudaFree(Mh_ Gmx_Res); - if(Mh_ Gmy_Res) cudaFree(Mh_ Gmy_Res); - if(Mh_ Gmz_Res) cudaFree(Mh_ Gmz_Res); - if(Mh_ gxx) cudaFree(Mh_ gxx); - if(Mh_ gyy) cudaFree(Mh_ gyy); - if(Mh_ gzz) cudaFree(Mh_ gzz); - if(Mh_ chix) cudaFree(Mh_ chix); - if(Mh_ chiy) cudaFree(Mh_ chiy); - if(Mh_ chiz) cudaFree(Mh_ chiz); - if(Mh_ gxxx) cudaFree(Mh_ gxxx); - if(Mh_ gxyx) cudaFree(Mh_ gxyx); - if(Mh_ gxzx) cudaFree(Mh_ gxzx); - if(Mh_ gyyx) cudaFree(Mh_ gyyx); - if(Mh_ gyzx) cudaFree(Mh_ gyzx); - if(Mh_ gzzx) cudaFree(Mh_ gzzx); - if(Mh_ gxxy) cudaFree(Mh_ gxxy); - if(Mh_ gxyy) cudaFree(Mh_ gxyy); - if(Mh_ gxzy) cudaFree(Mh_ gxzy); - if(Mh_ gyyy) cudaFree(Mh_ gyyy); - if(Mh_ gyzy) cudaFree(Mh_ gyzy); - if(Mh_ gzzy) cudaFree(Mh_ gzzy); - if(Mh_ gxxz) cudaFree(Mh_ gxxz); - if(Mh_ gxyz) cudaFree(Mh_ gxyz); - if(Mh_ gxzz) cudaFree(Mh_ gxzz); - if(Mh_ gyyz) cudaFree(Mh_ gyyz); - if(Mh_ gyzz) cudaFree(Mh_ gyzz); - if(Mh_ gzzz) cudaFree(Mh_ gzzz); - if(Mh_ Lapx) cudaFree(Mh_ Lapx); - if(Mh_ Lapy) cudaFree(Mh_ Lapy); - if(Mh_ Lapz) cudaFree(Mh_ Lapz); - if(Mh_ betaxx) cudaFree(Mh_ betaxx); - if(Mh_ betaxy) cudaFree(Mh_ betaxy); - if(Mh_ betaxz) cudaFree(Mh_ betaxz); - if(Mh_ betayy) cudaFree(Mh_ betayy); - if(Mh_ betayz) cudaFree(Mh_ betayz); - if(Mh_ betazz) cudaFree(Mh_ betazz); - if(Mh_ betayx) cudaFree(Mh_ betayx); - if(Mh_ betazy) cudaFree(Mh_ betazy); - if(Mh_ betazx) cudaFree(Mh_ betazx); - if(Mh_ Kx) cudaFree(Mh_ Kx); - if(Mh_ Ky) cudaFree(Mh_ Ky); - if(Mh_ Kz) cudaFree(Mh_ Kz); - if(Mh_ Gamxx) cudaFree(Mh_ Gamxx); - if(Mh_ Gamxy) cudaFree(Mh_ Gamxy); - if(Mh_ Gamxz) cudaFree(Mh_ Gamxz); - if(Mh_ Gamyy) cudaFree(Mh_ Gamyy); - if(Mh_ Gamyz) cudaFree(Mh_ Gamyz); - if(Mh_ Gamzz) cudaFree(Mh_ Gamzz); - if(Mh_ Gamyx) cudaFree(Mh_ Gamyx); - if(Mh_ Gamzy) cudaFree(Mh_ Gamzy); - if(Mh_ Gamzx) cudaFree(Mh_ Gamzx); - if(Mh_ div_beta) cudaFree(Mh_ div_beta); - if(Mh_ S) cudaFree(Mh_ S); - if(Mh_ f) cudaFree(Mh_ f); - if(Mh_ fxx) cudaFree(Mh_ fxx); - if(Mh_ fxy) cudaFree(Mh_ fxy); - if(Mh_ fxz) cudaFree(Mh_ fxz); - if(Mh_ fyy) cudaFree(Mh_ fyy); - if(Mh_ fyz) cudaFree(Mh_ fyz); - if(Mh_ fzz) cudaFree(Mh_ fzz); - if(Mh_ gupxx) cudaFree(Mh_ gupxx); - if(Mh_ gupxy) cudaFree(Mh_ gupxy); - if(Mh_ gupxz) cudaFree(Mh_ gupxz); - if(Mh_ gupyy) cudaFree(Mh_ gupyy); - if(Mh_ gupyz) cudaFree(Mh_ gupyz); - if(Mh_ gupzz) cudaFree(Mh_ gupzz); - if(Mh_ Gamxa) cudaFree(Mh_ Gamxa); - if(Mh_ Gamya) cudaFree(Mh_ Gamya); - if(Mh_ Gamza) cudaFree(Mh_ Gamza); - if(Mh_ alpn1) cudaFree(Mh_ alpn1); - if(Mh_ chin1) cudaFree(Mh_ chin1); - if(Mh_ fh) cudaFree(Mh_ fh); - if(Mh_ fh2) cudaFree(Mh_ fh2); - if(Mh_ gxx_rhs) cudaFree(Mh_ gxx_rhs); - if(Mh_ gyy_rhs) cudaFree(Mh_ gyy_rhs); - if(Mh_ gzz_rhs) cudaFree(Mh_ gzz_rhs); - -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - // if(Mh_ reta) CUDA_SAFE_CALL(cudaFree(Mh_ reta)); - if(Mh_ reta) cudaFree(Mh_ reta); - -#endif - - //if(Mh_ other_int) cudaFree(Mh_ other_int); - //if(Mh_ other_double) cudaFree(Mh_ other_double); - //cout<<"Address of meta:"<<&meta< 1 && abs[0] < dXh) {ijkmin_h[0] = -2; ijkmin2_h[0] = -3;} - if(Symmetry > 1 && abs[1] < dYh) {ijkmin_h[1] = -2; ijkmin2_h[1] = -3;} - if(Symmetry > 0 && abs[2] < dZh) {ijkmin_h[2] = -2; ijkmin2_h[2] = -3;} - - if(Symmetry > 2 && abs[0] < dXh) {ijkmin3_h[0] = -3;} - if(Symmetry > 2 && abs[1] < dYh) {ijkmin3_h[1] = -3;} - if(Symmetry > 0 && abs[2] < dZh) {ijkmin3_h[2] = -3;} - - cudaMemcpyToSymbol(ijk_max,ijkmax_h,3*sizeof(int)); - cudaMemcpyToSymbol(ijk_min,ijkmin_h,3*sizeof(int)); - cudaMemcpyToSymbol(ijk_min2,ijkmin2_h,3*sizeof(int)); - cudaMemcpyToSymbol(ijk_min3,ijkmin3_h,3*sizeof(int)); - - double d12dxyz_h[3] = {1.0,1.0,1.0}; - double d2dxyz_h[3] = {1.0,1.0,1.0}; - d12dxyz_h[0] /= 12; d12dxyz_h[1] /= 12; d12dxyz_h[2] /= 12; - d12dxyz_h[0] /= dXh; d12dxyz_h[1] /= dYh; d12dxyz_h[2] /= dZh; - d2dxyz_h[0] /= 2; d2dxyz_h[1] /= 2; d2dxyz_h[2] /= 2; - d2dxyz_h[0] /= dXh; d2dxyz_h[1] /= dYh; d2dxyz_h[2] /= dZh; - - cudaMemcpyToSymbol(d12dxyz,d12dxyz_h,3*sizeof(double)); - cudaMemcpyToSymbol(d2dxyz,d2dxyz_h,3*sizeof(double)); - -//3.3--------for fdderivs------------ - double Sdxdxh = 1.0 /( dXh * dXh ); - double Sdydyh = 1.0 /( dYh * dYh ); - double Sdzdzh = 1.0 /( dZh * dZh ); - double Fdxdxh = 1.0 / 12.0 /( dXh * dXh ); - double Fdydyh = 1.0 / 12.0 /( dYh * dYh ); - double Fdzdzh = 1.0 / 12.0 /( dZh * dZh ); - double Sdxdyh = 1.0/4.0 /( dXh * dYh ); - double Sdxdzh = 1.0/4.0 /( dXh * dZh ); - double Sdydzh = 1.0/4.0 /( dYh * dZh ); - double Fdxdyh = 1.0/144.0 /( dXh * dYh ); - double Fdxdzh = 1.0/144.0 /( dXh * dZh ); - double Fdydzh = 1.0/144.0 /( dYh * dZh ); - cudaMemcpyToSymbol(Sdxdx,&Sdxdxh,sizeof(double)); - cudaMemcpyToSymbol(Sdydy,&Sdydyh,sizeof(double)); - cudaMemcpyToSymbol(Sdzdz,&Sdzdzh,sizeof(double)); - cudaMemcpyToSymbol(Sdxdy,&Sdxdyh,sizeof(double)); - cudaMemcpyToSymbol(Sdxdz,&Sdxdzh,sizeof(double)); - cudaMemcpyToSymbol(Sdydz,&Sdydzh,sizeof(double)); - cudaMemcpyToSymbol(Fdxdx,&Fdxdxh,sizeof(double)); - cudaMemcpyToSymbol(Fdydy,&Fdydyh,sizeof(double)); - cudaMemcpyToSymbol(Fdzdz,&Fdzdzh,sizeof(double)); - cudaMemcpyToSymbol(Fdxdy,&Fdxdyh,sizeof(double)); - cudaMemcpyToSymbol(Fdxdz,&Fdxdzh,sizeof(double)); - cudaMemcpyToSymbol(Fdydz,&Fdydzh,sizeof(double)); - -//3.4---------for lopsided--------------------------- - - -#ifdef TIMING1 - cudaThreadSynchronize(); - gettimeofday(&tv2, NULL); - cout<<"TIME USED"<>>(ctest_d); - cudaMemcpy(ctest, ctest_d, sizeof(double), cudaMemcpyDeviceToHost); - cout<<"My rank is: "<>>(); - cudaThreadSynchronize(); - - sub_fderivs(Mh_ betax,Mh_ fh,Mh_ betaxx,Mh_ betaxy,Mh_ betaxz,ass); - sub_fderivs(Mh_ betay,Mh_ fh,Mh_ betayx,Mh_ betayy,Mh_ betayz,sas); - sub_fderivs(Mh_ betaz,Mh_ fh,Mh_ betazx,Mh_ betazy,Mh_ betazz,ssa); - sub_fderivs(Mh_ chi,Mh_ fh,Mh_ chix,Mh_ chiy,Mh_ chiz, sss); - sub_fderivs(Mh_ Lap,Mh_ fh,Mh_ Lapx,Mh_ Lapy,Mh_ Lapz, sss); - sub_fderivs(Mh_ trK,Mh_ fh,Mh_ Kx,Mh_ Ky,Mh_ Kz, sss); - sub_fderivs(Mh_ dxx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz, sss); - sub_fderivs(Mh_ dyy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz, sss); - sub_fderivs(Mh_ dzz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz, sss); - sub_fderivs(Mh_ gxy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz, aas); - sub_fderivs(Mh_ gxz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz, asa); - sub_fderivs(Mh_ gyz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz, saa); - - compute_rhs_bssn_part2<<>>(); - cudaThreadSynchronize(); - - sub_fdderivs(Mh_ betax,Mh_ fh,Mh_ gxxx,Mh_ gxyx,Mh_ gxzx,Mh_ gyyx,Mh_ gyzx,Mh_ gzzx,ass); - sub_fdderivs(Mh_ betay,Mh_ fh,Mh_ gxxy,Mh_ gxyy,Mh_ gxzy,Mh_ gyyy,Mh_ gyzy,Mh_ gzzy,sas); - sub_fdderivs(Mh_ betaz,Mh_ fh,Mh_ gxxz,Mh_ gxyz,Mh_ gxzz,Mh_ gyyz,Mh_ gyzz,Mh_ gzzz,ssa); - sub_fderivs( Mh_ Gamx, Mh_ fh,Mh_ Gamxx, Mh_ Gamxy, Mh_ Gamxz,ass); - sub_fderivs( Mh_ Gamy, Mh_ fh,Mh_ Gamyx, Mh_ Gamyy, Mh_ Gamyz,sas); - sub_fderivs( Mh_ Gamz, Mh_ fh,Mh_ Gamzx, Mh_ Gamzy, Mh_ Gamzz,ssa); - - compute_rhs_bssn_part3<<>>(); - cudaThreadSynchronize(); - - computeRicci(Mh_ dxx,Mh_ Rxx,sss, meta); - computeRicci(Mh_ dyy,Mh_ Ryy,sss, meta); - computeRicci(Mh_ dzz,Mh_ Rzz,sss, meta); - computeRicci(Mh_ gxy,Mh_ Rxy,aas, meta); - computeRicci(Mh_ gxz,Mh_ Rxz,asa, meta); - computeRicci(Mh_ gyz,Mh_ Ryz,saa, meta); - - cudaThreadSynchronize(); - - compute_rhs_bssn_part4<<>>(); - cudaThreadSynchronize(); - - sub_fdderivs(Mh_ chi,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); - - compute_rhs_bssn_part5<<>>(); - cudaThreadSynchronize(); - - sub_fdderivs(Mh_ Lap,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); - - compute_rhs_bssn_part6<<>>(); - cudaThreadSynchronize(); - -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) - sub_fderivs(Mh_ chi,Mh_ fh, Mh_ dtSfx_rhs, Mh_ dtSfy_rhs, Mh_ dtSfz_rhs,sss); - compute_rhs_bssn_part6_gauge<<>>(); -#endif - - sub_lopsided(Mh_ gxx,Mh_ fh2,Mh_ gxx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ gxy,Mh_ fh2,Mh_ gxy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,aas); - sub_lopsided(Mh_ gxz,Mh_ fh2,Mh_ gxz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,asa); - sub_lopsided(Mh_ gyy,Mh_ fh2,Mh_ gyy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ gyz,Mh_ fh2,Mh_ gyz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,saa); - sub_lopsided(Mh_ gzz,Mh_ fh2,Mh_ gzz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ Axx,Mh_ fh2,Mh_ Axx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ Axy,Mh_ fh2,Mh_ Axy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,aas); - sub_lopsided(Mh_ Axz,Mh_ fh2,Mh_ Axz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,asa); - sub_lopsided(Mh_ Ayy,Mh_ fh2,Mh_ Ayy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ Ayz,Mh_ fh2,Mh_ Ayz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,saa); - sub_lopsided(Mh_ Azz,Mh_ fh2,Mh_ Azz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ chi,Mh_ fh2,Mh_ chi_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ trK,Mh_ fh2,Mh_ trK_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - sub_lopsided(Mh_ Gamx,Mh_ fh2,Mh_ Gamx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ass); - sub_lopsided(Mh_ Gamy,Mh_ fh2,Mh_ Gamy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sas); - sub_lopsided(Mh_ Gamz,Mh_ fh2,Mh_ Gamz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ssa); - sub_lopsided(Mh_ Lap,Mh_ fh2,Mh_ Lap_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); - -#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - - sub_lopsided(Mh_ betax,Mh_ fh2,Mh_ betax_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ass); - sub_lopsided(Mh_ betay,Mh_ fh2,Mh_ betay_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sas); - sub_lopsided(Mh_ betaz,Mh_ fh2,Mh_ betaz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ssa); - -#endif -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - sub_lopsided(Mh_ dtSfx,Mh_ fh2,Mh_ dtSfx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ass); - sub_lopsided(Mh_ dtSfy,Mh_ fh2,Mh_ dtSfy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sas); - sub_lopsided(Mh_ dtSfz,Mh_ fh2,Mh_ dtSfz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ssa); -#endif - if(eps > 0){ - sub_kodis(Mh_ chi,Mh_ fh2, Mh_ chi_rhs,sss); - sub_kodis(Mh_ trK,Mh_ fh2, Mh_ trK_rhs,sss); - sub_kodis(Mh_ dxx,Mh_ fh2, Mh_ gxx_rhs,sss); - sub_kodis(Mh_ gxy,Mh_ fh2, Mh_ gxy_rhs,aas); - sub_kodis(Mh_ gxz,Mh_ fh2, Mh_ gxz_rhs,asa); - sub_kodis(Mh_ dyy,Mh_ fh2, Mh_ gyy_rhs,sss); - sub_kodis(Mh_ gyz,Mh_ fh2, Mh_ gyz_rhs,saa); - sub_kodis(Mh_ dzz,Mh_ fh2, Mh_ gzz_rhs,sss); - sub_kodis(Mh_ Axx,Mh_ fh2, Mh_ Axx_rhs,sss); - sub_kodis(Mh_ Axy,Mh_ fh2, Mh_ Axy_rhs,aas); - sub_kodis(Mh_ Axz,Mh_ fh2, Mh_ Axz_rhs,asa); - sub_kodis(Mh_ Ayy,Mh_ fh2, Mh_ Ayy_rhs,sss); - sub_kodis(Mh_ Ayz,Mh_ fh2, Mh_ Ayz_rhs,saa); - sub_kodis(Mh_ Azz,Mh_ fh2, Mh_ Azz_rhs,sss); - sub_kodis(Mh_ Gamx,Mh_ fh2, Mh_ Gamx_rhs,ass); - sub_kodis(Mh_ Gamy,Mh_ fh2, Mh_ Gamy_rhs,sas); - sub_kodis(Mh_ Gamz,Mh_ fh2, Mh_ Gamz_rhs,ssa); - - sub_kodis(Mh_ Lap,Mh_ fh2, Mh_ Lap_rhs,sss); - sub_kodis(Mh_ betax,Mh_ fh2, Mh_ betax_rhs,ass); - sub_kodis(Mh_ betay,Mh_ fh2, Mh_ betay_rhs,sas); - sub_kodis(Mh_ betaz,Mh_ fh2, Mh_ betaz_rhs,ssa); - -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - sub_kodis(Mh_ dtSfx,Mh_ fh2, Mh_ dtSfx_rhs,ass); - sub_kodis(Mh_ dtSfy,Mh_ fh2, Mh_ dtSfy_rhs,sas); - sub_kodis(Mh_ dtSfz,Mh_ fh2, Mh_ dtSfz_rhs,ssa); -#endif - - } - - if(co == 0){ - compute_rhs_bssn_part7<<>>(); - cudaThreadSynchronize(); - - sub_fderivs(Mh_ Axx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz,sss); - sub_fderivs(Mh_ Axy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz,aas); - sub_fderivs(Mh_ Axz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz,asa); - sub_fderivs(Mh_ Ayy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz,sss); - sub_fderivs(Mh_ Ayz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz,saa); - sub_fderivs(Mh_ Azz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz,sss); - compute_rhs_bssn_part8<<>>(); - cudaThreadSynchronize(); - } - -#if (ABV == 1) - cout<<"TODO: bssn_gpu.cu::2373 (ABV == 1)"< +#include +#include +#include +#include +#include +#include +//#include "cutil.h" +#include +#include +using namespace std; + +//includes, bssn +#include "gpu_mem.h" +#include "bssn_gpu.h" +#ifdef RESULT_CHECK +#include +#endif + +void compare_result_gpu(int ftag1,double * datac,int data_num){ + double * data = (double*)malloc(sizeof(double)*data_num); + cudaMemcpy(data, datac, data_num * sizeof(double), cudaMemcpyDeviceToHost); + compare_result(ftag1,data,data_num); + free(data); +} + +__global__ void test_const_address(double * testd){ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + if(_t == 0) + testd[0] = F1o3; +} + +__global__ void enforce_ga(double * trA){ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + //int ps; //TOTRY: i,j,k; double value; + + while(_t < _3D_SIZE[0]) + { + M_ gxx[_t] = M_ dxx[_t] + 1; + M_ gyy[_t] = M_ dyy[_t] + 1; + M_ gzz[_t] = M_ dzz[_t] + 1; + // for M_ g; + M_ gupzz[_t] = M_ gxx[_t] * M_ gyy[_t] * M_ gzz[_t] + M_ gxy[_t] * M_ gyz[_t] * M_ gxz[_t] + M_ gxz[_t] * M_ gxy[_t] * M_ gyz[_t] - + M_ gxz[_t] * M_ gyy[_t] * M_ gxz[_t] - M_ gxy[_t] * M_ gxy[_t] * M_ gzz[_t] - M_ gxx[_t] * M_ gyz[_t] * M_ gyz[_t]; + + M_ gupzz[_t] = 1.0 / pow( M_ gupzz[_t] , F1o3 ) ; + + M_ gxx[_t] = M_ gxx[_t] * M_ gupzz[_t]; + M_ gxy[_t] = M_ gxy[_t] * M_ gupzz[_t]; + M_ gxz[_t] = M_ gxz[_t] * M_ gupzz[_t]; + M_ gyy[_t] = M_ gyy[_t] * M_ gupzz[_t]; + M_ gyz[_t] = M_ gyz[_t] * M_ gupzz[_t]; + M_ gzz[_t] = M_ gzz[_t] * M_ gupzz[_t]; + + M_ dxx[_t] = M_ gxx[_t] - 1; + M_ dyy[_t] = M_ gyy[_t] - 1; + M_ dzz[_t] = M_ gzz[_t] - 1; + // for A ; + + M_ gupxx[_t] = ( M_ gyy[_t] * M_ gzz[_t] - M_ gyz[_t] * M_ gyz[_t] ); + M_ gupxy[_t] = - ( M_ gxy[_t] * M_ gzz[_t] - M_ gyz[_t] * M_ gxz[_t] ); + M_ gupxz[_t] = ( M_ gxy[_t] * M_ gyz[_t] - M_ gyy[_t] * M_ gxz[_t] ); + M_ gupyy[_t] = ( M_ gxx[_t] * M_ gzz[_t] - M_ gxz[_t] * M_ gxz[_t] ); + M_ gupyz[_t] = - ( M_ gxx[_t] * M_ gyz[_t] - M_ gxy[_t] * M_ gxz[_t] ); + M_ gupzz[_t] = ( M_ gxx[_t] * M_ gyy[_t] - M_ gxy[_t] * M_ gxy[_t] ); + + trA[_t] = M_ gupxx[_t] *M_ Axx[_t] + M_ gupyy[_t] * M_ Ayy[_t] + M_ gupzz[_t] * M_ Azz[_t] + + 2 * (M_ gupxy[_t] *M_ Axy[_t] + M_ gupxz[_t] *M_ Axz[_t] + M_ gupyz[_t] * M_ Ayz[_t]); + + M_ Axx[_t] = M_ Axx[_t] - F1o3 * M_ gxx[_t] * trA[_t]; + M_ Axy[_t] = M_ Axy[_t] - F1o3 * M_ gxy[_t] * trA[_t]; + M_ Axz[_t] = M_ Axz[_t] - F1o3 * M_ gxz[_t] * trA[_t]; + M_ Ayy[_t] = M_ Ayy[_t] - F1o3 * M_ gyy[_t] * trA[_t]; + M_ Ayz[_t] = M_ Ayz[_t] - F1o3 * M_ gyz[_t] * trA[_t]; + M_ Azz[_t] = M_ Azz[_t] - F1o3 * M_ gzz[_t] * trA[_t]; + //------------------- + _t += STEP_SIZE; + } +} + +inline void sub_enforce_ga(int matrix_size){ + double * trA = M_ chin1; + enforce_ga<<>>(trA); + cudaMemset(trA,0,matrix_size * sizeof(double)); + cudaThreadSynchronize(); + + //cudaMemset(Mh_ gupxx,0,matrix_size * sizeof(double)); + //trA gxx,gyy,gzz gupxx,gupxy,gupxz,gupyy,gupyz,gupzz + +} +__device__ volatile unsigned int global_count = 0; +__global__ void test_init_matrix(){ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int curr = tid; + while(curr < _3D_SIZE[2]) + { + metac.fh[curr] = 0; + curr += STEP_SIZE; + } + curr = tid; + while(curr < _3D_SIZE[0]) + { + metac.betaxx[curr] = 0; + metac.betaxy[curr] = 0; + metac.betaxz[curr] = 0; + curr += STEP_SIZE; + } +} +__global__ void init_matrix(double * mat){ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int curr = tid; + while(curr < _3D_SIZE[0]) + { + mat[curr] = 0; + curr += STEP_SIZE; + } +} +__global__ void init_3_matrixs(double * mat1,double* mat2,double *mat3){ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int curr = tid; + while(curr < _3D_SIZE[0]) + { + mat1[curr] = 0; + mat2[curr] = 0; + mat3[curr] = 0; + curr += STEP_SIZE; + } +} +__global__ void init_matrix_fh(double * mat){ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int curr = tid; + while(curr < _3D_SIZE[2]) + { + mat[curr] = 0; + curr += STEP_SIZE; + } +} + + +__global__ void sub_symmetry_bd_partF(int ord, double * func, double *funcc) +{ + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(curr < _3D_SIZE[0]) + { + int k = curr / _2D_SIZE[0]; + ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); //= ps % ex_c[0]; + + funcc[i+ ord + (ord +j)* _1D_SIZE[ord] + (k + ord) * _2D_SIZE[ord]] = func[curr]; + + curr += STEP_SIZE; + } + +} + +#ifdef Vertex +__global__ void sub_symmetry_bd_partI(int ord, double * func, double * funcc,double S1){ + //for i + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; + int m; + while(curr < (ex_c[1]+ord)*(ex_c[2]+ord) ){ + m = ord * 2; + ps = curr * _1D_SIZE[ord]; + for(int i = 0;i < ord; ++i){ + funcc[ps] = funcc [ps + m] * S1; + ps ++; + m -= 2; + } + curr+= STEP_SIZE; + } + __syncthreads(); +} +__global__ void sub_symmetry_bd_partJ(int ord,double * func, double * funcc,double S2){ + //for j + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; + int m; + + while(curr < (ex_c[0]+ord)*(ex_c[2]+ord)) + { + m = 2 * ord; + ps = (curr/_1D_SIZE[ord])*_2D_SIZE[ord] + (curr % _1D_SIZE[ord]); + for(int i = 0;i>>(ord,func,funcc); + cudaThreadSynchronize(); + sub_symmetry_bd_partI<<>>(ord,func,funcc,SoA[0]); + cudaThreadSynchronize(); + sub_symmetry_bd_partJ<<>>(ord,func,funcc,SoA[1]); + cudaThreadSynchronize(); + sub_symmetry_bd_partK<<>>(ord,func,funcc,SoA[2]); + cudaThreadSynchronize(); +} + + +__global__ void sub_fdderivs_part1(double * f,double *fh,double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz) + { + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(curr < _3D_SIZE[0]) + { + int k = curr / _2D_SIZE[0]; + ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k == ex_c[2]-1 || i == ex_c[0]-1 || j == ex_c[1]-1){ + curr += STEP_SIZE; + continue; + } + else + { + //xx + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]){ + fxx[curr] = Fdxdx*(-_FH2_(i,(j+2),(k+2))+16*_FH2_((i+1),(j+2),(k+2))-30*_FH2_((i+2),(j+2),(k+2)) + -_FH2_((i+4),(j+2),(k+2))+16*_FH2_((i+3),(j+2),(k+2)) ); + + } + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]){ + fxx[curr] = Sdxdx*(_FH2_((i+1),(j+2),(k+2))-2*_FH2_((i+2),(j+2),(k+2)) + +_FH2_(i+3,(j+2),(k+2)) ); + } + //zz-- + if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]){ + fzz[curr] = Fdzdz * (-_FH2_((i+2),(j+2),k) + 16 *_FH2_((i+2),(j+2),(k+1))- 30*_FH2_((i+2),(j+2),(k+2)) + -_FH2_((i+2),(j+2),(k+4))+ 16*_FH2_((i+2),(j+2),(k+3)) ); + } + else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]){ + fzz[curr] = Sdzdz*(_FH2_((i+2),(j+2),(k+1))- 2 * _FH2_((i+2),(j+2),(k+2)) + + _FH2_((i+2),(j+2),(k+3)) ); + } + + //yy-- + if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]){ + fyy[curr] = Fdydy*(-_FH2_((i+2),j,(k+2))+16*_FH2_((i+2),(j+1),(k+2))-30*_FH2_((i+2),(j+2),(k+2)) + -_FH2_((i+2),(j+4),(k+2))+16*_FH2_((i+2),(j+3),(k+2)) ); + } + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]){ + fyy[curr] = Sdydy*(_FH2_((i+2),(j+1),(k+2))-2*_FH2_((i+2),(j+2),(k+2)) + +_FH2_((i+2),(j+3),(k+2)) ); + } + + + + //xy + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) + fxy[curr] = Fdxdy*((_FH2_(i,j,(k+2))-8*_FH2_((i+1),j,(k+2))+8*_FH2_((i+3),j,(k+2))-_FH2_((i+4),j,(k+2))) + -8 *(_FH2_(i,(j+1),(k+2))-8*_FH2_((i+1),(j+1),(k+2))+8*_FH2_((i+3),(j+1),(k+2))-_FH2_((i+4),(j+1),(k+2))) + +8 *(_FH2_(i,(j+3),(k+2))-8*_FH2_((i+1),(j+3),(k+2))+8*_FH2_((i+3),(j+3),(k+2))-_FH2_((i+4),(j+3),(k+2))) + - (_FH2_(i,(j+4),(k+2))-8*_FH2_((i+1),(j+4),(k+2))+8*_FH2_((i+3),(j+4),(k+2))-_FH2_((i+4),(j+4),(k+2)))); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) + + fxy[curr] = Sdxdy*(_FH2_((i+1),(j+1),(k+2))-_FH2_((i+3),(j+1),(k+2))-_FH2_((i+1),(j+3),(k+2))+_FH2_((i+3),(j+3),(k+2))); + //xz + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) + fxz[curr] = Fdxdz*( (_FH2_(i,(j+2),k)-8*_FH2_((i+1),(j+2),k)+8*_FH2_((i+3),(j+2),k)-_FH2_((i+4),(j+2),k)) + -8 *(_FH2_(i,(j+2),(k+1))-8*_FH2_((i+1),(j+2),(k+1))+8*_FH2_((i+3),(j+2),(k+1))-_FH2_((i+4),(j+2),(k+1))) + +8 *(_FH2_(i,(j+2),(k+3))-8*_FH2_((i+1),(j+2),(k+3))+8*_FH2_((i+3),(j+2),(k+3))-_FH2_((i+4),(j+2),(k+3))) + - (_FH2_(i,(j+2),(k+4))-8*_FH2_((i+1),(j+2),(k+4))+8*_FH2_((i+3),(j+2),(k+4))-_FH2_((i+4),(j+2),(k+4)))); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) + fxz[curr] = Sdxdz*(_FH2_((i+1),(j+2),(k+1))-_FH2_((i+3),(j+2),(k+1))-_FH2_((i+1),(j+2),(k+3))+_FH2_((i+3),(j+2),(k+3))); + //yz + if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) + fyz[curr] = Fdydz*( (_FH2_((i+2),j,k)-8*_FH2_((i+2),(j+1),k)+8*_FH2_((i+2),(j+3),k)-_FH2_((i+2),(j+4),k)) + -8 *(_FH2_((i+2),j,(k+1))-8*_FH2_((i+2),(j+1),(k+1))+8*_FH2_((i+2),(j+3),(k+1))-_FH2_((i+2),(j+4),(k+1))) + +8 *(_FH2_((i+2),j,(k+3))-8*_FH2_((i+2),(j+1),(k+3))+8*_FH2_((i+2),(j+3),(k+3))-_FH2_((i+2),(j+4),(k+3))) + - (_FH2_((i+2),j,(k+4))-8*_FH2_((i+2),(j+1),(k+4))+8*_FH2_((i+2),(j+3),(k+4))-_FH2_((i+2),(j+4),(k+4)))); + + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) + fyz[curr] = Sdydz*(_FH2_((i+2),(j+1),(k+1))-_FH2_((i+2),(j+3),(k+1))-_FH2_((i+2),(j+1),(k+3))+_FH2_((i+2),(j+3),(k+3))); + + curr += STEP_SIZE; + } + } + + __syncthreads(); + } + +inline void sub_fdderivs(double * f,double *fh,double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz,double* SoA) +{ + sub_symmetry_bd(2,f,fh,SoA); + cudaMemset(fxx,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fxy,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fxz,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fyy,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fyz,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fzz,0,_3D_SIZE[0] * sizeof(double)); + cudaThreadSynchronize(); + sub_fdderivs_part1<<>>(f,fh,fxx,fxy,fxz,fyy,fyz,fzz); + cudaThreadSynchronize(); +} + +__global__ void sub_fderivs_part1(double * f,double * fh,double *fx,double *fy,double *fz ) + { + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(curr < _3D_SIZE[0]) + { + int k = curr / _2D_SIZE[0]; + ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k == ex_c[2]-1 || i == ex_c[0]-1 || j == ex_c[1]-1){ + curr += STEP_SIZE; + continue; + } + + //X-- + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]) + fx[curr] = d12dxyz[0]*(fh[i+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] - + 8*fh[i+1+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + + 8*fh[i+3+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] - + fh[i+4+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] ); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]) + fx[curr] = d2dxyz[0]*(-fh[i+1+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + + fh[i+3+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] ); + //Y-- + if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) + fy[curr]=d12dxyz[1]*(fh[i+2+j*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]- + 8*fh[i+2+(j+1)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + + 8*fh[i+2+(j+3)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] - + fh[i+2+(j+4)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]); + + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) + fy[curr]=d2dxyz[1]*(-fh[i+2+(j+1)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]] + + fh[i+2+(j+3)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]); + //Z-- + + if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) + fz[curr]=d12dxyz[2]*( fh[i+2+(j+2)*_1D_SIZE[2]+k *_2D_SIZE[2]] - + 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]] + + 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k+3)*_2D_SIZE[2]] - + fh[i+2+(j+2)*_1D_SIZE[2]+(k+4)*_2D_SIZE[2]]); + + else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) + fz[curr]=d2dxyz[2]*(-fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]]+ + fh[i+2+(j+2)*_1D_SIZE[2]+(k+3)*_2D_SIZE[2]]); + + curr += STEP_SIZE; + + } + } + +inline void sub_fderivs(double * f,double * fh,double *fx,double *fy,double *fz,double * SoA) +{ + sub_symmetry_bd(2,f,fh,SoA); + + cudaMemset(fx,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fy,0,_3D_SIZE[0] * sizeof(double)); + cudaMemset(fz,0,_3D_SIZE[0] * sizeof(double)); + + cudaThreadSynchronize(); + sub_fderivs_part1<<>>(f,fh,fx,fy,fz); + cudaThreadSynchronize(); +} + +__global__ void computeRicci_part1(double * dst) +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + dst[_t] = M_ gupxx [_t]* M_ fxx [_t]+ M_ gupyy[_t]* M_ fyy[_t]+ M_ gupzz[_t]* M_ fzz[_t]+ + ( M_ gupxy[_t]* M_ fxy[_t]+ M_ gupxz[_t]* M_ fxz[_t]+ M_ gupyz[_t]* M_ fyz[_t]) * 2; + + _t += STEP_SIZE; + } +} + + inline void computeRicci(double * src,double* dst,double * SoA, Meta* meta) +{ + sub_fdderivs(src,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,SoA); + cudaThreadSynchronize(); + computeRicci_part1<<>>(dst); + cudaThreadSynchronize(); + +}/*Exception*/ + +__global__ void sub_kodis_part1(double *f,double *fh,double *f_rhs) +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + double inc_f_rhs; + while(_t < _3D_SIZE[0]) + { + int k = _t / _2D_SIZE[0]; + ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k == ex_c[2]-1 && i == ex_c[0]-1 && j == ex_c[1]-1){ + _t += STEP_SIZE; + continue; + } + + if(i-3 >= ijk_min3[0] && i+3 <= ijk_max[0] && + j-3 >= ijk_min3[1] && j+3 <= ijk_max[1] && + k-3 >= ijk_min3[2] && k+3 <= ijk_max[2]) + { + // x direction + inc_f_rhs = ( (_FH3_(i,(j+3),(k+3))+_FH3_((i+6),(j+3),(k+3))) - + 6*(_FH3_((i+1),(j+3),(k+3))+_FH3_((i+5),(j+3),(k+3))) + + 15*(_FH3_((i+2),(j+3),(k+3))+_FH3_((i+4),(j+3),(k+3))) - + 20* _FH3_((i+3),(j+3),(k+3)) ) /dX; + + + // y direction + + inc_f_rhs += ( (_FH3_((i+3),j,(k+3))+_FH3_((i+3),(j+6),(k+3))) - + 6*(_FH3_((i+3),(j+1),(k+3))+_FH3_((i+3),(j+5),(k+3))) + + 15*(_FH3_((i+3),(j+2),(k+3))+_FH3_((i+3),(j+4),(k+3))) - + 20* _FH3_((i+3),(j+3),(k+3)) )/dY; + + // z direction + + inc_f_rhs += ( (_FH3_((i+3),(j+3),k)+_FH3_((i+3),(j+3),(k+6))) - + 6*(_FH3_((i+3),(j+3),(k+1))+_FH3_((i+3),(j+3),(k+5))) + + 15*(_FH3_((i+3),(j+3),(k+2))+_FH3_((i+3),(j+3),(k+4))) - + 20* _FH3_((i+3),(j+3),(k+3)) )/dZ; + inc_f_rhs *= eps_c; + inc_f_rhs /= 64; + f_rhs[_t] += inc_f_rhs; //be careful the mark is "+=" not "==" ! + } + + _t += STEP_SIZE; + } +} + +inline void sub_kodis(double *f,double *fh,double *f_rhs,double *SoA) +{ + sub_symmetry_bd(3,f,fh,SoA); + cudaThreadSynchronize(); + sub_kodis_part1<<>>(f,fh,f_rhs); + cudaThreadSynchronize(); +} + +__global__ void sub_lopsided_part1(double *f,double* fh,double *f_rhs,double *Sfx,double *Sfy,double *Sfz) +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(_t < _3D_SIZE[0]) + { + int k = _t / _2D_SIZE[0]; + ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k < ex_c[2]-1 && i < ex_c[0]-1 && j < ex_c[1]-1){ + // x direction + if(Sfx[_t] >= 0 && i+3 <= ijk_max[0] && i-1 >= ijk_min2[0]) + f_rhs[_t]=f_rhs[_t]+ + Sfx[_t]*d12dxyz[0]*(-3*_FH3_((i+2),(j+3),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+4),(j+3),(k+3)) + -6*_FH3_((i+5),(j+3),(k+3))+ _FH3_((i+6),(j+3),(k+3))); + + else if(Sfx[_t] <= 0 && i-3 >= ijk_min2[0] && i+1 <= ijk_max[0]) + f_rhs[_t]=f_rhs[_t]- + Sfx[_t]*d12dxyz[0]*(-3*_FH3_((i+4),(j+3),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+2),(j+3),(k+3)) + -6*_FH3_((i+1),(j+3),(k+3))+ _FH3_(i,(j+3),(k+3))); + + else if(i+2 <= ijk_max[0] && i-2 >= ijk_min2[0]) + + + f_rhs[_t]=f_rhs[_t]+ + Sfx[_t]*d12dxyz[0]*(_FH3_((i+1),(j+3),(k+3))-8*_FH3_((i+2),(j+3),(k+3))+8*_FH3_((i+4),(j+3),(k+3))-_FH3_((i+5),(j+3),(k+3))); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min2[0]) + + f_rhs[_t]=f_rhs[_t] + Sfx[_t]*d2dxyz[0]*(-_FH3_((i+2),(j+3),(k+3))+_FH3_((i+4),(j+3),(k+3))); + + + // y direction + if(Sfy[_t] >= 0 && j+3 <= ijk_max[1] && j-1 >= ijk_min2[1]) + + f_rhs[_t]=f_rhs[_t]+ + Sfy[_t]*d12dxyz[1]*(-3*_FH3_((i+3),(j+2),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+4),(k+3)) + -6*_FH3_((i+3),(j+5),(k+3))+ _FH3_((i+3),(j+6),(k+3))); + + else if(Sfy[_t] <= 0 && j-3 >= ijk_min2[1] && j+1 <= ijk_max[1]) + f_rhs[_t]=f_rhs[_t]- + Sfy[_t]*d12dxyz[1]*(-3*_FH3_((i+3),(j+4),(k+3))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+2),(k+3)) + -6*_FH3_((i+3),(j+1),(k+3))+ _FH3_((i+3),j,(k+3))); + + else if(j+2 <= ijk_max[1] && j-2 >= ijk_min2[1]) + + f_rhs[_t]=f_rhs[_t]+ + Sfy[_t]*d12dxyz[1]*(_FH3_((i+3),(j+1),(k+3))-8*_FH3_((i+3),(j+2),(k+3))+8*_FH3_((i+3),(j+4),(k+3))-_FH3_((i+3),(j+5),(k+3))); + + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min2[1]) + + f_rhs[_t]=f_rhs[_t] + Sfy[_t]*d2dxyz[1]*(-_FH3_((i+3),(j+2),(k+3))+_FH3_((i+3),(j+4),(k+3))); + + + // z direction + if(Sfz[_t] >= 0 && k+3 <= ijk_max[2] && k-1 >= ijk_min2[2]) + // v + // D f = ------[ - 3f - 10f + 18f - 6f + f ] + // i 12dx i-v i i+v i+2v i+3v + f_rhs[_t]=f_rhs[_t]+ + Sfz[_t]*d12dxyz[2]*(-3*_FH3_((i+3),(j+3),(k+2))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+3),(k+4)) + -6*_FH3_((i+3),(j+3),(k+5))+ _FH3_((i+3),(j+3),(k+6))); + + else if(Sfz[_t] <= 0 && k-3 >= ijk_min2[2] && k+1 <= ijk_max[2]) + f_rhs[_t]=f_rhs[_t]- + Sfz[_t]*d12dxyz[2]*(-3*_FH3_((i+3),(j+3),(k+4))-10*_FH3_((i+3),(j+3),(k+3))+18*_FH3_((i+3),(j+3),(k+2)) + -6*_FH3_((i+3),(j+3),(k+1))+ _FH3_((i+3),(j+3),k)); + + else if(k+2 <= ijk_max[2] && k-2 >= ijk_min2[2]) + + f_rhs[_t]=f_rhs[_t]+ + Sfz[_t]*d12dxyz[2]*(_FH3_((i+3),(j+3),(k+1))-8*_FH3_((i+3),(j+3),(k+2))+8*_FH3_((i+3),(j+3),(k+4))-_FH3_((i+3),(j+3),(k+5))); + + else if(k+1 <= ijk_max[2] && k-1 >= ijk_min2[2]) + + f_rhs[_t]=f_rhs[_t]+Sfz[_t]*d2dxyz[2]*(-_FH3_((i+3),(j+3),(k+2))+_FH3_((i+3),(j+3),(k+4))); + } + //------------------- + _t += STEP_SIZE; + } +} + + +inline void sub_lopsided(double *f,double*fh,double *f_rhs,double *Sfx,double *Sfy,double *Sfz,double *SoA){ + sub_symmetry_bd(3,f,fh,SoA); + cudaThreadSynchronize(); + sub_lopsided_part1<<>>(f,fh,f_rhs,Sfx,Sfy,Sfz); + cudaThreadSynchronize(); +} + +__global__ void compute_rhs_bssn_part1() +{ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int curr = tid; + while(curr < _3D_SIZE[0]) + { + metac.alpn1[curr] = metac.Lap[curr] + 1; + metac.chin1[curr] = metac.chi[curr] + 1; + metac.gxx[curr] = metac.dxx[curr] + 1; + metac.gyy[curr] = metac.dyy[curr] + 1; + metac.gzz[curr] = metac.dzz[curr] + 1; + + curr += STEP_SIZE; + } +} + +__global__ void compute_rhs_bssn_part2() +{ + //__shared__ int judge = 1; + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + + M_ div_beta[_t] = M_ betaxx[_t] + M_ betayy[_t] + M_ betazz[_t]; + M_ chi_rhs[_t] = F2o3 *M_ chin1[_t]*( M_ alpn1[_t] * M_ trK[_t] - M_ div_beta[_t] ); //rhs[_t] for M_ chi + + M_ gxx_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axx[_t] - F2o3 * M_ gxx[_t]* M_ div_beta[_t] + + 2 *( M_ gxx[_t]* M_ betaxx[_t]+ M_ gxy[_t]* M_ betayx[_t]+ M_ gxz[_t]* M_ betazx[_t]); + M_ gyy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayy[_t] - F2o3 * M_ gyy[_t]* M_ div_beta[_t] + + 2 *( M_ gxy[_t]* M_ betaxy[_t]+ M_ gyy[_t]* M_ betayy[_t]+ M_ gyz[_t]* M_ betazy[_t]); + + M_ gzz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Azz[_t] - F2o3 * M_ gzz[_t]* M_ div_beta[_t] + + 2 *( M_ gxz[_t]* M_ betaxz[_t]+ M_ gyz[_t]* M_ betayz[_t]+ M_ gzz[_t]* M_ betazz[_t]); + + M_ gxy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axy[_t] + F1o3 * M_ gxy[_t] * M_ div_beta[_t] + + M_ gxx[_t]* M_ betaxy[_t] + M_ gxz[_t]* M_ betazy[_t]+ + M_ gyy[_t]* M_ betayx[_t]+ M_ gyz[_t]* M_ betazx[_t] + - M_ gxy[_t]* M_ betazz[_t]; + + M_ gyz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayz[_t] + F1o3 * M_ gyz[_t] * M_ div_beta[_t] + + M_ gxy[_t]* M_ betaxz[_t]+ M_ gyy[_t]* M_ betayz[_t] + + M_ gxz[_t]* M_ betaxy[_t] + M_ gzz[_t]* M_ betazy[_t] + - M_ gyz[_t]* M_ betaxx[_t]; + + M_ gxz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axz[_t] + F1o3 * M_ gxz[_t] * M_ div_beta[_t] + + M_ gxx[_t]* M_ betaxz[_t]+ M_ gxy[_t]* M_ betayz[_t] + + M_ gyz[_t]* M_ betayx[_t]+ M_ gzz[_t]* M_ betazx[_t] + - M_ gxz[_t]* M_ betayy[_t]; //rhs[_t] for gij + + // invert tilted metric + M_ gupzz[_t]= M_ gxx[_t]* M_ gyy[_t]* M_ gzz[_t]+ M_ gxy[_t]* M_ gyz[_t]* M_ gxz[_t]+ M_ gxz[_t]* M_ gxy[_t]* M_ gyz[_t]- + M_ gxz[_t]* M_ gyy[_t]* M_ gxz[_t]- M_ gxy[_t]* M_ gxy[_t]* M_ gzz[_t]- M_ gxx[_t]* M_ gyz[_t]* M_ gyz[_t]; + M_ gupxx[_t]= ( M_ gyy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gyz[_t]) / M_ gupzz[_t]; + M_ gupxy[_t]= - ( M_ gxy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupxz[_t]= ( M_ gxy[_t]* M_ gyz[_t]- M_ gyy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupyy[_t]= ( M_ gxx[_t]* M_ gzz[_t]- M_ gxz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupyz[_t]= - ( M_ gxx[_t]* M_ gyz[_t]- M_ gxy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupzz[_t]= ( M_ gxx[_t]* M_ gyy[_t]- M_ gxy[_t]* M_ gxy[_t]) / M_ gupzz[_t]; + //if(threadIdx.x == 0){ + // judge = co_c; + //} + //__syncthreads(); + + if(co_c == 0) + { + // M_ Gam^i_Res = M_ Gam^i + M_ gup^ij_,j + M_ Gmx_Res[_t] = M_ Gamx[_t] - (M_ gupxx[_t]*(M_ gupxx[_t]*M_ gxxx[_t]+M_ gupxy[_t]*M_ gxyx[_t]+M_ gupxz[_t]*M_ gxzx[_t]) + +M_ gupxy[_t]*(M_ gupxx[_t]*M_ gxyx[_t]+M_ gupxy[_t]*M_ gyyx[_t]+M_ gupxz[_t]*M_ gyzx[_t]) + +M_ gupxz[_t]*(M_ gupxx[_t]*M_ gxzx[_t]+M_ gupxy[_t]*M_ gyzx[_t]+M_ gupxz[_t]*M_ gzzx[_t]) + +M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) + +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) + +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) + +M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) + +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); + M_ Gmy_Res[_t] = M_ Gamy[_t] - (M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxx[_t]+M_ gupyy[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gxzx[_t]) + +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyx[_t]+M_ gupyy[_t]*M_ gyyx[_t]+M_ gupyz[_t]*M_ gyzx[_t]) + +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzx[_t]+M_ gupyy[_t]*M_ gyzx[_t]+M_ gupyz[_t]*M_ gzzx[_t]) + +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) + +M_ gupyy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) + +M_ gupyz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) + +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) + +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); + M_ Gmz_Res[_t] = M_ Gamz[_t] - (M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxx[_t]+M_ gupyz[_t]*M_ gxyx[_t]+M_ gupzz[_t]*M_ gxzx[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gyyx[_t]+M_ gupzz[_t]*M_ gyzx[_t]) + +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzx[_t]+M_ gupyz[_t]*M_ gyzx[_t]+M_ gupzz[_t]*M_ gzzx[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxy[_t]+M_ gupyz[_t]*M_ gxyy[_t]+M_ gupzz[_t]*M_ gxzy[_t]) + +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gyyy[_t]+M_ gupzz[_t]*M_ gyzy[_t]) + +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzy[_t]+M_ gupyz[_t]*M_ gyzy[_t]+M_ gupzz[_t]*M_ gzzy[_t]) + +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) + +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) + +M_ gupzz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); + }//if(co == 0) + + // second kind of connection + M_ Gamxxx[_t]=HALF*( M_ gupxx[_t]*M_ gxxx[_t]+ M_ gupxy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupxz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); + M_ Gamyxx[_t]=HALF*( M_ gupxy[_t]*M_ gxxx[_t]+ M_ gupyy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupyz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); + M_ Gamzxx[_t]=HALF*( M_ gupxz[_t]*M_ gxxx[_t]+ M_ gupyz[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupzz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); + + M_ Gamxyy[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupxy[_t]*M_ gyyy[_t]+ M_ gupxz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); + M_ Gamyyy[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupyz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); + M_ Gamzyy[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyz[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); + + M_ Gamxzz[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupxy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupxz[_t]*M_ gzzz[_t]); + M_ Gamyzz[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupyz[_t]*M_ gzzz[_t]); + M_ Gamzzz[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyz[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupzz[_t]*M_ gzzz[_t]); + + M_ Gamxxy[_t]=HALF*( M_ gupxx[_t]*M_ gxxy[_t]+ M_ gupxy[_t]*M_ gyyx[_t]+ M_ gupxz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); + M_ Gamyxy[_t]=HALF*( M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupyy[_t]*M_ gyyx[_t]+ M_ gupyz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); + M_ Gamzxy[_t]=HALF*( M_ gupxz[_t]*M_ gxxy[_t]+ M_ gupyz[_t]*M_ gyyx[_t]+ M_ gupzz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); + + M_ Gamxxz[_t]=HALF*( M_ gupxx[_t]*M_ gxxz[_t]+ M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupxz[_t]*M_ gzzx[_t]); + M_ Gamyxz[_t]=HALF*( M_ gupxy[_t]*M_ gxxz[_t]+ M_ gupyy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupyz[_t]*M_ gzzx[_t]); + M_ Gamzxz[_t]=HALF*( M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupzz[_t]*M_ gzzx[_t]); + + M_ Gamxyz[_t]=HALF*( M_ gupxx[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupxy[_t]*M_ gyyz[_t]+ M_ gupxz[_t]*M_ gzzy[_t]); + M_ Gamyyz[_t]=HALF*( M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyy[_t]*M_ gyyz[_t]+ M_ gupyz[_t]*M_ gzzy[_t]); + M_ Gamzyz[_t]=HALF*( M_ gupxz[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyz[_t]*M_ gyyz[_t]+ M_ gupzz[_t]*M_ gzzy[_t]); + // Raise indices of \tilde A_{ij} and store in R_ij + + M_ Rxx[_t]= M_ gupxx[_t]* M_ gupxx[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupxy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupxz[_t]* M_ Azz[_t]+ + 2*(M_ gupxx[_t]* M_ gupxy[_t]* M_ Axy[_t]+ M_ gupxx[_t]* M_ gupxz[_t]* M_ Axz[_t]+ M_ gupxy[_t]* M_ gupxz[_t]* M_ Ayz[_t]); + + M_ Ryy[_t]= M_ gupxy[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ + 2*(M_ gupxy[_t]* M_ gupyy[_t]* M_ Axy[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayz[_t]); + + M_ Rzz[_t]= M_ gupxz[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ + 2*(M_ gupxz[_t]* M_ gupyz[_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Ayz[_t]); + + M_ Rxy[_t]= M_ gupxx[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ + (M_ gupxx[_t]* M_ gupyy[_t] + M_ gupxy[_t]* M_ gupxy[_t])* M_ Axy[_t] + + (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupxy[_t])* M_ Axz[_t] + + (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupyy[_t])* M_ Ayz[_t]; + + M_ Rxz[_t]= M_ gupxx[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ + (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxy[_t]* M_ gupxz[_t])* M_ Axy[_t] + + (M_ gupxx[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupxz[_t])* M_ Axz[_t] + + (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; + + M_ Ryz[_t]= M_ gupxy[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ + (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupyy[_t]* M_ gupxz[_t])* M_ Axy[_t] + + (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupxz[_t])* M_ Axz[_t] + + (M_ gupyy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; + + // Right hand side for M_ Gam^i without shift terms... + + M_ Gamx_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxx[_t]+ M_ Lapy[_t] * M_ Rxy[_t]+ M_ Lapz[_t] * M_ Rxz[_t]) + + 2 * M_ alpn1[_t] * ( + -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxx[_t]+ M_ chiy[_t] * M_ Rxy[_t]+ M_ chiz[_t] * M_ Rxz[_t]) - + M_ gupxx[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - + M_ gupxy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - + M_ gupxz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + + M_ Gamxxx[_t]* M_ Rxx[_t]+ M_ Gamxyy[_t]* M_ Ryy[_t]+ M_ Gamxzz[_t]* M_ Rzz[_t] + + 2 * ( M_ Gamxxy[_t]* M_ Rxy[_t]+ M_ Gamxxz[_t]* M_ Rxz[_t]+ M_ Gamxyz[_t]* M_ Ryz[_t]) ); + + M_ Gamy_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxy[_t]+ M_ Lapy[_t] * M_ Ryy[_t]+ M_ Lapz[_t] * M_ Ryz[_t]) + + 2 * M_ alpn1[_t] * ( + -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxy[_t]+ M_ chiy[_t] * M_ Ryy[_t]+ M_ chiz[_t] * M_ Ryz[_t]) - + M_ gupxy[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - + M_ gupyy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - + M_ gupyz[_t]* ( F2o3 * M_ Kz [_t] + 8 * PI * M_ Sz[_t] ) + + M_ Gamyxx[_t]* M_ Rxx[_t]+ M_ Gamyyy[_t]* M_ Ryy[_t]+ M_ Gamyzz[_t]* M_ Rzz[_t] + + 2 * ( M_ Gamyxy[_t]* M_ Rxy[_t]+ M_ Gamyxz[_t]* M_ Rxz[_t]+ M_ Gamyyz[_t]* M_ Ryz[_t]) ); + + M_ Gamz_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxz[_t]+ M_ Lapy[_t] * M_ Ryz[_t]+ M_ Lapz[_t] * M_ Rzz[_t]) + + 2 * M_ alpn1[_t] * ( + -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxz[_t]+ M_ chiy[_t] * M_ Ryz[_t]+ M_ chiz[_t] * M_ Rzz[_t]) - + M_ gupxz[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - + M_ gupyz[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - + M_ gupzz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + + M_ Gamzxx[_t]* M_ Rxx[_t]+ M_ Gamzyy[_t]* M_ Ryy[_t]+ M_ Gamzzz[_t]* M_ Rzz[_t] + + 2 * ( M_ Gamzxy[_t]* M_ Rxy[_t]+ M_ Gamzxz[_t]* M_ Rxz[_t]+ M_ Gamzyz[_t]* M_ Ryz[_t]) ); + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_bssn_part3() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ fxx [_t]= M_ gxxx[_t]+ M_ gxyy[_t]+ M_ gxzz[_t]; + M_ fxy[_t]= M_ gxyx[_t]+ M_ gyyy[_t]+ M_ gyzz[_t]; + M_ fxz[_t]= M_ gxzx[_t]+ M_ gyzy[_t]+ M_ gzzz[_t]; + + M_ Gamxa[_t]= M_ gupxx [_t]* M_ Gamxxx [_t]+ M_ gupyy[_t]* M_ Gamxyy[_t]+ M_ gupzz[_t]* M_ Gamxzz[_t]+ + 2*( M_ gupxy[_t]* M_ Gamxxy[_t]+ M_ gupxz[_t]* M_ Gamxxz[_t]+ M_ gupyz[_t]* M_ Gamxyz[_t]); + M_ Gamya[_t]= M_ gupxx [_t]* M_ Gamyxx [_t]+ M_ gupyy[_t]* M_ Gamyyy[_t]+ M_ gupzz[_t]* M_ Gamyzz[_t]+ + 2*( M_ gupxy[_t]* M_ Gamyxy[_t]+ M_ gupxz[_t]* M_ Gamyxz[_t]+ M_ gupyz[_t]* M_ Gamyyz[_t]); + M_ Gamza[_t]= M_ gupxx [_t]* M_ Gamzxx [_t]+ M_ gupyy[_t]* M_ Gamzyy[_t]+ M_ gupzz[_t]* M_ Gamzzz[_t]+ + 2*( M_ gupxy[_t]* M_ Gamzxy[_t]+ M_ gupxz[_t]* M_ Gamzxz[_t]+ M_ gupyz[_t]* M_ Gamzyz[_t]); + + + + M_ Gamx_rhs[_t] = M_ Gamx_rhs[_t] + F2o3 * M_ Gamxa[_t]* M_ div_beta[_t] - + M_ Gamxa[_t]* M_ betaxx [_t]- M_ Gamya[_t]* M_ betaxy[_t]- M_ Gamza[_t]* M_ betaxz[_t] + + F1o3 * (M_ gupxx [_t]* M_ fxx [_t] + M_ gupxy[_t]* M_ fxy[_t] + M_ gupxz[_t]* M_ fxz[_t] ) + + M_ gupxx [_t]* M_ gxxx [_t] + M_ gupyy[_t]* M_ gyyx [_t] + M_ gupzz[_t]* M_ gzzx [_t] + + 2 * (M_ gupxy[_t]* M_ gxyx [_t] + M_ gupxz[_t]* M_ gxzx [_t] + M_ gupyz[_t]* M_ gyzx [_t] ); + + M_ Gamy_rhs[_t] = M_ Gamy_rhs[_t] + F2o3 * M_ Gamya[_t]* M_ div_beta[_t] - + M_ Gamxa[_t]* M_ betayx [_t]- M_ Gamya[_t]* M_ betayy[_t]- M_ Gamza[_t]* M_ betayz[_t] + + F1o3 * (M_ gupxy[_t]* M_ fxx [_t] + M_ gupyy[_t]* M_ fxy[_t] + M_ gupyz[_t]* M_ fxz[_t] ) + + M_ gupxx [_t]* M_ gxxy[_t] + M_ gupyy[_t]* M_ gyyy[_t] + M_ gupzz[_t]* M_ gzzy[_t] + + 2 * (M_ gupxy[_t]* M_ gxyy[_t] + M_ gupxz[_t]* M_ gxzy[_t] + M_ gupyz[_t]* M_ gyzy[_t] ); + + M_ Gamz_rhs[_t] = M_ Gamz_rhs[_t] + F2o3 * M_ Gamza[_t]* M_ div_beta[_t] - + M_ Gamxa[_t]* M_ betazx [_t]- M_ Gamya[_t]* M_ betazy[_t]- M_ Gamza[_t]* M_ betazz[_t] + + F1o3 * (M_ gupxz[_t]* M_ fxx [_t] + M_ gupyz[_t]* M_ fxy[_t] + M_ gupzz[_t]* M_ fxz[_t] ) + + M_ gupxx [_t]* M_ gxxz[_t] + M_ gupyy[_t]* M_ gyyz[_t] + M_ gupzz[_t]* M_ gzzz[_t] + + 2 * (M_ gupxy[_t]* M_ gxyz[_t] + M_ gupxz[_t]* M_ gxzz[_t] + M_ gupyz[_t]* M_ gyzz[_t] ) ; //rhs M_ for M_ Gam^i + + //first kind of connection stored in M_ gij,k + M_ gxxx [_t]= M_ gxx [_t]* M_ Gamxxx [_t]+ M_ gxy[_t]* M_ Gamyxx [_t]+ M_ gxz[_t]* M_ Gamzxx[_t]; + M_ gxyx [_t]= M_ gxx [_t]* M_ Gamxxy[_t]+ M_ gxy[_t]* M_ Gamyxy[_t]+ M_ gxz[_t]* M_ Gamzxy[_t]; + M_ gxzx [_t]= M_ gxx [_t]* M_ Gamxxz[_t]+ M_ gxy[_t]* M_ Gamyxz[_t]+ M_ gxz[_t]* M_ Gamzxz[_t]; + M_ gyyx [_t]= M_ gxx [_t]* M_ Gamxyy[_t]+ M_ gxy[_t]* M_ Gamyyy[_t]+ M_ gxz[_t]* M_ Gamzyy[_t]; + M_ gyzx [_t]= M_ gxx [_t]* M_ Gamxyz[_t]+ M_ gxy[_t]* M_ Gamyyz[_t]+ M_ gxz[_t]* M_ Gamzyz[_t]; + M_ gzzx [_t]= M_ gxx [_t]* M_ Gamxzz[_t]+ M_ gxy[_t]* M_ Gamyzz[_t]+ M_ gxz[_t]* M_ Gamzzz[_t]; + M_ gxxy[_t]= M_ gxy[_t]* M_ Gamxxx [_t]+ M_ gyy[_t]* M_ Gamyxx [_t]+ M_ gyz[_t]* M_ Gamzxx[_t]; + M_ gxyy[_t]= M_ gxy[_t]* M_ Gamxxy[_t]+ M_ gyy[_t]* M_ Gamyxy[_t]+ M_ gyz[_t]* M_ Gamzxy[_t]; + M_ gxzy[_t]= M_ gxy[_t]* M_ Gamxxz[_t]+ M_ gyy[_t]* M_ Gamyxz[_t]+ M_ gyz[_t]* M_ Gamzxz[_t]; + M_ gyyy[_t]= M_ gxy[_t]* M_ Gamxyy[_t]+ M_ gyy[_t]* M_ Gamyyy[_t]+ M_ gyz[_t]* M_ Gamzyy[_t]; + M_ gyzy[_t]= M_ gxy[_t]* M_ Gamxyz[_t]+ M_ gyy[_t]* M_ Gamyyz[_t]+ M_ gyz[_t]* M_ Gamzyz[_t]; + M_ gzzy[_t]= M_ gxy[_t]* M_ Gamxzz[_t]+ M_ gyy[_t]* M_ Gamyzz[_t]+ M_ gyz[_t]* M_ Gamzzz[_t]; + M_ gxxz[_t]= M_ gxz[_t]* M_ Gamxxx [_t]+ M_ gyz[_t]* M_ Gamyxx [_t]+ M_ gzz[_t]* M_ Gamzxx[_t]; + M_ gxyz[_t]= M_ gxz[_t]* M_ Gamxxy[_t]+ M_ gyz[_t]* M_ Gamyxy[_t]+ M_ gzz[_t]* M_ Gamzxy[_t]; + M_ gxzz[_t]= M_ gxz[_t]* M_ Gamxxz[_t]+ M_ gyz[_t]* M_ Gamyxz[_t]+ M_ gzz[_t]* M_ Gamzxz[_t]; + M_ gyyz[_t]= M_ gxz[_t]* M_ Gamxyy[_t]+ M_ gyz[_t]* M_ Gamyyy[_t]+ M_ gzz[_t]* M_ Gamzyy[_t]; + M_ gyzz[_t]= M_ gxz[_t]* M_ Gamxyz[_t]+ M_ gyz[_t]* M_ Gamyyz[_t]+ M_ gzz[_t]* M_ Gamzyz[_t]; + M_ gzzz[_t]= M_ gxz[_t]* M_ Gamxzz[_t]+ M_ gyz[_t]* M_ Gamyzz[_t]+ M_ gzz[_t]* M_ Gamzzz[_t]; + + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_bssn_part4() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ Rxx [_t]= - HALF *M_ Rxx [_t] + + M_ gxx [_t]* M_ Gamxx[_t] +M_ gxy[_t]* M_ Gamyx [_t] + M_ gxz[_t]* M_ Gamzx [_t]+ + M_ Gamxa[_t]*M_ gxxx [_t]+ M_ Gamya[_t]*M_ gxyx [_t]+ M_ Gamza[_t]*M_ gxzx [_t] + + M_ gupxx [_t]*( + 2*(M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxyx [_t]+ M_ Gamzxx [_t]*M_ gxzx[_t]) + + M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxxy[_t]+ M_ Gamzxx [_t]*M_ gxxz[_t])+ + M_ gupxy[_t]*( + 2*(M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gyyx [_t]+ M_ Gamzxx [_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx[_t]) + + M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxxy[_t]+ M_ Gamzxy[_t]*M_ gxxz[_t] + + M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ + M_ gupxz[_t]*( + 2*(M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gyzx [_t]+ M_ Gamzxx [_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx[_t]) + + M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxxy[_t]+ M_ Gamzxz[_t]*M_ gxxz[_t] + + M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ + M_ gupyy[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx[_t]) + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ + M_ gupyz[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx[_t]) + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ + M_ gupzz[_t]*( + 2*(M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx[_t]) + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]); + + M_ Ryy[_t]= - HALF *M_ Ryy[_t] + + M_ gxy[_t]* M_ Gamxy[_t]+ M_ gyy[_t]* M_ Gamyy[_t] + M_ gyz[_t]* M_ Gamzy[_t] + + M_ Gamxa[_t]*M_ gxyy[_t]+ M_ Gamya[_t]*M_ gyyy[_t]+ M_ Gamza[_t]*M_ gyzy[_t] + + M_ gupxx [_t]*( + 2*(M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t]) + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ + M_ gupxy[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gxxy[_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxzy[_t]) + + M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ + M_ gupxz[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t]) + + M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupyy[_t]*( + 2*(M_ Gamxyy[_t]*M_ gxyy[_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyzy[_t]) + + M_ Gamxyy[_t]*M_ gyyx [_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyyz[_t])+ + M_ gupyz[_t]*( + 2*(M_ Gamxyy[_t]*M_ gxzy[_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t]) + + M_ Gamxyz[_t]*M_ gyyx [_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyyz[_t] + + M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ + M_ gupzz[_t]*( + 2*(M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t]) + + M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]); + + M_ Rzz[_t]= - HALF *M_ Rzz[_t] + + M_ gxz[_t]* M_ Gamxz[_t] +M_ gyz[_t]* M_ Gamyz[_t] + M_ gzz[_t]* M_ Gamzz[_t] + + M_ Gamxa[_t]*M_ gxzz[_t]+ M_ Gamya[_t]*M_ gyzz[_t]+ M_ Gamza[_t]*M_ gzzz[_t] + + M_ gupxx [_t]*( + 2*(M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]) + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t])+ + M_ gupxy[_t]*( + 2*(M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t]) + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t])+ + M_ gupxz[_t]*( + 2*(M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxxz[_t]+ M_ Gamyzz[_t]*M_ gxyz[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t]) + + M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gxzy[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t])+ + M_ gupyy[_t]*( + 2*(M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]) + + M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t])+ + M_ gupyz[_t]*( + 2*(M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxyz[_t]+ M_ Gamyzz[_t]*M_ gyyz[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t]) + + M_ Gamxzz[_t]*M_ gyzx [_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t])+ + M_ gupzz[_t]*( + 2*(M_ Gamxzz[_t]*M_ gxzz[_t]+ M_ Gamyzz[_t]*M_ gyzz[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]) + + M_ Gamxzz[_t]*M_ gzzx [_t]+ M_ Gamyzz[_t]*M_ gzzy[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]); + + M_ Rxy[_t]= HALF*( -M_ Rxy[_t] + + M_ gxx [_t]* M_ Gamxy[_t]+ M_ gxy[_t]* M_ Gamyy[_t]+M_ gxz[_t]* M_ Gamzy[_t] + + M_ gxy[_t]* M_ Gamxx [_t]+ M_ gyy[_t]* M_ Gamyx [_t]+M_ gyz[_t]* M_ Gamzx [_t] + + M_ Gamxa[_t]*M_ gxyx [_t]+ M_ Gamya[_t]*M_ gyyx [_t]+ M_ Gamza[_t]*M_ gyzx [_t] + + M_ Gamxa[_t]*M_ gxxy[_t]+ M_ Gamya[_t]*M_ gxyy[_t]+ M_ Gamza[_t]*M_ gxzy[_t])+ + M_ gupxx [_t]*( + M_ Gamxxx [_t]*M_ gxxy[_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ + M_ gupxy[_t]*( + M_ Gamxxx [_t]*M_ gxyy[_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyzy[_t] + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t] + + M_ Gamxyy[_t]*M_ gxxx [_t]+ M_ Gamyyy[_t]*M_ gxyx [_t]+ M_ Gamzyy[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gyyx [_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyyz[_t])+ + M_ gupxz[_t]*( + M_ Gamxxx [_t]*M_ gxzy[_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gzzy[_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + + M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + + M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ + M_ gupyy[_t]*( + M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gyyx [_t]+ M_ Gamzyy[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ + M_ gupyz[_t]*( + M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + + M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gyzx [_t]+ M_ Gamzyy[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gyyx [_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyyz[_t] + + M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + + M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupzz[_t]*( + M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t]); + + M_ Rxz[_t]= HALF*( -M_ Rxz[_t] + + M_ gxx [_t]* M_ Gamxz[_t]+ M_ gxy[_t]* M_ Gamyz[_t]+M_ gxz[_t]* M_ Gamzz[_t] + + M_ gxz[_t]* M_ Gamxx [_t]+ M_ gyz[_t]* M_ Gamyx [_t]+M_ gzz[_t]* M_ Gamzx [_t] + + M_ Gamxa[_t]*M_ gxzx [_t]+ M_ Gamya[_t]*M_ gyzx [_t]+ M_ Gamza[_t]*M_ gzzx [_t] + + M_ Gamxa[_t]*M_ gxxz[_t]+ M_ Gamya[_t]*M_ gxyz[_t]+ M_ Gamza[_t]*M_ gxzz[_t])+ + M_ gupxx [_t]*( + M_ Gamxxx [_t]*M_ gxxz[_t]+ M_ Gamyxx [_t]*M_ gxyz[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ + M_ gupxy[_t]*( + M_ Gamxxx [_t]*M_ gxyz[_t]+ M_ Gamyxx [_t]*M_ gyyz[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t] + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + + M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + + M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ + M_ gupxz[_t]*( + M_ Gamxxx [_t]*M_ gxzz[_t]+ M_ Gamyxx [_t]*M_ gyzz[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t] + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + + M_ Gamxzz[_t]*M_ gxxx [_t]+ M_ Gamyzz[_t]*M_ gxyx [_t]+ M_ Gamzzz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gzzx [_t]+ M_ Gamyxx [_t]*M_ gzzy[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t])+ + M_ gupyy[_t]*( + M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupyz[_t]*( + M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + + M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + + M_ Gamxzz[_t]*M_ gxyx [_t]+ M_ Gamyzz[_t]*M_ gyyx [_t]+ M_ Gamzzz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ + M_ gupzz[_t]*( + M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gyzx [_t]+ M_ Gamzzz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t]); + + M_ Ryz[_t]= HALF*( -M_ Ryz[_t] + + M_ gxy[_t]* M_ Gamxz[_t]+M_ gyy[_t]* M_ Gamyz[_t]+M_ gyz[_t]* M_ Gamzz[_t] + + M_ gxz[_t]* M_ Gamxy[_t]+M_ gyz[_t]* M_ Gamyy[_t]+M_ gzz[_t]* M_ Gamzy[_t] + + M_ Gamxa[_t]*M_ gxzy[_t]+ M_ Gamya[_t]*M_ gyzy[_t]+ M_ Gamza[_t]*M_ gzzy[_t] + + M_ Gamxa[_t]*M_ gxyz[_t]+ M_ Gamya[_t]*M_ gyyz[_t]+ M_ Gamza[_t]*M_ gyzz[_t])+ + M_ gupxx [_t]*( + M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ + M_ gupxy[_t]*( + M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + + M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gxzy[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + + M_ Gamxyy[_t]*M_ gxxz[_t]+ M_ Gamyyy[_t]*M_ gxyz[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + + M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupxz[_t]*( + M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + + M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + + M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + + M_ Gamxzz[_t]*M_ gxxy[_t]+ M_ Gamyzz[_t]*M_ gxyy[_t]+ M_ Gamzzz[_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ + M_ gupyy[_t]*( + M_ Gamxyy[_t]*M_ gxyz[_t]+ M_ Gamyyy[_t]*M_ gyyz[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ + M_ gupyz[_t]*( + M_ Gamxyy[_t]*M_ gxzz[_t]+ M_ Gamyyy[_t]*M_ gyzz[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t] + + M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + + M_ Gamxzz[_t]*M_ gxyy[_t]+ M_ Gamyzz[_t]*M_ gyyy[_t]+ M_ Gamzzz[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gzzx [_t]+ M_ Gamyyy[_t]*M_ gzzy[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t])+ + M_ gupzz[_t]*( + M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxzy[_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t]); + + _t += STEP_SIZE; + } +} +__global__ void compute_rhs_bssn_part5() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx [_t]* M_ chix [_t]- M_ Gamyxx [_t]* M_ chiy[_t]- M_ Gamzxx [_t]* M_ chiz[_t]; + M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]* M_ chix [_t]- M_ Gamyxy[_t]* M_ chiy[_t]- M_ Gamzxy[_t]* M_ chiz[_t]; + M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]* M_ chix [_t]- M_ Gamyxz[_t]* M_ chiy[_t]- M_ Gamzxz[_t]* M_ chiz[_t]; + M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]* M_ chix [_t]- M_ Gamyyy[_t]* M_ chiy[_t]- M_ Gamzyy[_t]* M_ chiz[_t]; + M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]* M_ chix [_t]- M_ Gamyyz[_t]* M_ chiy[_t]- M_ Gamzyz[_t]* M_ chiz[_t]; + M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]* M_ chix [_t]- M_ Gamyzz[_t]* M_ chiy[_t]- M_ Gamzzz[_t]* M_ chiz[_t]; + // M_ Store D^l D_l M_ chi - 3/(2*M_ chi) D^l M_ chi D_l M_ chi inM_ f[_t] + + M_ f[_t] = M_ gupxx [_t]* (M_ fxx [_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chix [_t]) + + M_ gupyy[_t]* (M_ fyy[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiy[_t]) + + M_ gupzz[_t]* (M_ fzz[_t]- F3o2/M_ chin1[_t] * M_ chiz[_t]* M_ chiz[_t]) + + 2 *M_ gupxy[_t]* (M_ fxy[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiy[_t]) + + 2 *M_ gupxz[_t]* (M_ fxz[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiz[_t]) + + 2 *M_ gupyz[_t]* (M_ fyz[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiz[_t]); + // M_ Add M_ chi part toM_ Ricci tensor: + + M_ Rxx [_t]=M_ Rxx [_t]+ (M_ fxx [_t]- M_ chix[_t]*M_ chix[_t]/M_ chin1[_t]/2 +M_ gxx [_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Ryy[_t]=M_ Ryy[_t]+ (M_ fyy[_t]- M_ chiy[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gyy[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Rzz[_t]=M_ Rzz[_t]+ (M_ fzz[_t]- M_ chiz[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gzz[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Rxy[_t]=M_ Rxy[_t]+ (M_ fxy[_t]- M_ chix[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gxy[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Rxz[_t]=M_ Rxz[_t]+ (M_ fxz[_t]- M_ chix[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gxz[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Ryz[_t]=M_ Ryz[_t]+ (M_ fyz[_t]- M_ chiy[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gyz[_t]*M_ f[_t])/M_ chin1[_t]/2; + + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_bssn_part6() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ gxxx [_t]= (M_ gupxx [_t]* M_ chix [_t]+M_ gupxy[_t]* M_ chiy[_t]+M_ gupxz[_t]* M_ chiz[_t])/M_ chin1[_t]; + M_ gxxy[_t]= (M_ gupxy[_t]* M_ chix [_t]+M_ gupyy[_t]* M_ chiy[_t]+M_ gupyz[_t]* M_ chiz[_t])/M_ chin1[_t]; + M_ gxxz[_t]= (M_ gupxz[_t]* M_ chix [_t]+M_ gupyz[_t]* M_ chiy[_t]+M_ gupzz[_t]* M_ chiz[_t])/M_ chin1[_t]; + // nowM_ get physical second kind of connection + M_ Gamxxx [_t]= M_ Gamxxx [_t]- ( (M_ chix [_t]+ M_ chix[_t])/M_ chin1[_t] -M_ gxx [_t]*M_ gxxx [_t])*HALF; + M_ Gamyxx [_t]= M_ Gamyxx [_t]- ( -M_ gxx [_t]*M_ gxxy[_t])*HALF; + M_ Gamzxx [_t]= M_ Gamzxx [_t]- ( -M_ gxx [_t]*M_ gxxz[_t])*HALF; + M_ Gamxyy[_t]= M_ Gamxyy[_t]- ( -M_ gyy[_t]*M_ gxxx [_t])*HALF; + M_ Gamyyy[_t]= M_ Gamyyy[_t]- ( (M_ chiy[_t]+ M_ chiy[_t])/M_ chin1[_t] -M_ gyy[_t]*M_ gxxy[_t])*HALF; + M_ Gamzyy[_t]= M_ Gamzyy[_t]- ( -M_ gyy[_t]*M_ gxxz[_t])*HALF; + M_ Gamxzz[_t]= M_ Gamxzz[_t]- ( -M_ gzz[_t]*M_ gxxx [_t])*HALF; + M_ Gamyzz[_t]= M_ Gamyzz[_t]- ( -M_ gzz[_t]*M_ gxxy[_t])*HALF; + M_ Gamzzz[_t]= M_ Gamzzz[_t]- ( (M_ chiz[_t]+ M_ chiz[_t])/M_ chin1[_t] -M_ gzz[_t]*M_ gxxz[_t])*HALF; + M_ Gamxxy[_t]= M_ Gamxxy[_t]- ( M_ chiy[_t] /M_ chin1[_t] -M_ gxy[_t]*M_ gxxx [_t])*HALF; + M_ Gamyxy[_t]= M_ Gamyxy[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxy[_t]*M_ gxxy[_t])*HALF; + M_ Gamzxy[_t]= M_ Gamzxy[_t]- ( -M_ gxy[_t]*M_ gxxz[_t])*HALF; + M_ Gamxxz[_t]= M_ Gamxxz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gxz[_t]*M_ gxxx [_t])*HALF; + M_ Gamyxz[_t]= M_ Gamyxz[_t]- ( -M_ gxz[_t]*M_ gxxy[_t])*HALF; + M_ Gamzxz[_t]= M_ Gamzxz[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxz[_t]*M_ gxxz[_t])*HALF; + M_ Gamxyz[_t]= M_ Gamxyz[_t]- ( -M_ gyz[_t]*M_ gxxx [_t])*HALF; + M_ Gamyyz[_t]= M_ Gamyyz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gyz[_t]*M_ gxxy[_t])*HALF; + M_ Gamzyz[_t]= M_ Gamzyz[_t]- ( M_ chiy[_t]/M_ chin1[_t] -M_ gyz[_t]*M_ gxxz[_t])*HALF; + + M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx[_t]*M_ Lapx [_t]- M_ Gamyxx[_t]*M_ Lapy[_t]- M_ Gamzxx[_t]*M_ Lapz[_t]; + M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]*M_ Lapx [_t]- M_ Gamyyy[_t]*M_ Lapy[_t]- M_ Gamzyy[_t]*M_ Lapz[_t]; + M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]*M_ Lapx [_t]- M_ Gamyzz[_t]*M_ Lapy[_t]- M_ Gamzzz[_t]*M_ Lapz[_t]; + M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]*M_ Lapx [_t]- M_ Gamyxy[_t]*M_ Lapy[_t]- M_ Gamzxy[_t]*M_ Lapz[_t]; + M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]*M_ Lapx [_t]- M_ Gamyxz[_t]*M_ Lapy[_t]- M_ Gamzxz[_t]*M_ Lapz[_t]; + M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]*M_ Lapx [_t]- M_ Gamyyz[_t]*M_ Lapy[_t]- M_ Gamzyz[_t]*M_ Lapz[_t]; + + // store D^i D_i Lap in M_ trK_rhs[_t] upto M_ chi + M_ trK_rhs[_t] = M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ + 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]); + // M_ Add lapse and M_ S_ij parts toM_ Ricci tensor: + + //follow bam code + M_ S[_t] = M_ chin1[_t] * ( M_ gupxx[_t] * M_ Sxx[_t] + M_ gupyy[_t] * M_ Syy[_t] + M_ gupzz[_t] * M_ Szz[_t] + + + 2 * ( M_ gupxy[_t] * M_ Sxy[_t] + M_ gupxz[_t] * M_ Sxz[_t] + M_ gupyz[_t] * M_ Syz[_t] ) ); + + +M_ f[_t] = F2o3 * M_ trK[_t] * M_ trK[_t] -( + + M_ gupxx[_t] * ( + + M_ gupxx[_t] * M_ Axx[_t] * M_ Axx[_t] + M_ gupyy[_t] * M_ Axy[_t] * M_ Axy[_t] + M_ gupzz[_t] * M_ Axz[_t] * M_ Axz[_t] + + + 2 * (M_ gupxy[_t] * M_ Axx[_t] * M_ Axy[_t] + M_ gupxz[_t] * M_ Axx[_t] * M_ Axz[_t] + M_ gupyz[_t] * M_ Axy[_t] * M_ Axz[_t]) ) + + + M_ gupyy[_t] * ( + + M_ gupxx[_t] * M_ Axy[_t] * M_ Axy[_t] + M_ gupyy[_t] * M_ Ayy[_t] * M_ Ayy[_t] + M_ gupzz[_t] * M_ Ayz[_t] * M_ Ayz[_t] + + + 2 * (M_ gupxy[_t] * M_ Axy[_t] * M_ Ayy[_t] + M_ gupxz[_t] * M_ Axy[_t] * M_ Ayz[_t] + M_ gupyz[_t] * M_ Ayy[_t] * M_ Ayz[_t]) ) + + + M_ gupzz[_t] * ( + + M_ gupxx[_t] * M_ Axz[_t] * M_ Axz[_t] + M_ gupyy[_t] * M_ Ayz[_t] * M_ Ayz[_t] + M_ gupzz[_t] * M_ Azz[_t] * M_ Azz[_t] + + + 2 * (M_ gupxy[_t] * M_ Axz[_t] * M_ Ayz[_t] + M_ gupxz[_t] * M_ Axz[_t] * M_ Azz[_t] + M_ gupyz[_t] * M_ Ayz[_t] * M_ Azz[_t]) ) + + + 2 * ( + + M_ gupxy[_t] * ( + + M_ gupxx[_t] * M_ Axx[_t] * M_ Axy[_t] + M_ gupyy[_t] * M_ Axy[_t] * M_ Ayy[_t] + M_ gupzz[_t] * M_ Axz[_t] * M_ Ayz[_t] + + + M_ gupxy[_t] * (M_ Axx[_t] * M_ Ayy[_t] + M_ Axy[_t] * M_ Axy[_t]) + + + M_ gupxz[_t] * (M_ Axx[_t] * M_ Ayz[_t] + M_ Axz[_t] * M_ Axy[_t]) + + + M_ gupyz[_t] * (M_ Axy[_t] * M_ Ayz[_t] + M_ Axz[_t] * M_ Ayy[_t]) ) + + + M_ gupxz[_t] * ( + + M_ gupxx[_t] * M_ Axx[_t] * M_ Axz[_t] + M_ gupyy[_t] * M_ Axy[_t] * M_ Ayz[_t] + M_ gupzz[_t] * M_ Axz[_t] * M_ Azz[_t] + + + M_ gupxy[_t] * (M_ Axx[_t] * M_ Ayz[_t] + M_ Axy[_t] * M_ Axz[_t]) + + + M_ gupxz[_t] * (M_ Axx[_t] * M_ Azz[_t] + M_ Axz[_t] * M_ Axz[_t]) + + + M_ gupyz[_t] * (M_ Axy[_t] * M_ Azz[_t] + M_ Axz[_t] * M_ Ayz[_t]) ) + + + M_ gupyz[_t] * ( + + M_ gupxx[_t] * M_ Axy[_t] * M_ Axz[_t] + M_ gupyy[_t] * M_ Ayy[_t] * M_ Ayz[_t] + M_ gupzz[_t] * M_ Ayz[_t] * M_ Azz[_t] + + + M_ gupxy[_t] * (M_ Axy[_t] * M_ Ayz[_t] + M_ Ayy[_t] * M_ Axz[_t]) + + + M_ gupxz[_t] * (M_ Axy[_t] * M_ Azz[_t] + M_ Ayz[_t] * M_ Axz[_t]) + + + M_ gupyz[_t] * (M_ Ayy[_t] * M_ Azz[_t] + M_ Ayz[_t] * M_ Ayz[_t]) ) )) -16 * PI * M_ rho[_t] + 8 * PI * M_ S[_t]; + + + M_ f[_t] = - F1o3 *( M_ gupxx[_t] * M_ fxx[_t] + M_ gupyy[_t] * M_ fyy[_t] + M_ gupzz[_t] * M_ fzz[_t] + + + 2* ( M_ gupxy[_t] * M_ fxy[_t] + M_ gupxz[_t] * M_ fxz[_t] + M_ gupyz[_t] * M_ fyz[_t] ) + M_ alpn1[_t] / M_ chin1[_t] * M_ f[_t]); + + + + M_ fxx[_t] = M_ alpn1[_t] * (M_ Rxx[_t] - 8 * PI * M_ Sxx[_t]) - M_ fxx[_t]; + + M_ fxy[_t] = M_ alpn1[_t] * (M_ Rxy[_t] - 8 * PI * M_ Sxy[_t]) - M_ fxy[_t]; + + M_ fxz[_t] = M_ alpn1[_t] * (M_ Rxz[_t] - 8 * PI * M_ Sxz[_t]) - M_ fxz[_t]; + + M_ fyy[_t] = M_ alpn1[_t] * (M_ Ryy[_t] - 8 * PI * M_ Syy[_t]) - M_ fyy[_t]; + + M_ fyz[_t] = M_ alpn1[_t] * (M_ Ryz[_t] - 8 * PI * M_ Syz[_t]) - M_ fyz[_t]; + + M_ fzz[_t] = M_ alpn1[_t] * (M_ Rzz[_t] - 8 * PI * M_ Szz[_t]) - M_ fzz[_t]; + /* + M_ fxx [_t]= M_ alpn1[_t]* (M_ Rxx [_t]- 8 * PI * M_ Sxx[_t]) -M_ fxx[_t]; + M_ fxy[_t]= M_ alpn1[_t]* (M_ Rxy[_t]- 8 * PI * M_ Sxy[_t]) -M_ fxy[_t]; + M_ fxz[_t]= M_ alpn1[_t]* (M_ Rxz[_t]- 8 * PI * M_ Sxz[_t]) -M_ fxz[_t]; + M_ fyy[_t]= M_ alpn1[_t]* (M_ Ryy[_t]- 8 * PI * M_ Syy[_t]) -M_ fyy[_t]; + M_ fyz[_t]= M_ alpn1[_t]* (M_ Ryz[_t]- 8 * PI * M_ Syz[_t]) -M_ fyz[_t]; + M_ fzz[_t]= M_ alpn1[_t]* (M_ Rzz[_t]- 8 * PI * M_ Szz[_t]) -M_ fzz[_t]; + + // Compute trace-free part (note: M_ chi^-1 and M_ chi cancel//): + + M_ f[_t] = F1o3 *( M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ + 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) ); + */ + M_ Axx_rhs[_t] =M_ fxx [_t]-M_ gxx [_t]*M_ f[_t]; + M_ Ayy_rhs[_t] =M_ fyy[_t]-M_ gyy[_t]*M_ f[_t]; + M_ Azz_rhs[_t] =M_ fzz[_t]-M_ gzz[_t]*M_ f[_t]; + M_ Axy_rhs[_t] =M_ fxy[_t]-M_ gxy[_t]*M_ f[_t]; + M_ Axz_rhs[_t] =M_ fxz[_t]-M_ gxz[_t]*M_ f[_t]; + M_ Ayz_rhs[_t] =M_ fyz[_t]-M_ gyz[_t]*M_ f[_t]; + + // Now: store M_ A_il M_ A^l_j intoM_ fij: + + M_ fxx [_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]); + + M_ fyy[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]); + + M_ fzz[_t]= M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]); + + M_ fxy[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ + M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + + M_ gupxz[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + + M_ gupyz[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]); + M_ fxz[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]*(M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]); + M_ fyz[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]*(M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]); + + M_ f[_t] = M_ chin1[_t]; + // store D^i D_i Lap in M_ trK_rhs[_t] + M_ trK_rhs[_t] =M_ f[_t]*M_ trK_rhs[_t]; + + M_ Axx_rhs[_t] = M_ f[_t] * M_ Axx_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Axx [_t]- 2 *M_ fxx[_t]) + + 2 * ( M_ Axx [_t]* M_ betaxx [_t]+ M_ Axy[_t]* M_ betayx [_t]+ M_ Axz[_t]* M_ betazx [_t])- + F2o3 * M_ Axx [_t]* M_ div_beta[_t]; + + M_ Ayy_rhs[_t] = M_ f[_t] * M_ Ayy_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Ayy[_t]- 2 *M_ fyy[_t]) + + 2 * ( M_ Axy[_t]* M_ betaxy[_t]+ M_ Ayy[_t]* M_ betayy[_t]+ M_ Ayz[_t]* M_ betazy[_t])- + F2o3 * M_ Ayy[_t]* M_ div_beta[_t]; + + M_ Azz_rhs[_t] = M_ f[_t] * M_ Azz_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Azz[_t]- 2 *M_ fzz[_t]) + + 2 * ( M_ Axz[_t]* M_ betaxz[_t]+ M_ Ayz[_t]* M_ betayz[_t]+ M_ Azz[_t]* M_ betazz[_t])- + F2o3 * M_ Azz[_t]* M_ div_beta[_t]; + + M_ Axy_rhs[_t] = M_ f[_t] * M_ Axy_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axy[_t] - 2 *M_ fxy[_t])+ + M_ Axx [_t]* M_ betaxy[_t] + M_ Axz[_t]* M_ betazy[_t] + + M_ Ayy[_t]* M_ betayx [_t]+ M_ Ayz[_t]* M_ betazx [_t] + + F1o3 * M_ Axy[_t]* M_ div_beta[_t] - M_ Axy[_t]* M_ betazz[_t]; + + M_ Ayz_rhs[_t] = M_ f[_t] * M_ Ayz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Ayz[_t] - 2 *M_ fyz[_t])+ + M_ Axy[_t]* M_ betaxz[_t]+ M_ Ayy[_t]* M_ betayz[_t] + + M_ Axz[_t]* M_ betaxy[_t] + M_ Azz[_t]* M_ betazy[_t] + + F1o3 * M_ Ayz[_t]* M_ div_beta[_t] - M_ Ayz[_t]* M_ betaxx[_t]; + + M_ Axz_rhs[_t] = M_ f[_t] * M_ Axz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axz[_t] - 2 *M_ fxz[_t])+ + M_ Axx [_t]* M_ betaxz[_t]+ M_ Axy[_t]* M_ betayz[_t] + + M_ Ayz[_t]* M_ betayx [_t]+ M_ Azz[_t]* M_ betazx [_t] + + F1o3 * M_ Axz[_t]* M_ div_beta[_t] - M_ Axz[_t]* M_ betayy[_t] ; //rhsM_ for M_ Aij + + // Compute trace of M_ S_ij + + M_ S[_t] = M_ f[_t] * (M_ gupxx [_t]* M_ Sxx [_t]+M_ gupyy[_t]* M_ Syy[_t]+M_ gupzz[_t]* M_ Szz[_t]+ + 2 * (M_ gupxy[_t]* M_ Sxy[_t]+M_ gupxz[_t]* M_ Sxz[_t]+M_ gupyz[_t]* M_ Syz[_t]) ); + + M_ trK_rhs[_t] = - M_ trK_rhs[_t] + M_ alpn1[_t]*( F1o3 * M_ trK[_t]* M_ trK[_t] + + M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t] + + 2 * (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) + + 4 * PI * ( M_ rho[_t] + M_ S[_t] )) ; //rhsM_ for M_ trK[_t] + + ////////M_ gauge variable part + + M_ Lap_rhs[_t] = -2*M_ alpn1[_t] * M_ trK[_t]; + +#if (GAUGE == 0) + M_ betax_rhs[_t] =0.75*M_ dtSfx[_t]; + M_ betay_rhs[_t] =0.75*M_ dtSfy[_t]; + M_ betaz_rhs[_t] =0.75*M_ dtSfz[_t]; + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] -2*M_ dtSfx[_t]; + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] -2*M_ dtSfy[_t]; + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] -2*M_ dtSfz[_t]; + +#elif (GAUGE == 1) + M_ betax_rhs[_t] =M_ Gamx[_t] - 2 * M_ betax[_t] ; + + M_ betay_rhs[_t] =M_ Gamy[_t] - 2 * M_ betay[_t] ; + + M_ betaz_rhs[_t] =M_ Gamz[_t] - 2 * M_ betaz[_t] ; + + M_ dtSfx_rhs[_t] = 0; + M_ dtSfy_rhs[_t] = 0; + M_ dtSfz_rhs[_t] = 0; + +#elif (GAUGE == 2 || GAUGE == 3) + + M_ betax_rhs[_t] = 0.75* M_ dtSfx[_t]; + + M_ betay_rhs[_t] = 0.75* M_ dtSfy[_t]; + + M_ betaz_rhs[_t] = 0.75* M_ dtSfz[_t]; + +#elif (GAUGE == 6) + if(BHN==2) + { + int k = _t / _2D_SIZE[0]; + int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + r1 = ( pow2((Porg[0]-X[i]))+ pow2((Porg[1]-Y[j]))+ pow2((Porg[2]-Z[k])) ) / + + ( pow2((Porg[0]-Porg[3]))+ pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ + + ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + reta[i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1/(1 + 12 * r1) + C2/(1 + 12 *r2); + }//BHN == 2 + + M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; + + M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; + + M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; + + + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t] * M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t] * M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t] * M_ dtSfz[_t]; + +#elif (GAUGE == 7) + if(BHN==2){ + int k = _t / _2D_SIZE[0]; + int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + r1 = ( pow2((Porg[0]-X[i])) + pow2((Porg[1]-Y[j])) + pow2((Porg[2]-Z[k])) )/ + + ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ + + ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + M_ reta[_t][i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1* exp(-12 *r1) + C2*exp(- 12*r2); + }//BHN ==2 + + M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; + + M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; + + M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; + + + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]*M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]*M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]*M_ dtSfz[_t]; + +#endif //if (GAUGE == ?) + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_bssn_part6_gauge() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { +#if (GAUGE == 2) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow2( ( 1-sqrt(M_ chin1[_t]) ) ); + + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; + +#elif (GAUGE == 3) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13/2 * sqrt( M_ reta[_t]/ M_ chin1[_t])/ pow2((1-M_ chin1[_t])); + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; + +#elif (GAUGE == 4) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * + M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * + M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow( (1-sqrt(M_ chin1[_t]))); + + + M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; + + M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; + + M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; + +#elif (GAUGE == 5) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1)/ pow( (1-M_ chin1[_t]) ); + + M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; + + M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; + + M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; + + + + M_ dtSfx_rhs[_t] = 0; + + M_ dtSfy_rhs[_t] = 0; + + M_ dtSfz_rhs[_t] = 0; +#endif + _t += STEP_SIZE; + } +} +__global__ void compute_rhs_bssn_part7() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ ham_Res[_t] = M_ gupxx [_t]* M_ Rxx [_t]+ M_ gupyy[_t]* M_ Ryy[_t]+ M_ gupzz[_t]* M_ Rzz[_t]+ + 2* ( M_ gupxy[_t]* M_ Rxy[_t]+ M_ gupxz[_t]* M_ Rxz[_t]+ M_ gupyz[_t]* M_ Ryz[_t]); + + M_ ham_Res[_t] = M_ chin1[_t]*M_ ham_Res[_t] + F2o3 * M_ trK[_t] * M_ trK[_t] -( + M_ gupxx [_t]* ( + M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]) ) + + M_ gupyy[_t]* ( + M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]) ) + + M_ gupzz[_t]* ( + M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+ M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+ M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]) ) + + 2 * ( + M_ gupxy[_t]* ( + M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ + M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + + M_ gupxz[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + + M_ gupyz[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]) ) + + M_ gupxz[_t]* ( + M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]* (M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]) ) + + M_ gupyz[_t]* ( + M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]* (M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]) ) ))- 16 * PI * M_ rho[_t]; + + _t += STEP_SIZE; + } +} +__global__ void compute_rhs_bssn_part8() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ gxxx [_t]= M_ gxxx [_t]- ( M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t] + + M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t]) - M_ chix[_t]*M_ Axx[_t]/M_ chin1[_t]; + + M_ gxyx [_t]= M_ gxyx [_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] + + M_ Gamxxx [_t]* M_ Axy[_t]+ M_ Gamyxx [_t]* M_ Ayy[_t]+ M_ Gamzxx [_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Axy[_t]/M_ chin1[_t]; + + M_ gxzx [_t]= M_ gxzx [_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] + + M_ Gamxxx [_t]* M_ Axz[_t]+ M_ Gamyxx [_t]* M_ Ayz[_t]+ M_ Gamzxx [_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Axz[_t]/M_ chin1[_t]; + + M_ gyyx [_t]= M_ gyyx [_t]- ( M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t] + + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Ayy[_t]/M_ chin1[_t]; + + M_ gyzx [_t]= M_ gyzx [_t]- ( M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t] + + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Ayz[_t]/M_ chin1[_t]; + + M_ gzzx [_t]= M_ gzzx [_t]- ( M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t] + + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Azz[_t]/M_ chin1[_t]; + + M_ gxxy[_t]= M_ gxxy[_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] + + M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t]) - M_ chiy[_t]*M_ Axx[_t]/M_ chin1[_t]; + + M_ gxyy[_t]= M_ gxyy[_t]- ( M_ Gamxyy[_t]* M_ Axx [_t]+ M_ Gamyyy[_t]* M_ Axy[_t]+ M_ Gamzyy[_t]* M_ Axz[_t] + + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Axy[_t]/M_ chin1[_t]; + + M_ gxzy[_t]= M_ gxzy[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] + + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Axz[_t]/M_ chin1[_t]; + + M_ gyyy[_t]= M_ gyyy[_t]- ( M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t] + + M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Ayy[_t]/M_ chin1[_t]; + + M_ gyzy[_t]= M_ gyzy[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] + + M_ Gamxyy[_t]* M_ Axz[_t]+ M_ Gamyyy[_t]* M_ Ayz[_t]+ M_ Gamzyy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Ayz[_t]/M_ chin1[_t]; + + M_ gzzy[_t]= M_ gzzy[_t]- ( M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t] + + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Azz[_t]/M_ chin1[_t]; + + M_ gxxz[_t]= M_ gxxz[_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] + + M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t]) - M_ chiz[_t]*M_ Axx[_t]/M_ chin1[_t]; + + M_ gxyz[_t]= M_ gxyz[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] + + M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Axy[_t]/M_ chin1[_t]; + + M_ gxzz[_t]= M_ gxzz[_t]- ( M_ Gamxzz[_t]* M_ Axx [_t]+ M_ Gamyzz[_t]* M_ Axy[_t]+ M_ Gamzzz[_t]* M_ Axz[_t] + + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Axz[_t]/M_ chin1[_t]; + + M_ gyyz[_t]= M_ gyyz[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] + + M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Ayy[_t]/M_ chin1[_t]; + + M_ gyzz[_t]= M_ gyzz[_t]- ( M_ Gamxzz[_t]* M_ Axy[_t]+ M_ Gamyzz[_t]* M_ Ayy[_t]+ M_ Gamzzz[_t]* M_ Ayz[_t] + + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Ayz[_t]/M_ chin1[_t]; + + M_ gzzz[_t]= M_ gzzz[_t]- ( M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t] + + M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Azz[_t]/M_ chin1[_t]; + + M_ movx_Res[_t] = M_ gupxx[_t]*M_ gxxx [_t]+ M_ gupyy[_t]*M_ gxyy[_t]+ M_ gupzz[_t]*M_ gxzz[_t] + +M_ gupxy[_t]*M_ gxyx [_t]+ M_ gupxz[_t]*M_ gxzx [_t]+ M_ gupyz[_t]*M_ gxzy[_t] + +M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*M_ gxyz[_t]; + M_ movy_Res[_t] = M_ gupxx[_t]*M_ gxyx [_t]+ M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*M_ gyzz[_t] + +M_ gupxy[_t]*M_ gyyx [_t]+ M_ gupxz[_t]*M_ gyzx [_t]+ M_ gupyz[_t]*M_ gyzy[_t] + +M_ gupxy[_t]*M_ gxyy[_t]+ M_ gupxz[_t]*M_ gxyz[_t]+ M_ gupyz[_t]*M_ gyyz[_t]; + + M_ movz_Res[_t] = M_ gupxx[_t]*M_ gxzx [_t]+ M_ gupyy[_t]*M_ gyzy[_t]+ M_ gupzz[_t]*M_ gzzz[_t] + +M_ gupxy[_t]*M_ gyzx [_t]+ M_ gupxz[_t]*M_ gzzx [_t]+ M_ gupyz[_t]*M_ gzzy[_t] + +M_ gupxy[_t]*M_ gxzy[_t]+ M_ gupxz[_t]*M_ gxzz[_t]+ M_ gupyz[_t]*M_ gyzz[_t]; + + M_ movx_Res[_t] = M_ movx_Res[_t] - F2o3*M_ Kx [_t]- 8*PI*M_ Sx[_t]; + M_ movy_Res[_t] = M_ movy_Res[_t] - F2o3*M_ Ky[_t]- 8*PI*M_ Sy[_t]; + M_ movz_Res[_t] = M_ movz_Res[_t] - F2o3*M_ Kz[_t]- 8*PI*M_ Sz[_t]; + + _t += STEP_SIZE; + } +} + + + +__global__ void device_test(double * result, double * Xt){ + /*result[0] = MAXSIZE; + result[1] = STEP; + result[2] = ex_c[0]; + result[3] = ex_c[1]; + result[4] = ex_c[2]; + result[5] = Xt[0]; + result[6] = Xt[1]; + result[7] = metac.X[0]; + result[8] = metac.X[1]; */ + + result[0] = metac.gzz[0]; + result[1] = metac.gzz[1]; + result[2] = metac.gzz[2]; + result[3] = metac.gyy[0]; + result[4] = metac.gyy[1]; + result[5] = metac.gyy[2]; + result[6] = _3D_SIZE[0]; + result[7] = STEP_SIZE; + result[8] = blockDim.x * gridDim.x; +} + +void destroy_meta(Meta *meta) +{ + /* + if(Mh_ X) CUDA_SAFE_CALL(cudaFree(Mh_ X)); + if(Mh_ Y) CUDA_SAFE_CALL(cudaFree(Mh_ Y)); + if(Mh_ Z) CUDA_SAFE_CALL(cudaFree(Mh_ Z)); + if(Mh_ chi) CUDA_SAFE_CALL(cudaFree(Mh_ chi)); + if(Mh_ dxx) CUDA_SAFE_CALL(cudaFree(Mh_ dxx)); + if(Mh_ dyy) CUDA_SAFE_CALL(cudaFree(Mh_ dyy)); + if(Mh_ dzz) CUDA_SAFE_CALL(cudaFree(Mh_ dzz)); + if(Mh_ trK) CUDA_SAFE_CALL(cudaFree(Mh_ trK)); + if(Mh_ gxy) CUDA_SAFE_CALL(cudaFree(Mh_ gxy)); + if(Mh_ gxz) CUDA_SAFE_CALL(cudaFree(Mh_ gxz)); + if(Mh_ gyz) CUDA_SAFE_CALL(cudaFree(Mh_ gyz)); + if(Mh_ Axx) CUDA_SAFE_CALL(cudaFree(Mh_ Axx)); + if(Mh_ Axy) CUDA_SAFE_CALL(cudaFree(Mh_ Axy)); + if(Mh_ Axz) CUDA_SAFE_CALL(cudaFree(Mh_ Axz)); + if(Mh_ Ayz) CUDA_SAFE_CALL(cudaFree(Mh_ Ayz)); + if(Mh_ Ayy) CUDA_SAFE_CALL(cudaFree(Mh_ Ayy)); + if(Mh_ Azz) CUDA_SAFE_CALL(cudaFree(Mh_ Azz)); + if(Mh_ Gamx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamx)); + if(Mh_ Gamy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamy)); + if(Mh_ Gamz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamz)); + if(Mh_ Lap) CUDA_SAFE_CALL(cudaFree(Mh_ Lap)); + if(Mh_ betax) CUDA_SAFE_CALL(cudaFree(Mh_ betax)); + if(Mh_ betay) CUDA_SAFE_CALL(cudaFree(Mh_ betay)); + if(Mh_ betaz) CUDA_SAFE_CALL(cudaFree(Mh_ betaz)); + if(Mh_ dtSfx) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfx)); + if(Mh_ dtSfy) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfy)); + if(Mh_ dtSfz) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfz)); + if(Mh_ chi_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ chi_rhs)); + if(Mh_ trK_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ trK_rhs)); + if(Mh_ gxy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gxy_rhs)); + if(Mh_ gxz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gxz_rhs)); + if(Mh_ gyz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gyz_rhs)); + if(Mh_ Axx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Axx_rhs)); + if(Mh_ Axy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Axy_rhs)); + if(Mh_ Axz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Axz_rhs)); + if(Mh_ Ayz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Ayz_rhs)); + if(Mh_ Ayy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Ayy_rhs)); + if(Mh_ Azz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Azz_rhs)); + if(Mh_ Gamx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Gamx_rhs)); + if(Mh_ Gamy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Gamy_rhs)); + if(Mh_ Gamz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Gamz_rhs)); + if(Mh_ Lap_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ Lap_rhs)); + if(Mh_ betax_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ betax_rhs)); + if(Mh_ betay_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ betay_rhs)); + if(Mh_ betaz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ betaz_rhs)); + if(Mh_ dtSfx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfx_rhs)); + if(Mh_ dtSfy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfy_rhs)); + if(Mh_ dtSfz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ dtSfz_rhs)); + if(Mh_ rho) CUDA_SAFE_CALL(cudaFree(Mh_ rho)); + if(Mh_ Sx) CUDA_SAFE_CALL(cudaFree(Mh_ Sx)); + if(Mh_ Sy) CUDA_SAFE_CALL(cudaFree(Mh_ Sy)); + if(Mh_ Sz) CUDA_SAFE_CALL(cudaFree(Mh_ Sz)); + if(Mh_ Sxx) CUDA_SAFE_CALL(cudaFree(Mh_ Sxx)); + if(Mh_ Sxy) CUDA_SAFE_CALL(cudaFree(Mh_ Sxy)); + if(Mh_ Sxz) CUDA_SAFE_CALL(cudaFree(Mh_ Sxz)); + if(Mh_ Syz) CUDA_SAFE_CALL(cudaFree(Mh_ Syz)); + if(Mh_ Syy) CUDA_SAFE_CALL(cudaFree(Mh_ Syy)); + if(Mh_ Szz) CUDA_SAFE_CALL(cudaFree(Mh_ Szz)); + if(Mh_ Gamxxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxxx)); + if(Mh_ Gamxxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxxy)); + if(Mh_ Gamxxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxxz)); + if(Mh_ Gamxyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxyy)); + if(Mh_ Gamxyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxyz)); + if(Mh_ Gamxzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxzz)); + if(Mh_ Gamyxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyxx)); + if(Mh_ Gamyxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyxy)); + if(Mh_ Gamyxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyxz)); + if(Mh_ Gamyyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyyy)); + if(Mh_ Gamyyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyyz)); + if(Mh_ Gamyzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyzz)); + if(Mh_ Gamzxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzxx)); + if(Mh_ Gamzxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzxy)); + if(Mh_ Gamzxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzxz)); + if(Mh_ Gamzyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzyz)); + if(Mh_ Gamzyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzyy)); + if(Mh_ Gamzzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzzz)); + if(Mh_ Rxx) CUDA_SAFE_CALL(cudaFree(Mh_ Rxx)); + if(Mh_ Rxy) CUDA_SAFE_CALL(cudaFree(Mh_ Rxy)); + if(Mh_ Rxz) CUDA_SAFE_CALL(cudaFree(Mh_ Rxz)); + if(Mh_ Ryy) CUDA_SAFE_CALL(cudaFree(Mh_ Ryy)); + if(Mh_ Ryz) CUDA_SAFE_CALL(cudaFree(Mh_ Ryz)); + if(Mh_ Rzz) CUDA_SAFE_CALL(cudaFree(Mh_ Rzz)); + if(Mh_ ham_Res) CUDA_SAFE_CALL(cudaFree(Mh_ ham_Res)); + if(Mh_ movx_Res) CUDA_SAFE_CALL(cudaFree(Mh_ movx_Res)); + if(Mh_ movy_Res) CUDA_SAFE_CALL(cudaFree(Mh_ movy_Res)); + if(Mh_ movz_Res) CUDA_SAFE_CALL(cudaFree(Mh_ movz_Res)); + if(Mh_ Gmx_Res) CUDA_SAFE_CALL(cudaFree(Mh_ Gmx_Res)); + if(Mh_ Gmy_Res) CUDA_SAFE_CALL(cudaFree(Mh_ Gmy_Res)); + if(Mh_ Gmz_Res) CUDA_SAFE_CALL(cudaFree(Mh_ Gmz_Res)); + if(Mh_ gxx) CUDA_SAFE_CALL(cudaFree(Mh_ gxx)); + if(Mh_ gyy) CUDA_SAFE_CALL(cudaFree(Mh_ gyy)); + if(Mh_ gzz) CUDA_SAFE_CALL(cudaFree(Mh_ gzz)); + if(Mh_ chix) CUDA_SAFE_CALL(cudaFree(Mh_ chix)); + if(Mh_ chiy) CUDA_SAFE_CALL(cudaFree(Mh_ chiy)); + if(Mh_ chiz) CUDA_SAFE_CALL(cudaFree(Mh_ chiz)); + if(Mh_ gxxx) CUDA_SAFE_CALL(cudaFree(Mh_ gxxx)); + if(Mh_ gxyx) CUDA_SAFE_CALL(cudaFree(Mh_ gxyx)); + if(Mh_ gxzx) CUDA_SAFE_CALL(cudaFree(Mh_ gxzx)); + if(Mh_ gyyx) CUDA_SAFE_CALL(cudaFree(Mh_ gyyx)); + if(Mh_ gyzx) CUDA_SAFE_CALL(cudaFree(Mh_ gyzx)); + if(Mh_ gzzx) CUDA_SAFE_CALL(cudaFree(Mh_ gzzx)); + if(Mh_ gxxy) CUDA_SAFE_CALL(cudaFree(Mh_ gxxy)); + if(Mh_ gxyy) CUDA_SAFE_CALL(cudaFree(Mh_ gxyy)); + if(Mh_ gxzy) CUDA_SAFE_CALL(cudaFree(Mh_ gxzy)); + if(Mh_ gyyy) CUDA_SAFE_CALL(cudaFree(Mh_ gyyy)); + if(Mh_ gyzy) CUDA_SAFE_CALL(cudaFree(Mh_ gyzy)); + if(Mh_ gzzy) CUDA_SAFE_CALL(cudaFree(Mh_ gzzy)); + if(Mh_ gxxz) CUDA_SAFE_CALL(cudaFree(Mh_ gxxz)); + if(Mh_ gxyz) CUDA_SAFE_CALL(cudaFree(Mh_ gxyz)); + if(Mh_ gxzz) CUDA_SAFE_CALL(cudaFree(Mh_ gxzz)); + if(Mh_ gyyz) CUDA_SAFE_CALL(cudaFree(Mh_ gyyz)); + if(Mh_ gyzz) CUDA_SAFE_CALL(cudaFree(Mh_ gyzz)); + if(Mh_ gzzz) CUDA_SAFE_CALL(cudaFree(Mh_ gzzz)); + if(Mh_ Lapx) CUDA_SAFE_CALL(cudaFree(Mh_ Lapx)); + if(Mh_ Lapy) CUDA_SAFE_CALL(cudaFree(Mh_ Lapy)); + if(Mh_ Lapz) CUDA_SAFE_CALL(cudaFree(Mh_ Lapz)); + if(Mh_ betaxx) CUDA_SAFE_CALL(cudaFree(Mh_ betaxx)); + if(Mh_ betaxy) CUDA_SAFE_CALL(cudaFree(Mh_ betaxy)); + if(Mh_ betaxz) CUDA_SAFE_CALL(cudaFree(Mh_ betaxz)); + if(Mh_ betayy) CUDA_SAFE_CALL(cudaFree(Mh_ betayy)); + if(Mh_ betayz) CUDA_SAFE_CALL(cudaFree(Mh_ betayz)); + if(Mh_ betazz) CUDA_SAFE_CALL(cudaFree(Mh_ betazz)); + if(Mh_ betayx) CUDA_SAFE_CALL(cudaFree(Mh_ betayx)); + if(Mh_ betazy) CUDA_SAFE_CALL(cudaFree(Mh_ betazy)); + if(Mh_ betazx) CUDA_SAFE_CALL(cudaFree(Mh_ betazx)); + if(Mh_ Kx) CUDA_SAFE_CALL(cudaFree(Mh_ Kx)); + if(Mh_ Ky) CUDA_SAFE_CALL(cudaFree(Mh_ Ky)); + if(Mh_ Kz) CUDA_SAFE_CALL(cudaFree(Mh_ Kz)); + if(Mh_ Gamxx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxx)); + if(Mh_ Gamxy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxy)); + if(Mh_ Gamxz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxz)); + if(Mh_ Gamyy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyy)); + if(Mh_ Gamyz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyz)); + if(Mh_ Gamzz) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzz)); + if(Mh_ Gamyx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamyx)); + if(Mh_ Gamzy) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzy)); + if(Mh_ Gamzx) CUDA_SAFE_CALL(cudaFree(Mh_ Gamzx)); + if(Mh_ div_beta) CUDA_SAFE_CALL(cudaFree(Mh_ div_beta)); + if(Mh_ S) CUDA_SAFE_CALL(cudaFree(Mh_ S)); + if(Mh_ f) CUDA_SAFE_CALL(cudaFree(Mh_ f)); + if(Mh_ fxx) CUDA_SAFE_CALL(cudaFree(Mh_ fxx)); + if(Mh_ fxy) CUDA_SAFE_CALL(cudaFree(Mh_ fxy)); + if(Mh_ fxz) CUDA_SAFE_CALL(cudaFree(Mh_ fxz)); + if(Mh_ fyy) CUDA_SAFE_CALL(cudaFree(Mh_ fyy)); + if(Mh_ fyz) CUDA_SAFE_CALL(cudaFree(Mh_ fyz)); + if(Mh_ fzz) CUDA_SAFE_CALL(cudaFree(Mh_ fzz)); + if(Mh_ gupxx) CUDA_SAFE_CALL(cudaFree(Mh_ gupxx)); + if(Mh_ gupxy) CUDA_SAFE_CALL(cudaFree(Mh_ gupxy)); + if(Mh_ gupxz) CUDA_SAFE_CALL(cudaFree(Mh_ gupxz)); + if(Mh_ gupyy) CUDA_SAFE_CALL(cudaFree(Mh_ gupyy)); + if(Mh_ gupyz) CUDA_SAFE_CALL(cudaFree(Mh_ gupyz)); + if(Mh_ gupzz) CUDA_SAFE_CALL(cudaFree(Mh_ gupzz)); + if(Mh_ Gamxa) CUDA_SAFE_CALL(cudaFree(Mh_ Gamxa)); + if(Mh_ Gamya) CUDA_SAFE_CALL(cudaFree(Mh_ Gamya)); + if(Mh_ Gamza) CUDA_SAFE_CALL(cudaFree(Mh_ Gamza)); + if(Mh_ alpn1) CUDA_SAFE_CALL(cudaFree(Mh_ alpn1)); + if(Mh_ chin1) CUDA_SAFE_CALL(cudaFree(Mh_ chin1)); + if(Mh_ fh) CUDA_SAFE_CALL(cudaFree(Mh_ fh)); + if(Mh_ fh2) CUDA_SAFE_CALL(cudaFree(Mh_ fh2)); + if(Mh_ gxx_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gxx_rhs)); + if(Mh_ gyy_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gyy_rhs)); + if(Mh_ gzz_rhs) CUDA_SAFE_CALL(cudaFree(Mh_ gzz_rhs)); + */ + + if(Mh_ X) cudaFree(Mh_ X); + if(Mh_ Y) cudaFree(Mh_ Y); + if(Mh_ Z) cudaFree(Mh_ Z); + if(Mh_ chi) cudaFree(Mh_ chi); + if(Mh_ dxx) cudaFree(Mh_ dxx); + if(Mh_ dyy) cudaFree(Mh_ dyy); + if(Mh_ dzz) cudaFree(Mh_ dzz); + if(Mh_ trK) cudaFree(Mh_ trK); + if(Mh_ gxy) cudaFree(Mh_ gxy); + if(Mh_ gxz) cudaFree(Mh_ gxz); + if(Mh_ gyz) cudaFree(Mh_ gyz); + if(Mh_ Axx) cudaFree(Mh_ Axx); + if(Mh_ Axy) cudaFree(Mh_ Axy); + if(Mh_ Axz) cudaFree(Mh_ Axz); + if(Mh_ Ayz) cudaFree(Mh_ Ayz); + if(Mh_ Ayy) cudaFree(Mh_ Ayy); + if(Mh_ Azz) cudaFree(Mh_ Azz); + if(Mh_ Gamx) cudaFree(Mh_ Gamx); + if(Mh_ Gamy) cudaFree(Mh_ Gamy); + if(Mh_ Gamz) cudaFree(Mh_ Gamz); + if(Mh_ Lap) cudaFree(Mh_ Lap); + if(Mh_ betax) cudaFree(Mh_ betax); + if(Mh_ betay) cudaFree(Mh_ betay); + if(Mh_ betaz) cudaFree(Mh_ betaz); + if(Mh_ dtSfx) cudaFree(Mh_ dtSfx); + if(Mh_ dtSfy) cudaFree(Mh_ dtSfy); + if(Mh_ dtSfz) cudaFree(Mh_ dtSfz); + if(Mh_ chi_rhs) cudaFree(Mh_ chi_rhs); + if(Mh_ trK_rhs) cudaFree(Mh_ trK_rhs); + if(Mh_ gxy_rhs) cudaFree(Mh_ gxy_rhs); + if(Mh_ gxz_rhs) cudaFree(Mh_ gxz_rhs); + if(Mh_ gyz_rhs) cudaFree(Mh_ gyz_rhs); + if(Mh_ Axx_rhs) cudaFree(Mh_ Axx_rhs); + if(Mh_ Axy_rhs) cudaFree(Mh_ Axy_rhs); + if(Mh_ Axz_rhs) cudaFree(Mh_ Axz_rhs); + if(Mh_ Ayz_rhs) cudaFree(Mh_ Ayz_rhs); + if(Mh_ Ayy_rhs) cudaFree(Mh_ Ayy_rhs); + if(Mh_ Azz_rhs) cudaFree(Mh_ Azz_rhs); + if(Mh_ Gamx_rhs) cudaFree(Mh_ Gamx_rhs); + if(Mh_ Gamy_rhs) cudaFree(Mh_ Gamy_rhs); + if(Mh_ Gamz_rhs) cudaFree(Mh_ Gamz_rhs); + if(Mh_ Lap_rhs) cudaFree(Mh_ Lap_rhs); + if(Mh_ betax_rhs) cudaFree(Mh_ betax_rhs); + if(Mh_ betay_rhs) cudaFree(Mh_ betay_rhs); + if(Mh_ betaz_rhs) cudaFree(Mh_ betaz_rhs); + if(Mh_ dtSfx_rhs) cudaFree(Mh_ dtSfx_rhs); + if(Mh_ dtSfy_rhs) cudaFree(Mh_ dtSfy_rhs); + if(Mh_ dtSfz_rhs) cudaFree(Mh_ dtSfz_rhs); + if(Mh_ rho) cudaFree(Mh_ rho); + if(Mh_ Sx) cudaFree(Mh_ Sx); + if(Mh_ Sy) cudaFree(Mh_ Sy); + if(Mh_ Sz) cudaFree(Mh_ Sz); + if(Mh_ Sxx) cudaFree(Mh_ Sxx); + if(Mh_ Sxy) cudaFree(Mh_ Sxy); + if(Mh_ Sxz) cudaFree(Mh_ Sxz); + if(Mh_ Syz) cudaFree(Mh_ Syz); + if(Mh_ Syy) cudaFree(Mh_ Syy); + if(Mh_ Szz) cudaFree(Mh_ Szz); + if(Mh_ Gamxxx) cudaFree(Mh_ Gamxxx); + if(Mh_ Gamxxy) cudaFree(Mh_ Gamxxy); + if(Mh_ Gamxxz) cudaFree(Mh_ Gamxxz); + if(Mh_ Gamxyy) cudaFree(Mh_ Gamxyy); + if(Mh_ Gamxyz) cudaFree(Mh_ Gamxyz); + if(Mh_ Gamxzz) cudaFree(Mh_ Gamxzz); + if(Mh_ Gamyxx) cudaFree(Mh_ Gamyxx); + if(Mh_ Gamyxy) cudaFree(Mh_ Gamyxy); + if(Mh_ Gamyxz) cudaFree(Mh_ Gamyxz); + if(Mh_ Gamyyy) cudaFree(Mh_ Gamyyy); + if(Mh_ Gamyyz) cudaFree(Mh_ Gamyyz); + if(Mh_ Gamyzz) cudaFree(Mh_ Gamyzz); + if(Mh_ Gamzxx) cudaFree(Mh_ Gamzxx); + if(Mh_ Gamzxy) cudaFree(Mh_ Gamzxy); + if(Mh_ Gamzxz) cudaFree(Mh_ Gamzxz); + if(Mh_ Gamzyz) cudaFree(Mh_ Gamzyz); + if(Mh_ Gamzyy) cudaFree(Mh_ Gamzyy); + if(Mh_ Gamzzz) cudaFree(Mh_ Gamzzz); + if(Mh_ Rxx) cudaFree(Mh_ Rxx); + if(Mh_ Rxy) cudaFree(Mh_ Rxy); + if(Mh_ Rxz) cudaFree(Mh_ Rxz); + if(Mh_ Ryy) cudaFree(Mh_ Ryy); + if(Mh_ Ryz) cudaFree(Mh_ Ryz); + if(Mh_ Rzz) cudaFree(Mh_ Rzz); + if(Mh_ ham_Res) cudaFree(Mh_ ham_Res); + if(Mh_ movx_Res) cudaFree(Mh_ movx_Res); + if(Mh_ movy_Res) cudaFree(Mh_ movy_Res); + if(Mh_ movz_Res) cudaFree(Mh_ movz_Res); + if(Mh_ Gmx_Res) cudaFree(Mh_ Gmx_Res); + if(Mh_ Gmy_Res) cudaFree(Mh_ Gmy_Res); + if(Mh_ Gmz_Res) cudaFree(Mh_ Gmz_Res); + if(Mh_ gxx) cudaFree(Mh_ gxx); + if(Mh_ gyy) cudaFree(Mh_ gyy); + if(Mh_ gzz) cudaFree(Mh_ gzz); + if(Mh_ chix) cudaFree(Mh_ chix); + if(Mh_ chiy) cudaFree(Mh_ chiy); + if(Mh_ chiz) cudaFree(Mh_ chiz); + if(Mh_ gxxx) cudaFree(Mh_ gxxx); + if(Mh_ gxyx) cudaFree(Mh_ gxyx); + if(Mh_ gxzx) cudaFree(Mh_ gxzx); + if(Mh_ gyyx) cudaFree(Mh_ gyyx); + if(Mh_ gyzx) cudaFree(Mh_ gyzx); + if(Mh_ gzzx) cudaFree(Mh_ gzzx); + if(Mh_ gxxy) cudaFree(Mh_ gxxy); + if(Mh_ gxyy) cudaFree(Mh_ gxyy); + if(Mh_ gxzy) cudaFree(Mh_ gxzy); + if(Mh_ gyyy) cudaFree(Mh_ gyyy); + if(Mh_ gyzy) cudaFree(Mh_ gyzy); + if(Mh_ gzzy) cudaFree(Mh_ gzzy); + if(Mh_ gxxz) cudaFree(Mh_ gxxz); + if(Mh_ gxyz) cudaFree(Mh_ gxyz); + if(Mh_ gxzz) cudaFree(Mh_ gxzz); + if(Mh_ gyyz) cudaFree(Mh_ gyyz); + if(Mh_ gyzz) cudaFree(Mh_ gyzz); + if(Mh_ gzzz) cudaFree(Mh_ gzzz); + if(Mh_ Lapx) cudaFree(Mh_ Lapx); + if(Mh_ Lapy) cudaFree(Mh_ Lapy); + if(Mh_ Lapz) cudaFree(Mh_ Lapz); + if(Mh_ betaxx) cudaFree(Mh_ betaxx); + if(Mh_ betaxy) cudaFree(Mh_ betaxy); + if(Mh_ betaxz) cudaFree(Mh_ betaxz); + if(Mh_ betayy) cudaFree(Mh_ betayy); + if(Mh_ betayz) cudaFree(Mh_ betayz); + if(Mh_ betazz) cudaFree(Mh_ betazz); + if(Mh_ betayx) cudaFree(Mh_ betayx); + if(Mh_ betazy) cudaFree(Mh_ betazy); + if(Mh_ betazx) cudaFree(Mh_ betazx); + if(Mh_ Kx) cudaFree(Mh_ Kx); + if(Mh_ Ky) cudaFree(Mh_ Ky); + if(Mh_ Kz) cudaFree(Mh_ Kz); + if(Mh_ Gamxx) cudaFree(Mh_ Gamxx); + if(Mh_ Gamxy) cudaFree(Mh_ Gamxy); + if(Mh_ Gamxz) cudaFree(Mh_ Gamxz); + if(Mh_ Gamyy) cudaFree(Mh_ Gamyy); + if(Mh_ Gamyz) cudaFree(Mh_ Gamyz); + if(Mh_ Gamzz) cudaFree(Mh_ Gamzz); + if(Mh_ Gamyx) cudaFree(Mh_ Gamyx); + if(Mh_ Gamzy) cudaFree(Mh_ Gamzy); + if(Mh_ Gamzx) cudaFree(Mh_ Gamzx); + if(Mh_ div_beta) cudaFree(Mh_ div_beta); + if(Mh_ S) cudaFree(Mh_ S); + if(Mh_ f) cudaFree(Mh_ f); + if(Mh_ fxx) cudaFree(Mh_ fxx); + if(Mh_ fxy) cudaFree(Mh_ fxy); + if(Mh_ fxz) cudaFree(Mh_ fxz); + if(Mh_ fyy) cudaFree(Mh_ fyy); + if(Mh_ fyz) cudaFree(Mh_ fyz); + if(Mh_ fzz) cudaFree(Mh_ fzz); + if(Mh_ gupxx) cudaFree(Mh_ gupxx); + if(Mh_ gupxy) cudaFree(Mh_ gupxy); + if(Mh_ gupxz) cudaFree(Mh_ gupxz); + if(Mh_ gupyy) cudaFree(Mh_ gupyy); + if(Mh_ gupyz) cudaFree(Mh_ gupyz); + if(Mh_ gupzz) cudaFree(Mh_ gupzz); + if(Mh_ Gamxa) cudaFree(Mh_ Gamxa); + if(Mh_ Gamya) cudaFree(Mh_ Gamya); + if(Mh_ Gamza) cudaFree(Mh_ Gamza); + if(Mh_ alpn1) cudaFree(Mh_ alpn1); + if(Mh_ chin1) cudaFree(Mh_ chin1); + if(Mh_ fh) cudaFree(Mh_ fh); + if(Mh_ fh2) cudaFree(Mh_ fh2); + if(Mh_ gxx_rhs) cudaFree(Mh_ gxx_rhs); + if(Mh_ gyy_rhs) cudaFree(Mh_ gyy_rhs); + if(Mh_ gzz_rhs) cudaFree(Mh_ gzz_rhs); + +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + // if(Mh_ reta) CUDA_SAFE_CALL(cudaFree(Mh_ reta)); + if(Mh_ reta) cudaFree(Mh_ reta); + +#endif + + //if(Mh_ other_int) cudaFree(Mh_ other_int); + //if(Mh_ other_double) cudaFree(Mh_ other_double); + //cout<<"Address of meta:"<<&meta< 1 && abs[0] < dXh) {ijkmin_h[0] = -2; ijkmin2_h[0] = -3;} + if(Symmetry > 1 && abs[1] < dYh) {ijkmin_h[1] = -2; ijkmin2_h[1] = -3;} + if(Symmetry > 0 && abs[2] < dZh) {ijkmin_h[2] = -2; ijkmin2_h[2] = -3;} + + if(Symmetry > 2 && abs[0] < dXh) {ijkmin3_h[0] = -3;} + if(Symmetry > 2 && abs[1] < dYh) {ijkmin3_h[1] = -3;} + if(Symmetry > 0 && abs[2] < dZh) {ijkmin3_h[2] = -3;} + + cudaMemcpyToSymbol(ijk_max,ijkmax_h,3*sizeof(int)); + cudaMemcpyToSymbol(ijk_min,ijkmin_h,3*sizeof(int)); + cudaMemcpyToSymbol(ijk_min2,ijkmin2_h,3*sizeof(int)); + cudaMemcpyToSymbol(ijk_min3,ijkmin3_h,3*sizeof(int)); + + double d12dxyz_h[3] = {1.0,1.0,1.0}; + double d2dxyz_h[3] = {1.0,1.0,1.0}; + d12dxyz_h[0] /= 12; d12dxyz_h[1] /= 12; d12dxyz_h[2] /= 12; + d12dxyz_h[0] /= dXh; d12dxyz_h[1] /= dYh; d12dxyz_h[2] /= dZh; + d2dxyz_h[0] /= 2; d2dxyz_h[1] /= 2; d2dxyz_h[2] /= 2; + d2dxyz_h[0] /= dXh; d2dxyz_h[1] /= dYh; d2dxyz_h[2] /= dZh; + + cudaMemcpyToSymbol(d12dxyz,d12dxyz_h,3*sizeof(double)); + cudaMemcpyToSymbol(d2dxyz,d2dxyz_h,3*sizeof(double)); + +//3.3--------for fdderivs------------ + double Sdxdxh = 1.0 /( dXh * dXh ); + double Sdydyh = 1.0 /( dYh * dYh ); + double Sdzdzh = 1.0 /( dZh * dZh ); + double Fdxdxh = 1.0 / 12.0 /( dXh * dXh ); + double Fdydyh = 1.0 / 12.0 /( dYh * dYh ); + double Fdzdzh = 1.0 / 12.0 /( dZh * dZh ); + double Sdxdyh = 1.0/4.0 /( dXh * dYh ); + double Sdxdzh = 1.0/4.0 /( dXh * dZh ); + double Sdydzh = 1.0/4.0 /( dYh * dZh ); + double Fdxdyh = 1.0/144.0 /( dXh * dYh ); + double Fdxdzh = 1.0/144.0 /( dXh * dZh ); + double Fdydzh = 1.0/144.0 /( dYh * dZh ); + cudaMemcpyToSymbol(Sdxdx,&Sdxdxh,sizeof(double)); + cudaMemcpyToSymbol(Sdydy,&Sdydyh,sizeof(double)); + cudaMemcpyToSymbol(Sdzdz,&Sdzdzh,sizeof(double)); + cudaMemcpyToSymbol(Sdxdy,&Sdxdyh,sizeof(double)); + cudaMemcpyToSymbol(Sdxdz,&Sdxdzh,sizeof(double)); + cudaMemcpyToSymbol(Sdydz,&Sdydzh,sizeof(double)); + cudaMemcpyToSymbol(Fdxdx,&Fdxdxh,sizeof(double)); + cudaMemcpyToSymbol(Fdydy,&Fdydyh,sizeof(double)); + cudaMemcpyToSymbol(Fdzdz,&Fdzdzh,sizeof(double)); + cudaMemcpyToSymbol(Fdxdy,&Fdxdyh,sizeof(double)); + cudaMemcpyToSymbol(Fdxdz,&Fdxdzh,sizeof(double)); + cudaMemcpyToSymbol(Fdydz,&Fdydzh,sizeof(double)); + +//3.4---------for lopsided--------------------------- + + +#ifdef TIMING1 + cudaThreadSynchronize(); + gettimeofday(&tv2, NULL); + cout<<"TIME USED"<>>(ctest_d); + cudaMemcpy(ctest, ctest_d, sizeof(double), cudaMemcpyDeviceToHost); + cout<<"My rank is: "<>>(); + cudaThreadSynchronize(); + + sub_fderivs(Mh_ betax,Mh_ fh,Mh_ betaxx,Mh_ betaxy,Mh_ betaxz,ass); + sub_fderivs(Mh_ betay,Mh_ fh,Mh_ betayx,Mh_ betayy,Mh_ betayz,sas); + sub_fderivs(Mh_ betaz,Mh_ fh,Mh_ betazx,Mh_ betazy,Mh_ betazz,ssa); + sub_fderivs(Mh_ chi,Mh_ fh,Mh_ chix,Mh_ chiy,Mh_ chiz, sss); + sub_fderivs(Mh_ Lap,Mh_ fh,Mh_ Lapx,Mh_ Lapy,Mh_ Lapz, sss); + sub_fderivs(Mh_ trK,Mh_ fh,Mh_ Kx,Mh_ Ky,Mh_ Kz, sss); + sub_fderivs(Mh_ dxx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz, sss); + sub_fderivs(Mh_ dyy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz, sss); + sub_fderivs(Mh_ dzz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz, sss); + sub_fderivs(Mh_ gxy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz, aas); + sub_fderivs(Mh_ gxz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz, asa); + sub_fderivs(Mh_ gyz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz, saa); + + compute_rhs_bssn_part2<<>>(); + cudaThreadSynchronize(); + + sub_fdderivs(Mh_ betax,Mh_ fh,Mh_ gxxx,Mh_ gxyx,Mh_ gxzx,Mh_ gyyx,Mh_ gyzx,Mh_ gzzx,ass); + sub_fdderivs(Mh_ betay,Mh_ fh,Mh_ gxxy,Mh_ gxyy,Mh_ gxzy,Mh_ gyyy,Mh_ gyzy,Mh_ gzzy,sas); + sub_fdderivs(Mh_ betaz,Mh_ fh,Mh_ gxxz,Mh_ gxyz,Mh_ gxzz,Mh_ gyyz,Mh_ gyzz,Mh_ gzzz,ssa); + sub_fderivs( Mh_ Gamx, Mh_ fh,Mh_ Gamxx, Mh_ Gamxy, Mh_ Gamxz,ass); + sub_fderivs( Mh_ Gamy, Mh_ fh,Mh_ Gamyx, Mh_ Gamyy, Mh_ Gamyz,sas); + sub_fderivs( Mh_ Gamz, Mh_ fh,Mh_ Gamzx, Mh_ Gamzy, Mh_ Gamzz,ssa); + + compute_rhs_bssn_part3<<>>(); + cudaThreadSynchronize(); + + computeRicci(Mh_ dxx,Mh_ Rxx,sss, meta); + computeRicci(Mh_ dyy,Mh_ Ryy,sss, meta); + computeRicci(Mh_ dzz,Mh_ Rzz,sss, meta); + computeRicci(Mh_ gxy,Mh_ Rxy,aas, meta); + computeRicci(Mh_ gxz,Mh_ Rxz,asa, meta); + computeRicci(Mh_ gyz,Mh_ Ryz,saa, meta); + + cudaThreadSynchronize(); + + compute_rhs_bssn_part4<<>>(); + cudaThreadSynchronize(); + + sub_fdderivs(Mh_ chi,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); + + compute_rhs_bssn_part5<<>>(); + cudaThreadSynchronize(); + + sub_fdderivs(Mh_ Lap,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); + + compute_rhs_bssn_part6<<>>(); + cudaThreadSynchronize(); + +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) + sub_fderivs(Mh_ chi,Mh_ fh, Mh_ dtSfx_rhs, Mh_ dtSfy_rhs, Mh_ dtSfz_rhs,sss); + compute_rhs_bssn_part6_gauge<<>>(); +#endif + + sub_lopsided(Mh_ gxx,Mh_ fh2,Mh_ gxx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ gxy,Mh_ fh2,Mh_ gxy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,aas); + sub_lopsided(Mh_ gxz,Mh_ fh2,Mh_ gxz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,asa); + sub_lopsided(Mh_ gyy,Mh_ fh2,Mh_ gyy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ gyz,Mh_ fh2,Mh_ gyz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,saa); + sub_lopsided(Mh_ gzz,Mh_ fh2,Mh_ gzz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ Axx,Mh_ fh2,Mh_ Axx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ Axy,Mh_ fh2,Mh_ Axy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,aas); + sub_lopsided(Mh_ Axz,Mh_ fh2,Mh_ Axz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,asa); + sub_lopsided(Mh_ Ayy,Mh_ fh2,Mh_ Ayy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ Ayz,Mh_ fh2,Mh_ Ayz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,saa); + sub_lopsided(Mh_ Azz,Mh_ fh2,Mh_ Azz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ chi,Mh_ fh2,Mh_ chi_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ trK,Mh_ fh2,Mh_ trK_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + sub_lopsided(Mh_ Gamx,Mh_ fh2,Mh_ Gamx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ass); + sub_lopsided(Mh_ Gamy,Mh_ fh2,Mh_ Gamy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sas); + sub_lopsided(Mh_ Gamz,Mh_ fh2,Mh_ Gamz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ssa); + sub_lopsided(Mh_ Lap,Mh_ fh2,Mh_ Lap_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sss); + +#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + + sub_lopsided(Mh_ betax,Mh_ fh2,Mh_ betax_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ass); + sub_lopsided(Mh_ betay,Mh_ fh2,Mh_ betay_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sas); + sub_lopsided(Mh_ betaz,Mh_ fh2,Mh_ betaz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ssa); + +#endif +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + sub_lopsided(Mh_ dtSfx,Mh_ fh2,Mh_ dtSfx_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ass); + sub_lopsided(Mh_ dtSfy,Mh_ fh2,Mh_ dtSfy_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,sas); + sub_lopsided(Mh_ dtSfz,Mh_ fh2,Mh_ dtSfz_rhs,Mh_ betax,Mh_ betay,Mh_ betaz,ssa); +#endif + if(eps > 0){ + sub_kodis(Mh_ chi,Mh_ fh2, Mh_ chi_rhs,sss); + sub_kodis(Mh_ trK,Mh_ fh2, Mh_ trK_rhs,sss); + sub_kodis(Mh_ dxx,Mh_ fh2, Mh_ gxx_rhs,sss); + sub_kodis(Mh_ gxy,Mh_ fh2, Mh_ gxy_rhs,aas); + sub_kodis(Mh_ gxz,Mh_ fh2, Mh_ gxz_rhs,asa); + sub_kodis(Mh_ dyy,Mh_ fh2, Mh_ gyy_rhs,sss); + sub_kodis(Mh_ gyz,Mh_ fh2, Mh_ gyz_rhs,saa); + sub_kodis(Mh_ dzz,Mh_ fh2, Mh_ gzz_rhs,sss); + sub_kodis(Mh_ Axx,Mh_ fh2, Mh_ Axx_rhs,sss); + sub_kodis(Mh_ Axy,Mh_ fh2, Mh_ Axy_rhs,aas); + sub_kodis(Mh_ Axz,Mh_ fh2, Mh_ Axz_rhs,asa); + sub_kodis(Mh_ Ayy,Mh_ fh2, Mh_ Ayy_rhs,sss); + sub_kodis(Mh_ Ayz,Mh_ fh2, Mh_ Ayz_rhs,saa); + sub_kodis(Mh_ Azz,Mh_ fh2, Mh_ Azz_rhs,sss); + sub_kodis(Mh_ Gamx,Mh_ fh2, Mh_ Gamx_rhs,ass); + sub_kodis(Mh_ Gamy,Mh_ fh2, Mh_ Gamy_rhs,sas); + sub_kodis(Mh_ Gamz,Mh_ fh2, Mh_ Gamz_rhs,ssa); + + sub_kodis(Mh_ Lap,Mh_ fh2, Mh_ Lap_rhs,sss); + sub_kodis(Mh_ betax,Mh_ fh2, Mh_ betax_rhs,ass); + sub_kodis(Mh_ betay,Mh_ fh2, Mh_ betay_rhs,sas); + sub_kodis(Mh_ betaz,Mh_ fh2, Mh_ betaz_rhs,ssa); + +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + sub_kodis(Mh_ dtSfx,Mh_ fh2, Mh_ dtSfx_rhs,ass); + sub_kodis(Mh_ dtSfy,Mh_ fh2, Mh_ dtSfy_rhs,sas); + sub_kodis(Mh_ dtSfz,Mh_ fh2, Mh_ dtSfz_rhs,ssa); +#endif + + } + + if(co == 0){ + compute_rhs_bssn_part7<<>>(); + cudaThreadSynchronize(); + + sub_fderivs(Mh_ Axx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz,sss); + sub_fderivs(Mh_ Axy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz,aas); + sub_fderivs(Mh_ Axz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz,asa); + sub_fderivs(Mh_ Ayy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz,sss); + sub_fderivs(Mh_ Ayz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz,saa); + sub_fderivs(Mh_ Azz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz,sss); + compute_rhs_bssn_part8<<>>(); + cudaThreadSynchronize(); + } + +#if (ABV == 1) + cout<<"TODO: bssn_gpu.cu::2373 (ABV == 1)"< -#define Ms_ metassc. -#define Msh_ metass-> - -// #define TIMING - -#define RHS_SS_PARA int calledby, int mpi_rank, int *ex, double &T, double *crho, double *sigma, double *R, double *X, double *Y, double *Z, double *drhodx, double *drhody, double *drhodz, double *dsigmadx, double *dsigmady, double *dsigmadz, double *dRdx, double *dRdy, double *dRdz, double *drhodxx, double *drhodxy, double *drhodxz, double *drhodyy, double *drhodyz, double *drhodzz, double *dsigmadxx, double *dsigmadxy, double *dsigmadxz, double *dsigmadyy, double *dsigmadyz, double *dsigmadzz, double *dRdxx, double *dRdxy, double *dRdxz, double *dRdyy, double *dRdyz, double *dRdzz, double *chi, double *trK, double *dxx, double *gxy, double *gxz, double *dyy, double *gyz, double *dzz, double *Axx, double *Axy, double *Axz, double *Ayy, double *Ayz, double *Azz, double *Gamx, double *Gamy, double *Gamz, double *Lap, double *betax, double *betay, double *betaz, double *dtSfx, double *dtSfy, double *dtSfz, double *chi_rhs, double *trK_rhs, double *gxx_rhs, double *gxy_rhs, double *gxz_rhs, double *gyy_rhs, double *gyz_rhs, double *gzz_rhs, double *Axx_rhs, double *Axy_rhs, double *Axz_rhs, double *Ayy_rhs, double *Ayz_rhs, double *Azz_rhs, double *Gamx_rhs, double *Gamy_rhs, double *Gamz_rhs, double *Lap_rhs, double *betax_rhs, double *betay_rhs, double *betaz_rhs, double *dtSfx_rhs, double *dtSfy_rhs, double *dtSfz_rhs, double *rho, double *Sx, double *Sy, double *Sz, double *Sxx, double *Sxy, double *Sxz, double *Syy, double *Syz, double *Szz, double *Gamxxx, double *Gamxxy, double *Gamxxz, double *Gamxyy, double *Gamxyz, double *Gamxzz, double *Gamyxx, double *Gamyxy, double *Gamyxz, double *Gamyyy, double *Gamyyz, double *Gamyzz, double *Gamzxx, double *Gamzxy, double *Gamzxz, double *Gamzyy, double *Gamzyz, double *Gamzzz, double *Rxx, double *Rxy, double *Rxz, double *Ryy, double *Ryz, double *Rzz, double *ham_Res, double *movx_Res, double *movy_Res, double *movz_Res, double *Gmx_Res, double *Gmy_Res, double *Gmz_Res, int &Symmetry, int &Lev, double &eps, int &sst, int &co - -/** main function */ -int gpu_rhs(int calledby, int mpi_rank, int *ex, double &T, - double *X, double *Y, double *Z, - - double *chi, double *trK, - - double *dxx, double *gxy, double *gxz, double *dyy, double *gyz, double *dzz, - - double *Axx, double *Axy, double *Axz, double *Ayy, double *Ayz, double *Azz, - - double *Gamx, double *Gamy, double *Gamz, - - double *Lap, double *betax, double *betay, double *betaz, - - double *dtSfx, double *dtSfy, double *dtSfz, - - double *chi_rhs, double *trK_rhs, - - double *gxx_rhs, double *gxy_rhs, double *gxz_rhs, double *gyy_rhs, double *gyz_rhs, double *gzz_rhs, - - double *Axx_rhs, double *Axy_rhs, double *Axz_rhs, double *Ayy_rhs, double *Ayz_rhs, double *Azz_rhs, - - double *Gamx_rhs, double *Gamy_rhs, double *Gamz_rhs, - - double *Lap_rhs, double *betax_rhs, double *betay_rhs, double *betaz_rhs, - - double *dtSfx_rhs, double *dtSfy_rhs, double *dtSfz_rhs, - - double *rho, double *Sx, double *Sy, double *Sz, double *Sxx, - double *Sxy, double *Sxz, double *Syy, double *Syz, double *Szz, - - double *Gamxxx, double *Gamxxy, double *Gamxxz, double *Gamxyy, double *Gamxyz, double *Gamxzz, - - double *Gamyxx, double *Gamyxy, double *Gamyxz, double *Gamyyy, double *Gamyyz, double *Gamyzz, - - double *Gamzxx, double *Gamzxy, double *Gamzxz, double *Gamzyy, double *Gamzyz, double *Gamzzz, - - double *Rxx, double *Rxy, double *Rxz, double *Ryy, double *Ryz, double *Rzz, - - double *ham_Res, double *movx_Res, double *movy_Res, double *movz_Res, - double *Gmx_Res, double *Gmy_Res, double *Gmz_Res, - int &Symmetry, int &Lev, double &eps, int &co); - -int gpu_rhs_ss(RHS_SS_PARA); - -/** Init GPU side data in GPUMeta. */ -// void init_fluid_meta_gpu(GPUMeta *gpu_meta); - -#endif + +#ifndef BSSN_GPU_H_ +#define BSSN_GPU_H_ +#include "bssn_macro.h" +#include "macrodef.fh" + +#define DEVICE_ID 0 +// #define DEVICE_ID_BY_MPI_RANK +#define GRID_DIM 256 +#define BLOCK_DIM 128 + +#define _FH2_(i, j, k) fh[(i) + (j) * _1D_SIZE[2] + (k) * _2D_SIZE[2]] +#define _FH3_(i, j, k) fh[(i) + (j) * _1D_SIZE[3] + (k) * _2D_SIZE[3]] +#define pow2(x) ((x) * (x)) +#define TimeBetween(a, b) ((b.tv_sec - a.tv_sec) + (b.tv_usec - a.tv_usec) / 1000000.0f) +#define M_ metac. +#define Mh_ meta-> +#define Ms_ metassc. +#define Msh_ metass-> + +// #define TIMING + +#define RHS_SS_PARA int calledby, int mpi_rank, int *ex, double &T, double *crho, double *sigma, double *R, double *X, double *Y, double *Z, double *drhodx, double *drhody, double *drhodz, double *dsigmadx, double *dsigmady, double *dsigmadz, double *dRdx, double *dRdy, double *dRdz, double *drhodxx, double *drhodxy, double *drhodxz, double *drhodyy, double *drhodyz, double *drhodzz, double *dsigmadxx, double *dsigmadxy, double *dsigmadxz, double *dsigmadyy, double *dsigmadyz, double *dsigmadzz, double *dRdxx, double *dRdxy, double *dRdxz, double *dRdyy, double *dRdyz, double *dRdzz, double *chi, double *trK, double *dxx, double *gxy, double *gxz, double *dyy, double *gyz, double *dzz, double *Axx, double *Axy, double *Axz, double *Ayy, double *Ayz, double *Azz, double *Gamx, double *Gamy, double *Gamz, double *Lap, double *betax, double *betay, double *betaz, double *dtSfx, double *dtSfy, double *dtSfz, double *chi_rhs, double *trK_rhs, double *gxx_rhs, double *gxy_rhs, double *gxz_rhs, double *gyy_rhs, double *gyz_rhs, double *gzz_rhs, double *Axx_rhs, double *Axy_rhs, double *Axz_rhs, double *Ayy_rhs, double *Ayz_rhs, double *Azz_rhs, double *Gamx_rhs, double *Gamy_rhs, double *Gamz_rhs, double *Lap_rhs, double *betax_rhs, double *betay_rhs, double *betaz_rhs, double *dtSfx_rhs, double *dtSfy_rhs, double *dtSfz_rhs, double *rho, double *Sx, double *Sy, double *Sz, double *Sxx, double *Sxy, double *Sxz, double *Syy, double *Syz, double *Szz, double *Gamxxx, double *Gamxxy, double *Gamxxz, double *Gamxyy, double *Gamxyz, double *Gamxzz, double *Gamyxx, double *Gamyxy, double *Gamyxz, double *Gamyyy, double *Gamyyz, double *Gamyzz, double *Gamzxx, double *Gamzxy, double *Gamzxz, double *Gamzyy, double *Gamzyz, double *Gamzzz, double *Rxx, double *Rxy, double *Rxz, double *Ryy, double *Ryz, double *Rzz, double *ham_Res, double *movx_Res, double *movy_Res, double *movz_Res, double *Gmx_Res, double *Gmy_Res, double *Gmz_Res, int &Symmetry, int &Lev, double &eps, int &sst, int &co + +/** main function */ +int gpu_rhs(int calledby, int mpi_rank, int *ex, double &T, + double *X, double *Y, double *Z, + + double *chi, double *trK, + + double *dxx, double *gxy, double *gxz, double *dyy, double *gyz, double *dzz, + + double *Axx, double *Axy, double *Axz, double *Ayy, double *Ayz, double *Azz, + + double *Gamx, double *Gamy, double *Gamz, + + double *Lap, double *betax, double *betay, double *betaz, + + double *dtSfx, double *dtSfy, double *dtSfz, + + double *chi_rhs, double *trK_rhs, + + double *gxx_rhs, double *gxy_rhs, double *gxz_rhs, double *gyy_rhs, double *gyz_rhs, double *gzz_rhs, + + double *Axx_rhs, double *Axy_rhs, double *Axz_rhs, double *Ayy_rhs, double *Ayz_rhs, double *Azz_rhs, + + double *Gamx_rhs, double *Gamy_rhs, double *Gamz_rhs, + + double *Lap_rhs, double *betax_rhs, double *betay_rhs, double *betaz_rhs, + + double *dtSfx_rhs, double *dtSfy_rhs, double *dtSfz_rhs, + + double *rho, double *Sx, double *Sy, double *Sz, double *Sxx, + double *Sxy, double *Sxz, double *Syy, double *Syz, double *Szz, + + double *Gamxxx, double *Gamxxy, double *Gamxxz, double *Gamxyy, double *Gamxyz, double *Gamxzz, + + double *Gamyxx, double *Gamyxy, double *Gamyxz, double *Gamyyy, double *Gamyyz, double *Gamyzz, + + double *Gamzxx, double *Gamzxy, double *Gamzxz, double *Gamzyy, double *Gamzyz, double *Gamzzz, + + double *Rxx, double *Rxy, double *Rxz, double *Ryy, double *Ryz, double *Rzz, + + double *ham_Res, double *movx_Res, double *movy_Res, double *movz_Res, + double *Gmx_Res, double *Gmy_Res, double *Gmz_Res, + int &Symmetry, int &Lev, double &eps, int &co); + +int gpu_rhs_ss(RHS_SS_PARA); + +/** Init GPU side data in GPUMeta. */ +// void init_fluid_meta_gpu(GPUMeta *gpu_meta); + +#endif diff --git a/AMSS_NCKU_source/bssn_gpu_class.C b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu_class.C similarity index 97% rename from AMSS_NCKU_source/bssn_gpu_class.C rename to AMSS_NCKU_source/BSSN_GPU/bssn_gpu_class.C index f6d5170..02ae6dc 100644 --- a/AMSS_NCKU_source/bssn_gpu_class.C +++ b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu_class.C @@ -1,7790 +1,7790 @@ - -#ifdef newc -#include -#include -using namespace std; -#else -#include -#endif - -#include "macrodef.h" -#include "misc.h" -#include -#include "Ansorg.h" -#include "fmisc.h" -#include "Parallel.h" -#include "bssn_gpu_class.h" -#include "bssn_rhs.h" -#include "initial_puncture.h" -#include "enforce_algebra.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" -#include "getnp4.h" -#include "shellfunctions.h" - -#ifdef With_AHF -#include "derivatives.h" -#include "myglobal.h" -#endif - -#include "perf.h" -#include "derivatives.h" -#include "ricci_gamma.h" - -// include GPU files -#include "bssn_gpu.h" - -//================================================================================================ - -// Define bssn_gpu_class - -//================================================================================================ - -bssn_class::bssn_class(double Couranti, double StartTimei, double TotalTimei, - double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, - double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi) - : Courant(Couranti), StartTime(StartTimei), TotalTime(TotalTimei), - DumpTime(DumpTimei), d2DumpTime(d2DumpTimei), CheckTime(CheckTimei), AnasTime(AnasTimei), - Symmetry(Symmetryi), checkrun(checkruni), numepss(numepssi), numepsb(numepsbi), numepsh(numepshi), -#ifdef With_AHF - xc(0), yc(0), zc(0), xr(0), yr(0), zr(0), trigger(0), dTT(0), dumpid(0), -#endif - a_lev(a_levi), maxl(maxli), decn(decni), maxrex(maxrexi), drex(drexi), - CheckPoint(0) -{ - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - // setup Monitors - { - stringstream a_stream; - a_stream.setf(ios::left); - a_stream << "# Error log information"; - ErrorMonitor = new monitor("Error.log", myrank, a_stream.str()); - ErrorMonitor->print_message("Warning: we always assume intput parameter in cell center style."); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - char str[50]; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - sprintf(str, "R%02dm%03d", pl, pm); - a_stream << setw(16) << str; - sprintf(str, "I%02dm%03d", pl, pm); - a_stream << setw(16) << str; - } - Psi4Monitor = new monitor("bssn_psi4.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - BHMonitor = new monitor("bssn_BH.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time ADMmass ADMPx ADMPy ADMPz ADMSx ADMSy ADMSz"; - MAPMonitor = new monitor("bssn_ADMQs.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time Ham Px Py Pz Gx Gy Gz"; - ConVMonitor = new monitor("bssn_constraint.dat", myrank, a_stream.str()); - } - // setup sphere integration engine - Waveshell = new surface_integral(Symmetry); - - trfls = 0; - chitiny = 0; - // read parameter from file - { - char filename[50]; - strcpy(filename, "input.par"); - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "chitiny") - chitiny = atof(sval.c_str()); - else if (sgrp == "BSSN" && skey == "time refinement start from level") - trfls = atoi(sval.c_str()); -#ifdef With_AHF - else if (sgrp == "AHF" && skey == "AHfindevery") - AHfindevery = atoi(sval.c_str()); - else if (sgrp == "AHF" && skey == "AHdumptime") - AHdumptime = atof(sval.c_str()); -#endif - } - inf.close(); - } - if (myrank == 0) - { - // echo information of lower bound of chi - cout << "chitiny = " << chitiny << endl; - cout << "time refinement start from level #" << trfls << endl; -#ifdef With_AHF - cout << "parameters for AHF:" << endl; - cout << "AHfindevery = " << AHfindevery << endl; - cout << "AHdumptime = " << AHdumptime << endl; -#endif - } - - chitiny = chitiny - 1; // because we have subtracted one from chi - - strcpy(checkfilename, checkfilenamei); - - ngfs = 0; - phio = new var("phio", ngfs++, 1, 1, 1); - trKo = new var("trKo", ngfs++, 1, 1, 1); - gxxo = new var("gxxo", ngfs++, 1, 1, 1); - gxyo = new var("gxyo", ngfs++, -1, -1, 1); - gxzo = new var("gxzo", ngfs++, -1, 1, -1); - gyyo = new var("gyyo", ngfs++, 1, 1, 1); - gyzo = new var("gyzo", ngfs++, 1, -1, -1); - gzzo = new var("gzzo", ngfs++, 1, 1, 1); - Axxo = new var("Axxo", ngfs++, 1, 1, 1); - Axyo = new var("Axyo", ngfs++, -1, -1, 1); - Axzo = new var("Axzo", ngfs++, -1, 1, -1); - Ayyo = new var("Ayyo", ngfs++, 1, 1, 1); - Ayzo = new var("Ayzo", ngfs++, 1, -1, -1); - Azzo = new var("Azzo", ngfs++, 1, 1, 1); - Gmxo = new var("Gmxo", ngfs++, -1, 1, 1); - Gmyo = new var("Gmyo", ngfs++, 1, -1, 1); - Gmzo = new var("Gmzo", ngfs++, 1, 1, -1); - Lapo = new var("Lapo", ngfs++, 1, 1, 1); - Sfxo = new var("Sfxo", ngfs++, -1, 1, 1); - Sfyo = new var("Sfyo", ngfs++, 1, -1, 1); - Sfzo = new var("Sfzo", ngfs++, 1, 1, -1); - dtSfxo = new var("dtSfxo", ngfs++, -1, 1, 1); - dtSfyo = new var("dtSfyo", ngfs++, 1, -1, 1); - dtSfzo = new var("dtSfzo", ngfs++, 1, 1, -1); - - phi0 = new var("phi0", ngfs++, 1, 1, 1); - trK0 = new var("trK0", ngfs++, 1, 1, 1); - gxx0 = new var("gxx0", ngfs++, 1, 1, 1); - gxy0 = new var("gxy0", ngfs++, -1, -1, 1); - gxz0 = new var("gxz0", ngfs++, -1, 1, -1); - gyy0 = new var("gyy0", ngfs++, 1, 1, 1); - gyz0 = new var("gyz0", ngfs++, 1, -1, -1); - gzz0 = new var("gzz0", ngfs++, 1, 1, 1); - Axx0 = new var("Axx0", ngfs++, 1, 1, 1); - Axy0 = new var("Axy0", ngfs++, -1, -1, 1); - Axz0 = new var("Axz0", ngfs++, -1, 1, -1); - Ayy0 = new var("Ayy0", ngfs++, 1, 1, 1); - Ayz0 = new var("Ayz0", ngfs++, 1, -1, -1); - Azz0 = new var("Azz0", ngfs++, 1, 1, 1); - Gmx0 = new var("Gmx0", ngfs++, -1, 1, 1); - Gmy0 = new var("Gmy0", ngfs++, 1, -1, 1); - Gmz0 = new var("Gmz0", ngfs++, 1, 1, -1); - Lap0 = new var("Lap0", ngfs++, 1, 1, 1); - Sfx0 = new var("Sfx0", ngfs++, -1, 1, 1); - Sfy0 = new var("Sfy0", ngfs++, 1, -1, 1); - Sfz0 = new var("Sfz0", ngfs++, 1, 1, -1); - dtSfx0 = new var("dtSfx0", ngfs++, -1, 1, 1); - dtSfy0 = new var("dtSfy0", ngfs++, 1, -1, 1); - dtSfz0 = new var("dtSfz0", ngfs++, 1, 1, -1); - - phi = new var("phi", ngfs++, 1, 1, 1); - trK = new var("trK", ngfs++, 1, 1, 1); - gxx = new var("gxx", ngfs++, 1, 1, 1); - gxy = new var("gxy", ngfs++, -1, -1, 1); - gxz = new var("gxz", ngfs++, -1, 1, -1); - gyy = new var("gyy", ngfs++, 1, 1, 1); - gyz = new var("gyz", ngfs++, 1, -1, -1); - gzz = new var("gzz", ngfs++, 1, 1, 1); - Axx = new var("Axx", ngfs++, 1, 1, 1); - Axy = new var("Axy", ngfs++, -1, -1, 1); - Axz = new var("Axz", ngfs++, -1, 1, -1); - Ayy = new var("Ayy", ngfs++, 1, 1, 1); - Ayz = new var("Ayz", ngfs++, 1, -1, -1); - Azz = new var("Azz", ngfs++, 1, 1, 1); - Gmx = new var("Gmx", ngfs++, -1, 1, 1); - Gmy = new var("Gmy", ngfs++, 1, -1, 1); - Gmz = new var("Gmz", ngfs++, 1, 1, -1); - Lap = new var("Lap", ngfs++, 1, 1, 1); - Sfx = new var("Sfx", ngfs++, -1, 1, 1); - Sfy = new var("Sfy", ngfs++, 1, -1, 1); - Sfz = new var("Sfz", ngfs++, 1, 1, -1); - dtSfx = new var("dtSfx", ngfs++, -1, 1, 1); - dtSfy = new var("dtSfy", ngfs++, 1, -1, 1); - dtSfz = new var("dtSfz", ngfs++, 1, 1, -1); - - phi1 = new var("phi1", ngfs++, 1, 1, 1); - trK1 = new var("trK1", ngfs++, 1, 1, 1); - gxx1 = new var("gxx1", ngfs++, 1, 1, 1); - gxy1 = new var("gxy1", ngfs++, -1, -1, 1); - gxz1 = new var("gxz1", ngfs++, -1, 1, -1); - gyy1 = new var("gyy1", ngfs++, 1, 1, 1); - gyz1 = new var("gyz1", ngfs++, 1, -1, -1); - gzz1 = new var("gzz1", ngfs++, 1, 1, 1); - Axx1 = new var("Axx1", ngfs++, 1, 1, 1); - Axy1 = new var("Axy1", ngfs++, -1, -1, 1); - Axz1 = new var("Axz1", ngfs++, -1, 1, -1); - Ayy1 = new var("Ayy1", ngfs++, 1, 1, 1); - Ayz1 = new var("Ayz1", ngfs++, 1, -1, -1); - Azz1 = new var("Azz1", ngfs++, 1, 1, 1); - Gmx1 = new var("Gmx1", ngfs++, -1, 1, 1); - Gmy1 = new var("Gmy1", ngfs++, 1, -1, 1); - Gmz1 = new var("Gmz1", ngfs++, 1, 1, -1); - Lap1 = new var("Lap1", ngfs++, 1, 1, 1); - Sfx1 = new var("Sfx1", ngfs++, -1, 1, 1); - Sfy1 = new var("Sfy1", ngfs++, 1, -1, 1); - Sfz1 = new var("Sfz1", ngfs++, 1, 1, -1); - dtSfx1 = new var("dtSfx1", ngfs++, -1, 1, 1); - dtSfy1 = new var("dtSfy1", ngfs++, 1, -1, 1); - dtSfz1 = new var("dtSfz1", ngfs++, 1, 1, -1); - - phi_rhs = new var("phi_rhs", ngfs++, 1, 1, 1); - trK_rhs = new var("trK_rhs", ngfs++, 1, 1, 1); - gxx_rhs = new var("gxx_rhs", ngfs++, 1, 1, 1); - gxy_rhs = new var("gxy_rhs", ngfs++, -1, -1, 1); - gxz_rhs = new var("gxz_rhs", ngfs++, -1, 1, -1); - gyy_rhs = new var("gyy_rhs", ngfs++, 1, 1, 1); - gyz_rhs = new var("gyz_rhs", ngfs++, 1, -1, -1); - gzz_rhs = new var("gzz_rhs", ngfs++, 1, 1, 1); - Axx_rhs = new var("Axx_rhs", ngfs++, 1, 1, 1); - Axy_rhs = new var("Axy_rhs", ngfs++, -1, -1, 1); - Axz_rhs = new var("Axz_rhs", ngfs++, -1, 1, -1); - Ayy_rhs = new var("Ayy_rhs", ngfs++, 1, 1, 1); - Ayz_rhs = new var("Ayz_rhs", ngfs++, 1, -1, -1); - Azz_rhs = new var("Azz_rhs", ngfs++, 1, 1, 1); - Gmx_rhs = new var("Gmx_rhs", ngfs++, -1, 1, 1); - Gmy_rhs = new var("Gmy_rhs", ngfs++, 1, -1, 1); - Gmz_rhs = new var("Gmz_rhs", ngfs++, 1, 1, -1); - Lap_rhs = new var("Lap_rhs", ngfs++, 1, 1, 1); - Sfx_rhs = new var("Sfx_rhs", ngfs++, -1, 1, 1); - Sfy_rhs = new var("Sfy_rhs", ngfs++, 1, -1, 1); - Sfz_rhs = new var("Sfz_rhs", ngfs++, 1, 1, -1); - dtSfx_rhs = new var("dtSfx_rhs", ngfs++, -1, 1, 1); - dtSfy_rhs = new var("dtSfy_rhs", ngfs++, 1, -1, 1); - dtSfz_rhs = new var("dtSfz_rhs", ngfs++, 1, 1, -1); - - rho = new var("rho", ngfs++, 1, 1, 1); - Sx = new var("Sx", ngfs++, -1, 1, 1); - Sy = new var("Sy", ngfs++, 1, -1, 1); - Sz = new var("Sz", ngfs++, 1, 1, -1); - Sxx = new var("Sxx", ngfs++, 1, 1, 1); - Sxy = new var("Sxy", ngfs++, -1, -1, 1); - Sxz = new var("Sxz", ngfs++, -1, 1, -1); - Syy = new var("Syy", ngfs++, 1, 1, 1); - Syz = new var("Syz", ngfs++, 1, -1, -1); - Szz = new var("Szz", ngfs++, 1, 1, 1); - - Gamxxx = new var("Gamxxx", ngfs++, -1, 1, 1); - Gamxxy = new var("Gamxxy", ngfs++, 1, -1, 1); - Gamxxz = new var("Gamxxz", ngfs++, 1, 1, -1); - Gamxyy = new var("Gamxyy", ngfs++, -1, 1, 1); - Gamxyz = new var("Gamxyz", ngfs++, -1, -1, -1); - Gamxzz = new var("Gamxzz", ngfs++, -1, 1, 1); - Gamyxx = new var("Gamyxx", ngfs++, 1, -1, 1); - Gamyxy = new var("Gamyxy", ngfs++, -1, 1, 1); - Gamyxz = new var("Gamyxz", ngfs++, -1, -1, -1); - Gamyyy = new var("Gamyyy", ngfs++, 1, -1, 1); - Gamyyz = new var("Gamyyz", ngfs++, 1, 1, -1); - Gamyzz = new var("Gamyzz", ngfs++, 1, -1, 1); - Gamzxx = new var("Gamzxx", ngfs++, 1, 1, -1); - Gamzxy = new var("Gamzxy", ngfs++, -1, -1, -1); - Gamzxz = new var("Gamzxz", ngfs++, -1, 1, 1); - Gamzyy = new var("Gamzyy", ngfs++, 1, 1, -1); - Gamzyz = new var("Gamzyz", ngfs++, 1, -1, 1); - Gamzzz = new var("Gamzzz", ngfs++, 1, 1, -1); - - Rxx = new var("Rxx", ngfs++, 1, 1, 1); - Rxy = new var("Rxy", ngfs++, -1, -1, 1); - Rxz = new var("Rxz", ngfs++, -1, 1, -1); - Ryy = new var("Ryy", ngfs++, 1, 1, 1); - Ryz = new var("Ryz", ngfs++, 1, -1, -1); - Rzz = new var("Rzz", ngfs++, 1, 1, 1); - - // refer to PRD, 77, 024027 (2008) - Rpsi4 = new var("Rpsi4", ngfs++, 1, 1, 1); - Ipsi4 = new var("Ipsi4", ngfs++, -1, -1, -1); - t1Rpsi4 = new var("t1Rpsi4", ngfs++, 1, 1, 1); - t1Ipsi4 = new var("t1Ipsi4", ngfs++, -1, -1, -1); - t2Rpsi4 = new var("t2Rpsi4", ngfs++, 1, 1, 1); - t2Ipsi4 = new var("t2Ipsi4", ngfs++, -1, -1, -1); - - // constraint violation monitor variables - Cons_Ham = new var("Cons_Ham", ngfs++, 1, 1, 1); - Cons_Px = new var("Cons_Px", ngfs++, -1, 1, 1); - Cons_Py = new var("Cons_Py", ngfs++, 1, -1, 1); - Cons_Pz = new var("Cons_Pz", ngfs++, 1, 1, -1); - Cons_Gx = new var("Cons_Gx", ngfs++, -1, 1, 1); - Cons_Gy = new var("Cons_Gy", ngfs++, 1, -1, 1); - Cons_Gz = new var("Cons_Gz", ngfs++, 1, 1, -1); - -#ifdef Point_Psi4 - phix = new var("phix", ngfs++, -1, 1, 1); - phiy = new var("phiy", ngfs++, 1, -1, 1); - phiz = new var("phiz", ngfs++, 1, 1, -1); - trKx = new var("trKx", ngfs++, -1, 1, 1); - trKy = new var("trKy", ngfs++, 1, -1, 1); - trKz = new var("trKz", ngfs++, 1, 1, -1); - Axxx = new var("Axxx", ngfs++, -1, 1, 1); - Axxy = new var("Axxy", ngfs++, 1, -1, 1); - Axxz = new var("Axxz", ngfs++, 1, 1, -1); - Axyx = new var("Axyx", ngfs++, 1, -1, 1); - Axyy = new var("Axyy", ngfs++, -1, 1, 1); - Axyz = new var("Axyz", ngfs++, -1, -1, -1); - Axzx = new var("Axzx", ngfs++, 1, 1, -1); - Axzy = new var("Axzy", ngfs++, -1, -1, -1); - Axzz = new var("Axzz", ngfs++, -1, 1, 1); - Ayyx = new var("Ayyx", ngfs++, -1, 1, 1); - Ayyy = new var("Ayyy", ngfs++, 1, -1, 1); - Ayyz = new var("Ayyz", ngfs++, 1, 1, -1); - Ayzx = new var("Ayzx", ngfs++, -1, -1, -1); - Ayzy = new var("Ayzy", ngfs++, 1, 1, -1); - Ayzz = new var("Ayzz", ngfs++, 1, -1, 1); - Azzx = new var("Azzx", ngfs++, -1, 1, 1); - Azzy = new var("Azzy", ngfs++, 1, -1, 1); - Azzz = new var("Azzz", ngfs++, 1, 1, -1); -#endif - - // specific properspeed for 1+log slice - { - const double vl = sqrt(2); - trKo->setpropspeed(vl); - trK0->setpropspeed(vl); - trK->setpropspeed(vl); - trK1->setpropspeed(vl); - trK_rhs->setpropspeed(vl); - - phio->setpropspeed(vl); - phi0->setpropspeed(vl); - phi->setpropspeed(vl); - phi1->setpropspeed(vl); - phi_rhs->setpropspeed(vl); - - Lapo->setpropspeed(vl); - Lap0->setpropspeed(vl); - Lap->setpropspeed(vl); - Lap1->setpropspeed(vl); - Lap_rhs->setpropspeed(vl); - } - - OldStateList = new MyList(phio); - OldStateList->insert(trKo); - OldStateList->insert(gxxo); - OldStateList->insert(gxyo); - OldStateList->insert(gxzo); - OldStateList->insert(gyyo); - OldStateList->insert(gyzo); - OldStateList->insert(gzzo); - OldStateList->insert(Axxo); - OldStateList->insert(Axyo); - OldStateList->insert(Axzo); - OldStateList->insert(Ayyo); - OldStateList->insert(Ayzo); - OldStateList->insert(Azzo); - OldStateList->insert(Gmxo); - OldStateList->insert(Gmyo); - OldStateList->insert(Gmzo); - OldStateList->insert(Lapo); - OldStateList->insert(Sfxo); - OldStateList->insert(Sfyo); - OldStateList->insert(Sfzo); - OldStateList->insert(dtSfxo); - OldStateList->insert(dtSfyo); - OldStateList->insert(dtSfzo); - - StateList = new MyList(phi0); - StateList->insert(trK0); - StateList->insert(gxx0); - StateList->insert(gxy0); - StateList->insert(gxz0); - StateList->insert(gyy0); - StateList->insert(gyz0); - StateList->insert(gzz0); - StateList->insert(Axx0); - StateList->insert(Axy0); - StateList->insert(Axz0); - StateList->insert(Ayy0); - StateList->insert(Ayz0); - StateList->insert(Azz0); - StateList->insert(Gmx0); - StateList->insert(Gmy0); - StateList->insert(Gmz0); - StateList->insert(Lap0); - StateList->insert(Sfx0); - StateList->insert(Sfy0); - StateList->insert(Sfz0); - StateList->insert(dtSfx0); - StateList->insert(dtSfy0); - StateList->insert(dtSfz0); - - RHSList = new MyList(phi_rhs); - RHSList->insert(trK_rhs); - RHSList->insert(gxx_rhs); - RHSList->insert(gxy_rhs); - RHSList->insert(gxz_rhs); - RHSList->insert(gyy_rhs); - RHSList->insert(gyz_rhs); - RHSList->insert(gzz_rhs); - RHSList->insert(Axx_rhs); - RHSList->insert(Axy_rhs); - RHSList->insert(Axz_rhs); - RHSList->insert(Ayy_rhs); - RHSList->insert(Ayz_rhs); - RHSList->insert(Azz_rhs); - RHSList->insert(Gmx_rhs); - RHSList->insert(Gmy_rhs); - RHSList->insert(Gmz_rhs); - RHSList->insert(Lap_rhs); - RHSList->insert(Sfx_rhs); - RHSList->insert(Sfy_rhs); - RHSList->insert(Sfz_rhs); - RHSList->insert(dtSfx_rhs); - RHSList->insert(dtSfy_rhs); - RHSList->insert(dtSfz_rhs); - - SynchList_pre = new MyList(phi); - SynchList_pre->insert(trK); - SynchList_pre->insert(gxx); - SynchList_pre->insert(gxy); - SynchList_pre->insert(gxz); - SynchList_pre->insert(gyy); - SynchList_pre->insert(gyz); - SynchList_pre->insert(gzz); - SynchList_pre->insert(Axx); - SynchList_pre->insert(Axy); - SynchList_pre->insert(Axz); - SynchList_pre->insert(Ayy); - SynchList_pre->insert(Ayz); - SynchList_pre->insert(Azz); - SynchList_pre->insert(Gmx); - SynchList_pre->insert(Gmy); - SynchList_pre->insert(Gmz); - SynchList_pre->insert(Lap); - SynchList_pre->insert(Sfx); - SynchList_pre->insert(Sfy); - SynchList_pre->insert(Sfz); - SynchList_pre->insert(dtSfx); - SynchList_pre->insert(dtSfy); - SynchList_pre->insert(dtSfz); - - SynchList_cor = new MyList(phi1); - SynchList_cor->insert(trK1); - SynchList_cor->insert(gxx1); - SynchList_cor->insert(gxy1); - SynchList_cor->insert(gxz1); - SynchList_cor->insert(gyy1); - SynchList_cor->insert(gyz1); - SynchList_cor->insert(gzz1); - SynchList_cor->insert(Axx1); - SynchList_cor->insert(Axy1); - SynchList_cor->insert(Axz1); - SynchList_cor->insert(Ayy1); - SynchList_cor->insert(Ayz1); - SynchList_cor->insert(Azz1); - SynchList_cor->insert(Gmx1); - SynchList_cor->insert(Gmy1); - SynchList_cor->insert(Gmz1); - SynchList_cor->insert(Lap1); - SynchList_cor->insert(Sfx1); - SynchList_cor->insert(Sfy1); - SynchList_cor->insert(Sfz1); - SynchList_cor->insert(dtSfx1); - SynchList_cor->insert(dtSfy1); - SynchList_cor->insert(dtSfz1); - - DumpList = new MyList(phi0); - DumpList->insert(trK0); - DumpList->insert(gxx0); - DumpList->insert(gxy0); - DumpList->insert(gxz0); - DumpList->insert(gyy0); - DumpList->insert(gyz0); - DumpList->insert(gzz0); - // DumpList->insert(Axx0); - // DumpList->insert(Axy0); - // DumpList->insert(Axz0); - // DumpList->insert(Ayy0); - // DumpList->insert(Ayz0); - // DumpList->insert(Azz0); - // DumpList->insert(Gmx0); - // DumpList->insert(Gmy0); - // DumpList->insert(Gmz0); - DumpList->insert(Lap0); - // DumpList->insert(Sfx0); - // DumpList->insert(Sfy0); - // DumpList->insert(Sfz0); - // DumpList->insert(dtSfx0); - // DumpList->insert(dtSfy0); - // DumpList->insert(dtSfz0); - DumpList->insert(Rpsi4); - DumpList->insert(Ipsi4); - DumpList->insert(Cons_Ham); - DumpList->insert(Cons_Px); - DumpList->insert(Cons_Py); - DumpList->insert(Cons_Pz); - // DumpList->insert(Cons_Gx); - // DumpList->insert(Cons_Gy); - // DumpList->insert(Cons_Gz); - - ConstraintList = new MyList(Cons_Ham); - ConstraintList->insert(Cons_Px); - ConstraintList->insert(Cons_Py); - ConstraintList->insert(Cons_Pz); - ConstraintList->insert(Cons_Gx); - ConstraintList->insert(Cons_Gy); - ConstraintList->insert(Cons_Gz); -#ifdef With_AHF - // setup kinds of var list - // List for AparentHorizonFinderDirect - // special attension is payed to symmetry type - // gij gij,x gij,y gij,z - AHList = new MyList(gxx0); - AHList->insert(Gamxxx); - AHList->insert(Gamyxx); - AHList->insert(Gamzxx); - AHList->insert(gxy0); - AHList->insert(Gamxxy); - AHList->insert(Gamyxy); - AHList->insert(Gamzxy); - AHList->insert(gxz0); - AHList->insert(Gamxxz); - AHList->insert(Gamyxz); - AHList->insert(Gamzxz); - AHList->insert(gyy0); - AHList->insert(Gamxyy); - AHList->insert(Gamyyy); - AHList->insert(Gamzyy); - AHList->insert(gyz0); - AHList->insert(Gamxyz); - AHList->insert(Gamyyz); - AHList->insert(Gamzyz); - AHList->insert(gzz0); - AHList->insert(Gamxzz); - AHList->insert(Gamyzz); - AHList->insert(Gamzzz); - // phi phi,x phi,y phi,z - AHList->insert(phi0); - AHList->insert(dtSfx_rhs); - AHList->insert(dtSfy_rhs); - AHList->insert(dtSfz_rhs); - // Aij - AHList->insert(Axx0); - AHList->insert(Axy0); - AHList->insert(Axz0); - AHList->insert(Ayy0); - AHList->insert(Ayz0); - AHList->insert(Azz0); - // trK - AHList->insert(trK0); - // gij,x gij,y gij,z - AHDList = new MyList(Gamxxx); - AHDList->insert(Gamyxx); - AHDList->insert(Gamzxx); - AHDList->insert(Gamxxy); - AHDList->insert(Gamyxy); - AHDList->insert(Gamzxy); - AHDList->insert(Gamxxz); - AHDList->insert(Gamyxz); - AHDList->insert(Gamzxz); - AHDList->insert(Gamxyy); - AHDList->insert(Gamyyy); - AHDList->insert(Gamzyy); - AHDList->insert(Gamxyz); - AHDList->insert(Gamyyz); - AHDList->insert(Gamzyz); - AHDList->insert(Gamxzz); - AHDList->insert(Gamyzz); - AHDList->insert(Gamzzz); - // phi,x phi,y phi,z - AHDList->insert(dtSfx_rhs); - AHDList->insert(dtSfy_rhs); - AHDList->insert(dtSfz_rhs); - - GaugeList = new MyList(Lap0); - GaugeList->insert(Sfx0); - GaugeList->insert(Sfy0); - GaugeList->insert(Sfz0); -#endif - - CheckPoint = new checkpoint(checkrun, checkfilename, myrank); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function initializes the class - -//================================================================================================ - -void bssn_class::Initialize() -{ - if (myrank == 0) - cout << "you have setted " << ngfs << " grid functions." << endl; - - CheckPoint->addvariablelist(StateList); - CheckPoint->addvariablelist(OldStateList); - - GH = new cgh(0, ngfs, Symmetry, "input.par", checkrun, ErrorMonitor); - if (checkrun) - CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); - else - GH->compose_cgh(nprocs); - -#ifdef WithShell - SH = new ShellPatch(0, ngfs, "input.par", Symmetry, myrank, ErrorMonitor); - SH->matchcheck(GH->PatL[0]); - SH->compose_sh(nprocs); - // SH->compose_shr(nprocs); //sh is faster than shr - SH->setupcordtrans(); - SH->Dump_xyz(0, 0, 1); - SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); - - if (checkrun) - CheckPoint->readcheck_sh(SH, myrank); -#else - SH = 0; -#endif - - double h = GH->PatL[0]->data->blb->data->getdX(0); - for (int i = 1; i < dim; i++) - h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); - dT = Courant * h; - - if (checkrun) - { - CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); - } - else - { - PhysTime = StartTime; - Setup_Black_Hole_position(); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// Destructor: free allocated variables - -//================================================================================================ - -bssn_class::~bssn_class() -{ -#ifdef With_AHF - AHList->clearList(); - AHDList->clearList(); - GaugeList->clearList(); - if (lastahdumpid) - delete[] lastahdumpid; - if (findeveryl) - delete[] findeveryl; - - if (xc) - { - delete[] xc; - delete[] yc; - delete[] zc; - delete[] xr; - delete[] yr; - delete[] zr; - delete[] trigger; - delete[] dumpid; - delete[] dTT; - } - - AHFinderDirect::AHFinderDirect_cleanup(); -#endif - - StateList->clearList(); - RHSList->clearList(); - OldStateList->clearList(); - SynchList_pre->clearList(); - SynchList_cor->clearList(); - DumpList->clearList(); - ConstraintList->clearList(); - - delete phio; - delete trKo; - delete gxxo; - delete gxyo; - delete gxzo; - delete gyyo; - delete gyzo; - delete gzzo; - delete Axxo; - delete Axyo; - delete Axzo; - delete Ayyo; - delete Ayzo; - delete Azzo; - delete Gmxo; - delete Gmyo; - delete Gmzo; - delete Lapo; - delete Sfxo; - delete Sfyo; - delete Sfzo; - delete dtSfxo; - delete dtSfyo; - delete dtSfzo; - - delete phi0; - delete trK0; - delete gxx0; - delete gxy0; - delete gxz0; - delete gyy0; - delete gyz0; - delete gzz0; - delete Axx0; - delete Axy0; - delete Axz0; - delete Ayy0; - delete Ayz0; - delete Azz0; - delete Gmx0; - delete Gmy0; - delete Gmz0; - delete Lap0; - delete Sfx0; - delete Sfy0; - delete Sfz0; - delete dtSfx0; - delete dtSfy0; - delete dtSfz0; - - delete phi; - delete trK; - delete gxx; - delete gxy; - delete gxz; - delete gyy; - delete gyz; - delete gzz; - delete Axx; - delete Axy; - delete Axz; - delete Ayy; - delete Ayz; - delete Azz; - delete Gmx; - delete Gmy; - delete Gmz; - delete Lap; - delete Sfx; - delete Sfy; - delete Sfz; - delete dtSfx; - delete dtSfy; - delete dtSfz; - - delete phi1; - delete trK1; - delete gxx1; - delete gxy1; - delete gxz1; - delete gyy1; - delete gyz1; - delete gzz1; - delete Axx1; - delete Axy1; - delete Axz1; - delete Ayy1; - delete Ayz1; - delete Azz1; - delete Gmx1; - delete Gmy1; - delete Gmz1; - delete Lap1; - delete Sfx1; - delete Sfy1; - delete Sfz1; - delete dtSfx1; - delete dtSfy1; - delete dtSfz1; - - delete phi_rhs; - delete trK_rhs; - delete gxx_rhs; - delete gxy_rhs; - delete gxz_rhs; - delete gyy_rhs; - delete gyz_rhs; - delete gzz_rhs; - delete Axx_rhs; - delete Axy_rhs; - delete Axz_rhs; - delete Ayy_rhs; - delete Ayz_rhs; - delete Azz_rhs; - delete Gmx_rhs; - delete Gmy_rhs; - delete Gmz_rhs; - delete Lap_rhs; - delete Sfx_rhs; - delete Sfy_rhs; - delete Sfz_rhs; - delete dtSfx_rhs; - delete dtSfy_rhs; - delete dtSfz_rhs; - - delete rho; - delete Sx; - delete Sy; - delete Sz; - delete Sxx; - delete Sxy; - delete Sxz; - delete Syy; - delete Syz; - delete Szz; - - delete Gamxxx; - delete Gamxxy; - delete Gamxxz; - delete Gamxyy; - delete Gamxyz; - delete Gamxzz; - delete Gamyxx; - delete Gamyxy; - delete Gamyxz; - delete Gamyyy; - delete Gamyyz; - delete Gamyzz; - delete Gamzxx; - delete Gamzxy; - delete Gamzxz; - delete Gamzyy; - delete Gamzyz; - delete Gamzzz; - - delete Rxx; - delete Rxy; - delete Rxz; - delete Ryy; - delete Ryz; - delete Rzz; - - delete Rpsi4; - delete Ipsi4; - delete t1Rpsi4; - delete t1Ipsi4; - delete t2Rpsi4; - delete t2Ipsi4; - - delete Cons_Ham; - delete Cons_Px; - delete Cons_Py; - delete Cons_Pz; - delete Cons_Gx; - delete Cons_Gy; - delete Cons_Gz; - -#ifdef Point_Psi4 - delete phix; - delete phiy; - delete phiz; - delete trKx; - delete trKy; - delete trKz; - delete Axxx; - delete Axxy; - delete Axxz; - delete Axyx; - delete Axyy; - delete Axyz; - delete Axzx; - delete Axzy; - delete Axzz; - delete Ayyx; - delete Ayyy; - delete Ayyz; - delete Ayzx; - delete Ayzy; - delete Ayzz; - delete Azzx; - delete Azzy; - delete Azzz; -#endif - - delete GH; -#ifdef WithShell - delete SH; -#endif - - for (int i = 0; i < BH_num; i++) - { - delete[] Porg0[i]; - delete[] Porgbr[i]; - delete[] Porg[i]; - delete[] Porg1[i]; - delete[] Porg_rhs[i]; - } - - delete[] Porg0; - delete[] Porgbr; - delete[] Porg; - delete[] Porg1; - delete[] Porg_rhs; - - delete[] Mass; - delete[] Spin; - delete[] Pmom; - - delete ErrorMonitor; - delete Psi4Monitor; - delete BHMonitor; - delete MAPMonitor; - delete ConVMonitor; - delete Waveshell; - - delete CheckPoint; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes initial data using Lousto's analytic formulas - -//================================================================================================ - -void bssn_class::Setup_Initial_Data_Lousto() -{ - if (!checkrun) - { - if (myrank == 0) - cout << "Setup initial data with Lousto's analytical formula." << endl; - char filename[50]; - strcpy(filename, "input.par"); - int BH_NM; - double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - // Use Lousto's analytic formulas to compute initial data - f_get_lousto_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_nbhs_sh(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - // dump read_in initial data - SH->Dump_Data(StateList, 0, PhysTime, dT); -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Pmom_here; - delete[] Spin_here; - // SH->Synch(GH->PatL[0],StateList,Symmetry); - // exit(0); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes initial data using analytic formulas by Prof. Cao - -//================================================================================================ - -void bssn_class::Setup_Initial_Data_Cao() -{ - if (!checkrun) - { - if (myrank == 0) - cout << "Setup initial data with Cao's analytical formula." << endl; - char filename[50]; - strcpy(filename, "input.par"); - int BH_NM; - double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - // Use Prof. Cao's analytic formulas to compute initial data - f_get_initial_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_nbhs_sh(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - // dump read_in initial data - SH->Dump_Data(StateList, 0, PhysTime, dT); -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Pmom_here; - delete[] Spin_here; - // SH->Synch(GH->PatL[0],StateList,Symmetry); - // exit(0); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes Kerr-Schild initial data analytically - -//================================================================================================ - -void bssn_class::Setup_KerrSchild() -{ - if (!checkrun) - { - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_kerrschild(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - int lev = 0, fngfs = Pp->data->fngfs; - - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_kerrschild_ss(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); - /* - f_fderivs_shc(cg->shape, - cg->fgfs[phi0->sgfn], - cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn], - cg->X[0],cg->X[1],cg->X[2], - phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], - Symmetry,lev,Pp->data->sst, - cg->fgfs[fngfs+ShellPatch::drhodx], - cg->fgfs[fngfs+ShellPatch::drhody], - cg->fgfs[fngfs+ShellPatch::drhodz], - cg->fgfs[fngfs+ShellPatch::dsigmadx], - cg->fgfs[fngfs+ShellPatch::dsigmady], - cg->fgfs[fngfs+ShellPatch::dsigmadz], - cg->fgfs[fngfs+ShellPatch::dRdx], - cg->fgfs[fngfs+ShellPatch::dRdy], - cg->fgfs[fngfs+ShellPatch::dRdz]); - f_fdderivs_shc(cg->shape,cg->fgfs[phi0->sgfn], - cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn], - cg->X[0],cg->X[1],cg->X[2], - phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], - Symmetry,lev,Pp->data->sst, - cg->fgfs[fngfs+ShellPatch::drhodx], - cg->fgfs[fngfs+ShellPatch::drhody], - cg->fgfs[fngfs+ShellPatch::drhodz], - cg->fgfs[fngfs+ShellPatch::dsigmadx], - cg->fgfs[fngfs+ShellPatch::dsigmady], - cg->fgfs[fngfs+ShellPatch::dsigmadz], - cg->fgfs[fngfs+ShellPatch::dRdx], - cg->fgfs[fngfs+ShellPatch::dRdy], - cg->fgfs[fngfs+ShellPatch::dRdz], - cg->fgfs[fngfs+ShellPatch::drhodxx], - cg->fgfs[fngfs+ShellPatch::drhodxy], - cg->fgfs[fngfs+ShellPatch::drhodxz], - cg->fgfs[fngfs+ShellPatch::drhodyy], - cg->fgfs[fngfs+ShellPatch::drhodyz], - cg->fgfs[fngfs+ShellPatch::drhodzz], - cg->fgfs[fngfs+ShellPatch::dsigmadxx], - cg->fgfs[fngfs+ShellPatch::dsigmadxy], - cg->fgfs[fngfs+ShellPatch::dsigmadxz], - cg->fgfs[fngfs+ShellPatch::dsigmadyy], - cg->fgfs[fngfs+ShellPatch::dsigmadyz], - cg->fgfs[fngfs+ShellPatch::dsigmadzz], - cg->fgfs[fngfs+ShellPatch::dRdxx], - cg->fgfs[fngfs+ShellPatch::dRdxy], - cg->fgfs[fngfs+ShellPatch::dRdxz], - cg->fgfs[fngfs+ShellPatch::dRdyy], - cg->fgfs[fngfs+ShellPatch::dRdyz], - cg->fgfs[fngfs+ShellPatch::dRdzz]); - */ - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - // dump read_in initial data - // SH->Synch(GH->PatL[0],StateList,Symmetry); - // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); - // SH->Dump_Data(StateList,0,PhysTime,dT); - // exit(0); - - /* - { - MyList * DG_List=new MyList(Sfx_rhs); - DG_List->insert(Sfy_rhs); DG_List->insert(Sfz_rhs); - DG_List->insert(Axx_rhs); DG_List->insert(Axy_rhs); DG_List->insert(Axz_rhs); - DG_List->insert(Ayy_rhs); DG_List->insert(Ayz_rhs); DG_List->insert(Azz_rhs); - SH->Synch(DG_List,Symmetry); - SH->Dump_Data(DG_List,0,PhysTime,dT); - DG_List->clearList(); - exit(0); - } - */ - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function reads initial data produced by Pablo Galaviz's Olliptic program - -//================================================================================================ - -//|---------------------------------------------------------------------------- -// read ASCII file with the style of Pablo -//|---------------------------------------------------------------------------- -bool bssn_class::read_Pablo_file(int *ext, double *datain, char *filename) -{ - int nx = ext[0], ny = ext[1], nz = ext[2]; - int i, j, k; - double x, y, z; - //|--->open in put file - ifstream infile; - infile.open(filename); - if (!infile) - { - cout << "bssn_class: read_Pablo_file can't open " << filename << " for input." << endl; - return false; - } - for (k = 0; k < nz; k++) - for (j = 0; j < ny; j++) - for (i = 0; i < nx; i++) - { - infile >> x >> y >> z >> datain[i + j * nx + k * nx * ny]; - } - - infile.close(); - - return true; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function writes initial data for Pablo Galaviz's Olliptic program - -//================================================================================================ - -//|---------------------------------------------------------------------------- -// write ASCII file with the style of Pablo -//|---------------------------------------------------------------------------- -void bssn_class::write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, - char *filename) -{ - int nx = ext[0], ny = ext[1], nz = ext[2]; - int i, j, k; - double *X, *Y, *Z; - X = new double[nx]; - Y = new double[ny]; - Z = new double[nz]; - double dX, dY, dZ; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dX = (xmax - xmin) / (nx - 1); - for (i = 0; i < nx; i++) - X[i] = xmin + i * dX; - dY = (ymax - ymin) / (ny - 1); - for (j = 0; j < ny; j++) - Y[j] = ymin + j * dY; - dZ = (zmax - zmin) / (nz - 1); - for (k = 0; k < nz; k++) - Z[k] = zmin + k * dZ; -#else -#ifdef Cell - dX = (xmax - xmin) / nx; - for (i = 0; i < nx; i++) - X[i] = xmin + (i + 0.5) * dX; - dY = (ymax - ymin) / ny; - for (j = 0; j < ny; j++) - Y[j] = ymin + (j + 0.5) * dY; - dZ = (zmax - zmin) / nz; - for (k = 0; k < nz; k++) - Z[k] = zmin + (k + 0.5) * dZ; -#else -#error Not define Vertex nor Cell -#endif -#endif - //|--->open out put file - ofstream outfile; - outfile.open(filename); - if (!outfile) - { - cout << "bssn=_class: write_Pablo_file can't open " << filename << " for output." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - for (k = 0; k < nz; k++) - for (j = 0; j < ny; j++) - for (i = 0; i < nx; i++) - { - outfile << X[i] << " " << Y[j] << " " << Z[k] << " " - << 0 << endl; - } - outfile.close(); - - delete[] X; - delete[] Y; - delete[] Z; -} - -//================================================================================================ - - - - -//================================================================================================ - -// This member function reads TwoPuncture initial data produced by the Ansorg solver - -//================================================================================================ - -// Read initial data solved by Ansorg, PRD 70, 064011 (2004) - -void bssn_class::Read_Ansorg() -{ - if (!checkrun) - { - if (myrank == 0) - cout << "Read initial data from Ansorg's solver," - << " please be sure the input parameters for black holes are puncture parameters!!" << endl; - char filename[50]; - strcpy(filename, "input.par"); - int BH_NM; - double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom_here = new double[3 * BH_NM]; - Spin_here = new double[3 * BH_NM]; - Mass_here = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass_here[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom_here[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - - int order = 6; - Ansorg read_ansorg("Ansorg.psid", order); - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); - - f_get_ansorg_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); - - f_get_ansorg_nbhs_ss(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); -#if 0 -// for check fderivs_sh - f_fderivs_sh(cg->shape,cg->fgfs[Ayz0->sgfn], - cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], - cg->X[0],cg->X[1],cg->X[2], - Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], - Symmetry,Pp->data->sst,Pp->data->sst); -#endif -#if 0 -// for check fderivs_shc - int fngfs = Pp->data->fngfs; - f_fderivs_shc(cg->shape,cg->fgfs[Ayz0->sgfn], - cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], - cg->X[0],cg->X[1],cg->X[2], - Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], - Symmetry,Pp->data->sst,Pp->data->sst, - cg->fgfs[fngfs+ShellPatch::drhodx], - cg->fgfs[fngfs+ShellPatch::drhody], - cg->fgfs[fngfs+ShellPatch::drhodz], - cg->fgfs[fngfs+ShellPatch::dsigmadx], - cg->fgfs[fngfs+ShellPatch::dsigmady], - cg->fgfs[fngfs+ShellPatch::dsigmadz], - cg->fgfs[fngfs+ShellPatch::dRdx], - cg->fgfs[fngfs+ShellPatch::dRdy], - cg->fgfs[fngfs+ShellPatch::dRdz]); -#endif - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - delete[] Porg_here; - delete[] Mass_here; - delete[] Pmom_here; - delete[] Spin_here; - - Compute_Constraint(); - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT); -#ifdef WithShell - SH->Dump_Data(DumpList, 0, PhysTime, dT); -#endif - // if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets up the time evolution for the entire process - -//================================================================================================ - -void bssn_class::Evolve(int Steps) -{ - - clock_t prev_clock, curr_clock; - double LastDump = 0.0, LastCheck = 0.0, Last2dDump = 0.0; - LastAnas = 0; -#if 0 -//initial checkpoint for special uasge - { - CheckPoint->write_Black_Hole_position(BH_num_input,BH_num,Porg0,Porgbr,Mass); - CheckPoint->writecheck_cgh(PhysTime,GH); -#ifdef WithShell - CheckPoint->writecheck_sh(PhysTime,SH); -#endif - CheckPoint->write_bssn(LastDump,Last2dDump,LastAnas); - misc::tillherecheck("complete initialization preparation"); // we need synchronization here - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } -#endif - - double beg_time; - beg_time = MPI_Wtime(); -// added by yangquan -#ifdef USE_GPU -#ifdef USE_GPU_DIVIDE - // new code considering different partition for cpu and gpu - { - MyList *Pp = GH->PatL[0]; - bool fg = true; - while (fg && Pp) - { - MyList *BP = Pp->data->blb; - while (fg && BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - use_gpu = cg->cgpu; - fg = false; - break; - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } -#else - // old yangquan code - use_gpu = 0; - if (myrank % 2 == 1) - use_gpu = 1; -#endif -#endif - - // for step 0 constraint interpolation - Interp_Constraint(true); - -#ifdef With_AHF - // setup apparent horizon finder direct of thornburg - { - HN_num = BH_num; - for (int ia = 0; ia < BH_num; ia++) - for (int ib = ia + 1; ib < BH_num; ib++) - HN_num++; - - AHFinderDirect::AHFinderDirect_setup(AHList, GaugeList, - this, - Symmetry, HN_num, &PhysTime); - - lastahdumpid = new int[HN_num]; - findeveryl = new int[HN_num]; - xc = new double[HN_num]; - yc = new double[HN_num]; - zc = new double[HN_num]; - xr = new double[HN_num]; - yr = new double[HN_num]; - zr = new double[HN_num]; - dTT = new double[HN_num]; - trigger = new bool[HN_num]; - dumpid = new int[HN_num]; - - for (int ihn = 0; ihn < HN_num; ihn++) - { - lastahdumpid[ihn] = 0; - findeveryl[ihn] = AHfindevery; - } - } -#endif - - if (checkrun) - CheckPoint->read_bssn(LastDump, Last2dDump, LastAnas); - - double dT_mon = dT * pow(0.5, Mymax(0, trfls)); - /* - #ifdef With_AHF - //initial apparent horizon finding - { - double gam; - double massmin=Mass[0]; - for(int ihn=1;ihnlevels; lev++) - GH->Lt[lev] = PhysTime; - - GH->settrfls(trfls); - - for (int ncount = 1; ncount < Steps + 1; ncount++) - { - cout << "Before Step: " << ncount << " My Rank: " << myrank - << " takes " << MPI_Wtime() - beg_time << " seconds!" << endl; - beg_time = MPI_Wtime(); -#if (PSTR == 0) - RecursiveStep(0); -#elif (PSTR == 1) - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - AnalysisStuff(a_lev, dT_mon); - ParallelStep(); -#endif - cout << "After Step: " << ncount << " My Rank: " << myrank - << " takes " << MPI_Wtime() - beg_time << " seconds!" << endl; - beg_time = MPI_Wtime(); - - // misc::tillherecheck("before Constraint_Out"); - - Constraint_Out(); // this will affect the Dump_List - - LastDump += dT_mon; - Last2dDump += dT_mon; - LastCheck += dT_mon; - - if (LastDump >= DumpTime) - { - // misc::tillherecheck("before Dump_Data"); - - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT_mon); -#ifdef WithShell - SH->Dump_Data(DumpList, 0, PhysTime, dT_mon); -#endif - - LastDump = 0; - - if (myrank == 0) - { - cout << "Dump done." << endl; - } - } - - if (Last2dDump >= d2DumpTime) - { - // misc::tillherecheck("before 2dDump_Data"); - - for (int lev = 0; lev < GH->levels; lev++) - Parallel::d2Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT_mon); - - Last2dDump = 0; - - if (myrank == 0) - { - cout << "2dDump done." << endl; - } - } - - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Timestep # " << ncount << ": integrating to time: " << PhysTime << endl; - cout << "used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - - if (PhysTime >= TotalTime) - break; - -#if (REGLEV == 1) - GH->Regrid(Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_mon, StartTime, dT_mon / 2), ErrorMonitor); -#endif - -#if (REGLEV == 0 && PSTR == 1) -// GH->Regrid_fake(Symmetry,BH_num,Porgbr,Porg0, -// SynchList_cor,OldStateList,StateList,SynchList_pre, -// fgt(PhysTime-dT_mon,StartTime,dT_mon/2),ErrorMonitor); -#endif - - bssn_perf.MemoryUsage(¤t_min, ¤t_avg, ¤t_max, - &peak_min, &peak_avg, &peak_max, nprocs); - if (myrank == 0) - printf("Memory usage: current %0.4lg/%0.4lg/%0.4lgMB, " - "peak %0.4lg/%0.4lg/%0.4lgMB\n", - (double)current_min / (1024.0 * 1024.0), - (double)current_avg / (1024.0 * 1024.0), - (double)current_max / (1024.0 * 1024.0), - (double)peak_min / (1024.0 * 1024.0), - (double)peak_avg / (1024.0 * 1024.0), - (double)peak_max / (1024.0 * 1024.0)); - - if (LastCheck >= CheckTime) - { - LastCheck = 0; - - CheckPoint->write_Black_Hole_position(BH_num_input, BH_num, Porg0, Porgbr, Mass); - CheckPoint->writecheck_cgh(PhysTime, GH); - CheckPoint->writecheck_sh(PhysTime, SH); - CheckPoint->write_bssn(LastDump, Last2dDump, LastAnas); - } - } - /* - #ifdef With_AHF - // final apparent horizon finding - { - double gam; - for(int ihn=0;ihnPatL[lev],StateList,0,PhysTime,dT_lev); - } - -#if 0 - if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); -#endif - -#if (REGLEV == 0) - GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor); -#endif -} - -//================================================================================================ - - - -//================================================================================================ - -// ParallelStep performs time evolution across multiple grid levels (includes parallel execution) -// This section applies only when PSTR == 1 - -//================================================================================================ - -#if (PSTR == 1) -void bssn_class::ParallelStep() -{ - // stringstream a_stream; - // a_stream.setf(ios::left); - - double *tporg, *tporgo; - tporg = new double[3 * BH_num]; - tporgo = new double[3 * BH_num]; - - int lev = GH->mylev; - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - double dT_levp1 = dT * pow(0.5, Mymax(lev + 1, trfls)); - double dT_levm1 = dT * pow(0.5, Mymax(lev - 1, trfls)); - - int NoIterations = 1, YN; - if (lev <= trfls) - NoIterations = 1; - else - NoIterations = int(pow(2.0, lev - trfls)); - - for (int i = 0; i < NoIterations; i++) - { - // if(myrank==GH->start_rank[lev]) cout<<"level now = "<Commlev[lev],GH->start_rank[lev],a_stream.str()); - - // Step(lev,YN); -#ifdef USE_GPU - if (use_gpu == 1) - Step_GPU(lev, YN); - else - Step(lev, YN); -#else - Step(lev, YN); -#endif - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - -#if (AGM == 2) - if (GH->levels == 1) - { - Enforce_algcon(lev, 0); - } -#endif - - GH->Lt[lev] += dT_lev; - - PhysTime += dT_lev; - -#if (AGM == 2) - if (lev > 0) - { - Enforce_algcon(lev, 0); - if (YN == 1) - Enforce_algcon(lev - 1, 0); - } -#endif - -#if (RPS == 1) - // mesh refinement boundary part - // - // till here the PhysTime has updated dT_lev - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - if (lev < GH->levels - 1) - { - if (lev + 1 <= trfls) - { - // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); - RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); - } - else - { - // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],"between RestrictProlong"); - - // RestrictProlong_aux(lev,0,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); - // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_levp1,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); - RestrictProlong(lev + 1, 0, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); - RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); - } - } - - // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],a_stream.str()); - - RestrictProlong(lev, YN, fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), StateList, OldStateList, SynchList_cor); - // RestrictProlong(lev,YN,false,StateList,OldStateList,SynchList_cor); - -// if(myrank==GH->start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],a_stream.str()); -#endif - - // Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT_lev); - - { - MPI_Status status; - // receive - if (lev < GH->levels - 1) - { - if (myrank == GH->start_rank[lev]) - { - MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev + 1], 1, MPI_COMM_WORLD, &status); - // cout<Commlev[lev]); - - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - Porg0[i][j] = tporg[3 * i + j]; - - // if(myrank==GH->start_rank[lev]) cout< 0 && YN == 1 && myrank == GH->start_rank[lev]) - { - for (int i = 0; i < BH_num; i++) - for (int j = 0; j < 3; j++) - tporg[3 * i + j] = Porg0[i][j]; - - MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev - 1], 1, MPI_COMM_WORLD); - } - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - } -#if (REGLEV == 0) - // for higher level - if (lev < GH->levels - 1) - { - if (lev + 1 >= GH->movls) - { - // GH->Regrid_Onelevel_aux(lev,Symmetry,BH_num,Porgbr,Porg0, - GH->Regrid_Onelevel(lev + 1, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), ErrorMonitor); - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel_aux for higher level"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - } - - // for this level - if (YN == 1) - { - GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor); - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - - // for lower level - if (lev - 1 >= GH->movls) - { - if (lev - 1 <= trfls) - { - if (YN == 1) - { - // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, - GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor); - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel_aux for lower level"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - } - else - { - if (i % 4 == 3) - { - // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, - GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, - SynchList_cor, OldStateList, StateList, SynchList_pre, - fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor); - - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Regrid_Onelevel_aux for lower level"; - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); - } - } - } -#endif - } - -#ifdef WithShell - SHStep(); - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - -#if (RPS == 1) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(StateList, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - // a_stream.clear(); - // a_stream.str(""); - // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); - } -#endif - -#endif - -#if 0 - if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); -#endif - - delete[] tporg; - delete[] tporgo; -} -#endif - -//================================================================================================ - - - -//================================================================================================ - -// This member function configures the single-step time evolution for each grid level -// during the time evolution process. -// For the case PSTR == 0 - -//================================================================================================ - -#if (PSTR == 0) -#if 1 -void bssn_class::Step(int lev, int YN) -{ - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - -// new code 2013-2-15, zjcao -#if (MAPBH == 1) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - for (int ith = 0; ith < 3; ith++) - Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } -#endif - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) -#warning "shell part still bam type" - if (lev == 0) // Shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check rhs - { - SH->Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } -#endif - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) - if (lev == 1) // shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } -#endif - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif - - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } -#endif - } - } -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets up the single-step time evolution for each grid level (alternate version) - -//================================================================================================ - -#else // #if 1 (comment may be incorrect; should be #if 0) -// ICN for bam comparison -void bssn_class::Step(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif - f_icn_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_icn_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check rhs - { - SH->Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } -#endif - - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } - // corrector - for (iter_count = 1; iter_count < 3; iter_count++) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_icn_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} -#endif - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets up the single-step time evolution for each grid level -// For the case PSTR == 1 - -//================================================================================================ - -#elif (PSTR == 1) -void bssn_class::Step(int lev, int YN) -{ - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); - - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - -// new code 2013-2-15, zjcao -#if (MAPBH == 1) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - for (int ith = 0; ith < 3; ith++) - Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif //(MAPBH == 1) - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) -#warning "shell part still bam type" - if (lev == 0) // Shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Predictor rhs calculation"); - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor sync"); - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector"); - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"head of Corrector"); - - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) - if (lev == 1) // shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector error check"); - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector sync"); - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector sync"); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector of black hole position"); -#endif - - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after pre cor swap"); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } -#endif - } - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"tail of corrector"); - } -#if (RPS == 0) - // mesh refinement boundary part - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before RestrictProlong"); - RestrictProlong(lev, YN, BB); -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - // if(myrank==GH->start_rank[lev]) - // cout<start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],"complet GH Step"); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets up the single-step time evolution for the spherical shell -// grid part during the time evolution process - -//================================================================================================ - -#ifdef WithShell -void bssn_class::SHStep() -{ - int lev = 0; - // #if (PSTR == 1) - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); - // #endif - - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - - // #if (PSTR == 1) - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); - // #endif - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - -#ifdef USE_GPU - if (use_gpu == 1) - { - - if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) - - { - - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - - ERROR = 1; - } - } - else - { - if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_FIRST_TIME)) - - { - - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - - ERROR = 1; - } - } - -#else - if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_FIRST_TIME)) - - { - - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - - ERROR = 1; - } -#endif // USE_GPU - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - -#if (PSTR == 1) -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor's error check"); -#endif - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - -#ifdef USE_GPU - if (use_gpu == 1) - { - - if(gpu_rhs_ss(CALLED_BY_STEP,myrank,RHS_PARA_CALLED_THEN) - - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - - ERROR = 1; - - } - } - else - { - if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_THEN)) - - { - - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - - ERROR = 1; - } - } - -#else - if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_THEN)) - - { - - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - - ERROR = 1; - } -#endif // USE_GPU - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } - - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#if (RPS == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds!" << endl; - } - } -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -} -#endif -#endif // withshell - -//================================================================================================ - - - -//================================================================================================ - -// 0: do not use mixing two levels data for OutBD; 1: do use - -#define MIXOUTB 0 -void bssn_class::RestrictProlong(int lev, int YN, bool BB, - MyList *SL, MyList *OL, MyList *corL) -// we assume -// StateList 1 ----------- -// -// OldStateList 0 ----------- -// -// SynchList_cor old ----------- -{ -#if (PSTR == 1) -// stringstream a_stream; -// a_stream.setf(ios::left); -#endif - - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, SL, OL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - -#if (PSTR == 1) -// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); -#endif - Pp = Pp->next; - } - -#if (PSTR == 1) -// Pp=GH->PatL[lev]; -// while(Pp) -// { -// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); -// Pp=Pp->next; -// } - -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 before Restrict"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); -#endif - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 after Restrict"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - - Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 after Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); -#endif - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 0 after OutBdLow2Hi"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - } - else // no time refinement levels and for all same time levels - { - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 before Restrict"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); -#endif - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 before Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - - Parallel::Sync(GH->PatL[lev - 1], SL, Symmetry); - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 after Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SL, SL, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SL, SL, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); -#endif - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": 1 after OutBdLow2Hi"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - } - - Parallel::Sync(GH->PatL[lev], SL, Symmetry); - -#if (PSTR == 1) -// a_stream.clear(); -// a_stream.str(""); -// a_stream<mylev<<": after Sync"; -// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); -#endif - } -} - -//================================================================================================ - - - -//================================================================================================ - -// auxiliary operation, input lev means original lev-1 - -void bssn_class::RestrictProlong_aux(int lev, int YN, bool BB, - MyList *SL, MyList *OL, MyList *corL) -// we assume -// StateList 1 ----------- -// -// OldStateList 0 ----------- -// -// SynchList_cor old ----------- -{ - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"starting RestrictProlong_aux"); - - if (lev >= GH->levels - 1) - return; - lev = lev + 1; - - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, SL, OL, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); -#endif - } - else // no time refinement levels and for all same time levels - { -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync(GH->PatL[lev - 1], SL, Symmetry); - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SL, SL, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SL, SL, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); -#endif - } - - Parallel::Sync(GH->PatL[lev], SL, Symmetry); - } -} - -//================================================================================================ - - - -//================================================================================================ - -void bssn_class::RestrictProlong(int lev, int YN, bool BB) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - // we assume for fine - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // for coarse - // StateList 1 ----------- - // - // OldStateList 0 ----------- - // - // SynchList_cor old ----------- - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - if (myrank == 0) - cout << "/=: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, Symmetry); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,SynchList_pre,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - } - else // no time refinement levels and for all same time levels - { - if (myrank == 0) - cout << "===: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); -#elif (RPB == 1) - // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, GH->rsul[lev], Symmetry); -#endif - - Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - } - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - } -} - -//================================================================================================ - - - -//================================================================================================ - -void bssn_class::ProlongRestrict(int lev, int YN, bool BB) -{ - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - } - else // no time refinement levels and for all same time levels - { -#if (RPB == 0) - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { -#if (MIXOUTB == 0) - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); -#elif (MIXOUTB == 1) - Parallel::OutBdLow2Himix(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); -#endif - Pp = Pp->next; - } - Ppc = Ppc->next; - } -#elif (RPB == 1) - // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); - Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); -#endif - -#if 0 -#if (RPB == 0) - Parallel::Restrict(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); -#elif (RPB == 1) -// Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); - Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,GH->rsul[lev],Symmetry); -#endif -#else - Parallel::Restrict_after(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); -#endif - Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); - } - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - } -} -#undef MIXOUTB - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes the gravitational radiation scalar Psi4 - -//================================================================================================ - -void bssn_class::Compute_Psi4(int lev) -{ - MyList *DG_List = new MyList(Rpsi4); - DG_List->insert(Ipsi4); - -#if 0 // test showes this operation does not help -for(int ilev = GH->levels-1;ilev>=lev;ilev--) -{ - MyList *Pp=GH->PatL[ilev]; -#else - MyList *Pp = GH->PatL[lev]; -#endif - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (Psi4type == 0) - if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation - f_ricci_gamma(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - Symmetry); - // the input arguments Gamma^i_jk and R_ij do not need synch, because we do not need to derivate them - f_getnp4(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry); -#elif (Psi4type == 1) - f_getnp4old(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry); -#else -#error "not recognized Psi4type" -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#if 0 - Parallel::Sync(GH->PatL[ilev],DG_List,Symmetry); -} -// because of double level data change, you can not do this in above loop -// prolong restrict Psi4 -for(int ilev=GH->levels-1;ilev>lev;ilev--) - RestrictProlong(ilev,1,false,DG_List,DG_List,DG_List); -#else - Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); -#endif - -#ifdef WithShell - // ShellPatch part - if (lev == 0) - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { -#if (Psi4type == 0) - if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation - f_ricci_gamma_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - Symmetry, lev, Pp->data->sst); - - f_getnp4_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry, Pp->data->sst); -#elif (Psi4type == 1) - f_getnp4old_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry, Pp->data->sst); -#else -#error "not recognized Psi4type" -#endif - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - - SH->Synch(DG_List, Symmetry); -#if 0 -// interpolate Psi4 - SH->CS_Inter(DG_List,Symmetry); -#endif - } -#endif - - DG_List->clearList(); - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end of Compute_Psi4"); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function sets the puncture positions of black holes at the initial time - -//================================================================================================ - -void bssn_class::Setup_Black_Hole_position() -{ - char filename[50]; - strcpy(filename, "input.par"); - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_num_input = BH_num = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - // set up the data for black holes - // these arrays will be deleted when bssn_class is deleted - Pmom = new double[3 * BH_num]; - Spin = new double[3 * BH_num]; - Mass = new double[BH_num]; - Porg0 = new double *[BH_num]; - Porgbr = new double *[BH_num]; - Porg = new double *[BH_num]; - Porg1 = new double *[BH_num]; - Porg_rhs = new double *[BH_num]; - for (int i = 0; i < BH_num; i++) - { - Porg0[i] = new double[3]; - Porgbr[i] = new double[3]; - Porg[i] = new double[3]; - Porg1[i] = new double[3]; - Porg_rhs[i] = new double[3]; - } - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_num) - { - if (skey == "Mass") - Mass[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg0[sind][0] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg0[sind][1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg0[sind][2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - // echo information of Black holes - if (myrank == 0) - { - cout << "initial information of " << BH_num << " Black Hole(s)" << endl; - cout << setw(16) << "Mass" - << setw(16) << "x" - << setw(16) << "y" - << setw(16) << "z" - << setw(16) << "Px" - << setw(16) << "Py" - << setw(16) << "Pz" - << setw(16) << "Sx" - << setw(16) << "Sy" - << setw(16) << "Sz" << endl; - for (int i = 0; i < BH_num; i++) - { - cout << setw(16) << Mass[i] - << setw(16) << Porg0[i][0] - << setw(16) << Porg0[i][1] - << setw(16) << Porg0[i][2] - << setw(16) << Pmom[i * 3] - << setw(16) << Pmom[i * 3 + 1] - << setw(16) << Pmom[i * 3 + 2] - << setw(16) << Spin[i * 3] - << setw(16) << Spin[i * 3 + 1] - << setw(16) << Spin[i * 3 + 2] << endl; - } - } - - int maxl = 1; - int levels; - int *grids; - double bbox[6]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && skey == "levels") - { - levels = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - grids = new int[levels]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && skey == "grids" && sind1 < levels) - grids[sind1] = atoi(sval.c_str()); - if (sgrp == "cgh" && skey == "bbox" && sind1 == 0 && sind2 == 0) - bbox[sind3] = atof(sval.c_str()); - } - inf.close(); - } - for (int i = 0; i < levels; i++) - if (maxl < grids[i]) - maxl = grids[i]; - - delete[] grids; - - if (BH_num > maxl) - { - int BH_numc = BH_num; - for (int i = 0; i < BH_num; i++) - if (Porg0[i][0] < bbox[0] || Porg0[i][0] > bbox[3] || - Porg0[i][1] < bbox[1] || Porg0[i][1] > bbox[4] || - Porg0[i][2] < bbox[2] || Porg0[i][2] > bbox[5]) - { - delete[] Porg0[i]; - Porg0[i] = 0; - BH_numc--; - } - - if (BH_num > BH_numc) - { - maxl = BH_numc; - int bhi; - double *tmp; - - tmp = Pmom; - Pmom = new double[3 * maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (Porg0[i]) - { - for (int j = 0; j < 3; j++) - Pmom[3 * bhi + j] = tmp[3 * i + j]; - bhi++; - } - delete[] tmp; - - tmp = Spin; - Spin = new double[3 * maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (Porg0[i]) - { - for (int j = 0; j < 3; j++) - Spin[3 * bhi + j] = tmp[3 * i + j]; - bhi++; - } - delete[] tmp; - - tmp = Mass; - Mass = new double[3 * maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (Porg0[i]) - { - Mass[bhi] = tmp[i]; - bhi++; - } - delete[] tmp; - - double **ttmp; - ttmp = Porg0; - Porg0 = new double *[maxl]; - bhi = 0; - for (int i = 0; i < BH_num; i++) - if (ttmp[i]) - { - Porg0[bhi] = ttmp[i]; - bhi++; - } - delete[] ttmp; - - for (int i = 0; i < BH_num; i++) - { - delete[] Porgbr[i]; - delete[] Porg[i]; - delete[] Porg1[i]; - delete[] Porg_rhs[i]; - } - delete[] Porgbr; - delete[] Porg; - delete[] Porg1; - delete[] Porg_rhs; - - BH_num = maxl; - - Porgbr = new double *[BH_num]; - Porg = new double *[BH_num]; - Porg1 = new double *[BH_num]; - Porg_rhs = new double *[BH_num]; - - for (int i = 0; i < BH_num; i++) - { - Porgbr[i] = new double[3]; - Porg[i] = new double[3]; - Porg1[i] = new double[3]; - Porg_rhs[i] = new double[3]; - } - } - } - - for (int i = 0; i < BH_num; i++) - { - for (int j = 0; j < dim; j++) - Porgbr[i][j] = Porg0[i][j]; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes black hole positions - -//================================================================================================ - -#if 0 -// old code - -void bssn_class::compute_Porg_rhs(double **BH_PS,double **BH_RHS,var *forx,var *fory,var *forz,int lev) -{ - const int InList = 3; - - MyList * DG_List=new MyList(forx); - DG_List->insert(fory); DG_List->insert(forz); - - int n; - double *x1,*y1,*z1; - double *shellf; - shellf=new double[3*BH_num]; - double *pox[3]; - for(int i=0;i<3;i++) pox[i] = new double[BH_num]; - for( n = 0; n < BH_num; n++) - { - pox[0][n] = BH_PS[n][0]; - pox[1][n] = BH_PS[n][1]; - pox[2][n] = BH_PS[n][2]; - } - - if(!Parallel::PatList_Interp_Points(GH->PatL[lev],DG_List,BH_num,pox,shellf,Symmetry)) - { - ErrorMonitor->outfile<<"fail to find black holes at t = "<outfile<<"(x,y,z) = ("<clearList(); - delete[] shellf; - for(int i=0;i<3;i++) delete[] pox[i]; -} - -#else - -// new code considering diferent levels for different black hole - -void bssn_class::compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int ilev) -{ - const int InList = 3; - - MyList *DG_List = new MyList(forx); - DG_List->insert(fory); - DG_List->insert(forz); - - double *x1, *y1, *z1; - double *shellf; - shellf = new double[3]; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[1]; - - for (int n = 0; n < BH_num; n++) - { - pox[0][0] = BH_PS[n][0]; - pox[1][0] = BH_PS[n][1]; - pox[2][0] = BH_PS[n][2]; - - int lev = ilev; - -#if (PSTR == 0) - while (!Parallel::PatList_Interp_Points(GH->PatL[lev], DG_List, 1, pox, shellf, Symmetry)) -#elif (PSTR == 1) - while (!Parallel::PatList_Interp_Points(GH->PatL[lev], DG_List, 1, pox, shellf, Symmetry, GH->Commlev[lev])) -#endif - { - lev--; - if (lev < 0) - { - ErrorMonitor->outfile << "fail to find black holes at t = " << PhysTime << endl; - for (n = 0; n < BH_num; n++) - ErrorMonitor->outfile << "(x,y,z) = (" << pox[0][n] << "," << pox[1][n] << "," << pox[2][n] << ")" << endl; - break; - } - } - - if (lev >= 0) - { - BH_RHS[n][0] = -shellf[0]; - BH_RHS[n][1] = -shellf[1]; - BH_RHS[n][2] = -shellf[2]; - } - } - - DG_List->clearList(); - delete[] shellf; - for (int i = 0; i < 3; i++) - delete[] pox[i]; -} -#endif - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes gravitational-wave related data - -//================================================================================================ - -void bssn_class::AnalysisStuff(int lev, double dT_lev) -{ - LastAnas += dT_lev; - - if (LastAnas >= AnasTime) - { -#ifdef Point_Psi4 -#error "not support parallel levels yet" - // Gam_ijk and R_ij have been calculated in Interp_Constraint() - double SYM = 1, ANT = -1; - for (int levh = lev; levh < GH->levels; levh++) - { - MyList *Pp = GH->PatL[levh]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], - cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[trK0->sgfn], - cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Axx0->sgfn], - cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Axy0->sgfn], - cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, ANT, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Axz0->sgfn], - cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, SYM, ANT, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Ayy0->sgfn], - cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Ayz0->sgfn], - cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, ANT, ANT, Symmetry, levh); - f_fderivs(cg->shape, cg->fgfs[Azz0->sgfn], - cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, levh); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#ifdef WithShell - // ShellPatch part - if (lev == 0) - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_fderivs_shc(cg->shape, cg->fgfs[phi0->sgfn], - cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - phi0->SoA[0], phi0->SoA[1], phi0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[trK0->sgfn], - cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - trK0->SoA[0], trK0->SoA[1], trK0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Axx0->sgfn], - cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Axx0->SoA[0], Axx0->SoA[1], Axx0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Axy0->sgfn], - cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Axy0->SoA[0], Axy0->SoA[1], Axy0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Axz0->sgfn], - cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Axz0->SoA[0], Axz0->SoA[1], Axz0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Ayy0->sgfn], - cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Ayy0->SoA[0], Ayy0->SoA[1], Ayy0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Ayz0->sgfn], - cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Ayz0->SoA[0], Ayz0->SoA[1], Ayz0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - f_fderivs_shc(cg->shape, cg->fgfs[Azz0->sgfn], - cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - Azz0->SoA[0], Azz0->SoA[1], Azz0->SoA[2], - Symmetry, levh, Pp->data->sst, - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#endif - } -#else - Compute_Psi4(lev); -#endif - double *RP, *IP, *RoutMAP; - int NN = 0; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - NN++; - RP = new double[NN]; - IP = new double[NN]; - RoutMAP = new double[7]; - double Rex = maxrex; - for (int i = 0; i < decn; i++) - { -#ifdef Point_Psi4 - Waveshell->surf_Wave(Rex, GH, SH, - phi, trK, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - phix, phiy, phiz, - trKx, trKy, trKz, - Axxx, Axxy, Axxz, - Axyx, Axyy, Axyz, - Axzx, Axzy, Axzz, - Ayyx, Ayyy, Ayyz, - Ayzx, Ayzy, Ayzz, - Azzx, Azzy, Azzz, - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, - 2, maxl, NN, RP, IP, ErrorMonitor); -#ifdef WithShell - if (lev > 0 || Rex < GH->bbox[0][0][3]) - { - Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor); - } - else - { - Waveshell->surf_MassPAng(Rex, lev, SH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor); - } -#else - Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor); -#endif -#else -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before surface integral"); -#ifdef WithShell - if (lev > 0 || Rex < GH->bbox[0][0][3]) - { - Waveshell->surf_Wave(Rex, lev, GH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor); - Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor); - } - else - { - Waveshell->surf_Wave(Rex, lev, SH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor); - Waveshell->surf_MassPAng(Rex, lev, SH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor); - } -#else -#if (PSTR == 0) - Waveshell->surf_Wave(Rex, lev, GH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor); - Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor); -#elif (PSTR == 1) - Waveshell->surf_Wave(Rex, lev, GH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor, GH->Commlev[lev]); - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after surf_Wave"); - Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, - gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, - Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, - Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables - RoutMAP, ErrorMonitor, GH->Commlev[lev]); -#endif -#endif -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end surface integral"); -#endif - if (i == 0) - { - ADMMass = RoutMAP[0]; - } -#if (PSTR == 1) - if (GH->start_rank[a_lev] > 0) - { - MPI_Status status; - // receive - if (myrank == 0) - { - MPI_Recv(RP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 1, MPI_COMM_WORLD, &status); - MPI_Recv(IP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 2, MPI_COMM_WORLD, &status); - MPI_Recv(RoutMAP, 7, MPI_DOUBLE, GH->start_rank[a_lev], 3, MPI_COMM_WORLD, &status); - } - // send - if (myrank == GH->start_rank[a_lev]) - { - MPI_Send(RP, NN, MPI_DOUBLE, 0, 1, MPI_COMM_WORLD); - MPI_Send(IP, NN, MPI_DOUBLE, 0, 2, MPI_COMM_WORLD); - MPI_Send(RoutMAP, 7, MPI_DOUBLE, 0, 3, MPI_COMM_WORLD); - } - } -#endif - Psi4Monitor->writefile(PhysTime, NN, RP, IP); - MAPMonitor->writefile(PhysTime, 7, RoutMAP); - Rex = Rex - drex; - } - delete[] RP; - delete[] IP; - delete[] RoutMAP; - - // black hole's position - { - double *pox; - pox = new double[dim * BH_num]; - for (int bhi = 0; bhi < BH_num; bhi++) - for (int i = 0; i < dim; i++) - pox[dim * bhi + i] = Porg0[bhi][i]; - BHMonitor->writefile(PhysTime, dim * BH_num, pox); - delete[] pox; - } - - LastAnas = 0; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes and outputs constraint violations - -//================================================================================================ - -void bssn_class::Constraint_Out() -{ - LastConsOut += dT * pow(0.5, Mymax(0, trfls)); - - if (LastConsOut >= AnasTime) - // Constraint violation - { - // recompute least the constraint data lost for moved new grid - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - if (lev > 0) // if the constrait quantities can be reused from the step rhs calculation - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -// added by yangquan -#ifdef USE_GPU - if (use_gpu == 1) - gpu_rhs(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Constraint_Out); - - else - f_compute_rhs_bssn(RHS_PARA_CALLED_Constraint_Out); -#else - f_compute_rhs_bssn(RHS_PARA_CALLED_Constraint_Out); -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - if (0) // if the constrait quantities can be reused from the step rhs calculation - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - double TRK4 = PhysTime; - int pre = 0; - int lev = 0; - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#ifdef USE_GPU - if (use_gpu == 1) - - gpu_rhs_ss(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Constraint_Out_SS); - else - f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Constraint_Out_SS); -#else - f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Constraint_Out_SS); - -#endif // USE_GPU - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); -#endif - - double ConV[7]; -#if (PSTR == 1) - double ConV_h[7]; -#endif - -#ifdef WithShell - ConV[0] = SH->L2Norm(Cons_Ham); - ConV[1] = SH->L2Norm(Cons_Px); - ConV[2] = SH->L2Norm(Cons_Py); - ConV[3] = SH->L2Norm(Cons_Pz); - ConV[4] = SH->L2Norm(Cons_Gx); - ConV[5] = SH->L2Norm(Cons_Gy); - ConV[6] = SH->L2Norm(Cons_Gz); - ConVMonitor->writefile(PhysTime, 7, ConV); -#endif - for (int levi = 0; levi < GH->levels; levi++) - { -#if (PSTR == 0) - ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham); - ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px); - ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py); - ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz); - ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx); - ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy); - ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz); -#elif (PSTR == 1) - ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham, GH->Commlev[levi]); - ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px, GH->Commlev[levi]); - ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py, GH->Commlev[levi]); - ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz, GH->Commlev[levi]); - ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx, GH->Commlev[levi]); - ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy, GH->Commlev[levi]); - ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz, GH->Commlev[levi]); - // misc::tillherecheck("before collect data to cpu0"); - // MPI_ALLREDUCE( sendbuf, recvbuf, count, datatype, op, comm), sendbu and recvbuf must be different - if (levi > 0) - { - if (GH->mylev == levi && myrank == GH->start_rank[levi]) - for (int i = 0; i < 7; i++) - ConV_h[i] = ConV[i]; - else - for (int i = 0; i < 7; i++) - ConV_h[i] = 0; - MPI_Allreduce(ConV_h, ConV, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - } -#endif - ConVMonitor->writefile(PhysTime, 7, ConV); - /* - if(fabs(ConV[0])<0.00001) - { - MyList * DG_List=new MyList(Cons_Ham); - DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); - DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); - Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); - DG_List->clearList(); - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } - */ - } - - Interp_Constraint(false); - - LastConsOut = 0; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes derivatives required by the apparent-horizon routines - -//================================================================================================ - -#ifdef With_AHF -void bssn_class::AH_Prepare_derivatives() -{ - double SYM = 1.0, ANT = -1.0; - int ZEO = 0; - - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gxx0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamzxx->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gxy0->sgfn], - cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamzxy->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, ANT, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gxz0->sgfn], - cg->fgfs[Gamxxz->sgfn], cg->fgfs[Gamyxz->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - ANT, SYM, ANT, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gyy0->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamzyy->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gyz0->sgfn], - cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamzyz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, ANT, ANT, Symmetry, ZEO); - f_fderivs(cg->shape, cg->fgfs[gzz0->sgfn], - cg->fgfs[Gamxzz->sgfn], cg->fgfs[Gamyzz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->X[0], cg->X[1], cg->X[2], - SYM, SYM, SYM, Symmetry, ZEO); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - Parallel::Sync(GH->PatL[lev], AHDList, Symmetry); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function interpolates apparent-horizon data - -//================================================================================================ - -bool bssn_class::AH_Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetryi) -{ - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double pox[3]; - for (int i = 0; i < NN; i++) - { - for (int j = 0; j < 3; j++) - pox[j] = XX[j][i]; - int lev = GH->levels - 1; - bool notfound = true; - - while (notfound) - { - if (lev < 0) - { -#ifdef WithShell - if (SH->Interp_One_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) - { - return true; - } - if (myrank == 0) - cout << "bssn_class::AH_Interp_Points: point (" - << pox[0] << "," << pox[1] << "," << pox[2] - << ") is out of cgh and shell domain!" << endl; -#else - if (myrank == 0) - cout << "bssn_class::AH_Interp_Points: point (" - << pox[0] << "," << pox[1] << "," << pox[2] - << ") is out of cgh domain!" << endl; -#endif - return false; - } - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - if (Pp->data->Interp_ONE_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) - { - notfound = false; - break; - } - Pp = Pp->next; - } - lev--; - } - } - return true; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes the apparent horizon at the current iteration step - -//================================================================================================ - -void bssn_class::AH_Step_Find(int lev, double dT_lev) -{ - if ((lev == GH->levels - 1)) - { - int ncount = int(PhysTime / dT_lev); - bool tf = false; - for (int ihn = 0; ihn < HN_num; ihn++) - { - if (ncount % findeveryl[ihn] == 0) - { - tf = true; - break; - } - } - if (tf) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - prev_clock = clock(); - const int cdumpid = int(PhysTime / AHdumptime) + 1; - for (int ihn = 0; ihn < HN_num; ihn++) - dumpid[ihn] = cdumpid; - - double gam; - for (int ihn = 0; ihn < BH_num; ihn++) - { - xc[ihn] = Porg0[ihn][0]; - yc[ihn] = Porg0[ihn][1]; - zc[ihn] = Porg0[ihn][2]; - gam = fabs(Pmom[ihn * 3]) / (Mass[ihn]); - gam = sqrt(1 - gam * gam); - xr[ihn] = Mass[ihn] * gam; - gam = fabs(Pmom[ihn * 3 + 1]) / (Mass[ihn]); - gam = sqrt(1 - gam * gam); - yr[ihn] = Mass[ihn] * gam; - gam = fabs(Pmom[ihn * 3 + 2]) / (Mass[ihn]); - gam = sqrt(1 - gam * gam); - zr[ihn] = Mass[ihn] * gam; - dTT[ihn] = -1; - - if (ncount % findeveryl[ihn] == 0) - { - trigger[ihn] = true; - dTT[ihn] = findeveryl[ihn] * dT_lev; - } - else - trigger[ihn] = false; - if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) - lastahdumpid[ihn] = dumpid[ihn]; - else - dumpid[ihn] = 0; - } - int ihn = BH_num; - for (int ia = 0; ia < BH_num; ia++) - for (int ib = ia + 1; ib < BH_num; ib++) - { - xc[ihn] = (Porg0[ia][0] + Porg0[ib][0]) / 2; - yc[ihn] = (Porg0[ia][1] + Porg0[ib][1]) / 2; - zc[ihn] = (Porg0[ia][2] + Porg0[ib][2]) / 2; - - xr[ihn] = yr[ihn] = zr[ihn] = Mass[ia] + Mass[ib]; - - dTT[ihn] = -1; - - if (fabs(Porg0[ia][0] - Porg0[ib][0]) < 2 * xr[ihn] && - fabs(Porg0[ia][1] - Porg0[ib][1]) < 2 * xr[ihn] && - fabs(Porg0[ia][2] - Porg0[ib][2]) < 2 * xr[ihn] && - (ncount % findeveryl[ihn] == 0)) - { - trigger[ihn] = true; - dTT[ihn] = findeveryl[ihn] * dT_lev; - } - else - trigger[ihn] = false; - - if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) - lastahdumpid[ihn] = dumpid[ihn]; - else - dumpid[ihn] = 0; - - ihn++; - } -#if (ABEtype == 1) - if (PhysTime > 10) - { - ihn--; - trigger[ihn] = true; - xr[ihn] = yr[ihn] = zr[ihn] = 50; - // if(myrank==0) for(ihn=0;ihn 0) - return; - - // recompute least the constraint data lost for moved new grid - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - if (lev > 0) // if the constrait quantities can be reused from the step rhs calculation - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -// added by yangquan -#ifdef USE_GPU - if (use_gpu == 1) - gpu_rhs(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Interp_Constraint); - else - f_compute_rhs_bssn(RHS_PARA_CALLED_Interp_Constraint); -#else - f_compute_rhs_bssn(RHS_PARA_CALLED_Interp_Constraint); -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - if (0) // if the constrait quantities can be reused from the step rhs calculation - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - double TRK4 = PhysTime; - int pre = 0; - int lev = 0; - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#ifdef USE_GPU - if (use_gpu == 1) - - gpu_rhs_ss(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Intrp_Constraint_Out_SS); - else - f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Intrp_Constraint_Out_SS); -#else - f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Intrp_Constraint_Out_SS); - -#endif // USE_GPU - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); -#endif - } - // interpolate - double *x1, *y1, *z1; - const int n = 1000; - double lmax, lmin, dd; - lmin = 0; -#ifdef WithShell - lmax = SH->Rrange[1]; -#else - lmax = GH->bbox[0][0][4]; -#endif -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (lmax - lmin) / (n - 1); -#else -#ifdef Cell - dd = (lmax - lmin) / n; -#else -#error Not define Vertex nor Cell -#endif -#endif - x1 = new double[n]; - y1 = new double[n]; - z1 = new double[n]; - for (int i = 0; i < n; i++) - { - x1[i] = 0; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y1[i] = lmin + i * dd; -#else -#ifdef Cell - y1[i] = lmin + (i + 0.5) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - z1[i] = 0; - } - - int InList = 0; - - MyList *varl = ConstraintList; - while (varl) - { - InList++; - varl = varl->next; - } - double *shellf; - shellf = new double[n * InList]; - for (int i = 0; i < n; i++) - { - double XX[3]; - XX[0] = x1[i]; - XX[1] = y1[i]; - XX[2] = z1[i]; - bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#ifdef WithShell - if (!fg) - fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#endif - if (!fg && myrank == 0) - { - cout << "bssn_class::Interp_Constraint meets wrong" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - if (myrank == 0) - { - ofstream outfile; - char filename[50]; - sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); - // 0.5 for round off - - outfile.open(filename); - outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; - for (int i = 0; i < n; i++) - { - outfile << setw(10) << setprecision(10) << y1[i]; - for (int j = 0; j < InList; j++) - outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; - outfile << endl; - } - outfile.close(); - } - - delete[] shellf; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes constraint violations - -//================================================================================================ - -void bssn_class::Compute_Constraint() -{ - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - int lev; - - for (lev = 0; lev < GH->levels; lev++) - { - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } - // prolong restrict constraint quantities - for (lev = GH->levels - 1; lev > 0; lev--) - RestrictProlong(lev, 1, false, ConstraintList, ConstraintList, ConstraintList); - -#ifdef WithShell - lev = 0; - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); - // interpolate constraint quantities - SH->CS_Inter(ConstraintList, Symmetry); -#endif -} - - -void bssn_class::testRestrict() -{ - MyList *DG_List = new MyList(phi0); - int lev = 0; - double ZEO = 0, ONE = 1; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - lev = 1; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], DG_List, DG_List, Symmetry); - Parallel::Sync(GH->PatL[lev - 1], DG_List, Symmetry); - - Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); - - DG_List->clearList(); - exit(0); -} - -//================================================================================================ - - - -//================================================================================================ - -void bssn_class::testOutBd() -{ - MyList *DG_List = new MyList(phi0); - int lev = 1; - double ZEO = 0, ONE = 1; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - lev = 0; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - lev = 1; - MyList *Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, DG_List, DG_List, Symmetry); - Pp = Pp->next; - } - Ppc = Ppc->next; - } - - Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); - - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); - Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); - - DG_List->clearList(); - exit(0); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function enforces/checks the trace-free condition - -//================================================================================================ - -void bssn_class::Enforce_algcon(int lev, int fg) -{ - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (fg == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); - else - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#ifdef WithShell - if (lev == 0) - { - MyList *sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (fg == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); - else - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif -} - -// added by yangquan -void bssn_class::Get_runtime_envirment() -{ - // get processor name - char pname[MPI_MAX_PROCESSOR_NAME]; - int resultlen = 0, pcode = 0; - MPI_Get_processor_name(pname, &resultlen); - cout << "MPI rank: " << myrank << "Processor name:" << pname << endl; - for (int i = 0; i < resultlen; ++i) - { - pcode += ((int)(pname[i]) - 65) * i; - } - - /*if(myrank % 2 == 0){ - - } */ -} - -//================================================================================================ - + +#ifdef newc +#include +#include +using namespace std; +#else +#include +#endif + +#include "macrodef.h" +#include "misc.h" +#include +#include "Ansorg.h" +#include "fmisc.h" +#include "Parallel.h" +#include "bssn_gpu_class.h" +#include "bssn_rhs.h" +#include "initial_puncture.h" +#include "enforce_algebra.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" +#include "getnp4.h" +#include "shellfunctions.h" + +#ifdef With_AHF +#include "derivatives.h" +#include "myglobal.h" +#endif + +#include "perf.h" +#include "derivatives.h" +#include "ricci_gamma.h" + +// include GPU files +#include "bssn_gpu.h" + +//================================================================================================ + +// Define bssn_gpu_class + +//================================================================================================ + +bssn_class::bssn_class(double Couranti, double StartTimei, double TotalTimei, + double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, + double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi) + : Courant(Couranti), StartTime(StartTimei), TotalTime(TotalTimei), + DumpTime(DumpTimei), d2DumpTime(d2DumpTimei), CheckTime(CheckTimei), AnasTime(AnasTimei), + Symmetry(Symmetryi), checkrun(checkruni), numepss(numepssi), numepsb(numepsbi), numepsh(numepshi), +#ifdef With_AHF + xc(0), yc(0), zc(0), xr(0), yr(0), zr(0), trigger(0), dTT(0), dumpid(0), +#endif + a_lev(a_levi), maxl(maxli), decn(decni), maxrex(maxrexi), drex(drexi), + CheckPoint(0) +{ + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + // setup Monitors + { + stringstream a_stream; + a_stream.setf(ios::left); + a_stream << "# Error log information"; + ErrorMonitor = new monitor("Error.log", myrank, a_stream.str()); + ErrorMonitor->print_message("Warning: we always assume intput parameter in cell center style."); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + char str[50]; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + sprintf(str, "R%02dm%03d", pl, pm); + a_stream << setw(16) << str; + sprintf(str, "I%02dm%03d", pl, pm); + a_stream << setw(16) << str; + } + Psi4Monitor = new monitor("bssn_psi4.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + BHMonitor = new monitor("bssn_BH.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time ADMmass ADMPx ADMPy ADMPz ADMSx ADMSy ADMSz"; + MAPMonitor = new monitor("bssn_ADMQs.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time Ham Px Py Pz Gx Gy Gz"; + ConVMonitor = new monitor("bssn_constraint.dat", myrank, a_stream.str()); + } + // setup sphere integration engine + Waveshell = new surface_integral(Symmetry); + + trfls = 0; + chitiny = 0; + // read parameter from file + { + char filename[50]; + strcpy(filename, "input.par"); + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "chitiny") + chitiny = atof(sval.c_str()); + else if (sgrp == "BSSN" && skey == "time refinement start from level") + trfls = atoi(sval.c_str()); +#ifdef With_AHF + else if (sgrp == "AHF" && skey == "AHfindevery") + AHfindevery = atoi(sval.c_str()); + else if (sgrp == "AHF" && skey == "AHdumptime") + AHdumptime = atof(sval.c_str()); +#endif + } + inf.close(); + } + if (myrank == 0) + { + // echo information of lower bound of chi + cout << "chitiny = " << chitiny << endl; + cout << "time refinement start from level #" << trfls << endl; +#ifdef With_AHF + cout << "parameters for AHF:" << endl; + cout << "AHfindevery = " << AHfindevery << endl; + cout << "AHdumptime = " << AHdumptime << endl; +#endif + } + + chitiny = chitiny - 1; // because we have subtracted one from chi + + strcpy(checkfilename, checkfilenamei); + + ngfs = 0; + phio = new var("phio", ngfs++, 1, 1, 1); + trKo = new var("trKo", ngfs++, 1, 1, 1); + gxxo = new var("gxxo", ngfs++, 1, 1, 1); + gxyo = new var("gxyo", ngfs++, -1, -1, 1); + gxzo = new var("gxzo", ngfs++, -1, 1, -1); + gyyo = new var("gyyo", ngfs++, 1, 1, 1); + gyzo = new var("gyzo", ngfs++, 1, -1, -1); + gzzo = new var("gzzo", ngfs++, 1, 1, 1); + Axxo = new var("Axxo", ngfs++, 1, 1, 1); + Axyo = new var("Axyo", ngfs++, -1, -1, 1); + Axzo = new var("Axzo", ngfs++, -1, 1, -1); + Ayyo = new var("Ayyo", ngfs++, 1, 1, 1); + Ayzo = new var("Ayzo", ngfs++, 1, -1, -1); + Azzo = new var("Azzo", ngfs++, 1, 1, 1); + Gmxo = new var("Gmxo", ngfs++, -1, 1, 1); + Gmyo = new var("Gmyo", ngfs++, 1, -1, 1); + Gmzo = new var("Gmzo", ngfs++, 1, 1, -1); + Lapo = new var("Lapo", ngfs++, 1, 1, 1); + Sfxo = new var("Sfxo", ngfs++, -1, 1, 1); + Sfyo = new var("Sfyo", ngfs++, 1, -1, 1); + Sfzo = new var("Sfzo", ngfs++, 1, 1, -1); + dtSfxo = new var("dtSfxo", ngfs++, -1, 1, 1); + dtSfyo = new var("dtSfyo", ngfs++, 1, -1, 1); + dtSfzo = new var("dtSfzo", ngfs++, 1, 1, -1); + + phi0 = new var("phi0", ngfs++, 1, 1, 1); + trK0 = new var("trK0", ngfs++, 1, 1, 1); + gxx0 = new var("gxx0", ngfs++, 1, 1, 1); + gxy0 = new var("gxy0", ngfs++, -1, -1, 1); + gxz0 = new var("gxz0", ngfs++, -1, 1, -1); + gyy0 = new var("gyy0", ngfs++, 1, 1, 1); + gyz0 = new var("gyz0", ngfs++, 1, -1, -1); + gzz0 = new var("gzz0", ngfs++, 1, 1, 1); + Axx0 = new var("Axx0", ngfs++, 1, 1, 1); + Axy0 = new var("Axy0", ngfs++, -1, -1, 1); + Axz0 = new var("Axz0", ngfs++, -1, 1, -1); + Ayy0 = new var("Ayy0", ngfs++, 1, 1, 1); + Ayz0 = new var("Ayz0", ngfs++, 1, -1, -1); + Azz0 = new var("Azz0", ngfs++, 1, 1, 1); + Gmx0 = new var("Gmx0", ngfs++, -1, 1, 1); + Gmy0 = new var("Gmy0", ngfs++, 1, -1, 1); + Gmz0 = new var("Gmz0", ngfs++, 1, 1, -1); + Lap0 = new var("Lap0", ngfs++, 1, 1, 1); + Sfx0 = new var("Sfx0", ngfs++, -1, 1, 1); + Sfy0 = new var("Sfy0", ngfs++, 1, -1, 1); + Sfz0 = new var("Sfz0", ngfs++, 1, 1, -1); + dtSfx0 = new var("dtSfx0", ngfs++, -1, 1, 1); + dtSfy0 = new var("dtSfy0", ngfs++, 1, -1, 1); + dtSfz0 = new var("dtSfz0", ngfs++, 1, 1, -1); + + phi = new var("phi", ngfs++, 1, 1, 1); + trK = new var("trK", ngfs++, 1, 1, 1); + gxx = new var("gxx", ngfs++, 1, 1, 1); + gxy = new var("gxy", ngfs++, -1, -1, 1); + gxz = new var("gxz", ngfs++, -1, 1, -1); + gyy = new var("gyy", ngfs++, 1, 1, 1); + gyz = new var("gyz", ngfs++, 1, -1, -1); + gzz = new var("gzz", ngfs++, 1, 1, 1); + Axx = new var("Axx", ngfs++, 1, 1, 1); + Axy = new var("Axy", ngfs++, -1, -1, 1); + Axz = new var("Axz", ngfs++, -1, 1, -1); + Ayy = new var("Ayy", ngfs++, 1, 1, 1); + Ayz = new var("Ayz", ngfs++, 1, -1, -1); + Azz = new var("Azz", ngfs++, 1, 1, 1); + Gmx = new var("Gmx", ngfs++, -1, 1, 1); + Gmy = new var("Gmy", ngfs++, 1, -1, 1); + Gmz = new var("Gmz", ngfs++, 1, 1, -1); + Lap = new var("Lap", ngfs++, 1, 1, 1); + Sfx = new var("Sfx", ngfs++, -1, 1, 1); + Sfy = new var("Sfy", ngfs++, 1, -1, 1); + Sfz = new var("Sfz", ngfs++, 1, 1, -1); + dtSfx = new var("dtSfx", ngfs++, -1, 1, 1); + dtSfy = new var("dtSfy", ngfs++, 1, -1, 1); + dtSfz = new var("dtSfz", ngfs++, 1, 1, -1); + + phi1 = new var("phi1", ngfs++, 1, 1, 1); + trK1 = new var("trK1", ngfs++, 1, 1, 1); + gxx1 = new var("gxx1", ngfs++, 1, 1, 1); + gxy1 = new var("gxy1", ngfs++, -1, -1, 1); + gxz1 = new var("gxz1", ngfs++, -1, 1, -1); + gyy1 = new var("gyy1", ngfs++, 1, 1, 1); + gyz1 = new var("gyz1", ngfs++, 1, -1, -1); + gzz1 = new var("gzz1", ngfs++, 1, 1, 1); + Axx1 = new var("Axx1", ngfs++, 1, 1, 1); + Axy1 = new var("Axy1", ngfs++, -1, -1, 1); + Axz1 = new var("Axz1", ngfs++, -1, 1, -1); + Ayy1 = new var("Ayy1", ngfs++, 1, 1, 1); + Ayz1 = new var("Ayz1", ngfs++, 1, -1, -1); + Azz1 = new var("Azz1", ngfs++, 1, 1, 1); + Gmx1 = new var("Gmx1", ngfs++, -1, 1, 1); + Gmy1 = new var("Gmy1", ngfs++, 1, -1, 1); + Gmz1 = new var("Gmz1", ngfs++, 1, 1, -1); + Lap1 = new var("Lap1", ngfs++, 1, 1, 1); + Sfx1 = new var("Sfx1", ngfs++, -1, 1, 1); + Sfy1 = new var("Sfy1", ngfs++, 1, -1, 1); + Sfz1 = new var("Sfz1", ngfs++, 1, 1, -1); + dtSfx1 = new var("dtSfx1", ngfs++, -1, 1, 1); + dtSfy1 = new var("dtSfy1", ngfs++, 1, -1, 1); + dtSfz1 = new var("dtSfz1", ngfs++, 1, 1, -1); + + phi_rhs = new var("phi_rhs", ngfs++, 1, 1, 1); + trK_rhs = new var("trK_rhs", ngfs++, 1, 1, 1); + gxx_rhs = new var("gxx_rhs", ngfs++, 1, 1, 1); + gxy_rhs = new var("gxy_rhs", ngfs++, -1, -1, 1); + gxz_rhs = new var("gxz_rhs", ngfs++, -1, 1, -1); + gyy_rhs = new var("gyy_rhs", ngfs++, 1, 1, 1); + gyz_rhs = new var("gyz_rhs", ngfs++, 1, -1, -1); + gzz_rhs = new var("gzz_rhs", ngfs++, 1, 1, 1); + Axx_rhs = new var("Axx_rhs", ngfs++, 1, 1, 1); + Axy_rhs = new var("Axy_rhs", ngfs++, -1, -1, 1); + Axz_rhs = new var("Axz_rhs", ngfs++, -1, 1, -1); + Ayy_rhs = new var("Ayy_rhs", ngfs++, 1, 1, 1); + Ayz_rhs = new var("Ayz_rhs", ngfs++, 1, -1, -1); + Azz_rhs = new var("Azz_rhs", ngfs++, 1, 1, 1); + Gmx_rhs = new var("Gmx_rhs", ngfs++, -1, 1, 1); + Gmy_rhs = new var("Gmy_rhs", ngfs++, 1, -1, 1); + Gmz_rhs = new var("Gmz_rhs", ngfs++, 1, 1, -1); + Lap_rhs = new var("Lap_rhs", ngfs++, 1, 1, 1); + Sfx_rhs = new var("Sfx_rhs", ngfs++, -1, 1, 1); + Sfy_rhs = new var("Sfy_rhs", ngfs++, 1, -1, 1); + Sfz_rhs = new var("Sfz_rhs", ngfs++, 1, 1, -1); + dtSfx_rhs = new var("dtSfx_rhs", ngfs++, -1, 1, 1); + dtSfy_rhs = new var("dtSfy_rhs", ngfs++, 1, -1, 1); + dtSfz_rhs = new var("dtSfz_rhs", ngfs++, 1, 1, -1); + + rho = new var("rho", ngfs++, 1, 1, 1); + Sx = new var("Sx", ngfs++, -1, 1, 1); + Sy = new var("Sy", ngfs++, 1, -1, 1); + Sz = new var("Sz", ngfs++, 1, 1, -1); + Sxx = new var("Sxx", ngfs++, 1, 1, 1); + Sxy = new var("Sxy", ngfs++, -1, -1, 1); + Sxz = new var("Sxz", ngfs++, -1, 1, -1); + Syy = new var("Syy", ngfs++, 1, 1, 1); + Syz = new var("Syz", ngfs++, 1, -1, -1); + Szz = new var("Szz", ngfs++, 1, 1, 1); + + Gamxxx = new var("Gamxxx", ngfs++, -1, 1, 1); + Gamxxy = new var("Gamxxy", ngfs++, 1, -1, 1); + Gamxxz = new var("Gamxxz", ngfs++, 1, 1, -1); + Gamxyy = new var("Gamxyy", ngfs++, -1, 1, 1); + Gamxyz = new var("Gamxyz", ngfs++, -1, -1, -1); + Gamxzz = new var("Gamxzz", ngfs++, -1, 1, 1); + Gamyxx = new var("Gamyxx", ngfs++, 1, -1, 1); + Gamyxy = new var("Gamyxy", ngfs++, -1, 1, 1); + Gamyxz = new var("Gamyxz", ngfs++, -1, -1, -1); + Gamyyy = new var("Gamyyy", ngfs++, 1, -1, 1); + Gamyyz = new var("Gamyyz", ngfs++, 1, 1, -1); + Gamyzz = new var("Gamyzz", ngfs++, 1, -1, 1); + Gamzxx = new var("Gamzxx", ngfs++, 1, 1, -1); + Gamzxy = new var("Gamzxy", ngfs++, -1, -1, -1); + Gamzxz = new var("Gamzxz", ngfs++, -1, 1, 1); + Gamzyy = new var("Gamzyy", ngfs++, 1, 1, -1); + Gamzyz = new var("Gamzyz", ngfs++, 1, -1, 1); + Gamzzz = new var("Gamzzz", ngfs++, 1, 1, -1); + + Rxx = new var("Rxx", ngfs++, 1, 1, 1); + Rxy = new var("Rxy", ngfs++, -1, -1, 1); + Rxz = new var("Rxz", ngfs++, -1, 1, -1); + Ryy = new var("Ryy", ngfs++, 1, 1, 1); + Ryz = new var("Ryz", ngfs++, 1, -1, -1); + Rzz = new var("Rzz", ngfs++, 1, 1, 1); + + // refer to PRD, 77, 024027 (2008) + Rpsi4 = new var("Rpsi4", ngfs++, 1, 1, 1); + Ipsi4 = new var("Ipsi4", ngfs++, -1, -1, -1); + t1Rpsi4 = new var("t1Rpsi4", ngfs++, 1, 1, 1); + t1Ipsi4 = new var("t1Ipsi4", ngfs++, -1, -1, -1); + t2Rpsi4 = new var("t2Rpsi4", ngfs++, 1, 1, 1); + t2Ipsi4 = new var("t2Ipsi4", ngfs++, -1, -1, -1); + + // constraint violation monitor variables + Cons_Ham = new var("Cons_Ham", ngfs++, 1, 1, 1); + Cons_Px = new var("Cons_Px", ngfs++, -1, 1, 1); + Cons_Py = new var("Cons_Py", ngfs++, 1, -1, 1); + Cons_Pz = new var("Cons_Pz", ngfs++, 1, 1, -1); + Cons_Gx = new var("Cons_Gx", ngfs++, -1, 1, 1); + Cons_Gy = new var("Cons_Gy", ngfs++, 1, -1, 1); + Cons_Gz = new var("Cons_Gz", ngfs++, 1, 1, -1); + +#ifdef Point_Psi4 + phix = new var("phix", ngfs++, -1, 1, 1); + phiy = new var("phiy", ngfs++, 1, -1, 1); + phiz = new var("phiz", ngfs++, 1, 1, -1); + trKx = new var("trKx", ngfs++, -1, 1, 1); + trKy = new var("trKy", ngfs++, 1, -1, 1); + trKz = new var("trKz", ngfs++, 1, 1, -1); + Axxx = new var("Axxx", ngfs++, -1, 1, 1); + Axxy = new var("Axxy", ngfs++, 1, -1, 1); + Axxz = new var("Axxz", ngfs++, 1, 1, -1); + Axyx = new var("Axyx", ngfs++, 1, -1, 1); + Axyy = new var("Axyy", ngfs++, -1, 1, 1); + Axyz = new var("Axyz", ngfs++, -1, -1, -1); + Axzx = new var("Axzx", ngfs++, 1, 1, -1); + Axzy = new var("Axzy", ngfs++, -1, -1, -1); + Axzz = new var("Axzz", ngfs++, -1, 1, 1); + Ayyx = new var("Ayyx", ngfs++, -1, 1, 1); + Ayyy = new var("Ayyy", ngfs++, 1, -1, 1); + Ayyz = new var("Ayyz", ngfs++, 1, 1, -1); + Ayzx = new var("Ayzx", ngfs++, -1, -1, -1); + Ayzy = new var("Ayzy", ngfs++, 1, 1, -1); + Ayzz = new var("Ayzz", ngfs++, 1, -1, 1); + Azzx = new var("Azzx", ngfs++, -1, 1, 1); + Azzy = new var("Azzy", ngfs++, 1, -1, 1); + Azzz = new var("Azzz", ngfs++, 1, 1, -1); +#endif + + // specific properspeed for 1+log slice + { + const double vl = sqrt(2); + trKo->setpropspeed(vl); + trK0->setpropspeed(vl); + trK->setpropspeed(vl); + trK1->setpropspeed(vl); + trK_rhs->setpropspeed(vl); + + phio->setpropspeed(vl); + phi0->setpropspeed(vl); + phi->setpropspeed(vl); + phi1->setpropspeed(vl); + phi_rhs->setpropspeed(vl); + + Lapo->setpropspeed(vl); + Lap0->setpropspeed(vl); + Lap->setpropspeed(vl); + Lap1->setpropspeed(vl); + Lap_rhs->setpropspeed(vl); + } + + OldStateList = new MyList(phio); + OldStateList->insert(trKo); + OldStateList->insert(gxxo); + OldStateList->insert(gxyo); + OldStateList->insert(gxzo); + OldStateList->insert(gyyo); + OldStateList->insert(gyzo); + OldStateList->insert(gzzo); + OldStateList->insert(Axxo); + OldStateList->insert(Axyo); + OldStateList->insert(Axzo); + OldStateList->insert(Ayyo); + OldStateList->insert(Ayzo); + OldStateList->insert(Azzo); + OldStateList->insert(Gmxo); + OldStateList->insert(Gmyo); + OldStateList->insert(Gmzo); + OldStateList->insert(Lapo); + OldStateList->insert(Sfxo); + OldStateList->insert(Sfyo); + OldStateList->insert(Sfzo); + OldStateList->insert(dtSfxo); + OldStateList->insert(dtSfyo); + OldStateList->insert(dtSfzo); + + StateList = new MyList(phi0); + StateList->insert(trK0); + StateList->insert(gxx0); + StateList->insert(gxy0); + StateList->insert(gxz0); + StateList->insert(gyy0); + StateList->insert(gyz0); + StateList->insert(gzz0); + StateList->insert(Axx0); + StateList->insert(Axy0); + StateList->insert(Axz0); + StateList->insert(Ayy0); + StateList->insert(Ayz0); + StateList->insert(Azz0); + StateList->insert(Gmx0); + StateList->insert(Gmy0); + StateList->insert(Gmz0); + StateList->insert(Lap0); + StateList->insert(Sfx0); + StateList->insert(Sfy0); + StateList->insert(Sfz0); + StateList->insert(dtSfx0); + StateList->insert(dtSfy0); + StateList->insert(dtSfz0); + + RHSList = new MyList(phi_rhs); + RHSList->insert(trK_rhs); + RHSList->insert(gxx_rhs); + RHSList->insert(gxy_rhs); + RHSList->insert(gxz_rhs); + RHSList->insert(gyy_rhs); + RHSList->insert(gyz_rhs); + RHSList->insert(gzz_rhs); + RHSList->insert(Axx_rhs); + RHSList->insert(Axy_rhs); + RHSList->insert(Axz_rhs); + RHSList->insert(Ayy_rhs); + RHSList->insert(Ayz_rhs); + RHSList->insert(Azz_rhs); + RHSList->insert(Gmx_rhs); + RHSList->insert(Gmy_rhs); + RHSList->insert(Gmz_rhs); + RHSList->insert(Lap_rhs); + RHSList->insert(Sfx_rhs); + RHSList->insert(Sfy_rhs); + RHSList->insert(Sfz_rhs); + RHSList->insert(dtSfx_rhs); + RHSList->insert(dtSfy_rhs); + RHSList->insert(dtSfz_rhs); + + SynchList_pre = new MyList(phi); + SynchList_pre->insert(trK); + SynchList_pre->insert(gxx); + SynchList_pre->insert(gxy); + SynchList_pre->insert(gxz); + SynchList_pre->insert(gyy); + SynchList_pre->insert(gyz); + SynchList_pre->insert(gzz); + SynchList_pre->insert(Axx); + SynchList_pre->insert(Axy); + SynchList_pre->insert(Axz); + SynchList_pre->insert(Ayy); + SynchList_pre->insert(Ayz); + SynchList_pre->insert(Azz); + SynchList_pre->insert(Gmx); + SynchList_pre->insert(Gmy); + SynchList_pre->insert(Gmz); + SynchList_pre->insert(Lap); + SynchList_pre->insert(Sfx); + SynchList_pre->insert(Sfy); + SynchList_pre->insert(Sfz); + SynchList_pre->insert(dtSfx); + SynchList_pre->insert(dtSfy); + SynchList_pre->insert(dtSfz); + + SynchList_cor = new MyList(phi1); + SynchList_cor->insert(trK1); + SynchList_cor->insert(gxx1); + SynchList_cor->insert(gxy1); + SynchList_cor->insert(gxz1); + SynchList_cor->insert(gyy1); + SynchList_cor->insert(gyz1); + SynchList_cor->insert(gzz1); + SynchList_cor->insert(Axx1); + SynchList_cor->insert(Axy1); + SynchList_cor->insert(Axz1); + SynchList_cor->insert(Ayy1); + SynchList_cor->insert(Ayz1); + SynchList_cor->insert(Azz1); + SynchList_cor->insert(Gmx1); + SynchList_cor->insert(Gmy1); + SynchList_cor->insert(Gmz1); + SynchList_cor->insert(Lap1); + SynchList_cor->insert(Sfx1); + SynchList_cor->insert(Sfy1); + SynchList_cor->insert(Sfz1); + SynchList_cor->insert(dtSfx1); + SynchList_cor->insert(dtSfy1); + SynchList_cor->insert(dtSfz1); + + DumpList = new MyList(phi0); + DumpList->insert(trK0); + DumpList->insert(gxx0); + DumpList->insert(gxy0); + DumpList->insert(gxz0); + DumpList->insert(gyy0); + DumpList->insert(gyz0); + DumpList->insert(gzz0); + // DumpList->insert(Axx0); + // DumpList->insert(Axy0); + // DumpList->insert(Axz0); + // DumpList->insert(Ayy0); + // DumpList->insert(Ayz0); + // DumpList->insert(Azz0); + // DumpList->insert(Gmx0); + // DumpList->insert(Gmy0); + // DumpList->insert(Gmz0); + DumpList->insert(Lap0); + // DumpList->insert(Sfx0); + // DumpList->insert(Sfy0); + // DumpList->insert(Sfz0); + // DumpList->insert(dtSfx0); + // DumpList->insert(dtSfy0); + // DumpList->insert(dtSfz0); + DumpList->insert(Rpsi4); + DumpList->insert(Ipsi4); + DumpList->insert(Cons_Ham); + DumpList->insert(Cons_Px); + DumpList->insert(Cons_Py); + DumpList->insert(Cons_Pz); + // DumpList->insert(Cons_Gx); + // DumpList->insert(Cons_Gy); + // DumpList->insert(Cons_Gz); + + ConstraintList = new MyList(Cons_Ham); + ConstraintList->insert(Cons_Px); + ConstraintList->insert(Cons_Py); + ConstraintList->insert(Cons_Pz); + ConstraintList->insert(Cons_Gx); + ConstraintList->insert(Cons_Gy); + ConstraintList->insert(Cons_Gz); +#ifdef With_AHF + // setup kinds of var list + // List for AparentHorizonFinderDirect + // special attension is payed to symmetry type + // gij gij,x gij,y gij,z + AHList = new MyList(gxx0); + AHList->insert(Gamxxx); + AHList->insert(Gamyxx); + AHList->insert(Gamzxx); + AHList->insert(gxy0); + AHList->insert(Gamxxy); + AHList->insert(Gamyxy); + AHList->insert(Gamzxy); + AHList->insert(gxz0); + AHList->insert(Gamxxz); + AHList->insert(Gamyxz); + AHList->insert(Gamzxz); + AHList->insert(gyy0); + AHList->insert(Gamxyy); + AHList->insert(Gamyyy); + AHList->insert(Gamzyy); + AHList->insert(gyz0); + AHList->insert(Gamxyz); + AHList->insert(Gamyyz); + AHList->insert(Gamzyz); + AHList->insert(gzz0); + AHList->insert(Gamxzz); + AHList->insert(Gamyzz); + AHList->insert(Gamzzz); + // phi phi,x phi,y phi,z + AHList->insert(phi0); + AHList->insert(dtSfx_rhs); + AHList->insert(dtSfy_rhs); + AHList->insert(dtSfz_rhs); + // Aij + AHList->insert(Axx0); + AHList->insert(Axy0); + AHList->insert(Axz0); + AHList->insert(Ayy0); + AHList->insert(Ayz0); + AHList->insert(Azz0); + // trK + AHList->insert(trK0); + // gij,x gij,y gij,z + AHDList = new MyList(Gamxxx); + AHDList->insert(Gamyxx); + AHDList->insert(Gamzxx); + AHDList->insert(Gamxxy); + AHDList->insert(Gamyxy); + AHDList->insert(Gamzxy); + AHDList->insert(Gamxxz); + AHDList->insert(Gamyxz); + AHDList->insert(Gamzxz); + AHDList->insert(Gamxyy); + AHDList->insert(Gamyyy); + AHDList->insert(Gamzyy); + AHDList->insert(Gamxyz); + AHDList->insert(Gamyyz); + AHDList->insert(Gamzyz); + AHDList->insert(Gamxzz); + AHDList->insert(Gamyzz); + AHDList->insert(Gamzzz); + // phi,x phi,y phi,z + AHDList->insert(dtSfx_rhs); + AHDList->insert(dtSfy_rhs); + AHDList->insert(dtSfz_rhs); + + GaugeList = new MyList(Lap0); + GaugeList->insert(Sfx0); + GaugeList->insert(Sfy0); + GaugeList->insert(Sfz0); +#endif + + CheckPoint = new checkpoint(checkrun, checkfilename, myrank); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function initializes the class + +//================================================================================================ + +void bssn_class::Initialize() +{ + if (myrank == 0) + cout << "you have setted " << ngfs << " grid functions." << endl; + + CheckPoint->addvariablelist(StateList); + CheckPoint->addvariablelist(OldStateList); + + GH = new cgh(0, ngfs, Symmetry, "input.par", checkrun, ErrorMonitor); + if (checkrun) + CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); + else + GH->compose_cgh(nprocs); + +#ifdef WithShell + SH = new ShellPatch(0, ngfs, "input.par", Symmetry, myrank, ErrorMonitor); + SH->matchcheck(GH->PatL[0]); + SH->compose_sh(nprocs); + // SH->compose_shr(nprocs); //sh is faster than shr + SH->setupcordtrans(); + SH->Dump_xyz(0, 0, 1); + SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); + + if (checkrun) + CheckPoint->readcheck_sh(SH, myrank); +#else + SH = 0; +#endif + + double h = GH->PatL[0]->data->blb->data->getdX(0); + for (int i = 1; i < dim; i++) + h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); + dT = Courant * h; + + if (checkrun) + { + CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); + } + else + { + PhysTime = StartTime; + Setup_Black_Hole_position(); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// Destructor: free allocated variables + +//================================================================================================ + +bssn_class::~bssn_class() +{ +#ifdef With_AHF + AHList->clearList(); + AHDList->clearList(); + GaugeList->clearList(); + if (lastahdumpid) + delete[] lastahdumpid; + if (findeveryl) + delete[] findeveryl; + + if (xc) + { + delete[] xc; + delete[] yc; + delete[] zc; + delete[] xr; + delete[] yr; + delete[] zr; + delete[] trigger; + delete[] dumpid; + delete[] dTT; + } + + AHFinderDirect::AHFinderDirect_cleanup(); +#endif + + StateList->clearList(); + RHSList->clearList(); + OldStateList->clearList(); + SynchList_pre->clearList(); + SynchList_cor->clearList(); + DumpList->clearList(); + ConstraintList->clearList(); + + delete phio; + delete trKo; + delete gxxo; + delete gxyo; + delete gxzo; + delete gyyo; + delete gyzo; + delete gzzo; + delete Axxo; + delete Axyo; + delete Axzo; + delete Ayyo; + delete Ayzo; + delete Azzo; + delete Gmxo; + delete Gmyo; + delete Gmzo; + delete Lapo; + delete Sfxo; + delete Sfyo; + delete Sfzo; + delete dtSfxo; + delete dtSfyo; + delete dtSfzo; + + delete phi0; + delete trK0; + delete gxx0; + delete gxy0; + delete gxz0; + delete gyy0; + delete gyz0; + delete gzz0; + delete Axx0; + delete Axy0; + delete Axz0; + delete Ayy0; + delete Ayz0; + delete Azz0; + delete Gmx0; + delete Gmy0; + delete Gmz0; + delete Lap0; + delete Sfx0; + delete Sfy0; + delete Sfz0; + delete dtSfx0; + delete dtSfy0; + delete dtSfz0; + + delete phi; + delete trK; + delete gxx; + delete gxy; + delete gxz; + delete gyy; + delete gyz; + delete gzz; + delete Axx; + delete Axy; + delete Axz; + delete Ayy; + delete Ayz; + delete Azz; + delete Gmx; + delete Gmy; + delete Gmz; + delete Lap; + delete Sfx; + delete Sfy; + delete Sfz; + delete dtSfx; + delete dtSfy; + delete dtSfz; + + delete phi1; + delete trK1; + delete gxx1; + delete gxy1; + delete gxz1; + delete gyy1; + delete gyz1; + delete gzz1; + delete Axx1; + delete Axy1; + delete Axz1; + delete Ayy1; + delete Ayz1; + delete Azz1; + delete Gmx1; + delete Gmy1; + delete Gmz1; + delete Lap1; + delete Sfx1; + delete Sfy1; + delete Sfz1; + delete dtSfx1; + delete dtSfy1; + delete dtSfz1; + + delete phi_rhs; + delete trK_rhs; + delete gxx_rhs; + delete gxy_rhs; + delete gxz_rhs; + delete gyy_rhs; + delete gyz_rhs; + delete gzz_rhs; + delete Axx_rhs; + delete Axy_rhs; + delete Axz_rhs; + delete Ayy_rhs; + delete Ayz_rhs; + delete Azz_rhs; + delete Gmx_rhs; + delete Gmy_rhs; + delete Gmz_rhs; + delete Lap_rhs; + delete Sfx_rhs; + delete Sfy_rhs; + delete Sfz_rhs; + delete dtSfx_rhs; + delete dtSfy_rhs; + delete dtSfz_rhs; + + delete rho; + delete Sx; + delete Sy; + delete Sz; + delete Sxx; + delete Sxy; + delete Sxz; + delete Syy; + delete Syz; + delete Szz; + + delete Gamxxx; + delete Gamxxy; + delete Gamxxz; + delete Gamxyy; + delete Gamxyz; + delete Gamxzz; + delete Gamyxx; + delete Gamyxy; + delete Gamyxz; + delete Gamyyy; + delete Gamyyz; + delete Gamyzz; + delete Gamzxx; + delete Gamzxy; + delete Gamzxz; + delete Gamzyy; + delete Gamzyz; + delete Gamzzz; + + delete Rxx; + delete Rxy; + delete Rxz; + delete Ryy; + delete Ryz; + delete Rzz; + + delete Rpsi4; + delete Ipsi4; + delete t1Rpsi4; + delete t1Ipsi4; + delete t2Rpsi4; + delete t2Ipsi4; + + delete Cons_Ham; + delete Cons_Px; + delete Cons_Py; + delete Cons_Pz; + delete Cons_Gx; + delete Cons_Gy; + delete Cons_Gz; + +#ifdef Point_Psi4 + delete phix; + delete phiy; + delete phiz; + delete trKx; + delete trKy; + delete trKz; + delete Axxx; + delete Axxy; + delete Axxz; + delete Axyx; + delete Axyy; + delete Axyz; + delete Axzx; + delete Axzy; + delete Axzz; + delete Ayyx; + delete Ayyy; + delete Ayyz; + delete Ayzx; + delete Ayzy; + delete Ayzz; + delete Azzx; + delete Azzy; + delete Azzz; +#endif + + delete GH; +#ifdef WithShell + delete SH; +#endif + + for (int i = 0; i < BH_num; i++) + { + delete[] Porg0[i]; + delete[] Porgbr[i]; + delete[] Porg[i]; + delete[] Porg1[i]; + delete[] Porg_rhs[i]; + } + + delete[] Porg0; + delete[] Porgbr; + delete[] Porg; + delete[] Porg1; + delete[] Porg_rhs; + + delete[] Mass; + delete[] Spin; + delete[] Pmom; + + delete ErrorMonitor; + delete Psi4Monitor; + delete BHMonitor; + delete MAPMonitor; + delete ConVMonitor; + delete Waveshell; + + delete CheckPoint; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes initial data using Lousto's analytic formulas + +//================================================================================================ + +void bssn_class::Setup_Initial_Data_Lousto() +{ + if (!checkrun) + { + if (myrank == 0) + cout << "Setup initial data with Lousto's analytical formula." << endl; + char filename[50]; + strcpy(filename, "input.par"); + int BH_NM; + double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + // Use Lousto's analytic formulas to compute initial data + f_get_lousto_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_nbhs_sh(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + // dump read_in initial data + SH->Dump_Data(StateList, 0, PhysTime, dT); +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Pmom_here; + delete[] Spin_here; + // SH->Synch(GH->PatL[0],StateList,Symmetry); + // exit(0); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes initial data using analytic formulas by Prof. Cao + +//================================================================================================ + +void bssn_class::Setup_Initial_Data_Cao() +{ + if (!checkrun) + { + if (myrank == 0) + cout << "Setup initial data with Cao's analytical formula." << endl; + char filename[50]; + strcpy(filename, "input.par"); + int BH_NM; + double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + // Use Prof. Cao's analytic formulas to compute initial data + f_get_initial_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_nbhs_sh(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + // dump read_in initial data + SH->Dump_Data(StateList, 0, PhysTime, dT); +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Pmom_here; + delete[] Spin_here; + // SH->Synch(GH->PatL[0],StateList,Symmetry); + // exit(0); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes Kerr-Schild initial data analytically + +//================================================================================================ + +void bssn_class::Setup_KerrSchild() +{ + if (!checkrun) + { + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_kerrschild(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + int lev = 0, fngfs = Pp->data->fngfs; + + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_kerrschild_ss(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn]); + /* + f_fderivs_shc(cg->shape, + cg->fgfs[phi0->sgfn], + cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn], + cg->X[0],cg->X[1],cg->X[2], + phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], + Symmetry,lev,Pp->data->sst, + cg->fgfs[fngfs+ShellPatch::drhodx], + cg->fgfs[fngfs+ShellPatch::drhody], + cg->fgfs[fngfs+ShellPatch::drhodz], + cg->fgfs[fngfs+ShellPatch::dsigmadx], + cg->fgfs[fngfs+ShellPatch::dsigmady], + cg->fgfs[fngfs+ShellPatch::dsigmadz], + cg->fgfs[fngfs+ShellPatch::dRdx], + cg->fgfs[fngfs+ShellPatch::dRdy], + cg->fgfs[fngfs+ShellPatch::dRdz]); + f_fdderivs_shc(cg->shape,cg->fgfs[phi0->sgfn], + cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn], + cg->X[0],cg->X[1],cg->X[2], + phi0->SoA[0],phi0->SoA[1],phi0->SoA[2], + Symmetry,lev,Pp->data->sst, + cg->fgfs[fngfs+ShellPatch::drhodx], + cg->fgfs[fngfs+ShellPatch::drhody], + cg->fgfs[fngfs+ShellPatch::drhodz], + cg->fgfs[fngfs+ShellPatch::dsigmadx], + cg->fgfs[fngfs+ShellPatch::dsigmady], + cg->fgfs[fngfs+ShellPatch::dsigmadz], + cg->fgfs[fngfs+ShellPatch::dRdx], + cg->fgfs[fngfs+ShellPatch::dRdy], + cg->fgfs[fngfs+ShellPatch::dRdz], + cg->fgfs[fngfs+ShellPatch::drhodxx], + cg->fgfs[fngfs+ShellPatch::drhodxy], + cg->fgfs[fngfs+ShellPatch::drhodxz], + cg->fgfs[fngfs+ShellPatch::drhodyy], + cg->fgfs[fngfs+ShellPatch::drhodyz], + cg->fgfs[fngfs+ShellPatch::drhodzz], + cg->fgfs[fngfs+ShellPatch::dsigmadxx], + cg->fgfs[fngfs+ShellPatch::dsigmadxy], + cg->fgfs[fngfs+ShellPatch::dsigmadxz], + cg->fgfs[fngfs+ShellPatch::dsigmadyy], + cg->fgfs[fngfs+ShellPatch::dsigmadyz], + cg->fgfs[fngfs+ShellPatch::dsigmadzz], + cg->fgfs[fngfs+ShellPatch::dRdxx], + cg->fgfs[fngfs+ShellPatch::dRdxy], + cg->fgfs[fngfs+ShellPatch::dRdxz], + cg->fgfs[fngfs+ShellPatch::dRdyy], + cg->fgfs[fngfs+ShellPatch::dRdyz], + cg->fgfs[fngfs+ShellPatch::dRdzz]); + */ + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + // dump read_in initial data + // SH->Synch(GH->PatL[0],StateList,Symmetry); + // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); + // SH->Dump_Data(StateList,0,PhysTime,dT); + // exit(0); + + /* + { + MyList * DG_List=new MyList(Sfx_rhs); + DG_List->insert(Sfy_rhs); DG_List->insert(Sfz_rhs); + DG_List->insert(Axx_rhs); DG_List->insert(Axy_rhs); DG_List->insert(Axz_rhs); + DG_List->insert(Ayy_rhs); DG_List->insert(Ayz_rhs); DG_List->insert(Azz_rhs); + SH->Synch(DG_List,Symmetry); + SH->Dump_Data(DG_List,0,PhysTime,dT); + DG_List->clearList(); + exit(0); + } + */ + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function reads initial data produced by Pablo Galaviz's Olliptic program + +//================================================================================================ + +//|---------------------------------------------------------------------------- +// read ASCII file with the style of Pablo +//|---------------------------------------------------------------------------- +bool bssn_class::read_Pablo_file(int *ext, double *datain, char *filename) +{ + int nx = ext[0], ny = ext[1], nz = ext[2]; + int i, j, k; + double x, y, z; + //|--->open in put file + ifstream infile; + infile.open(filename); + if (!infile) + { + cout << "bssn_class: read_Pablo_file can't open " << filename << " for input." << endl; + return false; + } + for (k = 0; k < nz; k++) + for (j = 0; j < ny; j++) + for (i = 0; i < nx; i++) + { + infile >> x >> y >> z >> datain[i + j * nx + k * nx * ny]; + } + + infile.close(); + + return true; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function writes initial data for Pablo Galaviz's Olliptic program + +//================================================================================================ + +//|---------------------------------------------------------------------------- +// write ASCII file with the style of Pablo +//|---------------------------------------------------------------------------- +void bssn_class::write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, + char *filename) +{ + int nx = ext[0], ny = ext[1], nz = ext[2]; + int i, j, k; + double *X, *Y, *Z; + X = new double[nx]; + Y = new double[ny]; + Z = new double[nz]; + double dX, dY, dZ; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dX = (xmax - xmin) / (nx - 1); + for (i = 0; i < nx; i++) + X[i] = xmin + i * dX; + dY = (ymax - ymin) / (ny - 1); + for (j = 0; j < ny; j++) + Y[j] = ymin + j * dY; + dZ = (zmax - zmin) / (nz - 1); + for (k = 0; k < nz; k++) + Z[k] = zmin + k * dZ; +#else +#ifdef Cell + dX = (xmax - xmin) / nx; + for (i = 0; i < nx; i++) + X[i] = xmin + (i + 0.5) * dX; + dY = (ymax - ymin) / ny; + for (j = 0; j < ny; j++) + Y[j] = ymin + (j + 0.5) * dY; + dZ = (zmax - zmin) / nz; + for (k = 0; k < nz; k++) + Z[k] = zmin + (k + 0.5) * dZ; +#else +#error Not define Vertex nor Cell +#endif +#endif + //|--->open out put file + ofstream outfile; + outfile.open(filename); + if (!outfile) + { + cout << "bssn=_class: write_Pablo_file can't open " << filename << " for output." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + for (k = 0; k < nz; k++) + for (j = 0; j < ny; j++) + for (i = 0; i < nx; i++) + { + outfile << X[i] << " " << Y[j] << " " << Z[k] << " " + << 0 << endl; + } + outfile.close(); + + delete[] X; + delete[] Y; + delete[] Z; +} + +//================================================================================================ + + + + +//================================================================================================ + +// This member function reads TwoPuncture initial data produced by the Ansorg solver + +//================================================================================================ + +// Read initial data solved by Ansorg, PRD 70, 064011 (2004) + +void bssn_class::Read_Ansorg() +{ + if (!checkrun) + { + if (myrank == 0) + cout << "Read initial data from Ansorg's solver," + << " please be sure the input parameters for black holes are puncture parameters!!" << endl; + char filename[50]; + strcpy(filename, "input.par"); + int BH_NM; + double *Porg_here, *Pmom_here, *Spin_here, *Mass_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom_here = new double[3 * BH_NM]; + Spin_here = new double[3 * BH_NM]; + Mass_here = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass_here[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom_here[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + + int order = 6; + Ansorg read_ansorg("Ansorg.psid", order); + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); + + f_get_ansorg_nbhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); + + f_get_ansorg_nbhs_ss(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + Mass_here, Porg_here, Pmom_here, Spin_here, BH_NM); +#if 0 +// for check fderivs_sh + f_fderivs_sh(cg->shape,cg->fgfs[Ayz0->sgfn], + cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], + cg->X[0],cg->X[1],cg->X[2], + Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], + Symmetry,Pp->data->sst,Pp->data->sst); +#endif +#if 0 +// for check fderivs_shc + int fngfs = Pp->data->fngfs; + f_fderivs_shc(cg->shape,cg->fgfs[Ayz0->sgfn], + cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn], + cg->X[0],cg->X[1],cg->X[2], + Ayz0->SoA[0],Ayz0->SoA[1],Ayz0->SoA[2], + Symmetry,Pp->data->sst,Pp->data->sst, + cg->fgfs[fngfs+ShellPatch::drhodx], + cg->fgfs[fngfs+ShellPatch::drhody], + cg->fgfs[fngfs+ShellPatch::drhodz], + cg->fgfs[fngfs+ShellPatch::dsigmadx], + cg->fgfs[fngfs+ShellPatch::dsigmady], + cg->fgfs[fngfs+ShellPatch::dsigmadz], + cg->fgfs[fngfs+ShellPatch::dRdx], + cg->fgfs[fngfs+ShellPatch::dRdy], + cg->fgfs[fngfs+ShellPatch::dRdz]); +#endif + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + delete[] Porg_here; + delete[] Mass_here; + delete[] Pmom_here; + delete[] Spin_here; + + Compute_Constraint(); + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT); +#ifdef WithShell + SH->Dump_Data(DumpList, 0, PhysTime, dT); +#endif + // if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets up the time evolution for the entire process + +//================================================================================================ + +void bssn_class::Evolve(int Steps) +{ + + clock_t prev_clock, curr_clock; + double LastDump = 0.0, LastCheck = 0.0, Last2dDump = 0.0; + LastAnas = 0; +#if 0 +//initial checkpoint for special uasge + { + CheckPoint->write_Black_Hole_position(BH_num_input,BH_num,Porg0,Porgbr,Mass); + CheckPoint->writecheck_cgh(PhysTime,GH); +#ifdef WithShell + CheckPoint->writecheck_sh(PhysTime,SH); +#endif + CheckPoint->write_bssn(LastDump,Last2dDump,LastAnas); + misc::tillherecheck("complete initialization preparation"); // we need synchronization here + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } +#endif + + double beg_time; + beg_time = MPI_Wtime(); +// added by yangquan +#ifdef USE_GPU +#ifdef USE_GPU_DIVIDE + // new code considering different partition for cpu and gpu + { + MyList *Pp = GH->PatL[0]; + bool fg = true; + while (fg && Pp) + { + MyList *BP = Pp->data->blb; + while (fg && BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + use_gpu = cg->cgpu; + fg = false; + break; + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } +#else + // old yangquan code + use_gpu = 0; + if (myrank % 2 == 1) + use_gpu = 1; +#endif +#endif + + // for step 0 constraint interpolation + Interp_Constraint(true); + +#ifdef With_AHF + // setup apparent horizon finder direct of thornburg + { + HN_num = BH_num; + for (int ia = 0; ia < BH_num; ia++) + for (int ib = ia + 1; ib < BH_num; ib++) + HN_num++; + + AHFinderDirect::AHFinderDirect_setup(AHList, GaugeList, + this, + Symmetry, HN_num, &PhysTime); + + lastahdumpid = new int[HN_num]; + findeveryl = new int[HN_num]; + xc = new double[HN_num]; + yc = new double[HN_num]; + zc = new double[HN_num]; + xr = new double[HN_num]; + yr = new double[HN_num]; + zr = new double[HN_num]; + dTT = new double[HN_num]; + trigger = new bool[HN_num]; + dumpid = new int[HN_num]; + + for (int ihn = 0; ihn < HN_num; ihn++) + { + lastahdumpid[ihn] = 0; + findeveryl[ihn] = AHfindevery; + } + } +#endif + + if (checkrun) + CheckPoint->read_bssn(LastDump, Last2dDump, LastAnas); + + double dT_mon = dT * pow(0.5, Mymax(0, trfls)); + /* + #ifdef With_AHF + //initial apparent horizon finding + { + double gam; + double massmin=Mass[0]; + for(int ihn=1;ihnlevels; lev++) + GH->Lt[lev] = PhysTime; + + GH->settrfls(trfls); + + for (int ncount = 1; ncount < Steps + 1; ncount++) + { + cout << "Before Step: " << ncount << " My Rank: " << myrank + << " takes " << MPI_Wtime() - beg_time << " seconds!" << endl; + beg_time = MPI_Wtime(); +#if (PSTR == 0) + RecursiveStep(0); +#elif (PSTR == 1) + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + AnalysisStuff(a_lev, dT_mon); + ParallelStep(); +#endif + cout << "After Step: " << ncount << " My Rank: " << myrank + << " takes " << MPI_Wtime() - beg_time << " seconds!" << endl; + beg_time = MPI_Wtime(); + + // misc::tillherecheck("before Constraint_Out"); + + Constraint_Out(); // this will affect the Dump_List + + LastDump += dT_mon; + Last2dDump += dT_mon; + LastCheck += dT_mon; + + if (LastDump >= DumpTime) + { + // misc::tillherecheck("before Dump_Data"); + + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT_mon); +#ifdef WithShell + SH->Dump_Data(DumpList, 0, PhysTime, dT_mon); +#endif + + LastDump = 0; + + if (myrank == 0) + { + cout << "Dump done." << endl; + } + } + + if (Last2dDump >= d2DumpTime) + { + // misc::tillherecheck("before 2dDump_Data"); + + for (int lev = 0; lev < GH->levels; lev++) + Parallel::d2Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT_mon); + + Last2dDump = 0; + + if (myrank == 0) + { + cout << "2dDump done." << endl; + } + } + + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Timestep # " << ncount << ": integrating to time: " << PhysTime << endl; + cout << "used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + + if (PhysTime >= TotalTime) + break; + +#if (REGLEV == 1) + GH->Regrid(Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_mon, StartTime, dT_mon / 2), ErrorMonitor); +#endif + +#if (REGLEV == 0 && PSTR == 1) +// GH->Regrid_fake(Symmetry,BH_num,Porgbr,Porg0, +// SynchList_cor,OldStateList,StateList,SynchList_pre, +// fgt(PhysTime-dT_mon,StartTime,dT_mon/2),ErrorMonitor); +#endif + + bssn_perf.MemoryUsage(¤t_min, ¤t_avg, ¤t_max, + &peak_min, &peak_avg, &peak_max, nprocs); + if (myrank == 0) + printf("Memory usage: current %0.4lg/%0.4lg/%0.4lgMB, " + "peak %0.4lg/%0.4lg/%0.4lgMB\n", + (double)current_min / (1024.0 * 1024.0), + (double)current_avg / (1024.0 * 1024.0), + (double)current_max / (1024.0 * 1024.0), + (double)peak_min / (1024.0 * 1024.0), + (double)peak_avg / (1024.0 * 1024.0), + (double)peak_max / (1024.0 * 1024.0)); + + if (LastCheck >= CheckTime) + { + LastCheck = 0; + + CheckPoint->write_Black_Hole_position(BH_num_input, BH_num, Porg0, Porgbr, Mass); + CheckPoint->writecheck_cgh(PhysTime, GH); + CheckPoint->writecheck_sh(PhysTime, SH); + CheckPoint->write_bssn(LastDump, Last2dDump, LastAnas); + } + } + /* + #ifdef With_AHF + // final apparent horizon finding + { + double gam; + for(int ihn=0;ihnPatL[lev],StateList,0,PhysTime,dT_lev); + } + +#if 0 + if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); +#endif + +#if (REGLEV == 0) + GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor); +#endif +} + +//================================================================================================ + + + +//================================================================================================ + +// ParallelStep performs time evolution across multiple grid levels (includes parallel execution) +// This section applies only when PSTR == 1 + +//================================================================================================ + +#if (PSTR == 1) +void bssn_class::ParallelStep() +{ + // stringstream a_stream; + // a_stream.setf(ios::left); + + double *tporg, *tporgo; + tporg = new double[3 * BH_num]; + tporgo = new double[3 * BH_num]; + + int lev = GH->mylev; + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + double dT_levp1 = dT * pow(0.5, Mymax(lev + 1, trfls)); + double dT_levm1 = dT * pow(0.5, Mymax(lev - 1, trfls)); + + int NoIterations = 1, YN; + if (lev <= trfls) + NoIterations = 1; + else + NoIterations = int(pow(2.0, lev - trfls)); + + for (int i = 0; i < NoIterations; i++) + { + // if(myrank==GH->start_rank[lev]) cout<<"level now = "<Commlev[lev],GH->start_rank[lev],a_stream.str()); + + // Step(lev,YN); +#ifdef USE_GPU + if (use_gpu == 1) + Step_GPU(lev, YN); + else + Step(lev, YN); +#else + Step(lev, YN); +#endif + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + +#if (AGM == 2) + if (GH->levels == 1) + { + Enforce_algcon(lev, 0); + } +#endif + + GH->Lt[lev] += dT_lev; + + PhysTime += dT_lev; + +#if (AGM == 2) + if (lev > 0) + { + Enforce_algcon(lev, 0); + if (YN == 1) + Enforce_algcon(lev - 1, 0); + } +#endif + +#if (RPS == 1) + // mesh refinement boundary part + // + // till here the PhysTime has updated dT_lev + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + if (lev < GH->levels - 1) + { + if (lev + 1 <= trfls) + { + // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); + RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); + } + else + { + // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],"between RestrictProlong"); + + // RestrictProlong_aux(lev,0,fgt(PhysTime-dT_lev,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); + // RestrictProlong_aux(lev,1,fgt(PhysTime-dT_levp1,StartTime,dT_levp1/2),StateList,OldStateList,SynchList_cor); + RestrictProlong(lev + 1, 0, fgt(PhysTime - dT_lev, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); + RestrictProlong(lev + 1, 1, fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), StateList, OldStateList, SynchList_cor); + } + } + + // if(myrank==GH->start_rank[lev]) cout<mylev<<", "<Commlev[lev],GH->start_rank[lev],a_stream.str()); + + RestrictProlong(lev, YN, fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), StateList, OldStateList, SynchList_cor); + // RestrictProlong(lev,YN,false,StateList,OldStateList,SynchList_cor); + +// if(myrank==GH->start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],a_stream.str()); +#endif + + // Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT_lev); + + { + MPI_Status status; + // receive + if (lev < GH->levels - 1) + { + if (myrank == GH->start_rank[lev]) + { + MPI_Recv(tporgo, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev + 1], 1, MPI_COMM_WORLD, &status); + // cout<Commlev[lev]); + + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + Porg0[i][j] = tporg[3 * i + j]; + + // if(myrank==GH->start_rank[lev]) cout< 0 && YN == 1 && myrank == GH->start_rank[lev]) + { + for (int i = 0; i < BH_num; i++) + for (int j = 0; j < 3; j++) + tporg[3 * i + j] = Porg0[i][j]; + + MPI_Send(tporg, 3 * BH_num, MPI_DOUBLE, GH->start_rank[lev - 1], 1, MPI_COMM_WORLD); + } + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + } +#if (REGLEV == 0) + // for higher level + if (lev < GH->levels - 1) + { + if (lev + 1 >= GH->movls) + { + // GH->Regrid_Onelevel_aux(lev,Symmetry,BH_num,Porgbr,Porg0, + GH->Regrid_Onelevel(lev + 1, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_levp1, StartTime, dT_levp1 / 2), ErrorMonitor); + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel_aux for higher level"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + } + + // for this level + if (YN == 1) + { + GH->Regrid_Onelevel(lev, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_lev / 2), ErrorMonitor); + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + + // for lower level + if (lev - 1 >= GH->movls) + { + if (lev - 1 <= trfls) + { + if (YN == 1) + { + // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, + GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor); + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel_aux for lower level"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + } + else + { + if (i % 4 == 3) + { + // GH->Regrid_Onelevel_aux(lev-2,Symmetry,BH_num,Porgbr,Porg0, + GH->Regrid_Onelevel(lev - 1, Symmetry, BH_num, Porgbr, Porg0, + SynchList_cor, OldStateList, StateList, SynchList_pre, + fgt(PhysTime - dT_lev, StartTime, dT_levm1 / 2), ErrorMonitor); + + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Regrid_Onelevel_aux for lower level"; + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],a_stream.str()); + } + } + } +#endif + } + +#ifdef WithShell + SHStep(); + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + +#if (RPS == 1) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(StateList, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + // a_stream.clear(); + // a_stream.str(""); + // a_stream<Commlev[lev],GH->start_rank[lev],a_stream.str()); + } +#endif + +#endif + +#if 0 + if(lev>0) Parallel::Restrict_after(GH->PatL[lev-1],GH->PatL[lev],StateList,StateList,Symmetry); +#endif + + delete[] tporg; + delete[] tporgo; +} +#endif + +//================================================================================================ + + + +//================================================================================================ + +// This member function configures the single-step time evolution for each grid level +// during the time evolution process. +// For the case PSTR == 0 + +//================================================================================================ + +#if (PSTR == 0) +#if 1 +void bssn_class::Step(int lev, int YN) +{ + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + +// new code 2013-2-15, zjcao +#if (MAPBH == 1) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + for (int ith = 0; ith < 3; ith++) + Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } +#endif + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) +#warning "shell part still bam type" + if (lev == 0) // Shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check rhs + { + SH->Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } +#endif + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) + if (lev == 1) // shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } +#endif + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif + + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } +#endif + } + } +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets up the single-step time evolution for each grid level (alternate version) + +//================================================================================================ + +#else // #if 1 (comment may be incorrect; should be #if 0) +// ICN for bam comparison +void bssn_class::Step(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif + f_icn_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_icn_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check rhs + { + SH->Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } +#endif + + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } + // corrector + for (iter_count = 1; iter_count < 3; iter_count++) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_icn_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} +#endif + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets up the single-step time evolution for each grid level +// For the case PSTR == 1 + +//================================================================================================ + +#elif (PSTR == 1) +void bssn_class::Step(int lev, int YN) +{ + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); + + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + +// new code 2013-2-15, zjcao +#if (MAPBH == 1) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + for (int ith = 0; ith < 3; ith++) + Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif //(MAPBH == 1) + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) +#warning "shell part still bam type" + if (lev == 0) // Shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Predictor rhs calculation"); + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor sync"); + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector"); + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"head of Corrector"); + + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) + if (lev == 1) // shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector error check"); + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector sync"); + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector sync"); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector of black hole position"); +#endif + + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after pre cor swap"); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } +#endif + } + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"tail of corrector"); + } +#if (RPS == 0) + // mesh refinement boundary part + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before RestrictProlong"); + RestrictProlong(lev, YN, BB); +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + // if(myrank==GH->start_rank[lev]) + // cout<start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],"complet GH Step"); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets up the single-step time evolution for the spherical shell +// grid part during the time evolution process + +//================================================================================================ + +#ifdef WithShell +void bssn_class::SHStep() +{ + int lev = 0; + // #if (PSTR == 1) + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); + // #endif + + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + + // #if (PSTR == 1) + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); + // #endif + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + +#ifdef USE_GPU + if (use_gpu == 1) + { + + if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) + + { + + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + + ERROR = 1; + } + } + else + { + if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_FIRST_TIME)) + + { + + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + + ERROR = 1; + } + } + +#else + if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_FIRST_TIME)) + + { + + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + + ERROR = 1; + } +#endif // USE_GPU + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + +#if (PSTR == 1) +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor's error check"); +#endif + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + +#ifdef USE_GPU + if (use_gpu == 1) + { + + if(gpu_rhs_ss(CALLED_BY_STEP,myrank,RHS_PARA_CALLED_THEN) + + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + + ERROR = 1; + + } + } + else + { + if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_THEN)) + + { + + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + + ERROR = 1; + } + } + +#else + if (f_compute_rhs_bssn_ss(RHS_PARA_CALLED_THEN)) + + { + + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + + ERROR = 1; + } +#endif // USE_GPU + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } + + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#if (RPS == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds!" << endl; + } + } +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +} +#endif +#endif // withshell + +//================================================================================================ + + + +//================================================================================================ + +// 0: do not use mixing two levels data for OutBD; 1: do use + +#define MIXOUTB 0 +void bssn_class::RestrictProlong(int lev, int YN, bool BB, + MyList *SL, MyList *OL, MyList *corL) +// we assume +// StateList 1 ----------- +// +// OldStateList 0 ----------- +// +// SynchList_cor old ----------- +{ +#if (PSTR == 1) +// stringstream a_stream; +// a_stream.setf(ios::left); +#endif + + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, SL, OL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + +#if (PSTR == 1) +// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); +#endif + Pp = Pp->next; + } + +#if (PSTR == 1) +// Pp=GH->PatL[lev]; +// while(Pp) +// { +// Pp->data->checkPatch(0,GH->start_rank[GH->mylev]); +// Pp=Pp->next; +// } + +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 before Restrict"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); +#endif + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 after Restrict"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + + Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 after Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); +#endif + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 0 after OutBdLow2Hi"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + } + else // no time refinement levels and for all same time levels + { + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 before Restrict"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); +#endif + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 before Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + + Parallel::Sync(GH->PatL[lev - 1], SL, Symmetry); + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 after Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SL, SL, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SL, SL, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); +#endif + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": 1 after OutBdLow2Hi"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + } + + Parallel::Sync(GH->PatL[lev], SL, Symmetry); + +#if (PSTR == 1) +// a_stream.clear(); +// a_stream.str(""); +// a_stream<mylev<<": after Sync"; +// misc::tillherecheck(GH->Commlev[GH->mylev],GH->start_rank[GH->mylev],a_stream.str()); +#endif + } +} + +//================================================================================================ + + + +//================================================================================================ + +// auxiliary operation, input lev means original lev-1 + +void bssn_class::RestrictProlong_aux(int lev, int YN, bool BB, + MyList *SL, MyList *OL, MyList *corL) +// we assume +// StateList 1 ----------- +// +// OldStateList 0 ----------- +// +// SynchList_cor old ----------- +{ + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"starting RestrictProlong_aux"); + + if (lev >= GH->levels - 1) + return; + lev = lev + 1; + + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, SL, OL, corL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, SL, OL, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, Symmetry); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SynchList_pre,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SynchList_pre, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SL, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SL, GH->bdsul[lev], Symmetry); +#endif + } + else // no time refinement levels and for all same time levels + { +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, Symmetry); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync(GH->PatL[lev - 1], SL, Symmetry); + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SL, SL, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SL, SL, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SL,SL,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SL, SL, GH->bdsul[lev], Symmetry); +#endif + } + + Parallel::Sync(GH->PatL[lev], SL, Symmetry); + } +} + +//================================================================================================ + + + +//================================================================================================ + +void bssn_class::RestrictProlong(int lev, int YN, bool BB) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + // we assume for fine + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // for coarse + // StateList 1 ----------- + // + // OldStateList 0 ----------- + // + // SynchList_cor old ----------- + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + if (myrank == 0) + cout << "/=: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, Symmetry); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,SynchList_pre,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + } + else // no time refinement levels and for all same time levels + { + if (myrank == 0) + cout << "===: " << GH->Lt[lev - 1] << "," << GH->Lt[lev] + dT_lev << endl; +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); +#elif (RPB == 1) + // Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, GH->rsul[lev], Symmetry); +#endif + + Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + } + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + } +} + +//================================================================================================ + + + +//================================================================================================ + +void bssn_class::ProlongRestrict(int lev, int YN, bool BB) +{ + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_pre,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], SynchList_pre, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + } + else // no time refinement levels and for all same time levels + { +#if (RPB == 0) + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { +#if (MIXOUTB == 0) + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); +#elif (MIXOUTB == 1) + Parallel::OutBdLow2Himix(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); +#endif + Pp = Pp->next; + } + Ppc = Ppc->next; + } +#elif (RPB == 1) + // Parallel::OutBdLow2Hi_bam(GH->PatL[lev-1],GH->PatL[lev],StateList,SynchList_cor,Symmetry); + Parallel::OutBdLow2Hi_bam(GH->PatL[lev - 1], GH->PatL[lev], StateList, SynchList_cor, GH->bdsul[lev], Symmetry); +#endif + +#if 0 +#if (RPB == 0) + Parallel::Restrict(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); +#elif (RPB == 1) +// Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,Symmetry); + Parallel::Restrict_bam(GH->PatL[lev-1],GH->PatL[lev],SynchList_cor,StateList,GH->rsul[lev],Symmetry); +#endif +#else + Parallel::Restrict_after(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); +#endif + Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); + } + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + } +} +#undef MIXOUTB + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes the gravitational radiation scalar Psi4 + +//================================================================================================ + +void bssn_class::Compute_Psi4(int lev) +{ + MyList *DG_List = new MyList(Rpsi4); + DG_List->insert(Ipsi4); + +#if 0 // test showes this operation does not help +for(int ilev = GH->levels-1;ilev>=lev;ilev--) +{ + MyList *Pp=GH->PatL[ilev]; +#else + MyList *Pp = GH->PatL[lev]; +#endif + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (Psi4type == 0) + if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation + f_ricci_gamma(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + Symmetry); + // the input arguments Gamma^i_jk and R_ij do not need synch, because we do not need to derivate them + f_getnp4(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry); +#elif (Psi4type == 1) + f_getnp4old(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry); +#else +#error "not recognized Psi4type" +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#if 0 + Parallel::Sync(GH->PatL[ilev],DG_List,Symmetry); +} +// because of double level data change, you can not do this in above loop +// prolong restrict Psi4 +for(int ilev=GH->levels-1;ilev>lev;ilev--) + RestrictProlong(ilev,1,false,DG_List,DG_List,DG_List); +#else + Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); +#endif + +#ifdef WithShell + // ShellPatch part + if (lev == 0) + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { +#if (Psi4type == 0) + if (0) // if Gamma^i_jk and R_ij can be reused from the rhs calculation + f_ricci_gamma_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + Symmetry, lev, Pp->data->sst); + + f_getnp4_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry, Pp->data->sst); +#elif (Psi4type == 1) + f_getnp4old_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry, Pp->data->sst); +#else +#error "not recognized Psi4type" +#endif + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + + SH->Synch(DG_List, Symmetry); +#if 0 +// interpolate Psi4 + SH->CS_Inter(DG_List,Symmetry); +#endif + } +#endif + + DG_List->clearList(); + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end of Compute_Psi4"); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function sets the puncture positions of black holes at the initial time + +//================================================================================================ + +void bssn_class::Setup_Black_Hole_position() +{ + char filename[50]; + strcpy(filename, "input.par"); + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_num_input = BH_num = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + // set up the data for black holes + // these arrays will be deleted when bssn_class is deleted + Pmom = new double[3 * BH_num]; + Spin = new double[3 * BH_num]; + Mass = new double[BH_num]; + Porg0 = new double *[BH_num]; + Porgbr = new double *[BH_num]; + Porg = new double *[BH_num]; + Porg1 = new double *[BH_num]; + Porg_rhs = new double *[BH_num]; + for (int i = 0; i < BH_num; i++) + { + Porg0[i] = new double[3]; + Porgbr[i] = new double[3]; + Porg[i] = new double[3]; + Porg1[i] = new double[3]; + Porg_rhs[i] = new double[3]; + } + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_num) + { + if (skey == "Mass") + Mass[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg0[sind][0] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg0[sind][1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg0[sind][2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + // echo information of Black holes + if (myrank == 0) + { + cout << "initial information of " << BH_num << " Black Hole(s)" << endl; + cout << setw(16) << "Mass" + << setw(16) << "x" + << setw(16) << "y" + << setw(16) << "z" + << setw(16) << "Px" + << setw(16) << "Py" + << setw(16) << "Pz" + << setw(16) << "Sx" + << setw(16) << "Sy" + << setw(16) << "Sz" << endl; + for (int i = 0; i < BH_num; i++) + { + cout << setw(16) << Mass[i] + << setw(16) << Porg0[i][0] + << setw(16) << Porg0[i][1] + << setw(16) << Porg0[i][2] + << setw(16) << Pmom[i * 3] + << setw(16) << Pmom[i * 3 + 1] + << setw(16) << Pmom[i * 3 + 2] + << setw(16) << Spin[i * 3] + << setw(16) << Spin[i * 3 + 1] + << setw(16) << Spin[i * 3 + 2] << endl; + } + } + + int maxl = 1; + int levels; + int *grids; + double bbox[6]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && skey == "levels") + { + levels = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + grids = new int[levels]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "bssn_class::Setup_Black_Hole_position: Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && skey == "grids" && sind1 < levels) + grids[sind1] = atoi(sval.c_str()); + if (sgrp == "cgh" && skey == "bbox" && sind1 == 0 && sind2 == 0) + bbox[sind3] = atof(sval.c_str()); + } + inf.close(); + } + for (int i = 0; i < levels; i++) + if (maxl < grids[i]) + maxl = grids[i]; + + delete[] grids; + + if (BH_num > maxl) + { + int BH_numc = BH_num; + for (int i = 0; i < BH_num; i++) + if (Porg0[i][0] < bbox[0] || Porg0[i][0] > bbox[3] || + Porg0[i][1] < bbox[1] || Porg0[i][1] > bbox[4] || + Porg0[i][2] < bbox[2] || Porg0[i][2] > bbox[5]) + { + delete[] Porg0[i]; + Porg0[i] = 0; + BH_numc--; + } + + if (BH_num > BH_numc) + { + maxl = BH_numc; + int bhi; + double *tmp; + + tmp = Pmom; + Pmom = new double[3 * maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (Porg0[i]) + { + for (int j = 0; j < 3; j++) + Pmom[3 * bhi + j] = tmp[3 * i + j]; + bhi++; + } + delete[] tmp; + + tmp = Spin; + Spin = new double[3 * maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (Porg0[i]) + { + for (int j = 0; j < 3; j++) + Spin[3 * bhi + j] = tmp[3 * i + j]; + bhi++; + } + delete[] tmp; + + tmp = Mass; + Mass = new double[3 * maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (Porg0[i]) + { + Mass[bhi] = tmp[i]; + bhi++; + } + delete[] tmp; + + double **ttmp; + ttmp = Porg0; + Porg0 = new double *[maxl]; + bhi = 0; + for (int i = 0; i < BH_num; i++) + if (ttmp[i]) + { + Porg0[bhi] = ttmp[i]; + bhi++; + } + delete[] ttmp; + + for (int i = 0; i < BH_num; i++) + { + delete[] Porgbr[i]; + delete[] Porg[i]; + delete[] Porg1[i]; + delete[] Porg_rhs[i]; + } + delete[] Porgbr; + delete[] Porg; + delete[] Porg1; + delete[] Porg_rhs; + + BH_num = maxl; + + Porgbr = new double *[BH_num]; + Porg = new double *[BH_num]; + Porg1 = new double *[BH_num]; + Porg_rhs = new double *[BH_num]; + + for (int i = 0; i < BH_num; i++) + { + Porgbr[i] = new double[3]; + Porg[i] = new double[3]; + Porg1[i] = new double[3]; + Porg_rhs[i] = new double[3]; + } + } + } + + for (int i = 0; i < BH_num; i++) + { + for (int j = 0; j < dim; j++) + Porgbr[i][j] = Porg0[i][j]; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes black hole positions + +//================================================================================================ + +#if 0 +// old code + +void bssn_class::compute_Porg_rhs(double **BH_PS,double **BH_RHS,var *forx,var *fory,var *forz,int lev) +{ + const int InList = 3; + + MyList * DG_List=new MyList(forx); + DG_List->insert(fory); DG_List->insert(forz); + + int n; + double *x1,*y1,*z1; + double *shellf; + shellf=new double[3*BH_num]; + double *pox[3]; + for(int i=0;i<3;i++) pox[i] = new double[BH_num]; + for( n = 0; n < BH_num; n++) + { + pox[0][n] = BH_PS[n][0]; + pox[1][n] = BH_PS[n][1]; + pox[2][n] = BH_PS[n][2]; + } + + if(!Parallel::PatList_Interp_Points(GH->PatL[lev],DG_List,BH_num,pox,shellf,Symmetry)) + { + ErrorMonitor->outfile<<"fail to find black holes at t = "<outfile<<"(x,y,z) = ("<clearList(); + delete[] shellf; + for(int i=0;i<3;i++) delete[] pox[i]; +} + +#else + +// new code considering diferent levels for different black hole + +void bssn_class::compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int ilev) +{ + const int InList = 3; + + MyList *DG_List = new MyList(forx); + DG_List->insert(fory); + DG_List->insert(forz); + + double *x1, *y1, *z1; + double *shellf; + shellf = new double[3]; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[1]; + + for (int n = 0; n < BH_num; n++) + { + pox[0][0] = BH_PS[n][0]; + pox[1][0] = BH_PS[n][1]; + pox[2][0] = BH_PS[n][2]; + + int lev = ilev; + +#if (PSTR == 0) + while (!Parallel::PatList_Interp_Points(GH->PatL[lev], DG_List, 1, pox, shellf, Symmetry)) +#elif (PSTR == 1) + while (!Parallel::PatList_Interp_Points(GH->PatL[lev], DG_List, 1, pox, shellf, Symmetry, GH->Commlev[lev])) +#endif + { + lev--; + if (lev < 0) + { + ErrorMonitor->outfile << "fail to find black holes at t = " << PhysTime << endl; + for (n = 0; n < BH_num; n++) + ErrorMonitor->outfile << "(x,y,z) = (" << pox[0][n] << "," << pox[1][n] << "," << pox[2][n] << ")" << endl; + break; + } + } + + if (lev >= 0) + { + BH_RHS[n][0] = -shellf[0]; + BH_RHS[n][1] = -shellf[1]; + BH_RHS[n][2] = -shellf[2]; + } + } + + DG_List->clearList(); + delete[] shellf; + for (int i = 0; i < 3; i++) + delete[] pox[i]; +} +#endif + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes gravitational-wave related data + +//================================================================================================ + +void bssn_class::AnalysisStuff(int lev, double dT_lev) +{ + LastAnas += dT_lev; + + if (LastAnas >= AnasTime) + { +#ifdef Point_Psi4 +#error "not support parallel levels yet" + // Gam_ijk and R_ij have been calculated in Interp_Constraint() + double SYM = 1, ANT = -1; + for (int levh = lev; levh < GH->levels; levh++) + { + MyList *Pp = GH->PatL[levh]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], + cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[trK0->sgfn], + cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Axx0->sgfn], + cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Axy0->sgfn], + cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, ANT, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Axz0->sgfn], + cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, SYM, ANT, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Ayy0->sgfn], + cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Ayz0->sgfn], + cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, ANT, ANT, Symmetry, levh); + f_fderivs(cg->shape, cg->fgfs[Azz0->sgfn], + cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, levh); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#ifdef WithShell + // ShellPatch part + if (lev == 0) + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_fderivs_shc(cg->shape, cg->fgfs[phi0->sgfn], + cg->fgfs[phix->sgfn], cg->fgfs[phiy->sgfn], cg->fgfs[phiz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + phi0->SoA[0], phi0->SoA[1], phi0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[trK0->sgfn], + cg->fgfs[trKx->sgfn], cg->fgfs[trKy->sgfn], cg->fgfs[trKz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + trK0->SoA[0], trK0->SoA[1], trK0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Axx0->sgfn], + cg->fgfs[Axxx->sgfn], cg->fgfs[Axxy->sgfn], cg->fgfs[Axxz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Axx0->SoA[0], Axx0->SoA[1], Axx0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Axy0->sgfn], + cg->fgfs[Axyx->sgfn], cg->fgfs[Axyy->sgfn], cg->fgfs[Axyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Axy0->SoA[0], Axy0->SoA[1], Axy0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Axz0->sgfn], + cg->fgfs[Axzx->sgfn], cg->fgfs[Axzy->sgfn], cg->fgfs[Axzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Axz0->SoA[0], Axz0->SoA[1], Axz0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Ayy0->sgfn], + cg->fgfs[Ayyx->sgfn], cg->fgfs[Ayyy->sgfn], cg->fgfs[Ayyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Ayy0->SoA[0], Ayy0->SoA[1], Ayy0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Ayz0->sgfn], + cg->fgfs[Ayzx->sgfn], cg->fgfs[Ayzy->sgfn], cg->fgfs[Ayzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Ayz0->SoA[0], Ayz0->SoA[1], Ayz0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + f_fderivs_shc(cg->shape, cg->fgfs[Azz0->sgfn], + cg->fgfs[Azzx->sgfn], cg->fgfs[Azzy->sgfn], cg->fgfs[Azzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + Azz0->SoA[0], Azz0->SoA[1], Azz0->SoA[2], + Symmetry, levh, Pp->data->sst, + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#endif + } +#else + Compute_Psi4(lev); +#endif + double *RP, *IP, *RoutMAP; + int NN = 0; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + NN++; + RP = new double[NN]; + IP = new double[NN]; + RoutMAP = new double[7]; + double Rex = maxrex; + for (int i = 0; i < decn; i++) + { +#ifdef Point_Psi4 + Waveshell->surf_Wave(Rex, GH, SH, + phi, trK, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + phix, phiy, phiz, + trKx, trKy, trKz, + Axxx, Axxy, Axxz, + Axyx, Axyy, Axyz, + Axzx, Axzy, Axzz, + Ayyx, Ayyy, Ayyz, + Ayzx, Ayzy, Ayzz, + Azzx, Azzy, Azzz, + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, + 2, maxl, NN, RP, IP, ErrorMonitor); +#ifdef WithShell + if (lev > 0 || Rex < GH->bbox[0][0][3]) + { + Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor); + } + else + { + Waveshell->surf_MassPAng(Rex, lev, SH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor); + } +#else + Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor); +#endif +#else +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before surface integral"); +#ifdef WithShell + if (lev > 0 || Rex < GH->bbox[0][0][3]) + { + Waveshell->surf_Wave(Rex, lev, GH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor); + Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor); + } + else + { + Waveshell->surf_Wave(Rex, lev, SH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor); + Waveshell->surf_MassPAng(Rex, lev, SH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor); + } +#else +#if (PSTR == 0) + Waveshell->surf_Wave(Rex, lev, GH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor); + Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor); +#elif (PSTR == 1) + Waveshell->surf_Wave(Rex, lev, GH, Rpsi4, Ipsi4, 2, maxl, NN, RP, IP, ErrorMonitor, GH->Commlev[lev]); + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after surf_Wave"); + Waveshell->surf_MassPAng(Rex, lev, GH, phi0, trK0, + gxx0, gxy0, gxz0, gyy0, gyz0, gzz0, + Axx0, Axy0, Axz0, Ayy0, Ayz0, Azz0, + Gmx0, Gmy0, Gmz0, Sfx1, Sfy1, Sfz1, // here we can not touch rhs variables, but 1 variables + RoutMAP, ErrorMonitor, GH->Commlev[lev]); +#endif +#endif +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"end surface integral"); +#endif + if (i == 0) + { + ADMMass = RoutMAP[0]; + } +#if (PSTR == 1) + if (GH->start_rank[a_lev] > 0) + { + MPI_Status status; + // receive + if (myrank == 0) + { + MPI_Recv(RP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 1, MPI_COMM_WORLD, &status); + MPI_Recv(IP, NN, MPI_DOUBLE, GH->start_rank[a_lev], 2, MPI_COMM_WORLD, &status); + MPI_Recv(RoutMAP, 7, MPI_DOUBLE, GH->start_rank[a_lev], 3, MPI_COMM_WORLD, &status); + } + // send + if (myrank == GH->start_rank[a_lev]) + { + MPI_Send(RP, NN, MPI_DOUBLE, 0, 1, MPI_COMM_WORLD); + MPI_Send(IP, NN, MPI_DOUBLE, 0, 2, MPI_COMM_WORLD); + MPI_Send(RoutMAP, 7, MPI_DOUBLE, 0, 3, MPI_COMM_WORLD); + } + } +#endif + Psi4Monitor->writefile(PhysTime, NN, RP, IP); + MAPMonitor->writefile(PhysTime, 7, RoutMAP); + Rex = Rex - drex; + } + delete[] RP; + delete[] IP; + delete[] RoutMAP; + + // black hole's position + { + double *pox; + pox = new double[dim * BH_num]; + for (int bhi = 0; bhi < BH_num; bhi++) + for (int i = 0; i < dim; i++) + pox[dim * bhi + i] = Porg0[bhi][i]; + BHMonitor->writefile(PhysTime, dim * BH_num, pox); + delete[] pox; + } + + LastAnas = 0; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes and outputs constraint violations + +//================================================================================================ + +void bssn_class::Constraint_Out() +{ + LastConsOut += dT * pow(0.5, Mymax(0, trfls)); + + if (LastConsOut >= AnasTime) + // Constraint violation + { + // recompute least the constraint data lost for moved new grid + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + if (lev > 0) // if the constrait quantities can be reused from the step rhs calculation + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +// added by yangquan +#ifdef USE_GPU + if (use_gpu == 1) + gpu_rhs(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Constraint_Out); + + else + f_compute_rhs_bssn(RHS_PARA_CALLED_Constraint_Out); +#else + f_compute_rhs_bssn(RHS_PARA_CALLED_Constraint_Out); +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + if (0) // if the constrait quantities can be reused from the step rhs calculation + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + double TRK4 = PhysTime; + int pre = 0; + int lev = 0; + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#ifdef USE_GPU + if (use_gpu == 1) + + gpu_rhs_ss(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Constraint_Out_SS); + else + f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Constraint_Out_SS); +#else + f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Constraint_Out_SS); + +#endif // USE_GPU + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); +#endif + + double ConV[7]; +#if (PSTR == 1) + double ConV_h[7]; +#endif + +#ifdef WithShell + ConV[0] = SH->L2Norm(Cons_Ham); + ConV[1] = SH->L2Norm(Cons_Px); + ConV[2] = SH->L2Norm(Cons_Py); + ConV[3] = SH->L2Norm(Cons_Pz); + ConV[4] = SH->L2Norm(Cons_Gx); + ConV[5] = SH->L2Norm(Cons_Gy); + ConV[6] = SH->L2Norm(Cons_Gz); + ConVMonitor->writefile(PhysTime, 7, ConV); +#endif + for (int levi = 0; levi < GH->levels; levi++) + { +#if (PSTR == 0) + ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham); + ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px); + ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py); + ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz); + ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx); + ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy); + ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz); +#elif (PSTR == 1) + ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham, GH->Commlev[levi]); + ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px, GH->Commlev[levi]); + ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py, GH->Commlev[levi]); + ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz, GH->Commlev[levi]); + ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx, GH->Commlev[levi]); + ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy, GH->Commlev[levi]); + ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz, GH->Commlev[levi]); + // misc::tillherecheck("before collect data to cpu0"); + // MPI_ALLREDUCE( sendbuf, recvbuf, count, datatype, op, comm), sendbu and recvbuf must be different + if (levi > 0) + { + if (GH->mylev == levi && myrank == GH->start_rank[levi]) + for (int i = 0; i < 7; i++) + ConV_h[i] = ConV[i]; + else + for (int i = 0; i < 7; i++) + ConV_h[i] = 0; + MPI_Allreduce(ConV_h, ConV, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + } +#endif + ConVMonitor->writefile(PhysTime, 7, ConV); + /* + if(fabs(ConV[0])<0.00001) + { + MyList * DG_List=new MyList(Cons_Ham); + DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); + DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); + Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); + DG_List->clearList(); + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } + */ + } + + Interp_Constraint(false); + + LastConsOut = 0; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes derivatives required by the apparent-horizon routines + +//================================================================================================ + +#ifdef With_AHF +void bssn_class::AH_Prepare_derivatives() +{ + double SYM = 1.0, ANT = -1.0; + int ZEO = 0; + + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_fderivs(cg->shape, cg->fgfs[phi0->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gxx0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamzxx->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gxy0->sgfn], + cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamzxy->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, ANT, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gxz0->sgfn], + cg->fgfs[Gamxxz->sgfn], cg->fgfs[Gamyxz->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + ANT, SYM, ANT, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gyy0->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamzyy->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gyz0->sgfn], + cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamzyz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, ANT, ANT, Symmetry, ZEO); + f_fderivs(cg->shape, cg->fgfs[gzz0->sgfn], + cg->fgfs[Gamxzz->sgfn], cg->fgfs[Gamyzz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->X[0], cg->X[1], cg->X[2], + SYM, SYM, SYM, Symmetry, ZEO); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + Parallel::Sync(GH->PatL[lev], AHDList, Symmetry); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function interpolates apparent-horizon data + +//================================================================================================ + +bool bssn_class::AH_Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetryi) +{ + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double pox[3]; + for (int i = 0; i < NN; i++) + { + for (int j = 0; j < 3; j++) + pox[j] = XX[j][i]; + int lev = GH->levels - 1; + bool notfound = true; + + while (notfound) + { + if (lev < 0) + { +#ifdef WithShell + if (SH->Interp_One_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) + { + return true; + } + if (myrank == 0) + cout << "bssn_class::AH_Interp_Points: point (" + << pox[0] << "," << pox[1] << "," << pox[2] + << ") is out of cgh and shell domain!" << endl; +#else + if (myrank == 0) + cout << "bssn_class::AH_Interp_Points: point (" + << pox[0] << "," << pox[1] << "," << pox[2] + << ") is out of cgh domain!" << endl; +#endif + return false; + } + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + if (Pp->data->Interp_ONE_Point(VarList, pox, Shellf + i * num_var, Symmetryi)) + { + notfound = false; + break; + } + Pp = Pp->next; + } + lev--; + } + } + return true; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes the apparent horizon at the current iteration step + +//================================================================================================ + +void bssn_class::AH_Step_Find(int lev, double dT_lev) +{ + if ((lev == GH->levels - 1)) + { + int ncount = int(PhysTime / dT_lev); + bool tf = false; + for (int ihn = 0; ihn < HN_num; ihn++) + { + if (ncount % findeveryl[ihn] == 0) + { + tf = true; + break; + } + } + if (tf) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + prev_clock = clock(); + const int cdumpid = int(PhysTime / AHdumptime) + 1; + for (int ihn = 0; ihn < HN_num; ihn++) + dumpid[ihn] = cdumpid; + + double gam; + for (int ihn = 0; ihn < BH_num; ihn++) + { + xc[ihn] = Porg0[ihn][0]; + yc[ihn] = Porg0[ihn][1]; + zc[ihn] = Porg0[ihn][2]; + gam = fabs(Pmom[ihn * 3]) / (Mass[ihn]); + gam = sqrt(1 - gam * gam); + xr[ihn] = Mass[ihn] * gam; + gam = fabs(Pmom[ihn * 3 + 1]) / (Mass[ihn]); + gam = sqrt(1 - gam * gam); + yr[ihn] = Mass[ihn] * gam; + gam = fabs(Pmom[ihn * 3 + 2]) / (Mass[ihn]); + gam = sqrt(1 - gam * gam); + zr[ihn] = Mass[ihn] * gam; + dTT[ihn] = -1; + + if (ncount % findeveryl[ihn] == 0) + { + trigger[ihn] = true; + dTT[ihn] = findeveryl[ihn] * dT_lev; + } + else + trigger[ihn] = false; + if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) + lastahdumpid[ihn] = dumpid[ihn]; + else + dumpid[ihn] = 0; + } + int ihn = BH_num; + for (int ia = 0; ia < BH_num; ia++) + for (int ib = ia + 1; ib < BH_num; ib++) + { + xc[ihn] = (Porg0[ia][0] + Porg0[ib][0]) / 2; + yc[ihn] = (Porg0[ia][1] + Porg0[ib][1]) / 2; + zc[ihn] = (Porg0[ia][2] + Porg0[ib][2]) / 2; + + xr[ihn] = yr[ihn] = zr[ihn] = Mass[ia] + Mass[ib]; + + dTT[ihn] = -1; + + if (fabs(Porg0[ia][0] - Porg0[ib][0]) < 2 * xr[ihn] && + fabs(Porg0[ia][1] - Porg0[ib][1]) < 2 * xr[ihn] && + fabs(Porg0[ia][2] - Porg0[ib][2]) < 2 * xr[ihn] && + (ncount % findeveryl[ihn] == 0)) + { + trigger[ihn] = true; + dTT[ihn] = findeveryl[ihn] * dT_lev; + } + else + trigger[ihn] = false; + + if (trigger[ihn] && (dumpid[ihn] > lastahdumpid[ihn])) + lastahdumpid[ihn] = dumpid[ihn]; + else + dumpid[ihn] = 0; + + ihn++; + } +#if (ABEtype == 1) + if (PhysTime > 10) + { + ihn--; + trigger[ihn] = true; + xr[ihn] = yr[ihn] = zr[ihn] = 50; + // if(myrank==0) for(ihn=0;ihn 0) + return; + + // recompute least the constraint data lost for moved new grid + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + if (lev > 0) // if the constrait quantities can be reused from the step rhs calculation + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +// added by yangquan +#ifdef USE_GPU + if (use_gpu == 1) + gpu_rhs(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Interp_Constraint); + else + f_compute_rhs_bssn(RHS_PARA_CALLED_Interp_Constraint); +#else + f_compute_rhs_bssn(RHS_PARA_CALLED_Interp_Constraint); +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + if (0) // if the constrait quantities can be reused from the step rhs calculation + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + double TRK4 = PhysTime; + int pre = 0; + int lev = 0; + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#ifdef USE_GPU + if (use_gpu == 1) + + gpu_rhs_ss(CALLED_BY_CONSTRAINT, myrank, RHS_PARA_CALLED_Intrp_Constraint_Out_SS); + else + f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Intrp_Constraint_Out_SS); +#else + f_compute_rhs_bssn_ss(RHS_PARA_CALLED_Intrp_Constraint_Out_SS); + +#endif // USE_GPU + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); +#endif + } + // interpolate + double *x1, *y1, *z1; + const int n = 1000; + double lmax, lmin, dd; + lmin = 0; +#ifdef WithShell + lmax = SH->Rrange[1]; +#else + lmax = GH->bbox[0][0][4]; +#endif +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (lmax - lmin) / (n - 1); +#else +#ifdef Cell + dd = (lmax - lmin) / n; +#else +#error Not define Vertex nor Cell +#endif +#endif + x1 = new double[n]; + y1 = new double[n]; + z1 = new double[n]; + for (int i = 0; i < n; i++) + { + x1[i] = 0; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y1[i] = lmin + i * dd; +#else +#ifdef Cell + y1[i] = lmin + (i + 0.5) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + z1[i] = 0; + } + + int InList = 0; + + MyList *varl = ConstraintList; + while (varl) + { + InList++; + varl = varl->next; + } + double *shellf; + shellf = new double[n * InList]; + for (int i = 0; i < n; i++) + { + double XX[3]; + XX[0] = x1[i]; + XX[1] = y1[i]; + XX[2] = z1[i]; + bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#ifdef WithShell + if (!fg) + fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#endif + if (!fg && myrank == 0) + { + cout << "bssn_class::Interp_Constraint meets wrong" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + if (myrank == 0) + { + ofstream outfile; + char filename[50]; + sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); + // 0.5 for round off + + outfile.open(filename); + outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; + for (int i = 0; i < n; i++) + { + outfile << setw(10) << setprecision(10) << y1[i]; + for (int j = 0; j < InList; j++) + outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; + outfile << endl; + } + outfile.close(); + } + + delete[] shellf; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes constraint violations + +//================================================================================================ + +void bssn_class::Compute_Constraint() +{ + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + int lev; + + for (lev = 0; lev < GH->levels; lev++) + { + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } + // prolong restrict constraint quantities + for (lev = GH->levels - 1; lev > 0; lev--) + RestrictProlong(lev, 1, false, ConstraintList, ConstraintList, ConstraintList); + +#ifdef WithShell + lev = 0; + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); + // interpolate constraint quantities + SH->CS_Inter(ConstraintList, Symmetry); +#endif +} + + +void bssn_class::testRestrict() +{ + MyList *DG_List = new MyList(phi0); + int lev = 0; + double ZEO = 0, ONE = 1; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + lev = 1; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], DG_List, DG_List, Symmetry); + Parallel::Sync(GH->PatL[lev - 1], DG_List, Symmetry); + + Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); + + DG_List->clearList(); + exit(0); +} + +//================================================================================================ + + + +//================================================================================================ + +void bssn_class::testOutBd() +{ + MyList *DG_List = new MyList(phi0); + int lev = 1; + double ZEO = 0, ONE = 1; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ZEO); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + lev = 0; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_set_value(cg->shape, cg->fgfs[phi0->sgfn], ONE); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + lev = 1; + MyList *Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, DG_List, DG_List, Symmetry); + Pp = Pp->next; + } + Ppc = Ppc->next; + } + + Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); + + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT); + Parallel::Dump_Data(GH->PatL[lev - 1], DG_List, 0, PhysTime, dT); + + DG_List->clearList(); + exit(0); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function enforces/checks the trace-free condition + +//================================================================================================ + +void bssn_class::Enforce_algcon(int lev, int fg) +{ + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (fg == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); + else + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#ifdef WithShell + if (lev == 0) + { + MyList *sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (fg == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); + else + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif +} + +// added by yangquan +void bssn_class::Get_runtime_envirment() +{ + // get processor name + char pname[MPI_MAX_PROCESSOR_NAME]; + int resultlen = 0, pcode = 0; + MPI_Get_processor_name(pname, &resultlen); + cout << "MPI rank: " << myrank << "Processor name:" << pname << endl; + for (int i = 0; i < resultlen; ++i) + { + pcode += ((int)(pname[i]) - 65) * i; + } + + /*if(myrank % 2 == 0){ + + } */ +} + +//================================================================================================ + diff --git a/AMSS_NCKU_source/bssn_gpu_class.h b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu_class.h similarity index 96% rename from AMSS_NCKU_source/bssn_gpu_class.h rename to AMSS_NCKU_source/BSSN_GPU/bssn_gpu_class.h index 98e844d..9fb3f75 100644 --- a/AMSS_NCKU_source/bssn_gpu_class.h +++ b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu_class.h @@ -1,210 +1,210 @@ - -#ifndef BSSN_GPU_CLASS_H -#define BSSN_GPU_CLASS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "cgh.h" -#include "ShellPatch.h" -#include "misc.h" -#include "var.h" -#include "MyList.h" -#include "monitor.h" -#include "surface_integral.h" -#include "checkpoint.h" - -// added by yangquan -#include "bssn_macro.h" - -extern void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN); - -class bssn_class -{ -public: - // added by yangquan - //---------------------- - int gpu_num_mynode; - int cpu_core_num_mynode; - int mpi_process_num_mynode; - int my_sequence_mynode; - int mynode_id; - int use_gpu; - - virtual void Step_GPU(int lev, int YN); - virtual void Get_runtime_envirment(); - // virtual void Step_OPENMP(int lev,int YN); - //---------------------- - - int ngfs; - int nprocs, myrank; - cgh *GH; - ShellPatch *SH; - double PhysTime; - - int checkrun; - char checkfilename[50]; - int Steps; - double StartTime, TotalTime; - double AnasTime, DumpTime, d2DumpTime, CheckTime; - double LastAnas, LastConsOut; - double Courant; - double numepss, numepsb, numepsh; - int Symmetry; - int maxl, decn; - double maxrex, drex; - int trfls, a_lev; - - double dT; - double chitiny; - - double **Porg0, **Porgbr, **Porg, **Porg1, **Porg_rhs; - int BH_num, BH_num_input; - double *Mass, *Pmom, *Spin; - double ADMMass; - - var *phio, *trKo; - var *gxxo, *gxyo, *gxzo, *gyyo, *gyzo, *gzzo; - var *Axxo, *Axyo, *Axzo, *Ayyo, *Ayzo, *Azzo; - var *Gmxo, *Gmyo, *Gmzo; - var *Lapo, *Sfxo, *Sfyo, *Sfzo; - var *dtSfxo, *dtSfyo, *dtSfzo; - - var *phi0, *trK0; - var *gxx0, *gxy0, *gxz0, *gyy0, *gyz0, *gzz0; - var *Axx0, *Axy0, *Axz0, *Ayy0, *Ayz0, *Azz0; - var *Gmx0, *Gmy0, *Gmz0; - var *Lap0, *Sfx0, *Sfy0, *Sfz0; - var *dtSfx0, *dtSfy0, *dtSfz0; - - var *phi, *trK; - var *gxx, *gxy, *gxz, *gyy, *gyz, *gzz; - var *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz; - var *Gmx, *Gmy, *Gmz; - var *Lap, *Sfx, *Sfy, *Sfz; - var *dtSfx, *dtSfy, *dtSfz; - - var *phi1, *trK1; - var *gxx1, *gxy1, *gxz1, *gyy1, *gyz1, *gzz1; - var *Axx1, *Axy1, *Axz1, *Ayy1, *Ayz1, *Azz1; - var *Gmx1, *Gmy1, *Gmz1; - var *Lap1, *Sfx1, *Sfy1, *Sfz1; - var *dtSfx1, *dtSfy1, *dtSfz1; - - var *phi_rhs, *trK_rhs; - var *gxx_rhs, *gxy_rhs, *gxz_rhs, *gyy_rhs, *gyz_rhs, *gzz_rhs; - var *Axx_rhs, *Axy_rhs, *Axz_rhs, *Ayy_rhs, *Ayz_rhs, *Azz_rhs; - var *Gmx_rhs, *Gmy_rhs, *Gmz_rhs; - var *Lap_rhs, *Sfx_rhs, *Sfy_rhs, *Sfz_rhs; - var *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs; - - var *rho, *Sx, *Sy, *Sz, *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz; - - var *Gamxxx, *Gamxxy, *Gamxxz, *Gamxyy, *Gamxyz, *Gamxzz; - var *Gamyxx, *Gamyxy, *Gamyxz, *Gamyyy, *Gamyyz, *Gamyzz; - var *Gamzxx, *Gamzxy, *Gamzxz, *Gamzyy, *Gamzyz, *Gamzzz; - - var *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz; - - var *Rpsi4, *Ipsi4; - var *t1Rpsi4, *t1Ipsi4, *t2Rpsi4, *t2Ipsi4; - - var *Cons_Ham, *Cons_Px, *Cons_Py, *Cons_Pz, *Cons_Gx, *Cons_Gy, *Cons_Gz; - -#ifdef Point_Psi4 - var *phix, *phiy, *phiz; - var *trKx, *trKy, *trKz; - var *Axxx, *Axxy, *Axxz; - var *Axyx, *Axyy, *Axyz; - var *Axzx, *Axzy, *Axzz; - var *Ayyx, *Ayyy, *Ayyz; - var *Ayzx, *Ayzy, *Ayzz; - var *Azzx, *Azzy, *Azzz; -#endif - // FIXME: uc = StateList, up = OldStateList, upp = SynchList_cor; so never touch these three data - MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; - MyList *OldStateList, *DumpList; - MyList *ConstraintList; - - monitor *ErrorMonitor, *Psi4Monitor, *BHMonitor, *MAPMonitor; - monitor *ConVMonitor; - surface_integral *Waveshell; - checkpoint *CheckPoint; - -public: - bssn_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi); - ~bssn_class(); - - void Evolve(int Steps); - void RecursiveStep(int lev); -#if (PSTR == 1) - void ParallelStep(); - void SHStep(); -#endif - void RestrictProlong(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); - void RestrictProlong_aux(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); - void RestrictProlong(int lev, int YN, bool BB); - void ProlongRestrict(int lev, int YN, bool BB); - void Setup_Black_Hole_position(); - void compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int lev); - bool read_Pablo_file(int *ext, double *datain, char *filename); - void write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, - char *filename); - void AnalysisStuff(int lev, double dT_lev); - void Setup_KerrSchild(); - void Enforce_algcon(int lev, int fg); - - void testRestrict(); - void testOutBd(); - - virtual void Setup_Initial_Data_Lousto(); - virtual void Setup_Initial_Data_Cao(); - virtual void Initialize(); - virtual void Read_Ansorg(); - virtual void Read_Pablo() {}; - virtual void Compute_Psi4(int lev); - virtual void Step(int lev, int YN); - virtual void Interp_Constraint(bool infg); - virtual void Constraint_Out(); - virtual void Compute_Constraint(); - -#ifdef With_AHF -protected: - MyList *AHList, *AHDList, *GaugeList; - int AHfindevery; - double AHdumptime; - int *lastahdumpid, HN_num; // number of possible horizons - int *findeveryl; - double *xc, *yc, *zc, *xr, *yr, *zr; - bool *trigger; - double *dTT; - int *dumpid; - -public: - void AH_Prepare_derivatives(); - bool AH_Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetryi); - void AH_Step_Find(int lev, double dT_lev); -#endif -}; -#endif /* BSSN_GPU_CLASS_H */ + +#ifndef BSSN_GPU_CLASS_H +#define BSSN_GPU_CLASS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "cgh.h" +#include "ShellPatch.h" +#include "misc.h" +#include "var.h" +#include "MyList.h" +#include "monitor.h" +#include "surface_integral.h" +#include "checkpoint.h" + +// added by yangquan +#include "bssn_macro.h" + +extern void setpbh(int iBHN, double **iPBH, double *iMass, int rBHN); + +class bssn_class +{ +public: + // added by yangquan + //---------------------- + int gpu_num_mynode; + int cpu_core_num_mynode; + int mpi_process_num_mynode; + int my_sequence_mynode; + int mynode_id; + int use_gpu; + + virtual void Step_GPU(int lev, int YN); + virtual void Get_runtime_envirment(); + // virtual void Step_OPENMP(int lev,int YN); + //---------------------- + + int ngfs; + int nprocs, myrank; + cgh *GH; + ShellPatch *SH; + double PhysTime; + + int checkrun; + char checkfilename[50]; + int Steps; + double StartTime, TotalTime; + double AnasTime, DumpTime, d2DumpTime, CheckTime; + double LastAnas, LastConsOut; + double Courant; + double numepss, numepsb, numepsh; + int Symmetry; + int maxl, decn; + double maxrex, drex; + int trfls, a_lev; + + double dT; + double chitiny; + + double **Porg0, **Porgbr, **Porg, **Porg1, **Porg_rhs; + int BH_num, BH_num_input; + double *Mass, *Pmom, *Spin; + double ADMMass; + + var *phio, *trKo; + var *gxxo, *gxyo, *gxzo, *gyyo, *gyzo, *gzzo; + var *Axxo, *Axyo, *Axzo, *Ayyo, *Ayzo, *Azzo; + var *Gmxo, *Gmyo, *Gmzo; + var *Lapo, *Sfxo, *Sfyo, *Sfzo; + var *dtSfxo, *dtSfyo, *dtSfzo; + + var *phi0, *trK0; + var *gxx0, *gxy0, *gxz0, *gyy0, *gyz0, *gzz0; + var *Axx0, *Axy0, *Axz0, *Ayy0, *Ayz0, *Azz0; + var *Gmx0, *Gmy0, *Gmz0; + var *Lap0, *Sfx0, *Sfy0, *Sfz0; + var *dtSfx0, *dtSfy0, *dtSfz0; + + var *phi, *trK; + var *gxx, *gxy, *gxz, *gyy, *gyz, *gzz; + var *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz; + var *Gmx, *Gmy, *Gmz; + var *Lap, *Sfx, *Sfy, *Sfz; + var *dtSfx, *dtSfy, *dtSfz; + + var *phi1, *trK1; + var *gxx1, *gxy1, *gxz1, *gyy1, *gyz1, *gzz1; + var *Axx1, *Axy1, *Axz1, *Ayy1, *Ayz1, *Azz1; + var *Gmx1, *Gmy1, *Gmz1; + var *Lap1, *Sfx1, *Sfy1, *Sfz1; + var *dtSfx1, *dtSfy1, *dtSfz1; + + var *phi_rhs, *trK_rhs; + var *gxx_rhs, *gxy_rhs, *gxz_rhs, *gyy_rhs, *gyz_rhs, *gzz_rhs; + var *Axx_rhs, *Axy_rhs, *Axz_rhs, *Ayy_rhs, *Ayz_rhs, *Azz_rhs; + var *Gmx_rhs, *Gmy_rhs, *Gmz_rhs; + var *Lap_rhs, *Sfx_rhs, *Sfy_rhs, *Sfz_rhs; + var *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs; + + var *rho, *Sx, *Sy, *Sz, *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz; + + var *Gamxxx, *Gamxxy, *Gamxxz, *Gamxyy, *Gamxyz, *Gamxzz; + var *Gamyxx, *Gamyxy, *Gamyxz, *Gamyyy, *Gamyyz, *Gamyzz; + var *Gamzxx, *Gamzxy, *Gamzxz, *Gamzyy, *Gamzyz, *Gamzzz; + + var *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz; + + var *Rpsi4, *Ipsi4; + var *t1Rpsi4, *t1Ipsi4, *t2Rpsi4, *t2Ipsi4; + + var *Cons_Ham, *Cons_Px, *Cons_Py, *Cons_Pz, *Cons_Gx, *Cons_Gy, *Cons_Gz; + +#ifdef Point_Psi4 + var *phix, *phiy, *phiz; + var *trKx, *trKy, *trKz; + var *Axxx, *Axxy, *Axxz; + var *Axyx, *Axyy, *Axyz; + var *Axzx, *Axzy, *Axzz; + var *Ayyx, *Ayyy, *Ayyz; + var *Ayzx, *Ayzy, *Ayzz; + var *Azzx, *Azzy, *Azzz; +#endif + // FIXME: uc = StateList, up = OldStateList, upp = SynchList_cor; so never touch these three data + MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; + MyList *OldStateList, *DumpList; + MyList *ConstraintList; + + monitor *ErrorMonitor, *Psi4Monitor, *BHMonitor, *MAPMonitor; + monitor *ConVMonitor; + surface_integral *Waveshell; + checkpoint *CheckPoint; + +public: + bssn_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi); + ~bssn_class(); + + void Evolve(int Steps); + void RecursiveStep(int lev); +#if (PSTR == 1) + void ParallelStep(); + void SHStep(); +#endif + void RestrictProlong(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); + void RestrictProlong_aux(int lev, int YN, bool BB, MyList *SL, MyList *OL, MyList *corL); + void RestrictProlong(int lev, int YN, bool BB); + void ProlongRestrict(int lev, int YN, bool BB); + void Setup_Black_Hole_position(); + void compute_Porg_rhs(double **BH_PS, double **BH_RHS, var *forx, var *fory, var *forz, int lev); + bool read_Pablo_file(int *ext, double *datain, char *filename); + void write_Pablo_file(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, + char *filename); + void AnalysisStuff(int lev, double dT_lev); + void Setup_KerrSchild(); + void Enforce_algcon(int lev, int fg); + + void testRestrict(); + void testOutBd(); + + virtual void Setup_Initial_Data_Lousto(); + virtual void Setup_Initial_Data_Cao(); + virtual void Initialize(); + virtual void Read_Ansorg(); + virtual void Read_Pablo() {}; + virtual void Compute_Psi4(int lev); + virtual void Step(int lev, int YN); + virtual void Interp_Constraint(bool infg); + virtual void Constraint_Out(); + virtual void Compute_Constraint(); + +#ifdef With_AHF +protected: + MyList *AHList, *AHDList, *GaugeList; + int AHfindevery; + double AHdumptime; + int *lastahdumpid, HN_num; // number of possible horizons + int *findeveryl; + double *xc, *yc, *zc, *xr, *yr, *zr; + bool *trigger; + double *dTT; + int *dumpid; + +public: + void AH_Prepare_derivatives(); + bool AH_Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetryi); + void AH_Step_Find(int lev, double dT_lev); +#endif +}; +#endif /* BSSN_GPU_CLASS_H */ diff --git a/AMSS_NCKU_source/bssn_gpu_rhs_ss.cu b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu_rhs_ss.cu similarity index 98% rename from AMSS_NCKU_source/bssn_gpu_rhs_ss.cu rename to AMSS_NCKU_source/BSSN_GPU/bssn_gpu_rhs_ss.cu index 11530ae..c6a1310 100644 --- a/AMSS_NCKU_source/bssn_gpu_rhs_ss.cu +++ b/AMSS_NCKU_source/BSSN_GPU/bssn_gpu_rhs_ss.cu @@ -1,2525 +1,2525 @@ -// includes, system -#include -#include -#include -#include -#include -#include -#include -//#include "cutil.h" -#ifdef RESULT_CHECK -#include -#endif -using namespace std; - -//includes, bssn -#include "gpu_rhsSS_mem.h" -#include "bssn_gpu.h" - -#ifdef WithShell - -__device__ volatile unsigned int global_count = 0; - -void compare_result_gpu(int ftag1,double * datac,int data_num){ - double * data = (double*)malloc(sizeof(double)*data_num); - cudaMemcpy(data, datac, data_num * sizeof(double), cudaMemcpyDeviceToHost); - compare_result(ftag1,data,data_num); - free(data); -} - -__global__ void sub_symmetry_bd_ss_partF(int ord, double * func, double *funcc) -{ - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(curr < _3D_SIZE[0]) - { - int k = curr / _2D_SIZE[0]; - ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); //= ps % ex_c[0]; - - funcc[i+ ord + (ord +j)* _1D_SIZE[ord] + k * _2D_SIZE[ord]] = func[curr]; - - curr += STEP_SIZE; - } -} - -#ifdef Vertex -__global__ void sub_symmetry_bd_ss_partI(int ord, double * func, double * funcc,double S1){ - //for i - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps,ps2; - int m; - while(curr < (ex_c[1]+ord*2)*ex_c[2] ){ - m = ord * 2; - ps = curr * _1D_SIZE[ord]; - ps2 = ps + _1D_SIZE[ord] - 1; - for(int i = 0;i < ord; ++i){ - //funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) - - //funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA(1) - funcc[ps] = funcc [ps + m] * S1; - funcc[ps2] = funcc[ps2 - m] * S1; - ps ++; - ps2 --; - m -= 2; - } - curr+= STEP_SIZE; - } - __syncthreads(); -} -__global__ void sub_symmetry_bd_ss_partJ(int ord,double * func, double * funcc,double S2){ - //for j - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps,ps2; - int m; - - while(curr < (ex_c[0]+ord*2)*ex_c[2]) - { - m = (2 * ord) * _1D_SIZE[ord]; - ps = (curr/_1D_SIZE[ord])*_2D_SIZE[ord] + (curr % _1D_SIZE[ord]); - //noticed that length_j == length_i, - //in other words, (ex[2]+ord*2) == (ex[2]+ord*2) == 1D_size[ord] - //so here we use "(_1D_SIZE[ord] - 1)" instead of "(ex[2]+ord*2) - 1" - ps2 = ps + (_1D_SIZE[ord] - 1) * _1D_SIZE[ord]; - for(int i = 0;i>>(ord,func,funcc); - cudaThreadSynchronize(); - sub_symmetry_bd_ss_partI<<>>(ord,func,funcc,SoA[0]); - cudaThreadSynchronize(); - sub_symmetry_bd_ss_partJ<<>>(ord,func,funcc,SoA[1]); - cudaThreadSynchronize(); -} - -__global__ void sub_fderivs_shc_part1(double *fx,double *fy,double *fz){ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int t_ = tid; - while(t_ < _3D_SIZE[0]) - { - fx[t_] = Ms_ dRdx[t_] * Ms_ gz[t_] + Ms_ drhodx[t_] * Ms_ gx[t_] + Ms_ dsigmadx[t_] * Ms_ gy[t_]; - - fy[t_] = Ms_ dRdy[t_] * Ms_ gz[t_] + Ms_ drhody[t_] * Ms_ gx[t_] + Ms_ dsigmady[t_] * Ms_ gy[t_]; - - fz[t_] = Ms_ dRdz[t_] * Ms_ gz[t_] + Ms_ drhodz[t_] * Ms_ gx[t_] + Ms_ dsigmadz[t_] * Ms_ gy[t_]; - - t_ += STEP_SIZE; - } -} - -__global__ void sub_fderivs_sh(double * fh,double *fx,double *fy,double *fz ) -{ - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(curr < _3D_SIZE[0]) - { - int k = curr / _2D_SIZE[0]; - ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k == ex_c[2] || i == ex_c[0] || j == ex_c[1]){ - curr += STEP_SIZE; - continue; - } - - //X-- - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]) - fx[curr] = d12dxyz[0]*(fh[i+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] - - 8*fh[i+1+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + - 8*fh[i+3+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] - - fh[i+4+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] ); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]) - fx[curr] = d2dxyz[0]*(-fh[i+1+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + - fh[i+3+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] ); - - //Y-- - if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) - fy[curr]=d12dxyz[1]*(fh[i+2+j*_1D_SIZE[2]+(k)*_2D_SIZE[2]]- - 8*fh[i+2+(j+1)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + - 8*fh[i+2+(j+3)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] - - fh[i+2+(j+4)*_1D_SIZE[2]+(k)*_2D_SIZE[2]]); - - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) - fy[curr]=d2dxyz[1]*(-fh[i+2+(j+1)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + - fh[i+2+(j+3)*_1D_SIZE[2]+(k)*_2D_SIZE[2]]); - //Z-- - - if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) - fz[curr]=d12dxyz[2]*( fh[i+2+(j+2)*_1D_SIZE[2]+(k-2) *_2D_SIZE[2]] - - 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k-1)*_2D_SIZE[2]] + - 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]] - - fh[i+2+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]); - - else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) - fz[curr]=d2dxyz[2]*(-fh[i+2+(j+2)*_1D_SIZE[2]+(k-1)*_2D_SIZE[2]]+ - fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]]); - - curr += STEP_SIZE; - } -} -inline void sub_fderivs_shc(int& sst,double * f,double * fh,double *fx,double *fy,double *fz, double * SoA) -{ - double SoA1[2]; - if(sst == 0){ - SoA1[0] = SoA[0]; - SoA1[1] = SoA[1]; - } - else if(sst == 2 || sst == 3 ){ - SoA1[0] = SoA[1]; - SoA1[1] = SoA[2]; - } - else if(sst == 4 || sst==5){ - SoA1[0] = SoA[0]; - SoA1[1] = SoA[2]; - } - //cudaMemset(Msh_ gx,0,h_3D_SIZE[0] * sizeof(double)); - //cudaMemset(Msh_ gy,0,h_3D_SIZE[0] * sizeof(double)); - //cudaMemset(Msh_ gz,0,h_3D_SIZE[0] * sizeof(double)); - sub_symmetry_bd_ss(2,f,fh,SoA1); - cudaThreadSynchronize(); - //compare_result_gpu(0,fh,h_3D_SIZE[2]); - sub_fderivs_sh<<>>(fh,Msh_ gx,Msh_ gy,Msh_ gz); - cudaThreadSynchronize(); - - sub_fderivs_shc_part1<<>>(fx,fy,fz); - cudaThreadSynchronize(); - //compare_result_gpu(1,fx,h_3D_SIZE[0]); - //compare_result_gpu(2,fy,h_3D_SIZE[0]); - //compare_result_gpu(3,fz,h_3D_SIZE[0]); -} -__global__ void compute_rhs_ss_part1() -{ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int t_ = tid; - while(t_ < _3D_SIZE[0]) - { - metac.alpn1[t_] = metac.Lap[t_] + 1; - metac.chin1[t_] = metac.chi[t_] + 1; - metac.gxx[t_] = metac.dxx[t_] + 1; - metac.gyy[t_] = metac.dyy[t_] + 1; - metac.gzz[t_] = metac.dzz[t_] + 1; - - t_ += STEP_SIZE; - } -} - -__global__ void sub_fdderivs_shc_part1(double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz) -{ - int tid = blockIdx.x*blockDim.x+threadIdx.x; - int t_ = tid; - while(t_ < _3D_SIZE[0]) - { - fxx[t_] = Ms_ dRdxx[t_] * Ms_ gz[t_] + Ms_ drhodxx[t_] * Ms_ gx[t_] + Ms_ dsigmadxx[t_] * Ms_ gy[t_] + - - Ms_ dRdx[t_] * Ms_ dRdx[t_] * Ms_ gzz[t_] + Ms_ drhodx[t_] * Ms_ drhodx[t_] * Ms_ gxx[t_] + Ms_ dsigmadx[t_] * Ms_ dsigmadx[t_] * Ms_ gyy[t_] + - - 2 * (Ms_ dRdx[t_] * Ms_ drhodx[t_] * Ms_ gxz[t_] + Ms_ dRdx[t_] * Ms_ dsigmadx[t_] * Ms_ gyz[t_] + Ms_ drhodx[t_] * Ms_ dsigmadx[t_] * Ms_ gxy[t_]); - - - fyy[t_] = Ms_ dRdyy[t_] * Ms_ gz[t_] + Ms_ drhodyy[t_] * Ms_ gx[t_] + Ms_ dsigmadyy[t_] * Ms_ gy[t_] + - - Ms_ dRdy[t_] * Ms_ dRdy[t_] * Ms_ gzz[t_] + Ms_ drhody[t_] * Ms_ drhody[t_] * Ms_ gxx[t_] + Ms_ dsigmady[t_] * Ms_ dsigmady[t_] * Ms_ gyy[t_] + - - 2 * (Ms_ dRdy[t_] * Ms_ drhody[t_] * Ms_ gxz[t_] + Ms_ dRdy[t_] * Ms_ dsigmady[t_] * Ms_ gyz[t_] + Ms_ drhody[t_] * Ms_ dsigmady[t_] * Ms_ gxy[t_]); - - - fzz[t_] = Ms_ dRdzz[t_] * Ms_ gz[t_] + Ms_ drhodzz[t_] * Ms_ gx[t_] + Ms_ dsigmadzz[t_] * Ms_ gy[t_] + - - Ms_ dRdz[t_] * Ms_ dRdz[t_] * Ms_ gzz[t_] + Ms_ drhodz[t_] * Ms_ drhodz[t_] * Ms_ gxx[t_] + Ms_ dsigmadz[t_] * Ms_ dsigmadz[t_] * Ms_ gyy[t_] + - - 2 * (Ms_ dRdz[t_] * Ms_ drhodz[t_] * Ms_ gxz[t_] + Ms_ dRdz[t_] * Ms_ dsigmadz[t_] * Ms_ gyz[t_] + Ms_ drhodz[t_] * Ms_ dsigmadz[t_] * Ms_ gxy[t_]); - - - fxy[t_] = Ms_ dRdxy[t_] * Ms_ gz[t_] + Ms_ drhodxy[t_] * Ms_ gx[t_] + Ms_ dsigmadxy[t_] * Ms_ gy[t_] + - - Ms_ dRdx[t_] * Ms_ drhody[t_] * Ms_ gxz[t_] + Ms_ dRdx[t_] * Ms_ dsigmady[t_] * Ms_ gyz[t_] + Ms_ drhodx[t_] * Ms_ dsigmady[t_] * Ms_ gxy[t_] + - - Ms_ dRdy[t_] * Ms_ drhodx[t_] * Ms_ gxz[t_] + Ms_ dRdy[t_] * Ms_ dsigmadx[t_] * Ms_ gyz[t_] + Ms_ drhody[t_] * Ms_ dsigmadx[t_] * Ms_ gxy[t_] + - - Ms_ dRdx[t_] * Ms_ dRdy[t_] * Ms_ gzz[t_] + Ms_ drhodx[t_] * Ms_ drhody[t_] * Ms_ gxx[t_] + Ms_ dsigmadx[t_] * Ms_ dsigmady[t_] * Ms_ gyy[t_]; - - - fxz[t_] = Ms_ dRdxz[t_] * Ms_ gz[t_] + Ms_ drhodxz[t_] * Ms_ gx[t_] + Ms_ dsigmadxz[t_] * Ms_ gy[t_] + - - Ms_ dRdx[t_] * Ms_ drhodz[t_] * Ms_ gxz[t_] + Ms_ dRdx[t_] * Ms_ dsigmadz[t_] * Ms_ gyz[t_] + Ms_ drhodx[t_] * Ms_ dsigmadz[t_] * Ms_ gxy[t_] + - - Ms_ dRdz[t_] * Ms_ drhodx[t_] * Ms_ gxz[t_] + Ms_ dRdz[t_] * Ms_ dsigmadx[t_] * Ms_ gyz[t_] + Ms_ drhodz[t_] * Ms_ dsigmadx[t_] * Ms_ gxy[t_] + - - Ms_ dRdx[t_] * Ms_ dRdz[t_] * Ms_ gzz[t_] + Ms_ drhodx[t_] * Ms_ drhodz[t_] * Ms_ gxx[t_] + Ms_ dsigmadx[t_] * Ms_ dsigmadz[t_] * Ms_ gyy[t_]; - - - fyz[t_] = Ms_ dRdyz[t_] * Ms_ gz[t_] + Ms_ drhodyz[t_] * Ms_ gx[t_] + Ms_ dsigmadyz[t_] * Ms_ gy[t_] + - - Ms_ dRdz[t_] * Ms_ drhody[t_] * Ms_ gxz[t_] + Ms_ dRdz[t_] * Ms_ dsigmady[t_] * Ms_ gyz[t_] + Ms_ drhodz[t_] * Ms_ dsigmady[t_] * Ms_ gxy[t_] + - - Ms_ dRdy[t_] * Ms_ drhodz[t_] * Ms_ gxz[t_] + Ms_ dRdy[t_] * Ms_ dsigmadz[t_] * Ms_ gyz[t_] + Ms_ drhody[t_] * Ms_ dsigmadz[t_] * Ms_ gxy[t_] + - - Ms_ dRdz[t_] * Ms_ dRdy[t_] * Ms_ gzz[t_] + Ms_ drhodz[t_] * Ms_ drhody[t_] * Ms_ gxx[t_] + Ms_ dsigmadz[t_] * Ms_ dsigmady[t_] * Ms_ gyy[t_]; - - t_ += STEP_SIZE; - } -} - -__global__ void sub_fdderivs_sh(double *fh,double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz) - { - int curr = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - - while(curr < _3D_SIZE[0]) - { - int k = curr / _2D_SIZE[0]; - ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k == ex_c[2] || i == ex_c[0] || j == ex_c[1]){ - curr += STEP_SIZE; - continue; - } - else - { - //xx - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]){ - fxx[curr] = Fdxdx*(-_FH2_(i,(j+2),(k))+16*_FH2_((i+1),(j+2),(k))-30*_FH2_((i+2),(j+2),(k)) - -_FH2_((i+4),(j+2),(k))+16*_FH2_((i+3),(j+2),(k)) ); - - } - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]){ - fxx[curr] = Sdxdx*(_FH2_((i+1),(j+2),(k))-2*_FH2_((i+2),(j+2),(k)) - +_FH2_(i+3,(j+2),(k)) ); - } - - - - //zz-- - if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]){ - fzz[curr] = Fdzdz * (-_FH2_((i+2),(j+2),(k-2)) + 16 *_FH2_((i+2),(j+2),(k-1))- 30*_FH2_((i+2),(j+2),(k)) - -_FH2_((i+2),(j+2),(k+2))+ 16*_FH2_((i+2),(j+2),(k+1))); - - } - else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]){ - fzz[curr] = Sdzdz*(_FH2_((i+2),(j+2),(k-1))- 2 * _FH2_((i+2),(j+2),(k)) - + _FH2_((i+2),(j+2),(k+1)) ); - - //fzz[curr] = 256; - } - - //yy-- - if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]){ - fyy[curr] = Fdydy*(-_FH2_((i+2),j,(k))+16*_FH2_((i+2),(j+1),(k))-30*_FH2_((i+2),(j+2),(k)) - -_FH2_((i+2),(j+4),(k))+16*_FH2_((i+2),(j+3),(k)) ); - } - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]){ - fyy[curr] = Sdydy*(_FH2_((i+2),(j+1),(k))-2*_FH2_((i+2),(j+2),(k)) - +_FH2_((i+2),(j+3),(k)) ); - } - - - - //xy - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) - fxy[curr] = Fdxdy*((_FH2_(i,j,(k))-8*_FH2_((i+1),j,(k))+8*_FH2_((i+3),j,(k))-_FH2_((i+4),j,(k))) - -8 *(_FH2_(i,(j+1),(k))-8*_FH2_((i+1),(j+1),(k))+8*_FH2_((i+3),(j+1),(k))-_FH2_((i+4),(j+1),(k))) - +8 *(_FH2_(i,(j+3),(k))-8*_FH2_((i+1),(j+3),(k))+8*_FH2_((i+3),(j+3),(k))-_FH2_((i+4),(j+3),(k))) - - (_FH2_(i,(j+4),(k))-8*_FH2_((i+1),(j+4),(k))+8*_FH2_((i+3),(j+4),(k))-_FH2_((i+4),(j+4),(k)))); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) - - fxy[curr] = Sdxdy*(_FH2_((i+1),(j+1),(k))-_FH2_((i+3),(j+1),(k))-_FH2_((i+1),(j+3),(k))+_FH2_((i+3),(j+3),(k))); - //xz - if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) - fxz[curr] = Fdxdz*((_FH2_(i,(j+2),(k-2))-8*_FH2_((i+1),(j+2),(k-2))+8*_FH2_((i+3),(j+2),(k-2))-_FH2_((i+4),(j+2),(k-2))) - -8 *(_FH2_(i,(j+2),(k-1))-8*_FH2_((i+1),(j+2),(k-1))+8*_FH2_((i+3),(j+2),(k-1))-_FH2_((i+4),(j+2),(k-1))) - +8 *(_FH2_(i,(j+2),(k+1))-8*_FH2_((i+1),(j+2),(k+1))+8*_FH2_((i+3),(j+2),(k+1))-_FH2_((i+4),(j+2),(k+1))) - - (_FH2_(i,(j+2),(k+2))-8*_FH2_((i+1),(j+2),(k+2))+8*_FH2_((i+3),(j+2),(k+2))-_FH2_((i+4),(j+2),(k+2)))); - - else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) - fxz[curr] = Sdxdz*(_FH2_((i+1),(j+2),(k-1))-_FH2_((i+3),(j+2),(k-1))-_FH2_((i+1),(j+2),(k+1))+_FH2_((i+3),(j+2),(k+1))); - //yz - if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) - fyz[curr] = Fdydz*( (_FH2_((i+2),j,(k-2))-8*_FH2_((i+2),(j+1),(k-2))+8*_FH2_((i+2),(j+3),(k-2))-_FH2_((i+2),(j+4),(k-2))) - -8 *(_FH2_((i+2),j,(k-1))-8*_FH2_((i+2),(j+1),(k-1))+8*_FH2_((i+2),(j+3),(k-1))-_FH2_((i+2),(j+4),(k-1))) - +8 *(_FH2_((i+2),j,(k+1))-8*_FH2_((i+2),(j+1),(k+1))+8*_FH2_((i+2),(j+3),(k+1))-_FH2_((i+2),(j+4),(k+1))) - - (_FH2_((i+2),j,(k+2))-8*_FH2_((i+2),(j+1),(k+2))+8*_FH2_((i+2),(j+3),(k+2))-_FH2_((i+2),(j+4),(k+2)))); - - else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) - fyz[curr] = Sdydz*(_FH2_((i+2),(j+1),(k-1))-_FH2_((i+2),(j+3),(k-1))-_FH2_((i+2),(j+1),(k+1))+_FH2_((i+2),(j+3),(k+1))); - - curr += STEP_SIZE; - } - } - __syncthreads(); - } - -inline void sub_fdderivs_shc(int& sst,double * f,double * fh, - double * fxx,double * fxy,double * fxz, - double * fyy,double * fyz,double * fzz, double * SoA) -{ - double SoA1[2]; - if(sst == 0){ - SoA1[0] = SoA[0]; - SoA1[1] = SoA[1]; - } - else if(sst == 2 || sst == 3 ){ - SoA1[0] = SoA[1]; - SoA1[1] = SoA[2]; - } - else if(sst == 4 || sst==5){ - SoA1[0] = SoA[0]; - SoA1[1] = SoA[2]; - } - cudaMemset(Msh_ gx,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gy,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gz,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gxx,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gxy,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gxz,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gyy,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gyz,0,h_3D_SIZE[0] * sizeof(double)); - cudaMemset(Msh_ gzz,0,h_3D_SIZE[0] * sizeof(double)); - - //fderivs_sh - sub_symmetry_bd_ss(2,f,fh,SoA1); - cudaThreadSynchronize(); - //compare_result_gpu(1,fh,h_3D_SIZE[2]); - sub_fderivs_sh<<>>(fh,Msh_ gx,Msh_ gy,Msh_ gz); - cudaThreadSynchronize(); - - //fdderivs_sh - sub_symmetry_bd_ss(2,f,fh,SoA1); - cudaThreadSynchronize(); - //compare_result_gpu(21,fh,h_3D_SIZE[2]); - sub_fdderivs_sh<<>>(fh,Msh_ gxx,Msh_ gxy,Msh_ gxz,Msh_ gyy,Msh_ gyz,Msh_ gzz); - cudaThreadSynchronize(); - /*compare_result_gpu(11,Msh_ gx,h_3D_SIZE[0]); - compare_result_gpu(12,Msh_ gy,h_3D_SIZE[0]); - compare_result_gpu(13,Msh_ gz,h_3D_SIZE[0]); - compare_result_gpu(1,Msh_ gxx,h_3D_SIZE[0]); - compare_result_gpu(2,Msh_ gxy,h_3D_SIZE[0]); - compare_result_gpu(3,Msh_ gxz,h_3D_SIZE[0]); - compare_result_gpu(4,Msh_ gyy,h_3D_SIZE[0]); - compare_result_gpu(5,Msh_ gyz,h_3D_SIZE[0]); - compare_result_gpu(6,Msh_ gzz,h_3D_SIZE[0]);*/ - sub_fdderivs_shc_part1<<>>(fxx,fxy,fxz,fyy,fyz,fzz); - cudaThreadSynchronize(); - /*compare_result_gpu(1,fxx,h_3D_SIZE[0]); - compare_result_gpu(2,fxy,h_3D_SIZE[0]); - compare_result_gpu(3,fxz,h_3D_SIZE[0]); - compare_result_gpu(4,fyy,h_3D_SIZE[0]); - compare_result_gpu(5,fyz,h_3D_SIZE[0]); - compare_result_gpu(6,fzz,h_3D_SIZE[0]);*/ -} - -__global__ void computeRicci_ss_part1(double * dst) -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - dst[_t] = M_ gupxx [_t]* M_ fxx [_t]+ M_ gupyy[_t]* M_ fyy[_t]+ M_ gupzz[_t]* M_ fzz[_t]+ - ( M_ gupxy[_t]* M_ fxy[_t]+ M_ gupxz[_t]* M_ fxz[_t]+ M_ gupyz[_t]* M_ fyz[_t]) * 2; - - _t += STEP_SIZE; - } -} - - inline void computeRicci_ss(int &sst,double * src,double* dst,double * SoA, Meta* meta) -{ - sub_fdderivs_shc(sst,src,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,SoA); - cudaThreadSynchronize(); - computeRicci_ss_part1<<>>(dst); - cudaThreadSynchronize(); - -} -__global__ void sub_lopsided_ss_part1(double * dst) -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - dst[_t] += M_ betax[_t] * M_ fxx[_t] + - M_ betay[_t] * M_ fxy[_t] + - M_ betaz[_t] * M_ fxz[_t]; - - _t += STEP_SIZE; - } -} -inline void sub_lopsided_ss(int& sst,double *src,double* dst,double *SoA) -{ - sub_fderivs_shc(sst,src,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,SoA); - cudaThreadSynchronize(); - sub_lopsided_ss_part1<<>>(dst); - cudaThreadSynchronize(); -} - -__global__ void sub_kodis_sh_part1(double *f,double *fh,double *f_rhs) -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - int ps; //TOTRY: i,j,k; double value; - double inc_f_rhs; - while(_t < _3D_SIZE[0]) - { - int k = _t / _2D_SIZE[0]; - ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - if(k == ex_c[2] && i == ex_c[0] && j == ex_c[1]){ - _t += STEP_SIZE; - continue; - } - - if(i-3 >= ijk_min3[0] && i+3 <= ijk_max3[0] && - j-3 >= ijk_min3[1] && j+3 <= ijk_max3[1] && - k-3 >= ijk_min3[2] && k+3 <= ijk_max3[2]) - { - - // x direction - inc_f_rhs = ( (_FH3_(i,(j+3),(k))+_FH3_((i+6),(j+3),(k))) - - 6*(_FH3_((i+1),(j+3),(k))+_FH3_((i+5),(j+3),(k))) + - 15*(_FH3_((i+2),(j+3),(k))+_FH3_((i+4),(j+3),(k))) - - 20* _FH3_((i+3),(j+3),(k)) ) /dX; - - - // y direction - - inc_f_rhs += ( (_FH3_((i+3),j,(k))+_FH3_((i+3),(j+6),(k))) - - 6*(_FH3_((i+3),(j+1),(k))+_FH3_((i+3),(j+5),(k))) + - 15*(_FH3_((i+3),(j+2),(k))+_FH3_((i+3),(j+4),(k))) - - 20* _FH3_((i+3),(j+3),(k)) )/dY; - - // z direction - - inc_f_rhs += ( (_FH3_((i+3),(j+3),(k-3))+_FH3_((i+3),(j+3),(k+3))) - - 6*(_FH3_((i+3),(j+3),(k-2))+_FH3_((i+3),(j+3),(k+2))) + - 15*(_FH3_((i+3),(j+3),(k-1))+_FH3_((i+3),(j+3),(k+1))) - - 20* _FH3_((i+3),(j+3),(k)) )/dZ; - inc_f_rhs *= eps_c; - inc_f_rhs /= 64; - - f_rhs[_t] += inc_f_rhs; //be careful the mark is "+=" not "==" ! - } - - _t += STEP_SIZE; - } -} - -inline void sub_kodis_ss(int &sst,double *f,double *fh,double *f_rhs,double *SoA) -{ - double SoA1[2]; - if(sst == 0){ - SoA1[0] = SoA[0]; - SoA1[1] = SoA[1]; - } - else if(sst == 2 || sst == 3 ){ - SoA1[0] = SoA[1]; - SoA1[1] = SoA[2]; - } - else if(sst == 4 || sst==5){ - SoA1[0] = SoA[0]; - SoA1[1] = SoA[2]; - } - //compare_result_gpu(10,f,h_3D_SIZE[0]); - sub_symmetry_bd_ss(3,f,fh,SoA1); - cudaThreadSynchronize(); - //compare_result_gpu(0,fh,h_3D_SIZE[3]); - - sub_kodis_sh_part1<<>>(f,fh,f_rhs); - cudaThreadSynchronize(); - //compare_result_gpu(1,f_rhs,h_3D_SIZE[0]); -} - -__global__ void compute_rhs_ss_part2() -{ - //__shared__ int judge = 1; - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - if(co_c == 0) - { - // M_ Gam^i_Res = M_ Gam^i + M_ gup^ij_,j - M_ Gmx_Res[_t] = M_ Gamx[_t] - (M_ gupxx[_t]*(M_ gupxx[_t]*M_ gxxx[_t]+M_ gupxy[_t]*M_ gxyx[_t]+M_ gupxz[_t]*M_ gxzx[_t]) - +M_ gupxy[_t]*(M_ gupxx[_t]*M_ gxyx[_t]+M_ gupxy[_t]*M_ gyyx[_t]+M_ gupxz[_t]*M_ gyzx[_t]) - +M_ gupxz[_t]*(M_ gupxx[_t]*M_ gxzx[_t]+M_ gupxy[_t]*M_ gyzx[_t]+M_ gupxz[_t]*M_ gzzx[_t]) - +M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) - +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) - +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) - +M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) - +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); - M_ Gmy_Res[_t] = M_ Gamy[_t] - (M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxx[_t]+M_ gupyy[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gxzx[_t]) - +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyx[_t]+M_ gupyy[_t]*M_ gyyx[_t]+M_ gupyz[_t]*M_ gyzx[_t]) - +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzx[_t]+M_ gupyy[_t]*M_ gyzx[_t]+M_ gupyz[_t]*M_ gzzx[_t]) - +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) - +M_ gupyy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) - +M_ gupyz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) - +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) - +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); - M_ Gmz_Res[_t] = M_ Gamz[_t] - (M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxx[_t]+M_ gupyz[_t]*M_ gxyx[_t]+M_ gupzz[_t]*M_ gxzx[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gyyx[_t]+M_ gupzz[_t]*M_ gyzx[_t]) - +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzx[_t]+M_ gupyz[_t]*M_ gyzx[_t]+M_ gupzz[_t]*M_ gzzx[_t]) - +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxy[_t]+M_ gupyz[_t]*M_ gxyy[_t]+M_ gupzz[_t]*M_ gxzy[_t]) - +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gyyy[_t]+M_ gupzz[_t]*M_ gyzy[_t]) - +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzy[_t]+M_ gupyz[_t]*M_ gyzy[_t]+M_ gupzz[_t]*M_ gzzy[_t]) - +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) - +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) - +M_ gupzz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); - }//if(co == 0) - - M_ div_beta[_t] = M_ betaxx[_t] + M_ betayy[_t] + M_ betazz[_t]; - M_ chi_rhs[_t] = F2o3 *M_ chin1[_t]*( M_ alpn1[_t] * M_ trK[_t] - M_ div_beta[_t] ); //rhs[_t] for M_ chi - - M_ gxx_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axx[_t] - F2o3 * M_ gxx[_t]* M_ div_beta[_t] + - 2 *( M_ gxx[_t]* M_ betaxx[_t]+ M_ gxy[_t]* M_ betayx[_t]+ M_ gxz[_t]* M_ betazx[_t]); - M_ gyy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayy[_t] - F2o3 * M_ gyy[_t]* M_ div_beta[_t] + - 2 *( M_ gxy[_t]* M_ betaxy[_t]+ M_ gyy[_t]* M_ betayy[_t]+ M_ gyz[_t]* M_ betazy[_t]); - - M_ gzz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Azz[_t] - F2o3 * M_ gzz[_t]* M_ div_beta[_t] + - 2 *( M_ gxz[_t]* M_ betaxz[_t]+ M_ gyz[_t]* M_ betayz[_t]+ M_ gzz[_t]* M_ betazz[_t]); - - M_ gxy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axy[_t] + F1o3 * M_ gxy[_t] * M_ div_beta[_t] + - M_ gxx[_t]* M_ betaxy[_t] + M_ gxz[_t]* M_ betazy[_t]+ - M_ gyy[_t]* M_ betayx[_t]+ M_ gyz[_t]* M_ betazx[_t] - - M_ gxy[_t]* M_ betazz[_t]; - - M_ gyz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayz[_t] + F1o3 * M_ gyz[_t] * M_ div_beta[_t] + - M_ gxy[_t]* M_ betaxz[_t]+ M_ gyy[_t]* M_ betayz[_t] + - M_ gxz[_t]* M_ betaxy[_t] + M_ gzz[_t]* M_ betazy[_t] - - M_ gyz[_t]* M_ betaxx[_t]; - - M_ gxz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axz[_t] + F1o3 * M_ gxz[_t] * M_ div_beta[_t] + - M_ gxx[_t]* M_ betaxz[_t]+ M_ gxy[_t]* M_ betayz[_t] + - M_ gyz[_t]* M_ betayx[_t]+ M_ gzz[_t]* M_ betazx[_t] - - M_ gxz[_t]* M_ betayy[_t]; //rhs[_t] for gij - - // invert tilted metric - M_ gupzz[_t]= M_ gxx[_t]* M_ gyy[_t]* M_ gzz[_t]+ M_ gxy[_t]* M_ gyz[_t]* M_ gxz[_t]+ M_ gxz[_t]* M_ gxy[_t]* M_ gyz[_t]- - M_ gxz[_t]* M_ gyy[_t]* M_ gxz[_t]- M_ gxy[_t]* M_ gxy[_t]* M_ gzz[_t]- M_ gxx[_t]* M_ gyz[_t]* M_ gyz[_t]; - M_ gupxx[_t]= ( M_ gyy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gyz[_t]) / M_ gupzz[_t]; - M_ gupxy[_t]= - ( M_ gxy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupxz[_t]= ( M_ gxy[_t]* M_ gyz[_t]- M_ gyy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupyy[_t]= ( M_ gxx[_t]* M_ gzz[_t]- M_ gxz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupyz[_t]= - ( M_ gxx[_t]* M_ gyz[_t]- M_ gxy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; - M_ gupzz[_t]= ( M_ gxx[_t]* M_ gyy[_t]- M_ gxy[_t]* M_ gxy[_t]) / M_ gupzz[_t]; - //if(threadIdx.x == 0){ - // judge = co_c; - //} - //__syncthreads(); - - - - // second kind of connection - M_ Gamxxx[_t]=HALF*( M_ gupxx[_t]*M_ gxxx[_t]+ M_ gupxy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupxz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); - M_ Gamyxx[_t]=HALF*( M_ gupxy[_t]*M_ gxxx[_t]+ M_ gupyy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupyz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); - M_ Gamzxx[_t]=HALF*( M_ gupxz[_t]*M_ gxxx[_t]+ M_ gupyz[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupzz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); - - M_ Gamxyy[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupxy[_t]*M_ gyyy[_t]+ M_ gupxz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); - M_ Gamyyy[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupyz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); - M_ Gamzyy[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyz[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); - - M_ Gamxzz[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupxy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupxz[_t]*M_ gzzz[_t]); - M_ Gamyzz[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupyz[_t]*M_ gzzz[_t]); - M_ Gamzzz[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyz[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupzz[_t]*M_ gzzz[_t]); - - M_ Gamxxy[_t]=HALF*( M_ gupxx[_t]*M_ gxxy[_t]+ M_ gupxy[_t]*M_ gyyx[_t]+ M_ gupxz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); - M_ Gamyxy[_t]=HALF*( M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupyy[_t]*M_ gyyx[_t]+ M_ gupyz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); - M_ Gamzxy[_t]=HALF*( M_ gupxz[_t]*M_ gxxy[_t]+ M_ gupyz[_t]*M_ gyyx[_t]+ M_ gupzz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); - - M_ Gamxxz[_t]=HALF*( M_ gupxx[_t]*M_ gxxz[_t]+ M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupxz[_t]*M_ gzzx[_t]); - M_ Gamyxz[_t]=HALF*( M_ gupxy[_t]*M_ gxxz[_t]+ M_ gupyy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupyz[_t]*M_ gzzx[_t]); - M_ Gamzxz[_t]=HALF*( M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupzz[_t]*M_ gzzx[_t]); - - M_ Gamxyz[_t]=HALF*( M_ gupxx[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupxy[_t]*M_ gyyz[_t]+ M_ gupxz[_t]*M_ gzzy[_t]); - M_ Gamyyz[_t]=HALF*( M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyy[_t]*M_ gyyz[_t]+ M_ gupyz[_t]*M_ gzzy[_t]); - M_ Gamzyz[_t]=HALF*( M_ gupxz[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyz[_t]*M_ gyyz[_t]+ M_ gupzz[_t]*M_ gzzy[_t]); - // Raise indices of \tilde A_{ij} and store in R_ij - - M_ Rxx[_t]= M_ gupxx[_t]* M_ gupxx[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupxy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupxz[_t]* M_ Azz[_t]+ - 2*(M_ gupxx[_t]* M_ gupxy[_t]* M_ Axy[_t]+ M_ gupxx[_t]* M_ gupxz[_t]* M_ Axz[_t]+ M_ gupxy[_t]* M_ gupxz[_t]* M_ Ayz[_t]); - - M_ Ryy[_t]= M_ gupxy[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ - 2*(M_ gupxy[_t]* M_ gupyy[_t]* M_ Axy[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayz[_t]); - - M_ Rzz[_t]= M_ gupxz[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ - 2*(M_ gupxz[_t]* M_ gupyz[_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Ayz[_t]); - - M_ Rxy[_t]= M_ gupxx[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ - (M_ gupxx[_t]* M_ gupyy[_t] + M_ gupxy[_t]* M_ gupxy[_t])* M_ Axy[_t] + - (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupxy[_t])* M_ Axz[_t] + - (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupyy[_t])* M_ Ayz[_t]; - - M_ Rxz[_t]= M_ gupxx[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ - (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxy[_t]* M_ gupxz[_t])* M_ Axy[_t] + - (M_ gupxx[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupxz[_t])* M_ Axz[_t] + - (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; - - M_ Ryz[_t]= M_ gupxy[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ - (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupyy[_t]* M_ gupxz[_t])* M_ Axy[_t] + - (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupxz[_t])* M_ Axz[_t] + - (M_ gupyy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; - - // Right hand side for M_ Gam^i without shift terms... - - M_ Gamx_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxx[_t]+ M_ Lapy[_t] * M_ Rxy[_t]+ M_ Lapz[_t] * M_ Rxz[_t]) + - 2 * M_ alpn1[_t] * ( - -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxx[_t]+ M_ chiy[_t] * M_ Rxy[_t]+ M_ chiz[_t] * M_ Rxz[_t]) - - M_ gupxx[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - - M_ gupxy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - - M_ gupxz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + - M_ Gamxxx[_t]* M_ Rxx[_t]+ M_ Gamxyy[_t]* M_ Ryy[_t]+ M_ Gamxzz[_t]* M_ Rzz[_t] + - 2 * ( M_ Gamxxy[_t]* M_ Rxy[_t]+ M_ Gamxxz[_t]* M_ Rxz[_t]+ M_ Gamxyz[_t]* M_ Ryz[_t]) ); - - M_ Gamy_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxy[_t]+ M_ Lapy[_t] * M_ Ryy[_t]+ M_ Lapz[_t] * M_ Ryz[_t]) + - 2 * M_ alpn1[_t] * ( - -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxy[_t]+ M_ chiy[_t] * M_ Ryy[_t]+ M_ chiz[_t] * M_ Ryz[_t]) - - M_ gupxy[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - - M_ gupyy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - - M_ gupyz[_t]* ( F2o3 * M_ Kz [_t] + 8 * PI * M_ Sz[_t] ) + - M_ Gamyxx[_t]* M_ Rxx[_t]+ M_ Gamyyy[_t]* M_ Ryy[_t]+ M_ Gamyzz[_t]* M_ Rzz[_t] + - 2 * ( M_ Gamyxy[_t]* M_ Rxy[_t]+ M_ Gamyxz[_t]* M_ Rxz[_t]+ M_ Gamyyz[_t]* M_ Ryz[_t]) ); - - M_ Gamz_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxz[_t]+ M_ Lapy[_t] * M_ Ryz[_t]+ M_ Lapz[_t] * M_ Rzz[_t]) + - 2 * M_ alpn1[_t] * ( - -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxz[_t]+ M_ chiy[_t] * M_ Ryz[_t]+ M_ chiz[_t] * M_ Rzz[_t]) - - M_ gupxz[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - - M_ gupyz[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - - M_ gupzz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + - M_ Gamzxx[_t]* M_ Rxx[_t]+ M_ Gamzyy[_t]* M_ Ryy[_t]+ M_ Gamzzz[_t]* M_ Rzz[_t] + - 2 * ( M_ Gamzxy[_t]* M_ Rxy[_t]+ M_ Gamzxz[_t]* M_ Rxz[_t]+ M_ Gamzyz[_t]* M_ Ryz[_t]) ); - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_ss_part3() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ fxx [_t]= M_ gxxx[_t]+ M_ gxyy[_t]+ M_ gxzz[_t]; - M_ fxy[_t]= M_ gxyx[_t]+ M_ gyyy[_t]+ M_ gyzz[_t]; - M_ fxz[_t]= M_ gxzx[_t]+ M_ gyzy[_t]+ M_ gzzz[_t]; - - M_ Gamxa[_t]= M_ gupxx [_t]* M_ Gamxxx [_t]+ M_ gupyy[_t]* M_ Gamxyy[_t]+ M_ gupzz[_t]* M_ Gamxzz[_t]+ - 2*( M_ gupxy[_t]* M_ Gamxxy[_t]+ M_ gupxz[_t]* M_ Gamxxz[_t]+ M_ gupyz[_t]* M_ Gamxyz[_t]); - M_ Gamya[_t]= M_ gupxx [_t]* M_ Gamyxx [_t]+ M_ gupyy[_t]* M_ Gamyyy[_t]+ M_ gupzz[_t]* M_ Gamyzz[_t]+ - 2*( M_ gupxy[_t]* M_ Gamyxy[_t]+ M_ gupxz[_t]* M_ Gamyxz[_t]+ M_ gupyz[_t]* M_ Gamyyz[_t]); - M_ Gamza[_t]= M_ gupxx [_t]* M_ Gamzxx [_t]+ M_ gupyy[_t]* M_ Gamzyy[_t]+ M_ gupzz[_t]* M_ Gamzzz[_t]+ - 2*( M_ gupxy[_t]* M_ Gamzxy[_t]+ M_ gupxz[_t]* M_ Gamzxz[_t]+ M_ gupyz[_t]* M_ Gamzyz[_t]); - - - - M_ Gamx_rhs[_t] = M_ Gamx_rhs[_t] + F2o3 * M_ Gamxa[_t]* M_ div_beta[_t] - - M_ Gamxa[_t]* M_ betaxx [_t]- M_ Gamya[_t]* M_ betaxy[_t]- M_ Gamza[_t]* M_ betaxz[_t] + - F1o3 * (M_ gupxx [_t]* M_ fxx [_t] + M_ gupxy[_t]* M_ fxy[_t] + M_ gupxz[_t]* M_ fxz[_t] ) + - M_ gupxx [_t]* M_ gxxx [_t] + M_ gupyy[_t]* M_ gyyx [_t] + M_ gupzz[_t]* M_ gzzx [_t] + - 2 * (M_ gupxy[_t]* M_ gxyx [_t] + M_ gupxz[_t]* M_ gxzx [_t] + M_ gupyz[_t]* M_ gyzx [_t] ); - - M_ Gamy_rhs[_t] = M_ Gamy_rhs[_t] + F2o3 * M_ Gamya[_t]* M_ div_beta[_t] - - M_ Gamxa[_t]* M_ betayx [_t]- M_ Gamya[_t]* M_ betayy[_t]- M_ Gamza[_t]* M_ betayz[_t] + - F1o3 * (M_ gupxy[_t]* M_ fxx [_t] + M_ gupyy[_t]* M_ fxy[_t] + M_ gupyz[_t]* M_ fxz[_t] ) + - M_ gupxx [_t]* M_ gxxy[_t] + M_ gupyy[_t]* M_ gyyy[_t] + M_ gupzz[_t]* M_ gzzy[_t] + - 2 * (M_ gupxy[_t]* M_ gxyy[_t] + M_ gupxz[_t]* M_ gxzy[_t] + M_ gupyz[_t]* M_ gyzy[_t] ); - - M_ Gamz_rhs[_t] = M_ Gamz_rhs[_t] + F2o3 * M_ Gamza[_t]* M_ div_beta[_t] - - M_ Gamxa[_t]* M_ betazx [_t]- M_ Gamya[_t]* M_ betazy[_t]- M_ Gamza[_t]* M_ betazz[_t] + - F1o3 * (M_ gupxz[_t]* M_ fxx [_t] + M_ gupyz[_t]* M_ fxy[_t] + M_ gupzz[_t]* M_ fxz[_t] ) + - M_ gupxx [_t]* M_ gxxz[_t] + M_ gupyy[_t]* M_ gyyz[_t] + M_ gupzz[_t]* M_ gzzz[_t] + - 2 * (M_ gupxy[_t]* M_ gxyz[_t] + M_ gupxz[_t]* M_ gxzz[_t] + M_ gupyz[_t]* M_ gyzz[_t] ) ; //rhs M_ for M_ Gam^i - - //first kind of connection stored in M_ gij,k - M_ gxxx [_t]= M_ gxx [_t]* M_ Gamxxx [_t]+ M_ gxy[_t]* M_ Gamyxx [_t]+ M_ gxz[_t]* M_ Gamzxx[_t]; - M_ gxyx [_t]= M_ gxx [_t]* M_ Gamxxy[_t]+ M_ gxy[_t]* M_ Gamyxy[_t]+ M_ gxz[_t]* M_ Gamzxy[_t]; - M_ gxzx [_t]= M_ gxx [_t]* M_ Gamxxz[_t]+ M_ gxy[_t]* M_ Gamyxz[_t]+ M_ gxz[_t]* M_ Gamzxz[_t]; - M_ gyyx [_t]= M_ gxx [_t]* M_ Gamxyy[_t]+ M_ gxy[_t]* M_ Gamyyy[_t]+ M_ gxz[_t]* M_ Gamzyy[_t]; - M_ gyzx [_t]= M_ gxx [_t]* M_ Gamxyz[_t]+ M_ gxy[_t]* M_ Gamyyz[_t]+ M_ gxz[_t]* M_ Gamzyz[_t]; - M_ gzzx [_t]= M_ gxx [_t]* M_ Gamxzz[_t]+ M_ gxy[_t]* M_ Gamyzz[_t]+ M_ gxz[_t]* M_ Gamzzz[_t]; - M_ gxxy[_t]= M_ gxy[_t]* M_ Gamxxx [_t]+ M_ gyy[_t]* M_ Gamyxx [_t]+ M_ gyz[_t]* M_ Gamzxx[_t]; - M_ gxyy[_t]= M_ gxy[_t]* M_ Gamxxy[_t]+ M_ gyy[_t]* M_ Gamyxy[_t]+ M_ gyz[_t]* M_ Gamzxy[_t]; - M_ gxzy[_t]= M_ gxy[_t]* M_ Gamxxz[_t]+ M_ gyy[_t]* M_ Gamyxz[_t]+ M_ gyz[_t]* M_ Gamzxz[_t]; - M_ gyyy[_t]= M_ gxy[_t]* M_ Gamxyy[_t]+ M_ gyy[_t]* M_ Gamyyy[_t]+ M_ gyz[_t]* M_ Gamzyy[_t]; - M_ gyzy[_t]= M_ gxy[_t]* M_ Gamxyz[_t]+ M_ gyy[_t]* M_ Gamyyz[_t]+ M_ gyz[_t]* M_ Gamzyz[_t]; - M_ gzzy[_t]= M_ gxy[_t]* M_ Gamxzz[_t]+ M_ gyy[_t]* M_ Gamyzz[_t]+ M_ gyz[_t]* M_ Gamzzz[_t]; - M_ gxxz[_t]= M_ gxz[_t]* M_ Gamxxx [_t]+ M_ gyz[_t]* M_ Gamyxx [_t]+ M_ gzz[_t]* M_ Gamzxx[_t]; - M_ gxyz[_t]= M_ gxz[_t]* M_ Gamxxy[_t]+ M_ gyz[_t]* M_ Gamyxy[_t]+ M_ gzz[_t]* M_ Gamzxy[_t]; - M_ gxzz[_t]= M_ gxz[_t]* M_ Gamxxz[_t]+ M_ gyz[_t]* M_ Gamyxz[_t]+ M_ gzz[_t]* M_ Gamzxz[_t]; - M_ gyyz[_t]= M_ gxz[_t]* M_ Gamxyy[_t]+ M_ gyz[_t]* M_ Gamyyy[_t]+ M_ gzz[_t]* M_ Gamzyy[_t]; - M_ gyzz[_t]= M_ gxz[_t]* M_ Gamxyz[_t]+ M_ gyz[_t]* M_ Gamyyz[_t]+ M_ gzz[_t]* M_ Gamzyz[_t]; - M_ gzzz[_t]= M_ gxz[_t]* M_ Gamxzz[_t]+ M_ gyz[_t]* M_ Gamyzz[_t]+ M_ gzz[_t]* M_ Gamzzz[_t]; - - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_ss_part4() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ Rxx [_t]= - HALF *M_ Rxx [_t] + - M_ gxx [_t]* M_ Gamxx[_t] +M_ gxy[_t]* M_ Gamyx [_t] + M_ gxz[_t]* M_ Gamzx [_t]+ - M_ Gamxa[_t]*M_ gxxx [_t]+ M_ Gamya[_t]*M_ gxyx [_t]+ M_ Gamza[_t]*M_ gxzx [_t] + - M_ gupxx [_t]*( - 2*(M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxyx [_t]+ M_ Gamzxx [_t]*M_ gxzx[_t]) + - M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxxy[_t]+ M_ Gamzxx [_t]*M_ gxxz[_t])+ - M_ gupxy[_t]*( - 2*(M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gyyx [_t]+ M_ Gamzxx [_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx[_t]) + - M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxxy[_t]+ M_ Gamzxy[_t]*M_ gxxz[_t] + - M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ - M_ gupxz[_t]*( - 2*(M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gyzx [_t]+ M_ Gamzxx [_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx[_t]) + - M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxxy[_t]+ M_ Gamzxz[_t]*M_ gxxz[_t] + - M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ - M_ gupyy[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx[_t]) + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ - M_ gupyz[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx[_t]) + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ - M_ gupzz[_t]*( - 2*(M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx[_t]) + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]); - - M_ Ryy[_t]= - HALF *M_ Ryy[_t] + - M_ gxy[_t]* M_ Gamxy[_t]+ M_ gyy[_t]* M_ Gamyy[_t] + M_ gyz[_t]* M_ Gamzy[_t] + - M_ Gamxa[_t]*M_ gxyy[_t]+ M_ Gamya[_t]*M_ gyyy[_t]+ M_ Gamza[_t]*M_ gyzy[_t] + - M_ gupxx [_t]*( - 2*(M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t]) + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ - M_ gupxy[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gxxy[_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxzy[_t]) + - M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ - M_ gupxz[_t]*( - 2*(M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t]) + - M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupyy[_t]*( - 2*(M_ Gamxyy[_t]*M_ gxyy[_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyzy[_t]) + - M_ Gamxyy[_t]*M_ gyyx [_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyyz[_t])+ - M_ gupyz[_t]*( - 2*(M_ Gamxyy[_t]*M_ gxzy[_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t]) + - M_ Gamxyz[_t]*M_ gyyx [_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyyz[_t] + - M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ - M_ gupzz[_t]*( - 2*(M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t]) + - M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]); - - M_ Rzz[_t]= - HALF *M_ Rzz[_t] + - M_ gxz[_t]* M_ Gamxz[_t] +M_ gyz[_t]* M_ Gamyz[_t] + M_ gzz[_t]* M_ Gamzz[_t] + - M_ Gamxa[_t]*M_ gxzz[_t]+ M_ Gamya[_t]*M_ gyzz[_t]+ M_ Gamza[_t]*M_ gzzz[_t] + - M_ gupxx [_t]*( - 2*(M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]) + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t])+ - M_ gupxy[_t]*( - 2*(M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t]) + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t])+ - M_ gupxz[_t]*( - 2*(M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxxz[_t]+ M_ Gamyzz[_t]*M_ gxyz[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t]) + - M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gxzy[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t])+ - M_ gupyy[_t]*( - 2*(M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]) + - M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t])+ - M_ gupyz[_t]*( - 2*(M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxyz[_t]+ M_ Gamyzz[_t]*M_ gyyz[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t]) + - M_ Gamxzz[_t]*M_ gyzx [_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t])+ - M_ gupzz[_t]*( - 2*(M_ Gamxzz[_t]*M_ gxzz[_t]+ M_ Gamyzz[_t]*M_ gyzz[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]) + - M_ Gamxzz[_t]*M_ gzzx [_t]+ M_ Gamyzz[_t]*M_ gzzy[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]); - - M_ Rxy[_t]= HALF*( -M_ Rxy[_t] + - M_ gxx [_t]* M_ Gamxy[_t]+ M_ gxy[_t]* M_ Gamyy[_t]+M_ gxz[_t]* M_ Gamzy[_t] + - M_ gxy[_t]* M_ Gamxx [_t]+ M_ gyy[_t]* M_ Gamyx [_t]+M_ gyz[_t]* M_ Gamzx [_t] + - M_ Gamxa[_t]*M_ gxyx [_t]+ M_ Gamya[_t]*M_ gyyx [_t]+ M_ Gamza[_t]*M_ gyzx [_t] + - M_ Gamxa[_t]*M_ gxxy[_t]+ M_ Gamya[_t]*M_ gxyy[_t]+ M_ Gamza[_t]*M_ gxzy[_t])+ - M_ gupxx [_t]*( - M_ Gamxxx [_t]*M_ gxxy[_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ - M_ gupxy[_t]*( - M_ Gamxxx [_t]*M_ gxyy[_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyzy[_t] + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t] + - M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t] + - M_ Gamxyy[_t]*M_ gxxx [_t]+ M_ Gamyyy[_t]*M_ gxyx [_t]+ M_ Gamzyy[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gyyx [_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyyz[_t])+ - M_ gupxz[_t]*( - M_ Gamxxx [_t]*M_ gxzy[_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gzzy[_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + - M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + - M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ - M_ gupyy[_t]*( - M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gyyx [_t]+ M_ Gamzyy[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ - M_ gupyz[_t]*( - M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + - M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gyzx [_t]+ M_ Gamzyy[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gyyx [_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyyz[_t] + - M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + - M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupzz[_t]*( - M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t]); - - M_ Rxz[_t]= HALF*( -M_ Rxz[_t] + - M_ gxx [_t]* M_ Gamxz[_t]+ M_ gxy[_t]* M_ Gamyz[_t]+M_ gxz[_t]* M_ Gamzz[_t] + - M_ gxz[_t]* M_ Gamxx [_t]+ M_ gyz[_t]* M_ Gamyx [_t]+M_ gzz[_t]* M_ Gamzx [_t] + - M_ Gamxa[_t]*M_ gxzx [_t]+ M_ Gamya[_t]*M_ gyzx [_t]+ M_ Gamza[_t]*M_ gzzx [_t] + - M_ Gamxa[_t]*M_ gxxz[_t]+ M_ Gamya[_t]*M_ gxyz[_t]+ M_ Gamza[_t]*M_ gxzz[_t])+ - M_ gupxx [_t]*( - M_ Gamxxx [_t]*M_ gxxz[_t]+ M_ Gamyxx [_t]*M_ gxyz[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ - M_ gupxy[_t]*( - M_ Gamxxx [_t]*M_ gxyz[_t]+ M_ Gamyxx [_t]*M_ gyyz[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t] + - M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + - M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + - M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ - M_ gupxz[_t]*( - M_ Gamxxx [_t]*M_ gxzz[_t]+ M_ Gamyxx [_t]*M_ gyzz[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t] + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + - M_ Gamxzz[_t]*M_ gxxx [_t]+ M_ Gamyzz[_t]*M_ gxyx [_t]+ M_ Gamzzz[_t]*M_ gxzx [_t] + - M_ Gamxxx [_t]*M_ gzzx [_t]+ M_ Gamyxx [_t]*M_ gzzy[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t])+ - M_ gupyy[_t]*( - M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupyz[_t]*( - M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + - M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + - M_ Gamxzz[_t]*M_ gxyx [_t]+ M_ Gamyzz[_t]*M_ gyyx [_t]+ M_ Gamzzz[_t]*M_ gyzx [_t] + - M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ - M_ gupzz[_t]*( - M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gyzx [_t]+ M_ Gamzzz[_t]*M_ gzzx [_t] + - M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t]); - - M_ Ryz[_t]= HALF*( -M_ Ryz[_t] + - M_ gxy[_t]* M_ Gamxz[_t]+M_ gyy[_t]* M_ Gamyz[_t]+M_ gyz[_t]* M_ Gamzz[_t] + - M_ gxz[_t]* M_ Gamxy[_t]+M_ gyz[_t]* M_ Gamyy[_t]+M_ gzz[_t]* M_ Gamzy[_t] + - M_ Gamxa[_t]*M_ gxzy[_t]+ M_ Gamya[_t]*M_ gyzy[_t]+ M_ Gamza[_t]*M_ gzzy[_t] + - M_ Gamxa[_t]*M_ gxyz[_t]+ M_ Gamya[_t]*M_ gyyz[_t]+ M_ Gamza[_t]*M_ gyzz[_t])+ - M_ gupxx [_t]*( - M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + - M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ - M_ gupxy[_t]*( - M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + - M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gxzy[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + - M_ Gamxyy[_t]*M_ gxxz[_t]+ M_ Gamyyy[_t]*M_ gxyz[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + - M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ - M_ gupxz[_t]*( - M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + - M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + - M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + - M_ Gamxzz[_t]*M_ gxxy[_t]+ M_ Gamyzz[_t]*M_ gxyy[_t]+ M_ Gamzzz[_t]*M_ gxzy[_t] + - M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ - M_ gupyy[_t]*( - M_ Gamxyy[_t]*M_ gxyz[_t]+ M_ Gamyyy[_t]*M_ gyyz[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ - M_ gupyz[_t]*( - M_ Gamxyy[_t]*M_ gxzz[_t]+ M_ Gamyyy[_t]*M_ gyzz[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t] + - M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + - M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + - M_ Gamxzz[_t]*M_ gxyy[_t]+ M_ Gamyzz[_t]*M_ gyyy[_t]+ M_ Gamzzz[_t]*M_ gyzy[_t] + - M_ Gamxyy[_t]*M_ gzzx [_t]+ M_ Gamyyy[_t]*M_ gzzy[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t])+ - M_ gupzz[_t]*( - M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + - M_ Gamxzz[_t]*M_ gxzy[_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gzzy[_t] + - M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t]); - - _t += STEP_SIZE; - } -} -__global__ void compute_rhs_ss_part5() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx [_t]* M_ chix [_t]- M_ Gamyxx [_t]* M_ chiy[_t]- M_ Gamzxx [_t]* M_ chiz[_t]; - M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]* M_ chix [_t]- M_ Gamyxy[_t]* M_ chiy[_t]- M_ Gamzxy[_t]* M_ chiz[_t]; - M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]* M_ chix [_t]- M_ Gamyxz[_t]* M_ chiy[_t]- M_ Gamzxz[_t]* M_ chiz[_t]; - M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]* M_ chix [_t]- M_ Gamyyy[_t]* M_ chiy[_t]- M_ Gamzyy[_t]* M_ chiz[_t]; - M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]* M_ chix [_t]- M_ Gamyyz[_t]* M_ chiy[_t]- M_ Gamzyz[_t]* M_ chiz[_t]; - M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]* M_ chix [_t]- M_ Gamyzz[_t]* M_ chiy[_t]- M_ Gamzzz[_t]* M_ chiz[_t]; - // M_ Store D^l D_l M_ chi - 3/(2*M_ chi) D^l M_ chi D_l M_ chi inM_ f[_t] - - M_ f[_t] = M_ gupxx [_t]* (M_ fxx [_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chix [_t]) + - M_ gupyy[_t]* (M_ fyy[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiy[_t]) + - M_ gupzz[_t]* (M_ fzz[_t]- F3o2/M_ chin1[_t] * M_ chiz[_t]* M_ chiz[_t]) + - 2 *M_ gupxy[_t]* (M_ fxy[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiy[_t]) + - 2 *M_ gupxz[_t]* (M_ fxz[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiz[_t]) + - 2 *M_ gupyz[_t]* (M_ fyz[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiz[_t]); - // M_ Add M_ chi part toM_ Ricci tensor: - - M_ Rxx [_t]=M_ Rxx [_t]+ (M_ fxx [_t]- M_ chix[_t]*M_ chix[_t]/M_ chin1[_t]/2 +M_ gxx [_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Ryy[_t]=M_ Ryy[_t]+ (M_ fyy[_t]- M_ chiy[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gyy[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Rzz[_t]=M_ Rzz[_t]+ (M_ fzz[_t]- M_ chiz[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gzz[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Rxy[_t]=M_ Rxy[_t]+ (M_ fxy[_t]- M_ chix[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gxy[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Rxz[_t]=M_ Rxz[_t]+ (M_ fxz[_t]- M_ chix[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gxz[_t]*M_ f[_t])/M_ chin1[_t]/2; - M_ Ryz[_t]=M_ Ryz[_t]+ (M_ fyz[_t]- M_ chiy[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gyz[_t]*M_ f[_t])/M_ chin1[_t]/2; - - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_ss_part6() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ gxxx [_t]= (M_ gupxx [_t]* M_ chix [_t]+M_ gupxy[_t]* M_ chiy[_t]+M_ gupxz[_t]* M_ chiz[_t])/M_ chin1[_t]; - M_ gxxy[_t]= (M_ gupxy[_t]* M_ chix [_t]+M_ gupyy[_t]* M_ chiy[_t]+M_ gupyz[_t]* M_ chiz[_t])/M_ chin1[_t]; - M_ gxxz[_t]= (M_ gupxz[_t]* M_ chix [_t]+M_ gupyz[_t]* M_ chiy[_t]+M_ gupzz[_t]* M_ chiz[_t])/M_ chin1[_t]; - // nowM_ get physical second kind of connection - M_ Gamxxx [_t]= M_ Gamxxx [_t]- ( (M_ chix [_t]+ M_ chix[_t])/M_ chin1[_t] -M_ gxx [_t]*M_ gxxx [_t])*HALF; - M_ Gamyxx [_t]= M_ Gamyxx [_t]- ( -M_ gxx [_t]*M_ gxxy[_t])*HALF; - M_ Gamzxx [_t]= M_ Gamzxx [_t]- ( -M_ gxx [_t]*M_ gxxz[_t])*HALF; - M_ Gamxyy[_t]= M_ Gamxyy[_t]- ( -M_ gyy[_t]*M_ gxxx [_t])*HALF; - M_ Gamyyy[_t]= M_ Gamyyy[_t]- ( (M_ chiy[_t]+ M_ chiy[_t])/M_ chin1[_t] -M_ gyy[_t]*M_ gxxy[_t])*HALF; - M_ Gamzyy[_t]= M_ Gamzyy[_t]- ( -M_ gyy[_t]*M_ gxxz[_t])*HALF; - M_ Gamxzz[_t]= M_ Gamxzz[_t]- ( -M_ gzz[_t]*M_ gxxx [_t])*HALF; - M_ Gamyzz[_t]= M_ Gamyzz[_t]- ( -M_ gzz[_t]*M_ gxxy[_t])*HALF; - M_ Gamzzz[_t]= M_ Gamzzz[_t]- ( (M_ chiz[_t]+ M_ chiz[_t])/M_ chin1[_t] -M_ gzz[_t]*M_ gxxz[_t])*HALF; - M_ Gamxxy[_t]= M_ Gamxxy[_t]- ( M_ chiy[_t] /M_ chin1[_t] -M_ gxy[_t]*M_ gxxx [_t])*HALF; - M_ Gamyxy[_t]= M_ Gamyxy[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxy[_t]*M_ gxxy[_t])*HALF; - M_ Gamzxy[_t]= M_ Gamzxy[_t]- ( -M_ gxy[_t]*M_ gxxz[_t])*HALF; - M_ Gamxxz[_t]= M_ Gamxxz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gxz[_t]*M_ gxxx [_t])*HALF; - M_ Gamyxz[_t]= M_ Gamyxz[_t]- ( -M_ gxz[_t]*M_ gxxy[_t])*HALF; - M_ Gamzxz[_t]= M_ Gamzxz[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxz[_t]*M_ gxxz[_t])*HALF; - M_ Gamxyz[_t]= M_ Gamxyz[_t]- ( -M_ gyz[_t]*M_ gxxx [_t])*HALF; - M_ Gamyyz[_t]= M_ Gamyyz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gyz[_t]*M_ gxxy[_t])*HALF; - M_ Gamzyz[_t]= M_ Gamzyz[_t]- ( M_ chiy[_t]/M_ chin1[_t] -M_ gyz[_t]*M_ gxxz[_t])*HALF; - - M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx[_t]*M_ Lapx [_t]- M_ Gamyxx[_t]*M_ Lapy[_t]- M_ Gamzxx[_t]*M_ Lapz[_t]; - M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]*M_ Lapx [_t]- M_ Gamyyy[_t]*M_ Lapy[_t]- M_ Gamzyy[_t]*M_ Lapz[_t]; - M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]*M_ Lapx [_t]- M_ Gamyzz[_t]*M_ Lapy[_t]- M_ Gamzzz[_t]*M_ Lapz[_t]; - M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]*M_ Lapx [_t]- M_ Gamyxy[_t]*M_ Lapy[_t]- M_ Gamzxy[_t]*M_ Lapz[_t]; - M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]*M_ Lapx [_t]- M_ Gamyxz[_t]*M_ Lapy[_t]- M_ Gamzxz[_t]*M_ Lapz[_t]; - M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]*M_ Lapx [_t]- M_ Gamyyz[_t]*M_ Lapy[_t]- M_ Gamzyz[_t]*M_ Lapz[_t]; - - // store D^i D_i Lap in M_ trK_rhs[_t] upto M_ chi - M_ trK_rhs[_t] = M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ - 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]); - // M_ Add lapse and M_ S_ij parts toM_ Ricci tensor: - - M_ fxx [_t]= M_ alpn1[_t]* (M_ Rxx [_t]- 8 * PI * M_ Sxx[_t]) -M_ fxx[_t]; - M_ fxy[_t]= M_ alpn1[_t]* (M_ Rxy[_t]- 8 * PI * M_ Sxy[_t]) -M_ fxy[_t]; - M_ fxz[_t]= M_ alpn1[_t]* (M_ Rxz[_t]- 8 * PI * M_ Sxz[_t]) -M_ fxz[_t]; - M_ fyy[_t]= M_ alpn1[_t]* (M_ Ryy[_t]- 8 * PI * M_ Syy[_t]) -M_ fyy[_t]; - M_ fyz[_t]= M_ alpn1[_t]* (M_ Ryz[_t]- 8 * PI * M_ Syz[_t]) -M_ fyz[_t]; - M_ fzz[_t]= M_ alpn1[_t]* (M_ Rzz[_t]- 8 * PI * M_ Szz[_t]) -M_ fzz[_t]; - - // Compute trace-free part (note: M_ chi^-1 and M_ chi cancel//): - - M_ f[_t] = F1o3 *( M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ - 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) ); - - M_ Axx_rhs[_t] =M_ fxx [_t]-M_ gxx [_t]*M_ f[_t]; - M_ Ayy_rhs[_t] =M_ fyy[_t]-M_ gyy[_t]*M_ f[_t]; - M_ Azz_rhs[_t] =M_ fzz[_t]-M_ gzz[_t]*M_ f[_t]; - M_ Axy_rhs[_t] =M_ fxy[_t]-M_ gxy[_t]*M_ f[_t]; - M_ Axz_rhs[_t] =M_ fxz[_t]-M_ gxz[_t]*M_ f[_t]; - M_ Ayz_rhs[_t] =M_ fyz[_t]-M_ gyz[_t]*M_ f[_t]; - - // Now: store M_ A_il M_ A^l_j intoM_ fij: - - M_ fxx [_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]); - - M_ fyy[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]); - - M_ fzz[_t]= M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]); - - M_ fxy[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ - M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + - M_ gupxz[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + - M_ gupyz[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]); - M_ fxz[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]*(M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]); - M_ fyz[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]*(M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]); - - M_ f[_t] = M_ chin1[_t]; - // store D^i D_i Lap in M_ trK_rhs[_t] - M_ trK_rhs[_t] =M_ f[_t]*M_ trK_rhs[_t]; - - M_ Axx_rhs[_t] = M_ f[_t] * M_ Axx_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Axx [_t]- 2 *M_ fxx[_t]) + - 2 * ( M_ Axx [_t]* M_ betaxx [_t]+ M_ Axy[_t]* M_ betayx [_t]+ M_ Axz[_t]* M_ betazx [_t])- - F2o3 * M_ Axx [_t]* M_ div_beta[_t]; - - M_ Ayy_rhs[_t] = M_ f[_t] * M_ Ayy_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Ayy[_t]- 2 *M_ fyy[_t]) + - 2 * ( M_ Axy[_t]* M_ betaxy[_t]+ M_ Ayy[_t]* M_ betayy[_t]+ M_ Ayz[_t]* M_ betazy[_t])- - F2o3 * M_ Ayy[_t]* M_ div_beta[_t]; - - M_ Azz_rhs[_t] = M_ f[_t] * M_ Azz_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Azz[_t]- 2 *M_ fzz[_t]) + - 2 * ( M_ Axz[_t]* M_ betaxz[_t]+ M_ Ayz[_t]* M_ betayz[_t]+ M_ Azz[_t]* M_ betazz[_t])- - F2o3 * M_ Azz[_t]* M_ div_beta[_t]; - - M_ Axy_rhs[_t] = M_ f[_t] * M_ Axy_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axy[_t] - 2 *M_ fxy[_t])+ - M_ Axx [_t]* M_ betaxy[_t] + M_ Axz[_t]* M_ betazy[_t] + - M_ Ayy[_t]* M_ betayx [_t]+ M_ Ayz[_t]* M_ betazx [_t] + - F1o3 * M_ Axy[_t]* M_ div_beta[_t] - M_ Axy[_t]* M_ betazz[_t]; - - M_ Ayz_rhs[_t] = M_ f[_t] * M_ Ayz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Ayz[_t] - 2 *M_ fyz[_t])+ - M_ Axy[_t]* M_ betaxz[_t]+ M_ Ayy[_t]* M_ betayz[_t] + - M_ Axz[_t]* M_ betaxy[_t] + M_ Azz[_t]* M_ betazy[_t] + - F1o3 * M_ Ayz[_t]* M_ div_beta[_t] - M_ Ayz[_t]* M_ betaxx[_t]; - - M_ Axz_rhs[_t] = M_ f[_t] * M_ Axz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axz[_t] - 2 *M_ fxz[_t])+ - M_ Axx [_t]* M_ betaxz[_t]+ M_ Axy[_t]* M_ betayz[_t] + - M_ Ayz[_t]* M_ betayx [_t]+ M_ Azz[_t]* M_ betazx [_t] + - F1o3 * M_ Axz[_t]* M_ div_beta[_t] - M_ Axz[_t]* M_ betayy[_t] ; //rhsM_ for M_ Aij - - // Compute trace of M_ S_ij - - M_ S[_t] = M_ f[_t] * (M_ gupxx [_t]* M_ Sxx [_t]+M_ gupyy[_t]* M_ Syy[_t]+M_ gupzz[_t]* M_ Szz[_t]+ - 2 * (M_ gupxy[_t]* M_ Sxy[_t]+M_ gupxz[_t]* M_ Sxz[_t]+M_ gupyz[_t]* M_ Syz[_t]) ); - - M_ trK_rhs[_t] = - M_ trK_rhs[_t] + M_ alpn1[_t]*( F1o3 * M_ trK[_t]* M_ trK[_t] + - M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t] + - 2 * (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) + - 4 * PI * ( M_ rho[_t] + M_ S[_t] )) ; //rhsM_ for M_ trK[_t] - - ////////M_ gauge variable part - - M_ Lap_rhs[_t] = -2*M_ alpn1[_t] * M_ trK[_t]; - -#if (GAUGE == 0) - M_ betax_rhs[_t] =0.75*M_ dtSfx[_t]; - M_ betay_rhs[_t] =0.75*M_ dtSfy[_t]; - M_ betaz_rhs[_t] =0.75*M_ dtSfz[_t]; - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] -2*M_ dtSfx[_t]; - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] -2*M_ dtSfy[_t]; - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] -2*M_ dtSfz[_t]; - -#elif (GAUGE == 1) - M_ betax_rhs[_t] =M_ Gamx[_t] - 2 * M_ betax[_t] ; - - M_ betay_rhs[_t] =M_ Gamy[_t] - 2 * M_ betay[_t] ; - - M_ betaz_rhs[_t] =M_ Gamz[_t] - 2 * M_ betaz[_t] ; - - M_ dtSfx_rhs[_t] = 0; - M_ dtSfy_rhs[_t] = 0; - M_ dtSfz_rhs[_t] = 0; - -#elif (GAUGE == 2 || GAUGE == 3) - - M_ betax_rhs[_t] = 0.75* M_ dtSfx[_t]; - - M_ betay_rhs[_t] = 0.75* M_ dtSfy[_t]; - - M_ betaz_rhs[_t] = 0.75* M_ dtSfz[_t]; - -#elif (GAUGE == 6) - if(BHN==2) - { - int k = _t / _2D_SIZE[0]; - int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - r1 = ( pow2((Porg[0]-X[i]))+ pow2((Porg[1]-Y[j]))+ pow2((Porg[2]-Z[k])) ) / - - ( pow2((Porg[0]-Porg[3]))+ pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ - - ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - reta[i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1/(1 + 12 * r1) + C2/(1 + 12 *r2); - }//BHN == 2 - - M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; - - M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; - - M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; - - - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t] * M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t] * M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t] * M_ dtSfz[_t]; - -#elif (GAUGE == 7) - if(BHN==2){ - int k = _t / _2D_SIZE[0]; - int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; - int j = ps / ex_c[0]; - int i = ps - (j * ex_c[0]); - - r1 = ( pow2((Porg[0]-X[i])) + pow2((Porg[1]-Y[j])) + pow2((Porg[2]-Z[k])) )/ - - ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ - - ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); - - - M_ reta[_t][i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1* exp(-12 *r1) + C2*exp(- 12*r2); - }//BHN ==2 - - M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; - - M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; - - M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; - - - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]*M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]*M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]*M_ dtSfz[_t]; - -#endif //if (GAUGE == ?) - - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_bssn_ss_part6_gauge() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { -#if (GAUGE == 2) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow2( ( 1-sqrt(M_ chin1[_t]) ) ); - - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; - -#elif (GAUGE == 3) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] - + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + - M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + - M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13/2 * sqrt( M_ reta[_t]/ M_ chin1[_t])/ pow2((1-M_ chin1[_t])); - - M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; - - M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; - - M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; - -#elif (GAUGE == 4) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * - M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * - M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow( (1-sqrt(M_ chin1[_t]))); - - - M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; - - M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; - - M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; - -#elif (GAUGE == 5) - M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + - - 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); - - - M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1)/ pow( (1-M_ chin1[_t]) ); - - M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; - - M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; - - M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; - - - - M_ dtSfx_rhs[_t] = 0; - - M_ dtSfy_rhs[_t] = 0; - - M_ dtSfz_rhs[_t] = 0; -#endif - _t += STEP_SIZE; - } -} - -__global__ void compute_rhs_ss_part7() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ ham_Res[_t] = M_ gupxx [_t]* M_ Rxx [_t]+ M_ gupyy[_t]* M_ Ryy[_t]+ M_ gupzz[_t]* M_ Rzz[_t]+ - 2* ( M_ gupxy[_t]* M_ Rxy[_t]+ M_ gupxz[_t]* M_ Rxz[_t]+ M_ gupyz[_t]* M_ Ryz[_t]); - - M_ ham_Res[_t] = M_ chin1[_t]*M_ ham_Res[_t] + F2o3 * M_ trK[_t] * M_ trK[_t] -( - M_ gupxx [_t]* ( - M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]) ) + - M_ gupyy[_t]* ( - M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]) ) + - M_ gupzz[_t]* ( - M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ - 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+ M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+ M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]) ) + - 2 * ( - M_ gupxy[_t]* ( - M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ - M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + - M_ gupxz[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + - M_ gupyz[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]) ) + - M_ gupxz[_t]* ( - M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]* (M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]) ) + - M_ gupyz[_t]* ( - M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ - M_ gupxy[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + - M_ gupxz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + - M_ gupyz[_t]* (M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]) ) ))- 16 * PI * M_ rho[_t]; - - _t += STEP_SIZE; - } -} -__global__ void compute_rhs_ss_part8() -{ - int _t = blockIdx.x*blockDim.x+threadIdx.x; - while(_t < _3D_SIZE[0]) - { - M_ gxxx [_t]= M_ gxxx [_t]- ( M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t] - + M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t]) - M_ chix[_t]*M_ Axx[_t]/M_ chin1[_t]; - - M_ gxyx [_t]= M_ gxyx [_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] - + M_ Gamxxx [_t]* M_ Axy[_t]+ M_ Gamyxx [_t]* M_ Ayy[_t]+ M_ Gamzxx [_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Axy[_t]/M_ chin1[_t]; - - M_ gxzx [_t]= M_ gxzx [_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] - + M_ Gamxxx [_t]* M_ Axz[_t]+ M_ Gamyxx [_t]* M_ Ayz[_t]+ M_ Gamzxx [_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Axz[_t]/M_ chin1[_t]; - - M_ gyyx [_t]= M_ gyyx [_t]- ( M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t] - + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Ayy[_t]/M_ chin1[_t]; - - M_ gyzx [_t]= M_ gyzx [_t]- ( M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t] - + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Ayz[_t]/M_ chin1[_t]; - - M_ gzzx [_t]= M_ gzzx [_t]- ( M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t] - + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Azz[_t]/M_ chin1[_t]; - - M_ gxxy[_t]= M_ gxxy[_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] - + M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t]) - M_ chiy[_t]*M_ Axx[_t]/M_ chin1[_t]; - - M_ gxyy[_t]= M_ gxyy[_t]- ( M_ Gamxyy[_t]* M_ Axx [_t]+ M_ Gamyyy[_t]* M_ Axy[_t]+ M_ Gamzyy[_t]* M_ Axz[_t] - + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Axy[_t]/M_ chin1[_t]; - - M_ gxzy[_t]= M_ gxzy[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] - + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Axz[_t]/M_ chin1[_t]; - - M_ gyyy[_t]= M_ gyyy[_t]- ( M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t] - + M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Ayy[_t]/M_ chin1[_t]; - - M_ gyzy[_t]= M_ gyzy[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] - + M_ Gamxyy[_t]* M_ Axz[_t]+ M_ Gamyyy[_t]* M_ Ayz[_t]+ M_ Gamzyy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Ayz[_t]/M_ chin1[_t]; - - M_ gzzy[_t]= M_ gzzy[_t]- ( M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t] - + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Azz[_t]/M_ chin1[_t]; - - M_ gxxz[_t]= M_ gxxz[_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] - + M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t]) - M_ chiz[_t]*M_ Axx[_t]/M_ chin1[_t]; - - M_ gxyz[_t]= M_ gxyz[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] - + M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Axy[_t]/M_ chin1[_t]; - - M_ gxzz[_t]= M_ gxzz[_t]- ( M_ Gamxzz[_t]* M_ Axx [_t]+ M_ Gamyzz[_t]* M_ Axy[_t]+ M_ Gamzzz[_t]* M_ Axz[_t] - + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Axz[_t]/M_ chin1[_t]; - - M_ gyyz[_t]= M_ gyyz[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] - + M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Ayy[_t]/M_ chin1[_t]; - - M_ gyzz[_t]= M_ gyzz[_t]- ( M_ Gamxzz[_t]* M_ Axy[_t]+ M_ Gamyzz[_t]* M_ Ayy[_t]+ M_ Gamzzz[_t]* M_ Ayz[_t] - + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Ayz[_t]/M_ chin1[_t]; - - M_ gzzz[_t]= M_ gzzz[_t]- ( M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t] - + M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Azz[_t]/M_ chin1[_t]; - - M_ movx_Res[_t] = M_ gupxx[_t]*M_ gxxx [_t]+ M_ gupyy[_t]*M_ gxyy[_t]+ M_ gupzz[_t]*M_ gxzz[_t] - +M_ gupxy[_t]*M_ gxyx [_t]+ M_ gupxz[_t]*M_ gxzx [_t]+ M_ gupyz[_t]*M_ gxzy[_t] - +M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*M_ gxyz[_t]; - M_ movy_Res[_t] = M_ gupxx[_t]*M_ gxyx [_t]+ M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*M_ gyzz[_t] - +M_ gupxy[_t]*M_ gyyx [_t]+ M_ gupxz[_t]*M_ gyzx [_t]+ M_ gupyz[_t]*M_ gyzy[_t] - +M_ gupxy[_t]*M_ gxyy[_t]+ M_ gupxz[_t]*M_ gxyz[_t]+ M_ gupyz[_t]*M_ gyyz[_t]; - - M_ movz_Res[_t] = M_ gupxx[_t]*M_ gxzx [_t]+ M_ gupyy[_t]*M_ gyzy[_t]+ M_ gupzz[_t]*M_ gzzz[_t] - +M_ gupxy[_t]*M_ gyzx [_t]+ M_ gupxz[_t]*M_ gzzx [_t]+ M_ gupyz[_t]*M_ gzzy[_t] - +M_ gupxy[_t]*M_ gxzy[_t]+ M_ gupxz[_t]*M_ gxzz[_t]+ M_ gupyz[_t]*M_ gyzz[_t]; - - M_ movx_Res[_t] = M_ movx_Res[_t] - F2o3*M_ Kx [_t]- 8*PI*M_ Sx[_t]; - M_ movy_Res[_t] = M_ movy_Res[_t] - F2o3*M_ Ky[_t]- 8*PI*M_ Sy[_t]; - M_ movz_Res[_t] = M_ movz_Res[_t] - F2o3*M_ Kz[_t]- 8*PI*M_ Sz[_t]; - - _t += STEP_SIZE; - } -} - -void destroy_meta(Meta *meta,Metass *metass) -{ - if(Mh_ X) cudaFree(Mh_ X); - if(Mh_ Y) cudaFree(Mh_ Y); - if(Mh_ Z) cudaFree(Mh_ Z); - if(Mh_ chi) cudaFree(Mh_ chi); - if(Mh_ dxx) cudaFree(Mh_ dxx); - if(Mh_ dyy) cudaFree(Mh_ dyy); - if(Mh_ dzz) cudaFree(Mh_ dzz); - if(Mh_ trK) cudaFree(Mh_ trK); - if(Mh_ gxy) cudaFree(Mh_ gxy); - if(Mh_ gxz) cudaFree(Mh_ gxz); - if(Mh_ gyz) cudaFree(Mh_ gyz); - if(Mh_ Axx) cudaFree(Mh_ Axx); - if(Mh_ Axy) cudaFree(Mh_ Axy); - if(Mh_ Axz) cudaFree(Mh_ Axz); - if(Mh_ Ayz) cudaFree(Mh_ Ayz); - if(Mh_ Ayy) cudaFree(Mh_ Ayy); - if(Mh_ Azz) cudaFree(Mh_ Azz); - if(Mh_ Gamx) cudaFree(Mh_ Gamx); - if(Mh_ Gamy) cudaFree(Mh_ Gamy); - if(Mh_ Gamz) cudaFree(Mh_ Gamz); - if(Mh_ Lap) cudaFree(Mh_ Lap); - if(Mh_ betax) cudaFree(Mh_ betax); - if(Mh_ betay) cudaFree(Mh_ betay); - if(Mh_ betaz) cudaFree(Mh_ betaz); - if(Mh_ dtSfx) cudaFree(Mh_ dtSfx); - if(Mh_ dtSfy) cudaFree(Mh_ dtSfy); - if(Mh_ dtSfz) cudaFree(Mh_ dtSfz); - if(Mh_ chi_rhs) cudaFree(Mh_ chi_rhs); - if(Mh_ trK_rhs) cudaFree(Mh_ trK_rhs); - if(Mh_ gxy_rhs) cudaFree(Mh_ gxy_rhs); - if(Mh_ gxz_rhs) cudaFree(Mh_ gxz_rhs); - if(Mh_ gyz_rhs) cudaFree(Mh_ gyz_rhs); - if(Mh_ Axx_rhs) cudaFree(Mh_ Axx_rhs); - if(Mh_ Axy_rhs) cudaFree(Mh_ Axy_rhs); - if(Mh_ Axz_rhs) cudaFree(Mh_ Axz_rhs); - if(Mh_ Ayz_rhs) cudaFree(Mh_ Ayz_rhs); - if(Mh_ Ayy_rhs) cudaFree(Mh_ Ayy_rhs); - if(Mh_ Azz_rhs) cudaFree(Mh_ Azz_rhs); - if(Mh_ Gamx_rhs) cudaFree(Mh_ Gamx_rhs); - if(Mh_ Gamy_rhs) cudaFree(Mh_ Gamy_rhs); - if(Mh_ Gamz_rhs) cudaFree(Mh_ Gamz_rhs); - if(Mh_ Lap_rhs) cudaFree(Mh_ Lap_rhs); - if(Mh_ betax_rhs) cudaFree(Mh_ betax_rhs); - if(Mh_ betay_rhs) cudaFree(Mh_ betay_rhs); - if(Mh_ betaz_rhs) cudaFree(Mh_ betaz_rhs); - if(Mh_ dtSfx_rhs) cudaFree(Mh_ dtSfx_rhs); - if(Mh_ dtSfy_rhs) cudaFree(Mh_ dtSfy_rhs); - if(Mh_ dtSfz_rhs) cudaFree(Mh_ dtSfz_rhs); - if(Mh_ rho) cudaFree(Mh_ rho); - if(Mh_ Sx) cudaFree(Mh_ Sx); - if(Mh_ Sy) cudaFree(Mh_ Sy); - if(Mh_ Sz) cudaFree(Mh_ Sz); - if(Mh_ Sxx) cudaFree(Mh_ Sxx); - if(Mh_ Sxy) cudaFree(Mh_ Sxy); - if(Mh_ Sxz) cudaFree(Mh_ Sxz); - if(Mh_ Syz) cudaFree(Mh_ Syz); - if(Mh_ Syy) cudaFree(Mh_ Syy); - if(Mh_ Szz) cudaFree(Mh_ Szz); - if(Mh_ Gamxxx) cudaFree(Mh_ Gamxxx); - if(Mh_ Gamxxy) cudaFree(Mh_ Gamxxy); - if(Mh_ Gamxxz) cudaFree(Mh_ Gamxxz); - if(Mh_ Gamxyy) cudaFree(Mh_ Gamxyy); - if(Mh_ Gamxyz) cudaFree(Mh_ Gamxyz); - if(Mh_ Gamxzz) cudaFree(Mh_ Gamxzz); - if(Mh_ Gamyxx) cudaFree(Mh_ Gamyxx); - if(Mh_ Gamyxy) cudaFree(Mh_ Gamyxy); - if(Mh_ Gamyxz) cudaFree(Mh_ Gamyxz); - if(Mh_ Gamyyy) cudaFree(Mh_ Gamyyy); - if(Mh_ Gamyyz) cudaFree(Mh_ Gamyyz); - if(Mh_ Gamyzz) cudaFree(Mh_ Gamyzz); - if(Mh_ Gamzxx) cudaFree(Mh_ Gamzxx); - if(Mh_ Gamzxy) cudaFree(Mh_ Gamzxy); - if(Mh_ Gamzxz) cudaFree(Mh_ Gamzxz); - if(Mh_ Gamzyz) cudaFree(Mh_ Gamzyz); - if(Mh_ Gamzyy) cudaFree(Mh_ Gamzyy); - if(Mh_ Gamzzz) cudaFree(Mh_ Gamzzz); - if(Mh_ Rxx) cudaFree(Mh_ Rxx); - if(Mh_ Rxy) cudaFree(Mh_ Rxy); - if(Mh_ Rxz) cudaFree(Mh_ Rxz); - if(Mh_ Ryy) cudaFree(Mh_ Ryy); - if(Mh_ Ryz) cudaFree(Mh_ Ryz); - if(Mh_ Rzz) cudaFree(Mh_ Rzz); - if(Mh_ ham_Res) cudaFree(Mh_ ham_Res); - if(Mh_ movx_Res) cudaFree(Mh_ movx_Res); - if(Mh_ movy_Res) cudaFree(Mh_ movy_Res); - if(Mh_ movz_Res) cudaFree(Mh_ movz_Res); - if(Mh_ Gmx_Res) cudaFree(Mh_ Gmx_Res); - if(Mh_ Gmy_Res) cudaFree(Mh_ Gmy_Res); - if(Mh_ Gmz_Res) cudaFree(Mh_ Gmz_Res); - if(Mh_ gxx) cudaFree(Mh_ gxx); - if(Mh_ gyy) cudaFree(Mh_ gyy); - if(Mh_ gzz) cudaFree(Mh_ gzz); - if(Mh_ chix) cudaFree(Mh_ chix); - if(Mh_ chiy) cudaFree(Mh_ chiy); - if(Mh_ chiz) cudaFree(Mh_ chiz); - if(Mh_ gxxx) cudaFree(Mh_ gxxx); - if(Mh_ gxyx) cudaFree(Mh_ gxyx); - if(Mh_ gxzx) cudaFree(Mh_ gxzx); - if(Mh_ gyyx) cudaFree(Mh_ gyyx); - if(Mh_ gyzx) cudaFree(Mh_ gyzx); - if(Mh_ gzzx) cudaFree(Mh_ gzzx); - if(Mh_ gxxy) cudaFree(Mh_ gxxy); - if(Mh_ gxyy) cudaFree(Mh_ gxyy); - if(Mh_ gxzy) cudaFree(Mh_ gxzy); - if(Mh_ gyyy) cudaFree(Mh_ gyyy); - if(Mh_ gyzy) cudaFree(Mh_ gyzy); - if(Mh_ gzzy) cudaFree(Mh_ gzzy); - if(Mh_ gxxz) cudaFree(Mh_ gxxz); - if(Mh_ gxyz) cudaFree(Mh_ gxyz); - if(Mh_ gxzz) cudaFree(Mh_ gxzz); - if(Mh_ gyyz) cudaFree(Mh_ gyyz); - if(Mh_ gyzz) cudaFree(Mh_ gyzz); - if(Mh_ gzzz) cudaFree(Mh_ gzzz); - if(Mh_ Lapx) cudaFree(Mh_ Lapx); - if(Mh_ Lapy) cudaFree(Mh_ Lapy); - if(Mh_ Lapz) cudaFree(Mh_ Lapz); - if(Mh_ betaxx) cudaFree(Mh_ betaxx); - if(Mh_ betaxy) cudaFree(Mh_ betaxy); - if(Mh_ betaxz) cudaFree(Mh_ betaxz); - if(Mh_ betayy) cudaFree(Mh_ betayy); - if(Mh_ betayz) cudaFree(Mh_ betayz); - if(Mh_ betazz) cudaFree(Mh_ betazz); - if(Mh_ betayx) cudaFree(Mh_ betayx); - if(Mh_ betazy) cudaFree(Mh_ betazy); - if(Mh_ betazx) cudaFree(Mh_ betazx); - if(Mh_ Kx) cudaFree(Mh_ Kx); - if(Mh_ Ky) cudaFree(Mh_ Ky); - if(Mh_ Kz) cudaFree(Mh_ Kz); - if(Mh_ Gamxx) cudaFree(Mh_ Gamxx); - if(Mh_ Gamxy) cudaFree(Mh_ Gamxy); - if(Mh_ Gamxz) cudaFree(Mh_ Gamxz); - if(Mh_ Gamyy) cudaFree(Mh_ Gamyy); - if(Mh_ Gamyz) cudaFree(Mh_ Gamyz); - if(Mh_ Gamzz) cudaFree(Mh_ Gamzz); - if(Mh_ Gamyx) cudaFree(Mh_ Gamyx); - if(Mh_ Gamzy) cudaFree(Mh_ Gamzy); - if(Mh_ Gamzx) cudaFree(Mh_ Gamzx); - if(Mh_ div_beta) cudaFree(Mh_ div_beta); - if(Mh_ S) cudaFree(Mh_ S); - if(Mh_ f) cudaFree(Mh_ f); - if(Mh_ fxx) cudaFree(Mh_ fxx); - if(Mh_ fxy) cudaFree(Mh_ fxy); - if(Mh_ fxz) cudaFree(Mh_ fxz); - if(Mh_ fyy) cudaFree(Mh_ fyy); - if(Mh_ fyz) cudaFree(Mh_ fyz); - if(Mh_ fzz) cudaFree(Mh_ fzz); - if(Mh_ gupxx) cudaFree(Mh_ gupxx); - if(Mh_ gupxy) cudaFree(Mh_ gupxy); - if(Mh_ gupxz) cudaFree(Mh_ gupxz); - if(Mh_ gupyy) cudaFree(Mh_ gupyy); - if(Mh_ gupyz) cudaFree(Mh_ gupyz); - if(Mh_ gupzz) cudaFree(Mh_ gupzz); - if(Mh_ Gamxa) cudaFree(Mh_ Gamxa); - if(Mh_ Gamya) cudaFree(Mh_ Gamya); - if(Mh_ Gamza) cudaFree(Mh_ Gamza); - if(Mh_ alpn1) cudaFree(Mh_ alpn1); - if(Mh_ chin1) cudaFree(Mh_ chin1); - if(Mh_ fh) cudaFree(Mh_ fh); - if(Mh_ fh2) cudaFree(Mh_ fh2); - if(Mh_ gxx_rhs) cudaFree(Mh_ gxx_rhs); - if(Mh_ gyy_rhs) cudaFree(Mh_ gyy_rhs); - if(Mh_ gzz_rhs) cudaFree(Mh_ gzz_rhs); - - //-----------SS----------------- - if(Msh_ crho) cudaFree(Msh_ crho); - if(Msh_ sigma) cudaFree(Msh_ sigma); - if(Msh_ R) cudaFree(Msh_ R); - if(Msh_ drhodx) cudaFree(Msh_ drhodx); - if(Msh_ drhody) cudaFree(Msh_ drhody); - if(Msh_ drhodz) cudaFree(Msh_ drhodz); - if(Msh_ dsigmadx) cudaFree(Msh_ dsigmadx); - if(Msh_ dsigmady) cudaFree(Msh_ dsigmady); - if(Msh_ dsigmadz) cudaFree(Msh_ dsigmadz); - if(Msh_ dRdx) cudaFree(Msh_ dRdx); - if(Msh_ dRdy) cudaFree(Msh_ dRdy); - if(Msh_ dRdz) cudaFree(Msh_ dRdz); - if(Msh_ drhodxx) cudaFree(Msh_ drhodxx); - if(Msh_ drhodxy) cudaFree(Msh_ drhodxy); - if(Msh_ drhodxz) cudaFree(Msh_ drhodxz); - if(Msh_ drhodyy) cudaFree(Msh_ drhodyy); - if(Msh_ drhodyz) cudaFree(Msh_ drhodyz); - if(Msh_ drhodzz) cudaFree(Msh_ drhodzz); - if(Msh_ dsigmadxx) cudaFree(Msh_ dsigmadxx); - if(Msh_ dsigmadxy) cudaFree(Msh_ dsigmadxy); - if(Msh_ dsigmadxz) cudaFree(Msh_ dsigmadxz); - if(Msh_ dsigmadyy) cudaFree(Msh_ dsigmadyy); - if(Msh_ dsigmadyz) cudaFree(Msh_ dsigmadyz); - if(Msh_ dsigmadzz) cudaFree(Msh_ dsigmadzz); - if(Msh_ dRdxx) cudaFree(Msh_ dRdxx); - if(Msh_ dRdxy) cudaFree(Msh_ dRdxy); - if(Msh_ dRdxz) cudaFree(Msh_ dRdxz); - if(Msh_ dRdyy) cudaFree(Msh_ dRdyy); - if(Msh_ dRdyz) cudaFree(Msh_ dRdyz); - if(Msh_ dRdzz) cudaFree(Msh_ dRdzz); - if(Msh_ gx) cudaFree(Msh_ gx); - if(Msh_ gy) cudaFree(Msh_ gy); - if(Msh_ gz) cudaFree(Msh_ gz); - - if(Msh_ gxx) cudaFree(Msh_ gxx); - if(Msh_ gxy) cudaFree(Msh_ gxy); - if(Msh_ gxz) cudaFree(Msh_ gxz); - if(Msh_ gyy) cudaFree(Msh_ gyy); - if(Msh_ gyz) cudaFree(Msh_ gyz); - if(Msh_ gzz) cudaFree(Msh_ gzz); - -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - if(Mh_ reta) CUDA_SAFE_CALL(cudaFree(Mh_ reta)); - -#endif - - //if(Mh_ other_int) cudaFree(Mh_ other_int); - //if(Mh_ other_double) cudaFree(Mh_ other_double); - //cout<<"Address of meta:"<<&meta<>>(); - cudaThreadSynchronize(); - - sub_fderivs_shc(sst,Mh_ betax,Mh_ fh,Mh_ betaxx,Mh_ betaxy,Mh_ betaxz,ass); - sub_fderivs_shc(sst,Mh_ betay,Mh_ fh,Mh_ betayx,Mh_ betayy,Mh_ betayz,sas); - sub_fderivs_shc(sst,Mh_ betaz,Mh_ fh,Mh_ betazx,Mh_ betazy,Mh_ betazz,ssa); - sub_fderivs_shc(sst,Mh_ chi,Mh_ fh,Mh_ chix,Mh_ chiy,Mh_ chiz, sss); - sub_fderivs_shc(sst,Mh_ Lap,Mh_ fh,Mh_ Lapx,Mh_ Lapy,Mh_ Lapz, sss); - sub_fderivs_shc(sst,Mh_ trK,Mh_ fh,Mh_ Kx,Mh_ Ky,Mh_ Kz, sss); - sub_fderivs_shc(sst,Mh_ dxx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz, sss); - sub_fderivs_shc(sst,Mh_ dyy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz, sss); - sub_fderivs_shc(sst,Mh_ dzz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz, sss); - sub_fderivs_shc(sst,Mh_ gxy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz, aas); - sub_fderivs_shc(sst,Mh_ gxz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz, asa); - sub_fderivs_shc(sst,Mh_ gyz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz, saa); - - compute_rhs_ss_part2<<>>(); - cudaThreadSynchronize(); - - sub_fdderivs_shc(sst,Mh_ betax,Mh_ fh,Mh_ gxxx,Mh_ gxyx,Mh_ gxzx,Mh_ gyyx,Mh_ gyzx,Mh_ gzzx,ass); - sub_fdderivs_shc(sst,Mh_ betay,Mh_ fh,Mh_ gxxy,Mh_ gxyy,Mh_ gxzy,Mh_ gyyy,Mh_ gyzy,Mh_ gzzy,sas); - sub_fdderivs_shc(sst,Mh_ betaz,Mh_ fh,Mh_ gxxz,Mh_ gxyz,Mh_ gxzz,Mh_ gyyz,Mh_ gyzz,Mh_ gzzz,ssa); - sub_fderivs_shc( sst,Mh_ Gamx, Mh_ fh,Mh_ Gamxx, Mh_ Gamxy, Mh_ Gamxz,ass); - sub_fderivs_shc( sst,Mh_ Gamy, Mh_ fh,Mh_ Gamyx, Mh_ Gamyy, Mh_ Gamyz,sas); - sub_fderivs_shc( sst,Mh_ Gamz, Mh_ fh,Mh_ Gamzx, Mh_ Gamzy, Mh_ Gamzz,ssa); - - compute_rhs_ss_part3<<>>(); - cudaThreadSynchronize(); - - computeRicci_ss(sst,Mh_ dxx,Mh_ Rxx,sss, meta); - computeRicci_ss(sst,Mh_ dyy,Mh_ Ryy,sss, meta); - computeRicci_ss(sst,Mh_ dzz,Mh_ Rzz,sss, meta); - computeRicci_ss(sst,Mh_ gxy,Mh_ Rxy,aas, meta); - computeRicci_ss(sst,Mh_ gxz,Mh_ Rxz,asa, meta); - computeRicci_ss(sst,Mh_ gyz,Mh_ Ryz,saa, meta); - cudaThreadSynchronize(); - - compute_rhs_ss_part4<<>>(); - cudaThreadSynchronize(); - - sub_fdderivs_shc(sst,Mh_ chi,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); - - //cudaThreadSynchronize(); - //compare_result_gpu(0,Mh_ chi,h_3D_SIZE[0]); - //compare_result_gpu(1,Mh_ chi,h_3D_SIZE[0]); - //compare_result_gpu(2,Mh_ fyz,h_3D_SIZE[0]); - - compute_rhs_ss_part5<<>>(); - cudaThreadSynchronize(); - - sub_fdderivs_shc(sst,Mh_ Lap,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); - - compute_rhs_ss_part6<<>>(); - cudaThreadSynchronize(); - -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) - sub_fderivs_shc(sst,Mh_ chi,Mh_ fh, Mh_ dtSfx_rhs, Mh_ dtSfy_rhs, Mh_ dtSfz_rhs,sss); - compute_rhs_bssn_ss_part6_gauge<<>>(); -#endif - //sub_lopsided_ss(int& sst,double *src,double* dst,double *SOA) - sub_lopsided_ss(sst,Mh_ gxx,Mh_ gxx_rhs,sss); - sub_lopsided_ss(sst,Mh_ gxy,Mh_ gxy_rhs,aas); - sub_lopsided_ss(sst,Mh_ gxz,Mh_ gxz_rhs,asa); - sub_lopsided_ss(sst,Mh_ gyy,Mh_ gyy_rhs,sss); - sub_lopsided_ss(sst,Mh_ gyz,Mh_ gyz_rhs,saa); - sub_lopsided_ss(sst,Mh_ gzz,Mh_ gzz_rhs,sss); - sub_lopsided_ss(sst,Mh_ Axx,Mh_ Axx_rhs,sss); - sub_lopsided_ss(sst,Mh_ Axy,Mh_ Axy_rhs,aas); - sub_lopsided_ss(sst,Mh_ Axz,Mh_ Axz_rhs,asa); - sub_lopsided_ss(sst,Mh_ Ayy,Mh_ Ayy_rhs,sss); - sub_lopsided_ss(sst,Mh_ Ayz,Mh_ Ayz_rhs,saa); - sub_lopsided_ss(sst,Mh_ Azz,Mh_ Azz_rhs,sss); - sub_lopsided_ss(sst,Mh_ chi,Mh_ chi_rhs,sss); - sub_lopsided_ss(sst,Mh_ trK,Mh_ trK_rhs,sss); - sub_lopsided_ss(sst,Mh_ Gamx,Mh_ Gamx_rhs,ass); - sub_lopsided_ss(sst,Mh_ Gamy,Mh_ Gamy_rhs,sas); - sub_lopsided_ss(sst,Mh_ Gamz,Mh_ Gamz_rhs,ssa); - sub_lopsided_ss(sst,Mh_ Lap,Mh_ Lap_rhs,sss); -#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - sub_lopsided_ss(sst,Mh_ betax,Mh_ betax_rhs,ass); - sub_lopsided_ss(sst,Mh_ betay,Mh_ betay_rhs,sas); - sub_lopsided_ss(sst,Mh_ betaz,Mh_ betaz_rhs,ssa); -#endif -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - sub_lopsided_ss(sst,Mh_ dtSfx,Mh_ dtSfx_rhs,ass); - sub_lopsided_ss(sst,Mh_ dtSfy,Mh_ dtSfy_rhs,sas); - sub_lopsided_ss(sst,Mh_ dtSfz,Mh_ dtSfz_rhs,ssa); -#endif - if(eps > 0){ - sub_kodis_ss(sst,Mh_ chi,Mh_ fh2, Mh_ chi_rhs,sss); - sub_kodis_ss(sst,Mh_ trK,Mh_ fh2, Mh_ trK_rhs,sss); - sub_kodis_ss(sst,Mh_ dxx,Mh_ fh2, Mh_ gxx_rhs,sss); - sub_kodis_ss(sst,Mh_ gxy,Mh_ fh2, Mh_ gxy_rhs,aas); - sub_kodis_ss(sst,Mh_ gxz,Mh_ fh2, Mh_ gxz_rhs,asa); - sub_kodis_ss(sst,Mh_ dyy,Mh_ fh2, Mh_ gyy_rhs,sss); - sub_kodis_ss(sst,Mh_ gyz,Mh_ fh2, Mh_ gyz_rhs,saa); - sub_kodis_ss(sst,Mh_ dzz,Mh_ fh2, Mh_ gzz_rhs,sss); - sub_kodis_ss(sst,Mh_ Axx,Mh_ fh2, Mh_ Axx_rhs,sss); - sub_kodis_ss(sst,Mh_ Axy,Mh_ fh2, Mh_ Axy_rhs,aas); - sub_kodis_ss(sst,Mh_ Axz,Mh_ fh2, Mh_ Axz_rhs,asa); - sub_kodis_ss(sst,Mh_ Ayy,Mh_ fh2, Mh_ Ayy_rhs,sss); - sub_kodis_ss(sst,Mh_ Ayz,Mh_ fh2, Mh_ Ayz_rhs,saa); - sub_kodis_ss(sst,Mh_ Azz,Mh_ fh2, Mh_ Azz_rhs,sss); - sub_kodis_ss(sst,Mh_ Gamx,Mh_ fh2, Mh_ Gamx_rhs,ass); - sub_kodis_ss(sst,Mh_ Gamy,Mh_ fh2, Mh_ Gamy_rhs,sas); - sub_kodis_ss(sst,Mh_ Gamz,Mh_ fh2, Mh_ Gamz_rhs,ssa); - sub_kodis_ss(sst,Mh_ Lap,Mh_ fh2, Mh_ Lap_rhs,sss); - sub_kodis_ss(sst,Mh_ betax,Mh_ fh2, Mh_ betax_rhs,ass); - sub_kodis_ss(sst,Mh_ betay,Mh_ fh2, Mh_ betay_rhs,sas); - sub_kodis_ss(sst,Mh_ betaz,Mh_ fh2, Mh_ betaz_rhs,ssa); -#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) - sub_kodis_ss(sst,Mh_ dtSfx,Mh_ fh2, Mh_ dtSfx_rhs,ass); - sub_kodis_ss(sst,Mh_ dtSfy,Mh_ fh2, Mh_ dtSfy_rhs,sas); - sub_kodis_ss(sst,Mh_ dtSfz,Mh_ fh2, Mh_ dtSfz_rhs,ssa); -#endif - } - if(co == 0){ - compute_rhs_ss_part7<<>>(); - cudaThreadSynchronize(); - - sub_fderivs_shc(sst,Mh_ Axx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz,sss); - sub_fderivs_shc(sst,Mh_ Axy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz,aas); - sub_fderivs_shc(sst,Mh_ Axz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz,asa); - sub_fderivs_shc(sst,Mh_ Ayy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz,sss); - sub_fderivs_shc(sst,Mh_ Ayz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz,saa); - sub_fderivs_shc(sst,Mh_ Azz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz,sss); - compute_rhs_ss_part8<<>>(); - cudaThreadSynchronize(); - } - -#if (ABV == 1) - cout<<"TODO: bssn_gpu.cu::2373 (ABV == 1)"< +#include +#include +#include +#include +#include +#include +//#include "cutil.h" +#ifdef RESULT_CHECK +#include +#endif +using namespace std; + +//includes, bssn +#include "gpu_rhsSS_mem.h" +#include "bssn_gpu.h" + +#ifdef WithShell + +__device__ volatile unsigned int global_count = 0; + +void compare_result_gpu(int ftag1,double * datac,int data_num){ + double * data = (double*)malloc(sizeof(double)*data_num); + cudaMemcpy(data, datac, data_num * sizeof(double), cudaMemcpyDeviceToHost); + compare_result(ftag1,data,data_num); + free(data); +} + +__global__ void sub_symmetry_bd_ss_partF(int ord, double * func, double *funcc) +{ + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(curr < _3D_SIZE[0]) + { + int k = curr / _2D_SIZE[0]; + ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); //= ps % ex_c[0]; + + funcc[i+ ord + (ord +j)* _1D_SIZE[ord] + k * _2D_SIZE[ord]] = func[curr]; + + curr += STEP_SIZE; + } +} + +#ifdef Vertex +__global__ void sub_symmetry_bd_ss_partI(int ord, double * func, double * funcc,double S1){ + //for i + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps,ps2; + int m; + while(curr < (ex_c[1]+ord*2)*ex_c[2] ){ + m = ord * 2; + ps = curr * _1D_SIZE[ord]; + ps2 = ps + _1D_SIZE[ord] - 1; + for(int i = 0;i < ord; ++i){ + //funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) + + //funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA(1) + funcc[ps] = funcc [ps + m] * S1; + funcc[ps2] = funcc[ps2 - m] * S1; + ps ++; + ps2 --; + m -= 2; + } + curr+= STEP_SIZE; + } + __syncthreads(); +} +__global__ void sub_symmetry_bd_ss_partJ(int ord,double * func, double * funcc,double S2){ + //for j + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps,ps2; + int m; + + while(curr < (ex_c[0]+ord*2)*ex_c[2]) + { + m = (2 * ord) * _1D_SIZE[ord]; + ps = (curr/_1D_SIZE[ord])*_2D_SIZE[ord] + (curr % _1D_SIZE[ord]); + //noticed that length_j == length_i, + //in other words, (ex[2]+ord*2) == (ex[2]+ord*2) == 1D_size[ord] + //so here we use "(_1D_SIZE[ord] - 1)" instead of "(ex[2]+ord*2) - 1" + ps2 = ps + (_1D_SIZE[ord] - 1) * _1D_SIZE[ord]; + for(int i = 0;i>>(ord,func,funcc); + cudaThreadSynchronize(); + sub_symmetry_bd_ss_partI<<>>(ord,func,funcc,SoA[0]); + cudaThreadSynchronize(); + sub_symmetry_bd_ss_partJ<<>>(ord,func,funcc,SoA[1]); + cudaThreadSynchronize(); +} + +__global__ void sub_fderivs_shc_part1(double *fx,double *fy,double *fz){ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int t_ = tid; + while(t_ < _3D_SIZE[0]) + { + fx[t_] = Ms_ dRdx[t_] * Ms_ gz[t_] + Ms_ drhodx[t_] * Ms_ gx[t_] + Ms_ dsigmadx[t_] * Ms_ gy[t_]; + + fy[t_] = Ms_ dRdy[t_] * Ms_ gz[t_] + Ms_ drhody[t_] * Ms_ gx[t_] + Ms_ dsigmady[t_] * Ms_ gy[t_]; + + fz[t_] = Ms_ dRdz[t_] * Ms_ gz[t_] + Ms_ drhodz[t_] * Ms_ gx[t_] + Ms_ dsigmadz[t_] * Ms_ gy[t_]; + + t_ += STEP_SIZE; + } +} + +__global__ void sub_fderivs_sh(double * fh,double *fx,double *fy,double *fz ) +{ + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(curr < _3D_SIZE[0]) + { + int k = curr / _2D_SIZE[0]; + ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k == ex_c[2] || i == ex_c[0] || j == ex_c[1]){ + curr += STEP_SIZE; + continue; + } + + //X-- + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]) + fx[curr] = d12dxyz[0]*(fh[i+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] - + 8*fh[i+1+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + + 8*fh[i+3+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] - + fh[i+4+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] ); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]) + fx[curr] = d2dxyz[0]*(-fh[i+1+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + + fh[i+3+(j+2)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] ); + + //Y-- + if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) + fy[curr]=d12dxyz[1]*(fh[i+2+j*_1D_SIZE[2]+(k)*_2D_SIZE[2]]- + 8*fh[i+2+(j+1)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + + 8*fh[i+2+(j+3)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] - + fh[i+2+(j+4)*_1D_SIZE[2]+(k)*_2D_SIZE[2]]); + + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) + fy[curr]=d2dxyz[1]*(-fh[i+2+(j+1)*_1D_SIZE[2]+(k)*_2D_SIZE[2]] + + fh[i+2+(j+3)*_1D_SIZE[2]+(k)*_2D_SIZE[2]]); + //Z-- + + if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) + fz[curr]=d12dxyz[2]*( fh[i+2+(j+2)*_1D_SIZE[2]+(k-2) *_2D_SIZE[2]] - + 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k-1)*_2D_SIZE[2]] + + 8* fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]] - + fh[i+2+(j+2)*_1D_SIZE[2]+(k+2)*_2D_SIZE[2]]); + + else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) + fz[curr]=d2dxyz[2]*(-fh[i+2+(j+2)*_1D_SIZE[2]+(k-1)*_2D_SIZE[2]]+ + fh[i+2+(j+2)*_1D_SIZE[2]+(k+1)*_2D_SIZE[2]]); + + curr += STEP_SIZE; + } +} +inline void sub_fderivs_shc(int& sst,double * f,double * fh,double *fx,double *fy,double *fz, double * SoA) +{ + double SoA1[2]; + if(sst == 0){ + SoA1[0] = SoA[0]; + SoA1[1] = SoA[1]; + } + else if(sst == 2 || sst == 3 ){ + SoA1[0] = SoA[1]; + SoA1[1] = SoA[2]; + } + else if(sst == 4 || sst==5){ + SoA1[0] = SoA[0]; + SoA1[1] = SoA[2]; + } + //cudaMemset(Msh_ gx,0,h_3D_SIZE[0] * sizeof(double)); + //cudaMemset(Msh_ gy,0,h_3D_SIZE[0] * sizeof(double)); + //cudaMemset(Msh_ gz,0,h_3D_SIZE[0] * sizeof(double)); + sub_symmetry_bd_ss(2,f,fh,SoA1); + cudaThreadSynchronize(); + //compare_result_gpu(0,fh,h_3D_SIZE[2]); + sub_fderivs_sh<<>>(fh,Msh_ gx,Msh_ gy,Msh_ gz); + cudaThreadSynchronize(); + + sub_fderivs_shc_part1<<>>(fx,fy,fz); + cudaThreadSynchronize(); + //compare_result_gpu(1,fx,h_3D_SIZE[0]); + //compare_result_gpu(2,fy,h_3D_SIZE[0]); + //compare_result_gpu(3,fz,h_3D_SIZE[0]); +} +__global__ void compute_rhs_ss_part1() +{ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int t_ = tid; + while(t_ < _3D_SIZE[0]) + { + metac.alpn1[t_] = metac.Lap[t_] + 1; + metac.chin1[t_] = metac.chi[t_] + 1; + metac.gxx[t_] = metac.dxx[t_] + 1; + metac.gyy[t_] = metac.dyy[t_] + 1; + metac.gzz[t_] = metac.dzz[t_] + 1; + + t_ += STEP_SIZE; + } +} + +__global__ void sub_fdderivs_shc_part1(double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz) +{ + int tid = blockIdx.x*blockDim.x+threadIdx.x; + int t_ = tid; + while(t_ < _3D_SIZE[0]) + { + fxx[t_] = Ms_ dRdxx[t_] * Ms_ gz[t_] + Ms_ drhodxx[t_] * Ms_ gx[t_] + Ms_ dsigmadxx[t_] * Ms_ gy[t_] + + + Ms_ dRdx[t_] * Ms_ dRdx[t_] * Ms_ gzz[t_] + Ms_ drhodx[t_] * Ms_ drhodx[t_] * Ms_ gxx[t_] + Ms_ dsigmadx[t_] * Ms_ dsigmadx[t_] * Ms_ gyy[t_] + + + 2 * (Ms_ dRdx[t_] * Ms_ drhodx[t_] * Ms_ gxz[t_] + Ms_ dRdx[t_] * Ms_ dsigmadx[t_] * Ms_ gyz[t_] + Ms_ drhodx[t_] * Ms_ dsigmadx[t_] * Ms_ gxy[t_]); + + + fyy[t_] = Ms_ dRdyy[t_] * Ms_ gz[t_] + Ms_ drhodyy[t_] * Ms_ gx[t_] + Ms_ dsigmadyy[t_] * Ms_ gy[t_] + + + Ms_ dRdy[t_] * Ms_ dRdy[t_] * Ms_ gzz[t_] + Ms_ drhody[t_] * Ms_ drhody[t_] * Ms_ gxx[t_] + Ms_ dsigmady[t_] * Ms_ dsigmady[t_] * Ms_ gyy[t_] + + + 2 * (Ms_ dRdy[t_] * Ms_ drhody[t_] * Ms_ gxz[t_] + Ms_ dRdy[t_] * Ms_ dsigmady[t_] * Ms_ gyz[t_] + Ms_ drhody[t_] * Ms_ dsigmady[t_] * Ms_ gxy[t_]); + + + fzz[t_] = Ms_ dRdzz[t_] * Ms_ gz[t_] + Ms_ drhodzz[t_] * Ms_ gx[t_] + Ms_ dsigmadzz[t_] * Ms_ gy[t_] + + + Ms_ dRdz[t_] * Ms_ dRdz[t_] * Ms_ gzz[t_] + Ms_ drhodz[t_] * Ms_ drhodz[t_] * Ms_ gxx[t_] + Ms_ dsigmadz[t_] * Ms_ dsigmadz[t_] * Ms_ gyy[t_] + + + 2 * (Ms_ dRdz[t_] * Ms_ drhodz[t_] * Ms_ gxz[t_] + Ms_ dRdz[t_] * Ms_ dsigmadz[t_] * Ms_ gyz[t_] + Ms_ drhodz[t_] * Ms_ dsigmadz[t_] * Ms_ gxy[t_]); + + + fxy[t_] = Ms_ dRdxy[t_] * Ms_ gz[t_] + Ms_ drhodxy[t_] * Ms_ gx[t_] + Ms_ dsigmadxy[t_] * Ms_ gy[t_] + + + Ms_ dRdx[t_] * Ms_ drhody[t_] * Ms_ gxz[t_] + Ms_ dRdx[t_] * Ms_ dsigmady[t_] * Ms_ gyz[t_] + Ms_ drhodx[t_] * Ms_ dsigmady[t_] * Ms_ gxy[t_] + + + Ms_ dRdy[t_] * Ms_ drhodx[t_] * Ms_ gxz[t_] + Ms_ dRdy[t_] * Ms_ dsigmadx[t_] * Ms_ gyz[t_] + Ms_ drhody[t_] * Ms_ dsigmadx[t_] * Ms_ gxy[t_] + + + Ms_ dRdx[t_] * Ms_ dRdy[t_] * Ms_ gzz[t_] + Ms_ drhodx[t_] * Ms_ drhody[t_] * Ms_ gxx[t_] + Ms_ dsigmadx[t_] * Ms_ dsigmady[t_] * Ms_ gyy[t_]; + + + fxz[t_] = Ms_ dRdxz[t_] * Ms_ gz[t_] + Ms_ drhodxz[t_] * Ms_ gx[t_] + Ms_ dsigmadxz[t_] * Ms_ gy[t_] + + + Ms_ dRdx[t_] * Ms_ drhodz[t_] * Ms_ gxz[t_] + Ms_ dRdx[t_] * Ms_ dsigmadz[t_] * Ms_ gyz[t_] + Ms_ drhodx[t_] * Ms_ dsigmadz[t_] * Ms_ gxy[t_] + + + Ms_ dRdz[t_] * Ms_ drhodx[t_] * Ms_ gxz[t_] + Ms_ dRdz[t_] * Ms_ dsigmadx[t_] * Ms_ gyz[t_] + Ms_ drhodz[t_] * Ms_ dsigmadx[t_] * Ms_ gxy[t_] + + + Ms_ dRdx[t_] * Ms_ dRdz[t_] * Ms_ gzz[t_] + Ms_ drhodx[t_] * Ms_ drhodz[t_] * Ms_ gxx[t_] + Ms_ dsigmadx[t_] * Ms_ dsigmadz[t_] * Ms_ gyy[t_]; + + + fyz[t_] = Ms_ dRdyz[t_] * Ms_ gz[t_] + Ms_ drhodyz[t_] * Ms_ gx[t_] + Ms_ dsigmadyz[t_] * Ms_ gy[t_] + + + Ms_ dRdz[t_] * Ms_ drhody[t_] * Ms_ gxz[t_] + Ms_ dRdz[t_] * Ms_ dsigmady[t_] * Ms_ gyz[t_] + Ms_ drhodz[t_] * Ms_ dsigmady[t_] * Ms_ gxy[t_] + + + Ms_ dRdy[t_] * Ms_ drhodz[t_] * Ms_ gxz[t_] + Ms_ dRdy[t_] * Ms_ dsigmadz[t_] * Ms_ gyz[t_] + Ms_ drhody[t_] * Ms_ dsigmadz[t_] * Ms_ gxy[t_] + + + Ms_ dRdz[t_] * Ms_ dRdy[t_] * Ms_ gzz[t_] + Ms_ drhodz[t_] * Ms_ drhody[t_] * Ms_ gxx[t_] + Ms_ dsigmadz[t_] * Ms_ dsigmady[t_] * Ms_ gyy[t_]; + + t_ += STEP_SIZE; + } +} + +__global__ void sub_fdderivs_sh(double *fh,double *fxx,double *fxy,double *fxz,double *fyy,double *fyz,double *fzz) + { + int curr = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + + while(curr < _3D_SIZE[0]) + { + int k = curr / _2D_SIZE[0]; + ps = curr - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k == ex_c[2] || i == ex_c[0] || j == ex_c[1]){ + curr += STEP_SIZE; + continue; + } + else + { + //xx + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0]){ + fxx[curr] = Fdxdx*(-_FH2_(i,(j+2),(k))+16*_FH2_((i+1),(j+2),(k))-30*_FH2_((i+2),(j+2),(k)) + -_FH2_((i+4),(j+2),(k))+16*_FH2_((i+3),(j+2),(k)) ); + + } + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0]){ + fxx[curr] = Sdxdx*(_FH2_((i+1),(j+2),(k))-2*_FH2_((i+2),(j+2),(k)) + +_FH2_(i+3,(j+2),(k)) ); + } + + + + //zz-- + if(k+2 <= ijk_max[2] && k-2 >= ijk_min[2]){ + fzz[curr] = Fdzdz * (-_FH2_((i+2),(j+2),(k-2)) + 16 *_FH2_((i+2),(j+2),(k-1))- 30*_FH2_((i+2),(j+2),(k)) + -_FH2_((i+2),(j+2),(k+2))+ 16*_FH2_((i+2),(j+2),(k+1))); + + } + else if(k+1 <= ijk_max[2] && k-1 >= ijk_min[2]){ + fzz[curr] = Sdzdz*(_FH2_((i+2),(j+2),(k-1))- 2 * _FH2_((i+2),(j+2),(k)) + + _FH2_((i+2),(j+2),(k+1)) ); + + //fzz[curr] = 256; + } + + //yy-- + if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1]){ + fyy[curr] = Fdydy*(-_FH2_((i+2),j,(k))+16*_FH2_((i+2),(j+1),(k))-30*_FH2_((i+2),(j+2),(k)) + -_FH2_((i+2),(j+4),(k))+16*_FH2_((i+2),(j+3),(k)) ); + } + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1]){ + fyy[curr] = Sdydy*(_FH2_((i+2),(j+1),(k))-2*_FH2_((i+2),(j+2),(k)) + +_FH2_((i+2),(j+3),(k)) ); + } + + + + //xy + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && j+2 <= ijk_max[1] && j-2 >= ijk_min[1]) + fxy[curr] = Fdxdy*((_FH2_(i,j,(k))-8*_FH2_((i+1),j,(k))+8*_FH2_((i+3),j,(k))-_FH2_((i+4),j,(k))) + -8 *(_FH2_(i,(j+1),(k))-8*_FH2_((i+1),(j+1),(k))+8*_FH2_((i+3),(j+1),(k))-_FH2_((i+4),(j+1),(k))) + +8 *(_FH2_(i,(j+3),(k))-8*_FH2_((i+1),(j+3),(k))+8*_FH2_((i+3),(j+3),(k))-_FH2_((i+4),(j+3),(k))) + - (_FH2_(i,(j+4),(k))-8*_FH2_((i+1),(j+4),(k))+8*_FH2_((i+3),(j+4),(k))-_FH2_((i+4),(j+4),(k)))); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && j+1 <= ijk_max[1] && j-1 >= ijk_min[1]) + + fxy[curr] = Sdxdy*(_FH2_((i+1),(j+1),(k))-_FH2_((i+3),(j+1),(k))-_FH2_((i+1),(j+3),(k))+_FH2_((i+3),(j+3),(k))); + //xz + if(i+2 <= ijk_max[0] && i-2 >= ijk_min[0] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) + fxz[curr] = Fdxdz*((_FH2_(i,(j+2),(k-2))-8*_FH2_((i+1),(j+2),(k-2))+8*_FH2_((i+3),(j+2),(k-2))-_FH2_((i+4),(j+2),(k-2))) + -8 *(_FH2_(i,(j+2),(k-1))-8*_FH2_((i+1),(j+2),(k-1))+8*_FH2_((i+3),(j+2),(k-1))-_FH2_((i+4),(j+2),(k-1))) + +8 *(_FH2_(i,(j+2),(k+1))-8*_FH2_((i+1),(j+2),(k+1))+8*_FH2_((i+3),(j+2),(k+1))-_FH2_((i+4),(j+2),(k+1))) + - (_FH2_(i,(j+2),(k+2))-8*_FH2_((i+1),(j+2),(k+2))+8*_FH2_((i+3),(j+2),(k+2))-_FH2_((i+4),(j+2),(k+2)))); + + else if(i+1 <= ijk_max[0] && i-1 >= ijk_min[0] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) + fxz[curr] = Sdxdz*(_FH2_((i+1),(j+2),(k-1))-_FH2_((i+3),(j+2),(k-1))-_FH2_((i+1),(j+2),(k+1))+_FH2_((i+3),(j+2),(k+1))); + //yz + if(j+2 <= ijk_max[1] && j-2 >= ijk_min[1] && k+2 <= ijk_max[2] && k-2 >= ijk_min[2]) + fyz[curr] = Fdydz*( (_FH2_((i+2),j,(k-2))-8*_FH2_((i+2),(j+1),(k-2))+8*_FH2_((i+2),(j+3),(k-2))-_FH2_((i+2),(j+4),(k-2))) + -8 *(_FH2_((i+2),j,(k-1))-8*_FH2_((i+2),(j+1),(k-1))+8*_FH2_((i+2),(j+3),(k-1))-_FH2_((i+2),(j+4),(k-1))) + +8 *(_FH2_((i+2),j,(k+1))-8*_FH2_((i+2),(j+1),(k+1))+8*_FH2_((i+2),(j+3),(k+1))-_FH2_((i+2),(j+4),(k+1))) + - (_FH2_((i+2),j,(k+2))-8*_FH2_((i+2),(j+1),(k+2))+8*_FH2_((i+2),(j+3),(k+2))-_FH2_((i+2),(j+4),(k+2)))); + + else if(j+1 <= ijk_max[1] && j-1 >= ijk_min[1] && k+1 <= ijk_max[2] && k-1 >= ijk_min[2]) + fyz[curr] = Sdydz*(_FH2_((i+2),(j+1),(k-1))-_FH2_((i+2),(j+3),(k-1))-_FH2_((i+2),(j+1),(k+1))+_FH2_((i+2),(j+3),(k+1))); + + curr += STEP_SIZE; + } + } + __syncthreads(); + } + +inline void sub_fdderivs_shc(int& sst,double * f,double * fh, + double * fxx,double * fxy,double * fxz, + double * fyy,double * fyz,double * fzz, double * SoA) +{ + double SoA1[2]; + if(sst == 0){ + SoA1[0] = SoA[0]; + SoA1[1] = SoA[1]; + } + else if(sst == 2 || sst == 3 ){ + SoA1[0] = SoA[1]; + SoA1[1] = SoA[2]; + } + else if(sst == 4 || sst==5){ + SoA1[0] = SoA[0]; + SoA1[1] = SoA[2]; + } + cudaMemset(Msh_ gx,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gy,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gz,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gxx,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gxy,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gxz,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gyy,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gyz,0,h_3D_SIZE[0] * sizeof(double)); + cudaMemset(Msh_ gzz,0,h_3D_SIZE[0] * sizeof(double)); + + //fderivs_sh + sub_symmetry_bd_ss(2,f,fh,SoA1); + cudaThreadSynchronize(); + //compare_result_gpu(1,fh,h_3D_SIZE[2]); + sub_fderivs_sh<<>>(fh,Msh_ gx,Msh_ gy,Msh_ gz); + cudaThreadSynchronize(); + + //fdderivs_sh + sub_symmetry_bd_ss(2,f,fh,SoA1); + cudaThreadSynchronize(); + //compare_result_gpu(21,fh,h_3D_SIZE[2]); + sub_fdderivs_sh<<>>(fh,Msh_ gxx,Msh_ gxy,Msh_ gxz,Msh_ gyy,Msh_ gyz,Msh_ gzz); + cudaThreadSynchronize(); + /*compare_result_gpu(11,Msh_ gx,h_3D_SIZE[0]); + compare_result_gpu(12,Msh_ gy,h_3D_SIZE[0]); + compare_result_gpu(13,Msh_ gz,h_3D_SIZE[0]); + compare_result_gpu(1,Msh_ gxx,h_3D_SIZE[0]); + compare_result_gpu(2,Msh_ gxy,h_3D_SIZE[0]); + compare_result_gpu(3,Msh_ gxz,h_3D_SIZE[0]); + compare_result_gpu(4,Msh_ gyy,h_3D_SIZE[0]); + compare_result_gpu(5,Msh_ gyz,h_3D_SIZE[0]); + compare_result_gpu(6,Msh_ gzz,h_3D_SIZE[0]);*/ + sub_fdderivs_shc_part1<<>>(fxx,fxy,fxz,fyy,fyz,fzz); + cudaThreadSynchronize(); + /*compare_result_gpu(1,fxx,h_3D_SIZE[0]); + compare_result_gpu(2,fxy,h_3D_SIZE[0]); + compare_result_gpu(3,fxz,h_3D_SIZE[0]); + compare_result_gpu(4,fyy,h_3D_SIZE[0]); + compare_result_gpu(5,fyz,h_3D_SIZE[0]); + compare_result_gpu(6,fzz,h_3D_SIZE[0]);*/ +} + +__global__ void computeRicci_ss_part1(double * dst) +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + dst[_t] = M_ gupxx [_t]* M_ fxx [_t]+ M_ gupyy[_t]* M_ fyy[_t]+ M_ gupzz[_t]* M_ fzz[_t]+ + ( M_ gupxy[_t]* M_ fxy[_t]+ M_ gupxz[_t]* M_ fxz[_t]+ M_ gupyz[_t]* M_ fyz[_t]) * 2; + + _t += STEP_SIZE; + } +} + + inline void computeRicci_ss(int &sst,double * src,double* dst,double * SoA, Meta* meta) +{ + sub_fdderivs_shc(sst,src,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,SoA); + cudaThreadSynchronize(); + computeRicci_ss_part1<<>>(dst); + cudaThreadSynchronize(); + +} +__global__ void sub_lopsided_ss_part1(double * dst) +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + dst[_t] += M_ betax[_t] * M_ fxx[_t] + + M_ betay[_t] * M_ fxy[_t] + + M_ betaz[_t] * M_ fxz[_t]; + + _t += STEP_SIZE; + } +} +inline void sub_lopsided_ss(int& sst,double *src,double* dst,double *SoA) +{ + sub_fderivs_shc(sst,src,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,SoA); + cudaThreadSynchronize(); + sub_lopsided_ss_part1<<>>(dst); + cudaThreadSynchronize(); +} + +__global__ void sub_kodis_sh_part1(double *f,double *fh,double *f_rhs) +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + int ps; //TOTRY: i,j,k; double value; + double inc_f_rhs; + while(_t < _3D_SIZE[0]) + { + int k = _t / _2D_SIZE[0]; + ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + if(k == ex_c[2] && i == ex_c[0] && j == ex_c[1]){ + _t += STEP_SIZE; + continue; + } + + if(i-3 >= ijk_min3[0] && i+3 <= ijk_max3[0] && + j-3 >= ijk_min3[1] && j+3 <= ijk_max3[1] && + k-3 >= ijk_min3[2] && k+3 <= ijk_max3[2]) + { + + // x direction + inc_f_rhs = ( (_FH3_(i,(j+3),(k))+_FH3_((i+6),(j+3),(k))) - + 6*(_FH3_((i+1),(j+3),(k))+_FH3_((i+5),(j+3),(k))) + + 15*(_FH3_((i+2),(j+3),(k))+_FH3_((i+4),(j+3),(k))) - + 20* _FH3_((i+3),(j+3),(k)) ) /dX; + + + // y direction + + inc_f_rhs += ( (_FH3_((i+3),j,(k))+_FH3_((i+3),(j+6),(k))) - + 6*(_FH3_((i+3),(j+1),(k))+_FH3_((i+3),(j+5),(k))) + + 15*(_FH3_((i+3),(j+2),(k))+_FH3_((i+3),(j+4),(k))) - + 20* _FH3_((i+3),(j+3),(k)) )/dY; + + // z direction + + inc_f_rhs += ( (_FH3_((i+3),(j+3),(k-3))+_FH3_((i+3),(j+3),(k+3))) - + 6*(_FH3_((i+3),(j+3),(k-2))+_FH3_((i+3),(j+3),(k+2))) + + 15*(_FH3_((i+3),(j+3),(k-1))+_FH3_((i+3),(j+3),(k+1))) - + 20* _FH3_((i+3),(j+3),(k)) )/dZ; + inc_f_rhs *= eps_c; + inc_f_rhs /= 64; + + f_rhs[_t] += inc_f_rhs; //be careful the mark is "+=" not "==" ! + } + + _t += STEP_SIZE; + } +} + +inline void sub_kodis_ss(int &sst,double *f,double *fh,double *f_rhs,double *SoA) +{ + double SoA1[2]; + if(sst == 0){ + SoA1[0] = SoA[0]; + SoA1[1] = SoA[1]; + } + else if(sst == 2 || sst == 3 ){ + SoA1[0] = SoA[1]; + SoA1[1] = SoA[2]; + } + else if(sst == 4 || sst==5){ + SoA1[0] = SoA[0]; + SoA1[1] = SoA[2]; + } + //compare_result_gpu(10,f,h_3D_SIZE[0]); + sub_symmetry_bd_ss(3,f,fh,SoA1); + cudaThreadSynchronize(); + //compare_result_gpu(0,fh,h_3D_SIZE[3]); + + sub_kodis_sh_part1<<>>(f,fh,f_rhs); + cudaThreadSynchronize(); + //compare_result_gpu(1,f_rhs,h_3D_SIZE[0]); +} + +__global__ void compute_rhs_ss_part2() +{ + //__shared__ int judge = 1; + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + if(co_c == 0) + { + // M_ Gam^i_Res = M_ Gam^i + M_ gup^ij_,j + M_ Gmx_Res[_t] = M_ Gamx[_t] - (M_ gupxx[_t]*(M_ gupxx[_t]*M_ gxxx[_t]+M_ gupxy[_t]*M_ gxyx[_t]+M_ gupxz[_t]*M_ gxzx[_t]) + +M_ gupxy[_t]*(M_ gupxx[_t]*M_ gxyx[_t]+M_ gupxy[_t]*M_ gyyx[_t]+M_ gupxz[_t]*M_ gyzx[_t]) + +M_ gupxz[_t]*(M_ gupxx[_t]*M_ gxzx[_t]+M_ gupxy[_t]*M_ gyzx[_t]+M_ gupxz[_t]*M_ gzzx[_t]) + +M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) + +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) + +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) + +M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) + +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); + M_ Gmy_Res[_t] = M_ Gamy[_t] - (M_ gupxx[_t]*(M_ gupxy[_t]*M_ gxxx[_t]+M_ gupyy[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gxzx[_t]) + +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxyx[_t]+M_ gupyy[_t]*M_ gyyx[_t]+M_ gupyz[_t]*M_ gyzx[_t]) + +M_ gupxz[_t]*(M_ gupxy[_t]*M_ gxzx[_t]+M_ gupyy[_t]*M_ gyzx[_t]+M_ gupyz[_t]*M_ gzzx[_t]) + +M_ gupxy[_t]*(M_ gupxy[_t]*M_ gxxy[_t]+M_ gupyy[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gxzy[_t]) + +M_ gupyy[_t]*(M_ gupxy[_t]*M_ gxyy[_t]+M_ gupyy[_t]*M_ gyyy[_t]+M_ gupyz[_t]*M_ gyzy[_t]) + +M_ gupyz[_t]*(M_ gupxy[_t]*M_ gxzy[_t]+M_ gupyy[_t]*M_ gyzy[_t]+M_ gupyz[_t]*M_ gzzy[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) + +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) + +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); + M_ Gmz_Res[_t] = M_ Gamz[_t] - (M_ gupxx[_t]*(M_ gupxz[_t]*M_ gxxx[_t]+M_ gupyz[_t]*M_ gxyx[_t]+M_ gupzz[_t]*M_ gxzx[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxyx[_t]+M_ gupyz[_t]*M_ gyyx[_t]+M_ gupzz[_t]*M_ gyzx[_t]) + +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxzx[_t]+M_ gupyz[_t]*M_ gyzx[_t]+M_ gupzz[_t]*M_ gzzx[_t]) + +M_ gupxy[_t]*(M_ gupxz[_t]*M_ gxxy[_t]+M_ gupyz[_t]*M_ gxyy[_t]+M_ gupzz[_t]*M_ gxzy[_t]) + +M_ gupyy[_t]*(M_ gupxz[_t]*M_ gxyy[_t]+M_ gupyz[_t]*M_ gyyy[_t]+M_ gupzz[_t]*M_ gyzy[_t]) + +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxzy[_t]+M_ gupyz[_t]*M_ gyzy[_t]+M_ gupzz[_t]*M_ gzzy[_t]) + +M_ gupxz[_t]*(M_ gupxz[_t]*M_ gxxz[_t]+M_ gupyz[_t]*M_ gxyz[_t]+M_ gupzz[_t]*M_ gxzz[_t]) + +M_ gupyz[_t]*(M_ gupxz[_t]*M_ gxyz[_t]+M_ gupyz[_t]*M_ gyyz[_t]+M_ gupzz[_t]*M_ gyzz[_t]) + +M_ gupzz[_t]*(M_ gupxz[_t]*M_ gxzz[_t]+M_ gupyz[_t]*M_ gyzz[_t]+M_ gupzz[_t]*M_ gzzz[_t])); + }//if(co == 0) + + M_ div_beta[_t] = M_ betaxx[_t] + M_ betayy[_t] + M_ betazz[_t]; + M_ chi_rhs[_t] = F2o3 *M_ chin1[_t]*( M_ alpn1[_t] * M_ trK[_t] - M_ div_beta[_t] ); //rhs[_t] for M_ chi + + M_ gxx_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axx[_t] - F2o3 * M_ gxx[_t]* M_ div_beta[_t] + + 2 *( M_ gxx[_t]* M_ betaxx[_t]+ M_ gxy[_t]* M_ betayx[_t]+ M_ gxz[_t]* M_ betazx[_t]); + M_ gyy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayy[_t] - F2o3 * M_ gyy[_t]* M_ div_beta[_t] + + 2 *( M_ gxy[_t]* M_ betaxy[_t]+ M_ gyy[_t]* M_ betayy[_t]+ M_ gyz[_t]* M_ betazy[_t]); + + M_ gzz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Azz[_t] - F2o3 * M_ gzz[_t]* M_ div_beta[_t] + + 2 *( M_ gxz[_t]* M_ betaxz[_t]+ M_ gyz[_t]* M_ betayz[_t]+ M_ gzz[_t]* M_ betazz[_t]); + + M_ gxy_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axy[_t] + F1o3 * M_ gxy[_t] * M_ div_beta[_t] + + M_ gxx[_t]* M_ betaxy[_t] + M_ gxz[_t]* M_ betazy[_t]+ + M_ gyy[_t]* M_ betayx[_t]+ M_ gyz[_t]* M_ betazx[_t] + - M_ gxy[_t]* M_ betazz[_t]; + + M_ gyz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Ayz[_t] + F1o3 * M_ gyz[_t] * M_ div_beta[_t] + + M_ gxy[_t]* M_ betaxz[_t]+ M_ gyy[_t]* M_ betayz[_t] + + M_ gxz[_t]* M_ betaxy[_t] + M_ gzz[_t]* M_ betazy[_t] + - M_ gyz[_t]* M_ betaxx[_t]; + + M_ gxz_rhs[_t] = - 2 * M_ alpn1[_t] * M_ Axz[_t] + F1o3 * M_ gxz[_t] * M_ div_beta[_t] + + M_ gxx[_t]* M_ betaxz[_t]+ M_ gxy[_t]* M_ betayz[_t] + + M_ gyz[_t]* M_ betayx[_t]+ M_ gzz[_t]* M_ betazx[_t] + - M_ gxz[_t]* M_ betayy[_t]; //rhs[_t] for gij + + // invert tilted metric + M_ gupzz[_t]= M_ gxx[_t]* M_ gyy[_t]* M_ gzz[_t]+ M_ gxy[_t]* M_ gyz[_t]* M_ gxz[_t]+ M_ gxz[_t]* M_ gxy[_t]* M_ gyz[_t]- + M_ gxz[_t]* M_ gyy[_t]* M_ gxz[_t]- M_ gxy[_t]* M_ gxy[_t]* M_ gzz[_t]- M_ gxx[_t]* M_ gyz[_t]* M_ gyz[_t]; + M_ gupxx[_t]= ( M_ gyy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gyz[_t]) / M_ gupzz[_t]; + M_ gupxy[_t]= - ( M_ gxy[_t]* M_ gzz[_t]- M_ gyz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupxz[_t]= ( M_ gxy[_t]* M_ gyz[_t]- M_ gyy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupyy[_t]= ( M_ gxx[_t]* M_ gzz[_t]- M_ gxz[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupyz[_t]= - ( M_ gxx[_t]* M_ gyz[_t]- M_ gxy[_t]* M_ gxz[_t]) / M_ gupzz[_t]; + M_ gupzz[_t]= ( M_ gxx[_t]* M_ gyy[_t]- M_ gxy[_t]* M_ gxy[_t]) / M_ gupzz[_t]; + //if(threadIdx.x == 0){ + // judge = co_c; + //} + //__syncthreads(); + + + + // second kind of connection + M_ Gamxxx[_t]=HALF*( M_ gupxx[_t]*M_ gxxx[_t]+ M_ gupxy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupxz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); + M_ Gamyxx[_t]=HALF*( M_ gupxy[_t]*M_ gxxx[_t]+ M_ gupyy[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupyz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); + M_ Gamzxx[_t]=HALF*( M_ gupxz[_t]*M_ gxxx[_t]+ M_ gupyz[_t]*(2*M_ gxyx[_t]- M_ gxxy[_t]) + M_ gupzz[_t]*(2*M_ gxzx[_t]- M_ gxxz[_t])); + + M_ Gamxyy[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupxy[_t]*M_ gyyy[_t]+ M_ gupxz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); + M_ Gamyyy[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupyz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); + M_ Gamzyy[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxyy[_t]- M_ gyyx[_t]) + M_ gupyz[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*(2*M_ gyzy[_t]- M_ gyyz[_t])); + + M_ Gamxzz[_t]=HALF*( M_ gupxx[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupxy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupxz[_t]*M_ gzzz[_t]); + M_ Gamyzz[_t]=HALF*( M_ gupxy[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyy[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupyz[_t]*M_ gzzz[_t]); + M_ Gamzzz[_t]=HALF*( M_ gupxz[_t]*(2*M_ gxzz[_t]- M_ gzzx[_t]) + M_ gupyz[_t]*(2*M_ gyzz[_t]- M_ gzzy[_t]) + M_ gupzz[_t]*M_ gzzz[_t]); + + M_ Gamxxy[_t]=HALF*( M_ gupxx[_t]*M_ gxxy[_t]+ M_ gupxy[_t]*M_ gyyx[_t]+ M_ gupxz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); + M_ Gamyxy[_t]=HALF*( M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupyy[_t]*M_ gyyx[_t]+ M_ gupyz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); + M_ Gamzxy[_t]=HALF*( M_ gupxz[_t]*M_ gxxy[_t]+ M_ gupyz[_t]*M_ gyyx[_t]+ M_ gupzz[_t]*( M_ gxzy[_t]+ M_ gyzx[_t]- M_ gxyz[_t]) ); + + M_ Gamxxz[_t]=HALF*( M_ gupxx[_t]*M_ gxxz[_t]+ M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupxz[_t]*M_ gzzx[_t]); + M_ Gamyxz[_t]=HALF*( M_ gupxy[_t]*M_ gxxz[_t]+ M_ gupyy[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupyz[_t]*M_ gzzx[_t]); + M_ Gamzxz[_t]=HALF*( M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*( M_ gxyz[_t]+ M_ gyzx[_t]- M_ gxzy[_t]) + M_ gupzz[_t]*M_ gzzx[_t]); + + M_ Gamxyz[_t]=HALF*( M_ gupxx[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupxy[_t]*M_ gyyz[_t]+ M_ gupxz[_t]*M_ gzzy[_t]); + M_ Gamyyz[_t]=HALF*( M_ gupxy[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyy[_t]*M_ gyyz[_t]+ M_ gupyz[_t]*M_ gzzy[_t]); + M_ Gamzyz[_t]=HALF*( M_ gupxz[_t]*( M_ gxyz[_t]+ M_ gxzy[_t]- M_ gyzx[_t]) + M_ gupyz[_t]*M_ gyyz[_t]+ M_ gupzz[_t]*M_ gzzy[_t]); + // Raise indices of \tilde A_{ij} and store in R_ij + + M_ Rxx[_t]= M_ gupxx[_t]* M_ gupxx[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupxy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupxz[_t]* M_ Azz[_t]+ + 2*(M_ gupxx[_t]* M_ gupxy[_t]* M_ Axy[_t]+ M_ gupxx[_t]* M_ gupxz[_t]* M_ Axz[_t]+ M_ gupxy[_t]* M_ gupxz[_t]* M_ Ayz[_t]); + + M_ Ryy[_t]= M_ gupxy[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ + 2*(M_ gupxy[_t]* M_ gupyy[_t]* M_ Axy[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayz[_t]); + + M_ Rzz[_t]= M_ gupxz[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyz[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ + 2*(M_ gupxz[_t]* M_ gupyz[_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Ayz[_t]); + + M_ Rxy[_t]= M_ gupxx[_t]* M_ gupxy[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupyz[_t]* M_ Azz[_t]+ + (M_ gupxx[_t]* M_ gupyy[_t] + M_ gupxy[_t]* M_ gupxy[_t])* M_ Axy[_t] + + (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupxy[_t])* M_ Axz[_t] + + (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupxz[_t]* M_ gupyy[_t])* M_ Ayz[_t]; + + M_ Rxz[_t]= M_ gupxx[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupxy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ + (M_ gupxx[_t]* M_ gupyz[_t] + M_ gupxy[_t]* M_ gupxz[_t])* M_ Axy[_t] + + (M_ gupxx[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupxz[_t])* M_ Axz[_t] + + (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupxz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; + + M_ Ryz[_t]= M_ gupxy[_t]* M_ gupxz[_t]* M_ Axx[_t]+ M_ gupyy[_t]* M_ gupyz[_t]* M_ Ayy[_t]+ M_ gupyz[_t]* M_ gupzz[_t]* M_ Azz[_t]+ + (M_ gupxy[_t]* M_ gupyz[_t] + M_ gupyy[_t]* M_ gupxz[_t])* M_ Axy[_t] + + (M_ gupxy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupxz[_t])* M_ Axz[_t] + + (M_ gupyy[_t]* M_ gupzz[_t] + M_ gupyz[_t]* M_ gupyz[_t])* M_ Ayz[_t]; + + // Right hand side for M_ Gam^i without shift terms... + + M_ Gamx_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxx[_t]+ M_ Lapy[_t] * M_ Rxy[_t]+ M_ Lapz[_t] * M_ Rxz[_t]) + + 2 * M_ alpn1[_t] * ( + -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxx[_t]+ M_ chiy[_t] * M_ Rxy[_t]+ M_ chiz[_t] * M_ Rxz[_t]) - + M_ gupxx[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - + M_ gupxy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - + M_ gupxz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + + M_ Gamxxx[_t]* M_ Rxx[_t]+ M_ Gamxyy[_t]* M_ Ryy[_t]+ M_ Gamxzz[_t]* M_ Rzz[_t] + + 2 * ( M_ Gamxxy[_t]* M_ Rxy[_t]+ M_ Gamxxz[_t]* M_ Rxz[_t]+ M_ Gamxyz[_t]* M_ Ryz[_t]) ); + + M_ Gamy_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxy[_t]+ M_ Lapy[_t] * M_ Ryy[_t]+ M_ Lapz[_t] * M_ Ryz[_t]) + + 2 * M_ alpn1[_t] * ( + -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxy[_t]+ M_ chiy[_t] * M_ Ryy[_t]+ M_ chiz[_t] * M_ Ryz[_t]) - + M_ gupxy[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - + M_ gupyy[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - + M_ gupyz[_t]* ( F2o3 * M_ Kz [_t] + 8 * PI * M_ Sz[_t] ) + + M_ Gamyxx[_t]* M_ Rxx[_t]+ M_ Gamyyy[_t]* M_ Ryy[_t]+ M_ Gamyzz[_t]* M_ Rzz[_t] + + 2 * ( M_ Gamyxy[_t]* M_ Rxy[_t]+ M_ Gamyxz[_t]* M_ Rxz[_t]+ M_ Gamyyz[_t]* M_ Ryz[_t]) ); + + M_ Gamz_rhs[_t] = - 2 * ( M_ Lapx[_t] * M_ Rxz[_t]+ M_ Lapy[_t] * M_ Ryz[_t]+ M_ Lapz[_t] * M_ Rzz[_t]) + + 2 * M_ alpn1[_t] * ( + -F3o2/M_ chin1[_t] * ( M_ chix[_t] * M_ Rxz[_t]+ M_ chiy[_t] * M_ Ryz[_t]+ M_ chiz[_t] * M_ Rzz[_t]) - + M_ gupxz[_t]* ( F2o3 * M_ Kx[_t] + 8 * PI * M_ Sx[_t] ) - + M_ gupyz[_t]* ( F2o3 * M_ Ky[_t] + 8 * PI * M_ Sy[_t] ) - + M_ gupzz[_t]* ( F2o3 * M_ Kz[_t] + 8 * PI * M_ Sz[_t] ) + + M_ Gamzxx[_t]* M_ Rxx[_t]+ M_ Gamzyy[_t]* M_ Ryy[_t]+ M_ Gamzzz[_t]* M_ Rzz[_t] + + 2 * ( M_ Gamzxy[_t]* M_ Rxy[_t]+ M_ Gamzxz[_t]* M_ Rxz[_t]+ M_ Gamzyz[_t]* M_ Ryz[_t]) ); + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_ss_part3() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ fxx [_t]= M_ gxxx[_t]+ M_ gxyy[_t]+ M_ gxzz[_t]; + M_ fxy[_t]= M_ gxyx[_t]+ M_ gyyy[_t]+ M_ gyzz[_t]; + M_ fxz[_t]= M_ gxzx[_t]+ M_ gyzy[_t]+ M_ gzzz[_t]; + + M_ Gamxa[_t]= M_ gupxx [_t]* M_ Gamxxx [_t]+ M_ gupyy[_t]* M_ Gamxyy[_t]+ M_ gupzz[_t]* M_ Gamxzz[_t]+ + 2*( M_ gupxy[_t]* M_ Gamxxy[_t]+ M_ gupxz[_t]* M_ Gamxxz[_t]+ M_ gupyz[_t]* M_ Gamxyz[_t]); + M_ Gamya[_t]= M_ gupxx [_t]* M_ Gamyxx [_t]+ M_ gupyy[_t]* M_ Gamyyy[_t]+ M_ gupzz[_t]* M_ Gamyzz[_t]+ + 2*( M_ gupxy[_t]* M_ Gamyxy[_t]+ M_ gupxz[_t]* M_ Gamyxz[_t]+ M_ gupyz[_t]* M_ Gamyyz[_t]); + M_ Gamza[_t]= M_ gupxx [_t]* M_ Gamzxx [_t]+ M_ gupyy[_t]* M_ Gamzyy[_t]+ M_ gupzz[_t]* M_ Gamzzz[_t]+ + 2*( M_ gupxy[_t]* M_ Gamzxy[_t]+ M_ gupxz[_t]* M_ Gamzxz[_t]+ M_ gupyz[_t]* M_ Gamzyz[_t]); + + + + M_ Gamx_rhs[_t] = M_ Gamx_rhs[_t] + F2o3 * M_ Gamxa[_t]* M_ div_beta[_t] - + M_ Gamxa[_t]* M_ betaxx [_t]- M_ Gamya[_t]* M_ betaxy[_t]- M_ Gamza[_t]* M_ betaxz[_t] + + F1o3 * (M_ gupxx [_t]* M_ fxx [_t] + M_ gupxy[_t]* M_ fxy[_t] + M_ gupxz[_t]* M_ fxz[_t] ) + + M_ gupxx [_t]* M_ gxxx [_t] + M_ gupyy[_t]* M_ gyyx [_t] + M_ gupzz[_t]* M_ gzzx [_t] + + 2 * (M_ gupxy[_t]* M_ gxyx [_t] + M_ gupxz[_t]* M_ gxzx [_t] + M_ gupyz[_t]* M_ gyzx [_t] ); + + M_ Gamy_rhs[_t] = M_ Gamy_rhs[_t] + F2o3 * M_ Gamya[_t]* M_ div_beta[_t] - + M_ Gamxa[_t]* M_ betayx [_t]- M_ Gamya[_t]* M_ betayy[_t]- M_ Gamza[_t]* M_ betayz[_t] + + F1o3 * (M_ gupxy[_t]* M_ fxx [_t] + M_ gupyy[_t]* M_ fxy[_t] + M_ gupyz[_t]* M_ fxz[_t] ) + + M_ gupxx [_t]* M_ gxxy[_t] + M_ gupyy[_t]* M_ gyyy[_t] + M_ gupzz[_t]* M_ gzzy[_t] + + 2 * (M_ gupxy[_t]* M_ gxyy[_t] + M_ gupxz[_t]* M_ gxzy[_t] + M_ gupyz[_t]* M_ gyzy[_t] ); + + M_ Gamz_rhs[_t] = M_ Gamz_rhs[_t] + F2o3 * M_ Gamza[_t]* M_ div_beta[_t] - + M_ Gamxa[_t]* M_ betazx [_t]- M_ Gamya[_t]* M_ betazy[_t]- M_ Gamza[_t]* M_ betazz[_t] + + F1o3 * (M_ gupxz[_t]* M_ fxx [_t] + M_ gupyz[_t]* M_ fxy[_t] + M_ gupzz[_t]* M_ fxz[_t] ) + + M_ gupxx [_t]* M_ gxxz[_t] + M_ gupyy[_t]* M_ gyyz[_t] + M_ gupzz[_t]* M_ gzzz[_t] + + 2 * (M_ gupxy[_t]* M_ gxyz[_t] + M_ gupxz[_t]* M_ gxzz[_t] + M_ gupyz[_t]* M_ gyzz[_t] ) ; //rhs M_ for M_ Gam^i + + //first kind of connection stored in M_ gij,k + M_ gxxx [_t]= M_ gxx [_t]* M_ Gamxxx [_t]+ M_ gxy[_t]* M_ Gamyxx [_t]+ M_ gxz[_t]* M_ Gamzxx[_t]; + M_ gxyx [_t]= M_ gxx [_t]* M_ Gamxxy[_t]+ M_ gxy[_t]* M_ Gamyxy[_t]+ M_ gxz[_t]* M_ Gamzxy[_t]; + M_ gxzx [_t]= M_ gxx [_t]* M_ Gamxxz[_t]+ M_ gxy[_t]* M_ Gamyxz[_t]+ M_ gxz[_t]* M_ Gamzxz[_t]; + M_ gyyx [_t]= M_ gxx [_t]* M_ Gamxyy[_t]+ M_ gxy[_t]* M_ Gamyyy[_t]+ M_ gxz[_t]* M_ Gamzyy[_t]; + M_ gyzx [_t]= M_ gxx [_t]* M_ Gamxyz[_t]+ M_ gxy[_t]* M_ Gamyyz[_t]+ M_ gxz[_t]* M_ Gamzyz[_t]; + M_ gzzx [_t]= M_ gxx [_t]* M_ Gamxzz[_t]+ M_ gxy[_t]* M_ Gamyzz[_t]+ M_ gxz[_t]* M_ Gamzzz[_t]; + M_ gxxy[_t]= M_ gxy[_t]* M_ Gamxxx [_t]+ M_ gyy[_t]* M_ Gamyxx [_t]+ M_ gyz[_t]* M_ Gamzxx[_t]; + M_ gxyy[_t]= M_ gxy[_t]* M_ Gamxxy[_t]+ M_ gyy[_t]* M_ Gamyxy[_t]+ M_ gyz[_t]* M_ Gamzxy[_t]; + M_ gxzy[_t]= M_ gxy[_t]* M_ Gamxxz[_t]+ M_ gyy[_t]* M_ Gamyxz[_t]+ M_ gyz[_t]* M_ Gamzxz[_t]; + M_ gyyy[_t]= M_ gxy[_t]* M_ Gamxyy[_t]+ M_ gyy[_t]* M_ Gamyyy[_t]+ M_ gyz[_t]* M_ Gamzyy[_t]; + M_ gyzy[_t]= M_ gxy[_t]* M_ Gamxyz[_t]+ M_ gyy[_t]* M_ Gamyyz[_t]+ M_ gyz[_t]* M_ Gamzyz[_t]; + M_ gzzy[_t]= M_ gxy[_t]* M_ Gamxzz[_t]+ M_ gyy[_t]* M_ Gamyzz[_t]+ M_ gyz[_t]* M_ Gamzzz[_t]; + M_ gxxz[_t]= M_ gxz[_t]* M_ Gamxxx [_t]+ M_ gyz[_t]* M_ Gamyxx [_t]+ M_ gzz[_t]* M_ Gamzxx[_t]; + M_ gxyz[_t]= M_ gxz[_t]* M_ Gamxxy[_t]+ M_ gyz[_t]* M_ Gamyxy[_t]+ M_ gzz[_t]* M_ Gamzxy[_t]; + M_ gxzz[_t]= M_ gxz[_t]* M_ Gamxxz[_t]+ M_ gyz[_t]* M_ Gamyxz[_t]+ M_ gzz[_t]* M_ Gamzxz[_t]; + M_ gyyz[_t]= M_ gxz[_t]* M_ Gamxyy[_t]+ M_ gyz[_t]* M_ Gamyyy[_t]+ M_ gzz[_t]* M_ Gamzyy[_t]; + M_ gyzz[_t]= M_ gxz[_t]* M_ Gamxyz[_t]+ M_ gyz[_t]* M_ Gamyyz[_t]+ M_ gzz[_t]* M_ Gamzyz[_t]; + M_ gzzz[_t]= M_ gxz[_t]* M_ Gamxzz[_t]+ M_ gyz[_t]* M_ Gamyzz[_t]+ M_ gzz[_t]* M_ Gamzzz[_t]; + + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_ss_part4() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ Rxx [_t]= - HALF *M_ Rxx [_t] + + M_ gxx [_t]* M_ Gamxx[_t] +M_ gxy[_t]* M_ Gamyx [_t] + M_ gxz[_t]* M_ Gamzx [_t]+ + M_ Gamxa[_t]*M_ gxxx [_t]+ M_ Gamya[_t]*M_ gxyx [_t]+ M_ Gamza[_t]*M_ gxzx [_t] + + M_ gupxx [_t]*( + 2*(M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxyx [_t]+ M_ Gamzxx [_t]*M_ gxzx[_t]) + + M_ Gamxxx [_t]*M_ gxxx [_t]+ M_ Gamyxx [_t]*M_ gxxy[_t]+ M_ Gamzxx [_t]*M_ gxxz[_t])+ + M_ gupxy[_t]*( + 2*(M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gyyx [_t]+ M_ Gamzxx [_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx[_t]) + + M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxxy[_t]+ M_ Gamzxy[_t]*M_ gxxz[_t] + + M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ + M_ gupxz[_t]*( + 2*(M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gyzx [_t]+ M_ Gamzxx [_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx[_t]) + + M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxxy[_t]+ M_ Gamzxz[_t]*M_ gxxz[_t] + + M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ + M_ gupyy[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx[_t]) + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ + M_ gupyz[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx[_t]) + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ + M_ gupzz[_t]*( + 2*(M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx[_t]) + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]); + + M_ Ryy[_t]= - HALF *M_ Ryy[_t] + + M_ gxy[_t]* M_ Gamxy[_t]+ M_ gyy[_t]* M_ Gamyy[_t] + M_ gyz[_t]* M_ Gamzy[_t] + + M_ Gamxa[_t]*M_ gxyy[_t]+ M_ Gamya[_t]*M_ gyyy[_t]+ M_ Gamza[_t]*M_ gyzy[_t] + + M_ gupxx [_t]*( + 2*(M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t]) + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t])+ + M_ gupxy[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gxxy[_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxzy[_t]) + + M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gxyy[_t]+ M_ Gamzyy[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ + M_ gupxz[_t]*( + 2*(M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t]) + + M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupyy[_t]*( + 2*(M_ Gamxyy[_t]*M_ gxyy[_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyzy[_t]) + + M_ Gamxyy[_t]*M_ gyyx [_t]+ M_ Gamyyy[_t]*M_ gyyy[_t]+ M_ Gamzyy[_t]*M_ gyyz[_t])+ + M_ gupyz[_t]*( + 2*(M_ Gamxyy[_t]*M_ gxzy[_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t]) + + M_ Gamxyz[_t]*M_ gyyx [_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyyz[_t] + + M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ + M_ gupzz[_t]*( + 2*(M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t]) + + M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]); + + M_ Rzz[_t]= - HALF *M_ Rzz[_t] + + M_ gxz[_t]* M_ Gamxz[_t] +M_ gyz[_t]* M_ Gamyz[_t] + M_ gzz[_t]* M_ Gamzz[_t] + + M_ Gamxa[_t]*M_ gxzz[_t]+ M_ Gamya[_t]*M_ gyzz[_t]+ M_ Gamza[_t]*M_ gzzz[_t] + + M_ gupxx [_t]*( + 2*(M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t]) + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t])+ + M_ gupxy[_t]*( + 2*(M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t]) + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t])+ + M_ gupxz[_t]*( + 2*(M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxxz[_t]+ M_ Gamyzz[_t]*M_ gxyz[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t]) + + M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gxzy[_t]+ M_ Gamzzz[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t])+ + M_ gupyy[_t]*( + 2*(M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t]) + + M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t])+ + M_ gupyz[_t]*( + 2*(M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxyz[_t]+ M_ Gamyzz[_t]*M_ gyyz[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t]) + + M_ Gamxzz[_t]*M_ gyzx [_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t])+ + M_ gupzz[_t]*( + 2*(M_ Gamxzz[_t]*M_ gxzz[_t]+ M_ Gamyzz[_t]*M_ gyzz[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]) + + M_ Gamxzz[_t]*M_ gzzx [_t]+ M_ Gamyzz[_t]*M_ gzzy[_t]+ M_ Gamzzz[_t]*M_ gzzz[_t]); + + M_ Rxy[_t]= HALF*( -M_ Rxy[_t] + + M_ gxx [_t]* M_ Gamxy[_t]+ M_ gxy[_t]* M_ Gamyy[_t]+M_ gxz[_t]* M_ Gamzy[_t] + + M_ gxy[_t]* M_ Gamxx [_t]+ M_ gyy[_t]* M_ Gamyx [_t]+M_ gyz[_t]* M_ Gamzx [_t] + + M_ Gamxa[_t]*M_ gxyx [_t]+ M_ Gamya[_t]*M_ gyyx [_t]+ M_ Gamza[_t]*M_ gyzx [_t] + + M_ Gamxa[_t]*M_ gxxy[_t]+ M_ Gamya[_t]*M_ gxyy[_t]+ M_ Gamza[_t]*M_ gxzy[_t])+ + M_ gupxx [_t]*( + M_ Gamxxx [_t]*M_ gxxy[_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gxxx [_t]+ M_ Gamyxy[_t]*M_ gxyx [_t]+ M_ Gamzxy[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gxyx [_t]+ M_ Gamyxx [_t]*M_ gxyy[_t]+ M_ Gamzxx [_t]*M_ gxyz[_t])+ + M_ gupxy[_t]*( + M_ Gamxxx [_t]*M_ gxyy[_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyzy[_t] + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gyyx [_t]+ M_ Gamzxy[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gxyx [_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxyz[_t] + + M_ Gamxxy[_t]*M_ gxxy[_t]+ M_ Gamyxy[_t]*M_ gxyy[_t]+ M_ Gamzxy[_t]*M_ gxzy[_t] + + M_ Gamxyy[_t]*M_ gxxx [_t]+ M_ Gamyyy[_t]*M_ gxyx [_t]+ M_ Gamzyy[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gyyx [_t]+ M_ Gamyxx [_t]*M_ gyyy[_t]+ M_ Gamzxx [_t]*M_ gyyz[_t])+ + M_ gupxz[_t]*( + M_ Gamxxx [_t]*M_ gxzy[_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gzzy[_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gyzx [_t]+ M_ Gamzxy[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxyz[_t] + + M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + + M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ + M_ gupyy[_t]*( + M_ Gamxxy[_t]*M_ gxyy[_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gxyx [_t]+ M_ Gamyyy[_t]*M_ gyyx [_t]+ M_ Gamzyy[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gyyx [_t]+ M_ Gamyxy[_t]*M_ gyyy[_t]+ M_ Gamzxy[_t]*M_ gyyz[_t])+ + M_ gupyz[_t]*( + M_ Gamxxy[_t]*M_ gxzy[_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gzzy[_t] + + M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gyzx [_t]+ M_ Gamzyy[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gyyx [_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyyz[_t] + + M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + + M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupzz[_t]*( + M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t]); + + M_ Rxz[_t]= HALF*( -M_ Rxz[_t] + + M_ gxx [_t]* M_ Gamxz[_t]+ M_ gxy[_t]* M_ Gamyz[_t]+M_ gxz[_t]* M_ Gamzz[_t] + + M_ gxz[_t]* M_ Gamxx [_t]+ M_ gyz[_t]* M_ Gamyx [_t]+M_ gzz[_t]* M_ Gamzx [_t] + + M_ Gamxa[_t]*M_ gxzx [_t]+ M_ Gamya[_t]*M_ gyzx [_t]+ M_ Gamza[_t]*M_ gzzx [_t] + + M_ Gamxa[_t]*M_ gxxz[_t]+ M_ Gamya[_t]*M_ gxyz[_t]+ M_ Gamza[_t]*M_ gxzz[_t])+ + M_ gupxx [_t]*( + M_ Gamxxx [_t]*M_ gxxz[_t]+ M_ Gamyxx [_t]*M_ gxyz[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gxxx [_t]+ M_ Gamyxz[_t]*M_ gxyx [_t]+ M_ Gamzxz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gxzx [_t]+ M_ Gamyxx [_t]*M_ gxzy[_t]+ M_ Gamzxx [_t]*M_ gxzz[_t])+ + M_ gupxy[_t]*( + M_ Gamxxx [_t]*M_ gxyz[_t]+ M_ Gamyxx [_t]*M_ gyyz[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t] + + M_ Gamxxz[_t]*M_ gxyx [_t]+ M_ Gamyxz[_t]*M_ gyyx [_t]+ M_ Gamzxz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + + M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + + M_ Gamxyz[_t]*M_ gxxx [_t]+ M_ Gamyyz[_t]*M_ gxyx [_t]+ M_ Gamzyz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gyzx [_t]+ M_ Gamyxx [_t]*M_ gyzy[_t]+ M_ Gamzxx [_t]*M_ gyzz[_t])+ + M_ gupxz[_t]*( + M_ Gamxxx [_t]*M_ gxzz[_t]+ M_ Gamyxx [_t]*M_ gyzz[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t] + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gyzx [_t]+ M_ Gamzxz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gxzx [_t]+ M_ Gamyxz[_t]*M_ gxzy[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gxxz[_t]+ M_ Gamyxz[_t]*M_ gxyz[_t]+ M_ Gamzxz[_t]*M_ gxzz[_t] + + M_ Gamxzz[_t]*M_ gxxx [_t]+ M_ Gamyzz[_t]*M_ gxyx [_t]+ M_ Gamzzz[_t]*M_ gxzx [_t] + + M_ Gamxxx [_t]*M_ gzzx [_t]+ M_ Gamyxx [_t]*M_ gzzy[_t]+ M_ Gamzxx [_t]*M_ gzzz[_t])+ + M_ gupyy[_t]*( + M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxyx [_t]+ M_ Gamyyz[_t]*M_ gyyx [_t]+ M_ Gamzyz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupyz[_t]*( + M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gyzx [_t]+ M_ Gamzyz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gyzx [_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + + M_ Gamxxz[_t]*M_ gxyz[_t]+ M_ Gamyxz[_t]*M_ gyyz[_t]+ M_ Gamzxz[_t]*M_ gyzz[_t] + + M_ Gamxzz[_t]*M_ gxyx [_t]+ M_ Gamyzz[_t]*M_ gyyx [_t]+ M_ Gamzzz[_t]*M_ gyzx [_t] + + M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ + M_ gupzz[_t]*( + M_ Gamxxz[_t]*M_ gxzz[_t]+ M_ Gamyxz[_t]*M_ gyzz[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxzx [_t]+ M_ Gamyzz[_t]*M_ gyzx [_t]+ M_ Gamzzz[_t]*M_ gzzx [_t] + + M_ Gamxxz[_t]*M_ gzzx [_t]+ M_ Gamyxz[_t]*M_ gzzy[_t]+ M_ Gamzxz[_t]*M_ gzzz[_t]); + + M_ Ryz[_t]= HALF*( -M_ Ryz[_t] + + M_ gxy[_t]* M_ Gamxz[_t]+M_ gyy[_t]* M_ Gamyz[_t]+M_ gyz[_t]* M_ Gamzz[_t] + + M_ gxz[_t]* M_ Gamxy[_t]+M_ gyz[_t]* M_ Gamyy[_t]+M_ gzz[_t]* M_ Gamzy[_t] + + M_ Gamxa[_t]*M_ gxzy[_t]+ M_ Gamya[_t]*M_ gyzy[_t]+ M_ Gamza[_t]*M_ gzzy[_t] + + M_ Gamxa[_t]*M_ gxyz[_t]+ M_ Gamya[_t]*M_ gyyz[_t]+ M_ Gamza[_t]*M_ gyzz[_t])+ + M_ gupxx [_t]*( + M_ Gamxxy[_t]*M_ gxxz[_t]+ M_ Gamyxy[_t]*M_ gxyz[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t] + + M_ Gamxxz[_t]*M_ gxxy[_t]+ M_ Gamyxz[_t]*M_ gxyy[_t]+ M_ Gamzxz[_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gxzx [_t]+ M_ Gamyxy[_t]*M_ gxzy[_t]+ M_ Gamzxy[_t]*M_ gxzz[_t])+ + M_ gupxy[_t]*( + M_ Gamxxy[_t]*M_ gxyz[_t]+ M_ Gamyxy[_t]*M_ gyyz[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t] + + M_ Gamxxz[_t]*M_ gxyy[_t]+ M_ Gamyxz[_t]*M_ gyyy[_t]+ M_ Gamzxz[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gxzx [_t]+ M_ Gamyyy[_t]*M_ gxzy[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + + M_ Gamxyy[_t]*M_ gxxz[_t]+ M_ Gamyyy[_t]*M_ gxyz[_t]+ M_ Gamzyy[_t]*M_ gxzz[_t] + + M_ Gamxyz[_t]*M_ gxxy[_t]+ M_ Gamyyz[_t]*M_ gxyy[_t]+ M_ Gamzyz[_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gyzx [_t]+ M_ Gamyxy[_t]*M_ gyzy[_t]+ M_ Gamzxy[_t]*M_ gyzz[_t])+ + M_ gupxz[_t]*( + M_ Gamxxy[_t]*M_ gxzz[_t]+ M_ Gamyxy[_t]*M_ gyzz[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t] + + M_ Gamxxz[_t]*M_ gxzy[_t]+ M_ Gamyxz[_t]*M_ gyzy[_t]+ M_ Gamzxz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gxzx [_t]+ M_ Gamyyz[_t]*M_ gxzy[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + + M_ Gamxyz[_t]*M_ gxxz[_t]+ M_ Gamyyz[_t]*M_ gxyz[_t]+ M_ Gamzyz[_t]*M_ gxzz[_t] + + M_ Gamxzz[_t]*M_ gxxy[_t]+ M_ Gamyzz[_t]*M_ gxyy[_t]+ M_ Gamzzz[_t]*M_ gxzy[_t] + + M_ Gamxxy[_t]*M_ gzzx [_t]+ M_ Gamyxy[_t]*M_ gzzy[_t]+ M_ Gamzxy[_t]*M_ gzzz[_t])+ + M_ gupyy[_t]*( + M_ Gamxyy[_t]*M_ gxyz[_t]+ M_ Gamyyy[_t]*M_ gyyz[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxyy[_t]+ M_ Gamyyz[_t]*M_ gyyy[_t]+ M_ Gamzyz[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gyzx [_t]+ M_ Gamyyy[_t]*M_ gyzy[_t]+ M_ Gamzyy[_t]*M_ gyzz[_t])+ + M_ gupyz[_t]*( + M_ Gamxyy[_t]*M_ gxzz[_t]+ M_ Gamyyy[_t]*M_ gyzz[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t] + + M_ Gamxyz[_t]*M_ gxzy[_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gyzx [_t]+ M_ Gamyyz[_t]*M_ gyzy[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + + M_ Gamxyz[_t]*M_ gxyz[_t]+ M_ Gamyyz[_t]*M_ gyyz[_t]+ M_ Gamzyz[_t]*M_ gyzz[_t] + + M_ Gamxzz[_t]*M_ gxyy[_t]+ M_ Gamyzz[_t]*M_ gyyy[_t]+ M_ Gamzzz[_t]*M_ gyzy[_t] + + M_ Gamxyy[_t]*M_ gzzx [_t]+ M_ Gamyyy[_t]*M_ gzzy[_t]+ M_ Gamzyy[_t]*M_ gzzz[_t])+ + M_ gupzz[_t]*( + M_ Gamxyz[_t]*M_ gxzz[_t]+ M_ Gamyyz[_t]*M_ gyzz[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t] + + M_ Gamxzz[_t]*M_ gxzy[_t]+ M_ Gamyzz[_t]*M_ gyzy[_t]+ M_ Gamzzz[_t]*M_ gzzy[_t] + + M_ Gamxyz[_t]*M_ gzzx [_t]+ M_ Gamyyz[_t]*M_ gzzy[_t]+ M_ Gamzyz[_t]*M_ gzzz[_t]); + + _t += STEP_SIZE; + } +} +__global__ void compute_rhs_ss_part5() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx [_t]* M_ chix [_t]- M_ Gamyxx [_t]* M_ chiy[_t]- M_ Gamzxx [_t]* M_ chiz[_t]; + M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]* M_ chix [_t]- M_ Gamyxy[_t]* M_ chiy[_t]- M_ Gamzxy[_t]* M_ chiz[_t]; + M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]* M_ chix [_t]- M_ Gamyxz[_t]* M_ chiy[_t]- M_ Gamzxz[_t]* M_ chiz[_t]; + M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]* M_ chix [_t]- M_ Gamyyy[_t]* M_ chiy[_t]- M_ Gamzyy[_t]* M_ chiz[_t]; + M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]* M_ chix [_t]- M_ Gamyyz[_t]* M_ chiy[_t]- M_ Gamzyz[_t]* M_ chiz[_t]; + M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]* M_ chix [_t]- M_ Gamyzz[_t]* M_ chiy[_t]- M_ Gamzzz[_t]* M_ chiz[_t]; + // M_ Store D^l D_l M_ chi - 3/(2*M_ chi) D^l M_ chi D_l M_ chi inM_ f[_t] + + M_ f[_t] = M_ gupxx [_t]* (M_ fxx [_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chix [_t]) + + M_ gupyy[_t]* (M_ fyy[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiy[_t]) + + M_ gupzz[_t]* (M_ fzz[_t]- F3o2/M_ chin1[_t] * M_ chiz[_t]* M_ chiz[_t]) + + 2 *M_ gupxy[_t]* (M_ fxy[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiy[_t]) + + 2 *M_ gupxz[_t]* (M_ fxz[_t]- F3o2/M_ chin1[_t] * M_ chix [_t]* M_ chiz[_t]) + + 2 *M_ gupyz[_t]* (M_ fyz[_t]- F3o2/M_ chin1[_t] * M_ chiy[_t]* M_ chiz[_t]); + // M_ Add M_ chi part toM_ Ricci tensor: + + M_ Rxx [_t]=M_ Rxx [_t]+ (M_ fxx [_t]- M_ chix[_t]*M_ chix[_t]/M_ chin1[_t]/2 +M_ gxx [_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Ryy[_t]=M_ Ryy[_t]+ (M_ fyy[_t]- M_ chiy[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gyy[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Rzz[_t]=M_ Rzz[_t]+ (M_ fzz[_t]- M_ chiz[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gzz[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Rxy[_t]=M_ Rxy[_t]+ (M_ fxy[_t]- M_ chix[_t]*M_ chiy[_t]/M_ chin1[_t]/2 +M_ gxy[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Rxz[_t]=M_ Rxz[_t]+ (M_ fxz[_t]- M_ chix[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gxz[_t]*M_ f[_t])/M_ chin1[_t]/2; + M_ Ryz[_t]=M_ Ryz[_t]+ (M_ fyz[_t]- M_ chiy[_t]*M_ chiz[_t]/M_ chin1[_t]/2 +M_ gyz[_t]*M_ f[_t])/M_ chin1[_t]/2; + + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_ss_part6() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ gxxx [_t]= (M_ gupxx [_t]* M_ chix [_t]+M_ gupxy[_t]* M_ chiy[_t]+M_ gupxz[_t]* M_ chiz[_t])/M_ chin1[_t]; + M_ gxxy[_t]= (M_ gupxy[_t]* M_ chix [_t]+M_ gupyy[_t]* M_ chiy[_t]+M_ gupyz[_t]* M_ chiz[_t])/M_ chin1[_t]; + M_ gxxz[_t]= (M_ gupxz[_t]* M_ chix [_t]+M_ gupyz[_t]* M_ chiy[_t]+M_ gupzz[_t]* M_ chiz[_t])/M_ chin1[_t]; + // nowM_ get physical second kind of connection + M_ Gamxxx [_t]= M_ Gamxxx [_t]- ( (M_ chix [_t]+ M_ chix[_t])/M_ chin1[_t] -M_ gxx [_t]*M_ gxxx [_t])*HALF; + M_ Gamyxx [_t]= M_ Gamyxx [_t]- ( -M_ gxx [_t]*M_ gxxy[_t])*HALF; + M_ Gamzxx [_t]= M_ Gamzxx [_t]- ( -M_ gxx [_t]*M_ gxxz[_t])*HALF; + M_ Gamxyy[_t]= M_ Gamxyy[_t]- ( -M_ gyy[_t]*M_ gxxx [_t])*HALF; + M_ Gamyyy[_t]= M_ Gamyyy[_t]- ( (M_ chiy[_t]+ M_ chiy[_t])/M_ chin1[_t] -M_ gyy[_t]*M_ gxxy[_t])*HALF; + M_ Gamzyy[_t]= M_ Gamzyy[_t]- ( -M_ gyy[_t]*M_ gxxz[_t])*HALF; + M_ Gamxzz[_t]= M_ Gamxzz[_t]- ( -M_ gzz[_t]*M_ gxxx [_t])*HALF; + M_ Gamyzz[_t]= M_ Gamyzz[_t]- ( -M_ gzz[_t]*M_ gxxy[_t])*HALF; + M_ Gamzzz[_t]= M_ Gamzzz[_t]- ( (M_ chiz[_t]+ M_ chiz[_t])/M_ chin1[_t] -M_ gzz[_t]*M_ gxxz[_t])*HALF; + M_ Gamxxy[_t]= M_ Gamxxy[_t]- ( M_ chiy[_t] /M_ chin1[_t] -M_ gxy[_t]*M_ gxxx [_t])*HALF; + M_ Gamyxy[_t]= M_ Gamyxy[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxy[_t]*M_ gxxy[_t])*HALF; + M_ Gamzxy[_t]= M_ Gamzxy[_t]- ( -M_ gxy[_t]*M_ gxxz[_t])*HALF; + M_ Gamxxz[_t]= M_ Gamxxz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gxz[_t]*M_ gxxx [_t])*HALF; + M_ Gamyxz[_t]= M_ Gamyxz[_t]- ( -M_ gxz[_t]*M_ gxxy[_t])*HALF; + M_ Gamzxz[_t]= M_ Gamzxz[_t]- ( M_ chix [_t]/M_ chin1[_t] -M_ gxz[_t]*M_ gxxz[_t])*HALF; + M_ Gamxyz[_t]= M_ Gamxyz[_t]- ( -M_ gyz[_t]*M_ gxxx [_t])*HALF; + M_ Gamyyz[_t]= M_ Gamyyz[_t]- ( M_ chiz[_t] /M_ chin1[_t] -M_ gyz[_t]*M_ gxxy[_t])*HALF; + M_ Gamzyz[_t]= M_ Gamzyz[_t]- ( M_ chiy[_t]/M_ chin1[_t] -M_ gyz[_t]*M_ gxxz[_t])*HALF; + + M_ fxx [_t]=M_ fxx [_t]- M_ Gamxxx[_t]*M_ Lapx [_t]- M_ Gamyxx[_t]*M_ Lapy[_t]- M_ Gamzxx[_t]*M_ Lapz[_t]; + M_ fyy[_t]=M_ fyy[_t]- M_ Gamxyy[_t]*M_ Lapx [_t]- M_ Gamyyy[_t]*M_ Lapy[_t]- M_ Gamzyy[_t]*M_ Lapz[_t]; + M_ fzz[_t]=M_ fzz[_t]- M_ Gamxzz[_t]*M_ Lapx [_t]- M_ Gamyzz[_t]*M_ Lapy[_t]- M_ Gamzzz[_t]*M_ Lapz[_t]; + M_ fxy[_t]=M_ fxy[_t]- M_ Gamxxy[_t]*M_ Lapx [_t]- M_ Gamyxy[_t]*M_ Lapy[_t]- M_ Gamzxy[_t]*M_ Lapz[_t]; + M_ fxz[_t]=M_ fxz[_t]- M_ Gamxxz[_t]*M_ Lapx [_t]- M_ Gamyxz[_t]*M_ Lapy[_t]- M_ Gamzxz[_t]*M_ Lapz[_t]; + M_ fyz[_t]=M_ fyz[_t]- M_ Gamxyz[_t]*M_ Lapx [_t]- M_ Gamyyz[_t]*M_ Lapy[_t]- M_ Gamzyz[_t]*M_ Lapz[_t]; + + // store D^i D_i Lap in M_ trK_rhs[_t] upto M_ chi + M_ trK_rhs[_t] = M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ + 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]); + // M_ Add lapse and M_ S_ij parts toM_ Ricci tensor: + + M_ fxx [_t]= M_ alpn1[_t]* (M_ Rxx [_t]- 8 * PI * M_ Sxx[_t]) -M_ fxx[_t]; + M_ fxy[_t]= M_ alpn1[_t]* (M_ Rxy[_t]- 8 * PI * M_ Sxy[_t]) -M_ fxy[_t]; + M_ fxz[_t]= M_ alpn1[_t]* (M_ Rxz[_t]- 8 * PI * M_ Sxz[_t]) -M_ fxz[_t]; + M_ fyy[_t]= M_ alpn1[_t]* (M_ Ryy[_t]- 8 * PI * M_ Syy[_t]) -M_ fyy[_t]; + M_ fyz[_t]= M_ alpn1[_t]* (M_ Ryz[_t]- 8 * PI * M_ Syz[_t]) -M_ fyz[_t]; + M_ fzz[_t]= M_ alpn1[_t]* (M_ Rzz[_t]- 8 * PI * M_ Szz[_t]) -M_ fzz[_t]; + + // Compute trace-free part (note: M_ chi^-1 and M_ chi cancel//): + + M_ f[_t] = F1o3 *( M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t]+ + 2* (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) ); + + M_ Axx_rhs[_t] =M_ fxx [_t]-M_ gxx [_t]*M_ f[_t]; + M_ Ayy_rhs[_t] =M_ fyy[_t]-M_ gyy[_t]*M_ f[_t]; + M_ Azz_rhs[_t] =M_ fzz[_t]-M_ gzz[_t]*M_ f[_t]; + M_ Axy_rhs[_t] =M_ fxy[_t]-M_ gxy[_t]*M_ f[_t]; + M_ Axz_rhs[_t] =M_ fxz[_t]-M_ gxz[_t]*M_ f[_t]; + M_ Ayz_rhs[_t] =M_ fyz[_t]-M_ gyz[_t]*M_ f[_t]; + + // Now: store M_ A_il M_ A^l_j intoM_ fij: + + M_ fxx [_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]); + + M_ fyy[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]); + + M_ fzz[_t]= M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]); + + M_ fxy[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ + M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + + M_ gupxz[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + + M_ gupyz[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]); + M_ fxz[_t]= M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]*(M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]*(M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]); + M_ fyz[_t]= M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]*(M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]*(M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]*(M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]); + + M_ f[_t] = M_ chin1[_t]; + // store D^i D_i Lap in M_ trK_rhs[_t] + M_ trK_rhs[_t] =M_ f[_t]*M_ trK_rhs[_t]; + + M_ Axx_rhs[_t] = M_ f[_t] * M_ Axx_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Axx [_t]- 2 *M_ fxx[_t]) + + 2 * ( M_ Axx [_t]* M_ betaxx [_t]+ M_ Axy[_t]* M_ betayx [_t]+ M_ Axz[_t]* M_ betazx [_t])- + F2o3 * M_ Axx [_t]* M_ div_beta[_t]; + + M_ Ayy_rhs[_t] = M_ f[_t] * M_ Ayy_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Ayy[_t]- 2 *M_ fyy[_t]) + + 2 * ( M_ Axy[_t]* M_ betaxy[_t]+ M_ Ayy[_t]* M_ betayy[_t]+ M_ Ayz[_t]* M_ betazy[_t])- + F2o3 * M_ Ayy[_t]* M_ div_beta[_t]; + + M_ Azz_rhs[_t] = M_ f[_t] * M_ Azz_rhs[_t]+ M_ alpn1[_t]* (M_ trK[_t]* M_ Azz[_t]- 2 *M_ fzz[_t]) + + 2 * ( M_ Axz[_t]* M_ betaxz[_t]+ M_ Ayz[_t]* M_ betayz[_t]+ M_ Azz[_t]* M_ betazz[_t])- + F2o3 * M_ Azz[_t]* M_ div_beta[_t]; + + M_ Axy_rhs[_t] = M_ f[_t] * M_ Axy_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axy[_t] - 2 *M_ fxy[_t])+ + M_ Axx [_t]* M_ betaxy[_t] + M_ Axz[_t]* M_ betazy[_t] + + M_ Ayy[_t]* M_ betayx [_t]+ M_ Ayz[_t]* M_ betazx [_t] + + F1o3 * M_ Axy[_t]* M_ div_beta[_t] - M_ Axy[_t]* M_ betazz[_t]; + + M_ Ayz_rhs[_t] = M_ f[_t] * M_ Ayz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Ayz[_t] - 2 *M_ fyz[_t])+ + M_ Axy[_t]* M_ betaxz[_t]+ M_ Ayy[_t]* M_ betayz[_t] + + M_ Axz[_t]* M_ betaxy[_t] + M_ Azz[_t]* M_ betazy[_t] + + F1o3 * M_ Ayz[_t]* M_ div_beta[_t] - M_ Ayz[_t]* M_ betaxx[_t]; + + M_ Axz_rhs[_t] = M_ f[_t] * M_ Axz_rhs[_t]+ M_ alpn1[_t]*( M_ trK[_t]* M_ Axz[_t] - 2 *M_ fxz[_t])+ + M_ Axx [_t]* M_ betaxz[_t]+ M_ Axy[_t]* M_ betayz[_t] + + M_ Ayz[_t]* M_ betayx [_t]+ M_ Azz[_t]* M_ betazx [_t] + + F1o3 * M_ Axz[_t]* M_ div_beta[_t] - M_ Axz[_t]* M_ betayy[_t] ; //rhsM_ for M_ Aij + + // Compute trace of M_ S_ij + + M_ S[_t] = M_ f[_t] * (M_ gupxx [_t]* M_ Sxx [_t]+M_ gupyy[_t]* M_ Syy[_t]+M_ gupzz[_t]* M_ Szz[_t]+ + 2 * (M_ gupxy[_t]* M_ Sxy[_t]+M_ gupxz[_t]* M_ Sxz[_t]+M_ gupyz[_t]* M_ Syz[_t]) ); + + M_ trK_rhs[_t] = - M_ trK_rhs[_t] + M_ alpn1[_t]*( F1o3 * M_ trK[_t]* M_ trK[_t] + + M_ gupxx [_t]*M_ fxx [_t]+M_ gupyy[_t]*M_ fyy[_t]+M_ gupzz[_t]*M_ fzz[_t] + + 2 * (M_ gupxy[_t]*M_ fxy[_t]+M_ gupxz[_t]*M_ fxz[_t]+M_ gupyz[_t]*M_ fyz[_t]) + + 4 * PI * ( M_ rho[_t] + M_ S[_t] )) ; //rhsM_ for M_ trK[_t] + + ////////M_ gauge variable part + + M_ Lap_rhs[_t] = -2*M_ alpn1[_t] * M_ trK[_t]; + +#if (GAUGE == 0) + M_ betax_rhs[_t] =0.75*M_ dtSfx[_t]; + M_ betay_rhs[_t] =0.75*M_ dtSfy[_t]; + M_ betaz_rhs[_t] =0.75*M_ dtSfz[_t]; + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] -2*M_ dtSfx[_t]; + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] -2*M_ dtSfy[_t]; + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] -2*M_ dtSfz[_t]; + +#elif (GAUGE == 1) + M_ betax_rhs[_t] =M_ Gamx[_t] - 2 * M_ betax[_t] ; + + M_ betay_rhs[_t] =M_ Gamy[_t] - 2 * M_ betay[_t] ; + + M_ betaz_rhs[_t] =M_ Gamz[_t] - 2 * M_ betaz[_t] ; + + M_ dtSfx_rhs[_t] = 0; + M_ dtSfy_rhs[_t] = 0; + M_ dtSfz_rhs[_t] = 0; + +#elif (GAUGE == 2 || GAUGE == 3) + + M_ betax_rhs[_t] = 0.75* M_ dtSfx[_t]; + + M_ betay_rhs[_t] = 0.75* M_ dtSfy[_t]; + + M_ betaz_rhs[_t] = 0.75* M_ dtSfz[_t]; + +#elif (GAUGE == 6) + if(BHN==2) + { + int k = _t / _2D_SIZE[0]; + int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + r1 = ( pow2((Porg[0]-X[i]))+ pow2((Porg[1]-Y[j]))+ pow2((Porg[2]-Z[k])) ) / + + ( pow2((Porg[0]-Porg[3]))+ pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ + + ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + reta[i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1/(1 + 12 * r1) + C2/(1 + 12 *r2); + }//BHN == 2 + + M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; + + M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; + + M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; + + + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t] * M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t] * M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t] * M_ dtSfz[_t]; + +#elif (GAUGE == 7) + if(BHN==2){ + int k = _t / _2D_SIZE[0]; + int ps = _t - (_2D_SIZE[0] * k); //TOTRY: = curr % _2D_SIZE[0]; + int j = ps / ex_c[0]; + int i = ps - (j * ex_c[0]); + + r1 = ( pow2((Porg[0]-X[i])) + pow2((Porg[1]-Y[j])) + pow2((Porg[2]-Z[k])) )/ + + ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + r2 = ( pow2((Porg[3]-X[i])) + pow2((Porg[4]-Y[j])) + pow2((Porg[5]-Z[k])) )/ + + ( pow2((Porg[0]-Porg[3])) + pow2((Porg[1]-Porg[4])) + pow2((Porg[2]-Porg[5])) ); + + + M_ reta[_t][i+ j*_1D_SIZE[0]+ k*_2D_SIZE[0] ] = A + C1* exp(-12 *r1) + C2*exp(- 12*r2); + }//BHN ==2 + + M_ betax_rhs[_t] = 0.75*M_ dtSfx[_t]; + + M_ betay_rhs[_t] = 0.75*M_ dtSfy[_t]; + + M_ betaz_rhs[_t] = 0.75*M_ dtSfz[_t]; + + + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]*M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]*M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]*M_ dtSfz[_t]; + +#endif //if (GAUGE == ?) + + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_bssn_ss_part6_gauge() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { +#if (GAUGE == 2) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow2( ( 1-sqrt(M_ chin1[_t]) ) ); + + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; + +#elif (GAUGE == 3) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13/2 * sqrt( M_ reta[_t]/ M_ chin1[_t])/ pow2((1-M_ chin1[_t])); + + M_ dtSfx_rhs[_t] = M_ Gamx_rhs[_t] - M_ reta[_t]* M_ dtSfx[_t]; + + M_ dtSfy_rhs[_t] = M_ Gamy_rhs[_t] - M_ reta[_t]* M_ dtSfy[_t]; + + M_ dtSfz_rhs[_t] = M_ Gamz_rhs[_t] - M_ reta[_t]* M_ dtSfz[_t]; + +#elif (GAUGE == 4) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * + M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * + M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1[_t])/ pow( (1-sqrt(M_ chin1[_t]))); + + + M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; + + M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; + + M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; + +#elif (GAUGE == 5) + M_ reta[_t] = M_ gupxx[_t] * M_ dtSfx_rhs[_t] * M_ dtSfx_rhs[_t] + M_ gupyy[_t] * M_ dtSfy_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupzz[_t] * M_ dtSfz_rhs[_t] * M_ dtSfz_rhs[_t] + + + 2 * ( M_ gupxy[_t] * M_ dtSfx_rhs[_t] * M_ dtSfy_rhs[_t] + M_ gupxz[_t] * M_ dtSfx_rhs[_t] * M_ dtSfz_rhs[_t] + M_ gupyz[_t] * M_ dtSfy_rhs[_t] * M_ dtSfz_rhs[_t]); + + + M_ reta[_t] = 1.13 / 2 * sqrt( M_ reta[_t]/M_ chin1)/ pow( (1-M_ chin1[_t]) ); + + M_ betax_rhs[_t] = 0.75* M_ Gamx[_t] - M_ reta[_t]*M_ betax[_t]; + + M_ betay_rhs[_t] = 0.75* M_ Gamy[_t] - M_ reta[_t]*M_ betay[_t]; + + M_ betaz_rhs[_t] = 0.75* M_ Gamz[_t] - M_ reta[_t]*M_ betaz[_t]; + + + + M_ dtSfx_rhs[_t] = 0; + + M_ dtSfy_rhs[_t] = 0; + + M_ dtSfz_rhs[_t] = 0; +#endif + _t += STEP_SIZE; + } +} + +__global__ void compute_rhs_ss_part7() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ ham_Res[_t] = M_ gupxx [_t]* M_ Rxx [_t]+ M_ gupyy[_t]* M_ Ryy[_t]+ M_ gupzz[_t]* M_ Rzz[_t]+ + 2* ( M_ gupxy[_t]* M_ Rxy[_t]+ M_ gupxz[_t]* M_ Rxz[_t]+ M_ gupyz[_t]* M_ Ryz[_t]); + + M_ ham_Res[_t] = M_ chin1[_t]*M_ ham_Res[_t] + F2o3 * M_ trK[_t] * M_ trK[_t] -( + M_ gupxx [_t]* ( + M_ gupxx [_t]* M_ Axx [_t]* M_ Axx [_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Axz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupxz[_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyz[_t]* M_ Axy[_t]* M_ Axz[_t]) ) + + M_ gupyy[_t]* ( + M_ gupxx [_t]* M_ Axy[_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupxz[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupyz[_t]* M_ Ayy[_t]* M_ Ayz[_t]) ) + + M_ gupzz[_t]* ( + M_ gupxx [_t]* M_ Axz[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayz[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Azz[_t]* M_ Azz[_t]+ + 2 * (M_ gupxy[_t]* M_ Axz[_t]* M_ Ayz[_t]+ M_ gupxz[_t]* M_ Axz[_t]* M_ Azz[_t]+ M_ gupyz[_t]* M_ Ayz[_t]* M_ Azz[_t]) ) + + 2 * ( + M_ gupxy[_t]* ( + M_ gupxx [_t]* M_ Axx [_t]* M_ Axy[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayy[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Ayz[_t]+ + M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayy[_t]+ M_ Axy[_t]* M_ Axy[_t]) + + M_ gupxz[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Axy[_t]) + + M_ gupyz[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Axz[_t]* M_ Ayy[_t]) ) + + M_ gupxz[_t]* ( + M_ gupxx [_t]* M_ Axx [_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Axy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Axz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]* (M_ Axx [_t]* M_ Ayz[_t]+ M_ Axy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]* (M_ Axx [_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Axz[_t]* M_ Ayz[_t]) ) + + M_ gupyz[_t]* ( + M_ gupxx [_t]* M_ Axy[_t]* M_ Axz[_t]+ M_ gupyy[_t]* M_ Ayy[_t]* M_ Ayz[_t]+ M_ gupzz[_t]* M_ Ayz[_t]* M_ Azz[_t]+ + M_ gupxy[_t]* (M_ Axy[_t]* M_ Ayz[_t]+ M_ Ayy[_t]* M_ Axz[_t]) + + M_ gupxz[_t]* (M_ Axy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Axz[_t]) + + M_ gupyz[_t]* (M_ Ayy[_t]* M_ Azz[_t]+ M_ Ayz[_t]* M_ Ayz[_t]) ) ))- 16 * PI * M_ rho[_t]; + + _t += STEP_SIZE; + } +} +__global__ void compute_rhs_ss_part8() +{ + int _t = blockIdx.x*blockDim.x+threadIdx.x; + while(_t < _3D_SIZE[0]) + { + M_ gxxx [_t]= M_ gxxx [_t]- ( M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t] + + M_ Gamxxx [_t]* M_ Axx [_t]+ M_ Gamyxx [_t]* M_ Axy[_t]+ M_ Gamzxx [_t]* M_ Axz[_t]) - M_ chix[_t]*M_ Axx[_t]/M_ chin1[_t]; + + M_ gxyx [_t]= M_ gxyx [_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] + + M_ Gamxxx [_t]* M_ Axy[_t]+ M_ Gamyxx [_t]* M_ Ayy[_t]+ M_ Gamzxx [_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Axy[_t]/M_ chin1[_t]; + + M_ gxzx [_t]= M_ gxzx [_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] + + M_ Gamxxx [_t]* M_ Axz[_t]+ M_ Gamyxx [_t]* M_ Ayz[_t]+ M_ Gamzxx [_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Axz[_t]/M_ chin1[_t]; + + M_ gyyx [_t]= M_ gyyx [_t]- ( M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t] + + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chix[_t]*M_ Ayy[_t]/M_ chin1[_t]; + + M_ gyzx [_t]= M_ gyzx [_t]- ( M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t] + + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Ayz[_t]/M_ chin1[_t]; + + M_ gzzx [_t]= M_ gzzx [_t]- ( M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t] + + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chix[_t]*M_ Azz[_t]/M_ chin1[_t]; + + M_ gxxy[_t]= M_ gxxy[_t]- ( M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t] + + M_ Gamxxy[_t]* M_ Axx [_t]+ M_ Gamyxy[_t]* M_ Axy[_t]+ M_ Gamzxy[_t]* M_ Axz[_t]) - M_ chiy[_t]*M_ Axx[_t]/M_ chin1[_t]; + + M_ gxyy[_t]= M_ gxyy[_t]- ( M_ Gamxyy[_t]* M_ Axx [_t]+ M_ Gamyyy[_t]* M_ Axy[_t]+ M_ Gamzyy[_t]* M_ Axz[_t] + + M_ Gamxxy[_t]* M_ Axy[_t]+ M_ Gamyxy[_t]* M_ Ayy[_t]+ M_ Gamzxy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Axy[_t]/M_ chin1[_t]; + + M_ gxzy[_t]= M_ gxzy[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] + + M_ Gamxxy[_t]* M_ Axz[_t]+ M_ Gamyxy[_t]* M_ Ayz[_t]+ M_ Gamzxy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Axz[_t]/M_ chin1[_t]; + + M_ gyyy[_t]= M_ gyyy[_t]- ( M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t] + + M_ Gamxyy[_t]* M_ Axy[_t]+ M_ Gamyyy[_t]* M_ Ayy[_t]+ M_ Gamzyy[_t]* M_ Ayz[_t]) - M_ chiy[_t]*M_ Ayy[_t]/M_ chin1[_t]; + + M_ gyzy[_t]= M_ gyzy[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] + + M_ Gamxyy[_t]* M_ Axz[_t]+ M_ Gamyyy[_t]* M_ Ayz[_t]+ M_ Gamzyy[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Ayz[_t]/M_ chin1[_t]; + + M_ gzzy[_t]= M_ gzzy[_t]- ( M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t] + + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiy[_t]*M_ Azz[_t]/M_ chin1[_t]; + + M_ gxxz[_t]= M_ gxxz[_t]- ( M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t] + + M_ Gamxxz[_t]* M_ Axx [_t]+ M_ Gamyxz[_t]* M_ Axy[_t]+ M_ Gamzxz[_t]* M_ Axz[_t]) - M_ chiz[_t]*M_ Axx[_t]/M_ chin1[_t]; + + M_ gxyz[_t]= M_ gxyz[_t]- ( M_ Gamxyz[_t]* M_ Axx [_t]+ M_ Gamyyz[_t]* M_ Axy[_t]+ M_ Gamzyz[_t]* M_ Axz[_t] + + M_ Gamxxz[_t]* M_ Axy[_t]+ M_ Gamyxz[_t]* M_ Ayy[_t]+ M_ Gamzxz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Axy[_t]/M_ chin1[_t]; + + M_ gxzz[_t]= M_ gxzz[_t]- ( M_ Gamxzz[_t]* M_ Axx [_t]+ M_ Gamyzz[_t]* M_ Axy[_t]+ M_ Gamzzz[_t]* M_ Axz[_t] + + M_ Gamxxz[_t]* M_ Axz[_t]+ M_ Gamyxz[_t]* M_ Ayz[_t]+ M_ Gamzxz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Axz[_t]/M_ chin1[_t]; + + M_ gyyz[_t]= M_ gyyz[_t]- ( M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t] + + M_ Gamxyz[_t]* M_ Axy[_t]+ M_ Gamyyz[_t]* M_ Ayy[_t]+ M_ Gamzyz[_t]* M_ Ayz[_t]) - M_ chiz[_t]*M_ Ayy[_t]/M_ chin1[_t]; + + M_ gyzz[_t]= M_ gyzz[_t]- ( M_ Gamxzz[_t]* M_ Axy[_t]+ M_ Gamyzz[_t]* M_ Ayy[_t]+ M_ Gamzzz[_t]* M_ Ayz[_t] + + M_ Gamxyz[_t]* M_ Axz[_t]+ M_ Gamyyz[_t]* M_ Ayz[_t]+ M_ Gamzyz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Ayz[_t]/M_ chin1[_t]; + + M_ gzzz[_t]= M_ gzzz[_t]- ( M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t] + + M_ Gamxzz[_t]* M_ Axz[_t]+ M_ Gamyzz[_t]* M_ Ayz[_t]+ M_ Gamzzz[_t]* M_ Azz[_t]) - M_ chiz[_t]*M_ Azz[_t]/M_ chin1[_t]; + + M_ movx_Res[_t] = M_ gupxx[_t]*M_ gxxx [_t]+ M_ gupyy[_t]*M_ gxyy[_t]+ M_ gupzz[_t]*M_ gxzz[_t] + +M_ gupxy[_t]*M_ gxyx [_t]+ M_ gupxz[_t]*M_ gxzx [_t]+ M_ gupyz[_t]*M_ gxzy[_t] + +M_ gupxy[_t]*M_ gxxy[_t]+ M_ gupxz[_t]*M_ gxxz[_t]+ M_ gupyz[_t]*M_ gxyz[_t]; + M_ movy_Res[_t] = M_ gupxx[_t]*M_ gxyx [_t]+ M_ gupyy[_t]*M_ gyyy[_t]+ M_ gupzz[_t]*M_ gyzz[_t] + +M_ gupxy[_t]*M_ gyyx [_t]+ M_ gupxz[_t]*M_ gyzx [_t]+ M_ gupyz[_t]*M_ gyzy[_t] + +M_ gupxy[_t]*M_ gxyy[_t]+ M_ gupxz[_t]*M_ gxyz[_t]+ M_ gupyz[_t]*M_ gyyz[_t]; + + M_ movz_Res[_t] = M_ gupxx[_t]*M_ gxzx [_t]+ M_ gupyy[_t]*M_ gyzy[_t]+ M_ gupzz[_t]*M_ gzzz[_t] + +M_ gupxy[_t]*M_ gyzx [_t]+ M_ gupxz[_t]*M_ gzzx [_t]+ M_ gupyz[_t]*M_ gzzy[_t] + +M_ gupxy[_t]*M_ gxzy[_t]+ M_ gupxz[_t]*M_ gxzz[_t]+ M_ gupyz[_t]*M_ gyzz[_t]; + + M_ movx_Res[_t] = M_ movx_Res[_t] - F2o3*M_ Kx [_t]- 8*PI*M_ Sx[_t]; + M_ movy_Res[_t] = M_ movy_Res[_t] - F2o3*M_ Ky[_t]- 8*PI*M_ Sy[_t]; + M_ movz_Res[_t] = M_ movz_Res[_t] - F2o3*M_ Kz[_t]- 8*PI*M_ Sz[_t]; + + _t += STEP_SIZE; + } +} + +void destroy_meta(Meta *meta,Metass *metass) +{ + if(Mh_ X) cudaFree(Mh_ X); + if(Mh_ Y) cudaFree(Mh_ Y); + if(Mh_ Z) cudaFree(Mh_ Z); + if(Mh_ chi) cudaFree(Mh_ chi); + if(Mh_ dxx) cudaFree(Mh_ dxx); + if(Mh_ dyy) cudaFree(Mh_ dyy); + if(Mh_ dzz) cudaFree(Mh_ dzz); + if(Mh_ trK) cudaFree(Mh_ trK); + if(Mh_ gxy) cudaFree(Mh_ gxy); + if(Mh_ gxz) cudaFree(Mh_ gxz); + if(Mh_ gyz) cudaFree(Mh_ gyz); + if(Mh_ Axx) cudaFree(Mh_ Axx); + if(Mh_ Axy) cudaFree(Mh_ Axy); + if(Mh_ Axz) cudaFree(Mh_ Axz); + if(Mh_ Ayz) cudaFree(Mh_ Ayz); + if(Mh_ Ayy) cudaFree(Mh_ Ayy); + if(Mh_ Azz) cudaFree(Mh_ Azz); + if(Mh_ Gamx) cudaFree(Mh_ Gamx); + if(Mh_ Gamy) cudaFree(Mh_ Gamy); + if(Mh_ Gamz) cudaFree(Mh_ Gamz); + if(Mh_ Lap) cudaFree(Mh_ Lap); + if(Mh_ betax) cudaFree(Mh_ betax); + if(Mh_ betay) cudaFree(Mh_ betay); + if(Mh_ betaz) cudaFree(Mh_ betaz); + if(Mh_ dtSfx) cudaFree(Mh_ dtSfx); + if(Mh_ dtSfy) cudaFree(Mh_ dtSfy); + if(Mh_ dtSfz) cudaFree(Mh_ dtSfz); + if(Mh_ chi_rhs) cudaFree(Mh_ chi_rhs); + if(Mh_ trK_rhs) cudaFree(Mh_ trK_rhs); + if(Mh_ gxy_rhs) cudaFree(Mh_ gxy_rhs); + if(Mh_ gxz_rhs) cudaFree(Mh_ gxz_rhs); + if(Mh_ gyz_rhs) cudaFree(Mh_ gyz_rhs); + if(Mh_ Axx_rhs) cudaFree(Mh_ Axx_rhs); + if(Mh_ Axy_rhs) cudaFree(Mh_ Axy_rhs); + if(Mh_ Axz_rhs) cudaFree(Mh_ Axz_rhs); + if(Mh_ Ayz_rhs) cudaFree(Mh_ Ayz_rhs); + if(Mh_ Ayy_rhs) cudaFree(Mh_ Ayy_rhs); + if(Mh_ Azz_rhs) cudaFree(Mh_ Azz_rhs); + if(Mh_ Gamx_rhs) cudaFree(Mh_ Gamx_rhs); + if(Mh_ Gamy_rhs) cudaFree(Mh_ Gamy_rhs); + if(Mh_ Gamz_rhs) cudaFree(Mh_ Gamz_rhs); + if(Mh_ Lap_rhs) cudaFree(Mh_ Lap_rhs); + if(Mh_ betax_rhs) cudaFree(Mh_ betax_rhs); + if(Mh_ betay_rhs) cudaFree(Mh_ betay_rhs); + if(Mh_ betaz_rhs) cudaFree(Mh_ betaz_rhs); + if(Mh_ dtSfx_rhs) cudaFree(Mh_ dtSfx_rhs); + if(Mh_ dtSfy_rhs) cudaFree(Mh_ dtSfy_rhs); + if(Mh_ dtSfz_rhs) cudaFree(Mh_ dtSfz_rhs); + if(Mh_ rho) cudaFree(Mh_ rho); + if(Mh_ Sx) cudaFree(Mh_ Sx); + if(Mh_ Sy) cudaFree(Mh_ Sy); + if(Mh_ Sz) cudaFree(Mh_ Sz); + if(Mh_ Sxx) cudaFree(Mh_ Sxx); + if(Mh_ Sxy) cudaFree(Mh_ Sxy); + if(Mh_ Sxz) cudaFree(Mh_ Sxz); + if(Mh_ Syz) cudaFree(Mh_ Syz); + if(Mh_ Syy) cudaFree(Mh_ Syy); + if(Mh_ Szz) cudaFree(Mh_ Szz); + if(Mh_ Gamxxx) cudaFree(Mh_ Gamxxx); + if(Mh_ Gamxxy) cudaFree(Mh_ Gamxxy); + if(Mh_ Gamxxz) cudaFree(Mh_ Gamxxz); + if(Mh_ Gamxyy) cudaFree(Mh_ Gamxyy); + if(Mh_ Gamxyz) cudaFree(Mh_ Gamxyz); + if(Mh_ Gamxzz) cudaFree(Mh_ Gamxzz); + if(Mh_ Gamyxx) cudaFree(Mh_ Gamyxx); + if(Mh_ Gamyxy) cudaFree(Mh_ Gamyxy); + if(Mh_ Gamyxz) cudaFree(Mh_ Gamyxz); + if(Mh_ Gamyyy) cudaFree(Mh_ Gamyyy); + if(Mh_ Gamyyz) cudaFree(Mh_ Gamyyz); + if(Mh_ Gamyzz) cudaFree(Mh_ Gamyzz); + if(Mh_ Gamzxx) cudaFree(Mh_ Gamzxx); + if(Mh_ Gamzxy) cudaFree(Mh_ Gamzxy); + if(Mh_ Gamzxz) cudaFree(Mh_ Gamzxz); + if(Mh_ Gamzyz) cudaFree(Mh_ Gamzyz); + if(Mh_ Gamzyy) cudaFree(Mh_ Gamzyy); + if(Mh_ Gamzzz) cudaFree(Mh_ Gamzzz); + if(Mh_ Rxx) cudaFree(Mh_ Rxx); + if(Mh_ Rxy) cudaFree(Mh_ Rxy); + if(Mh_ Rxz) cudaFree(Mh_ Rxz); + if(Mh_ Ryy) cudaFree(Mh_ Ryy); + if(Mh_ Ryz) cudaFree(Mh_ Ryz); + if(Mh_ Rzz) cudaFree(Mh_ Rzz); + if(Mh_ ham_Res) cudaFree(Mh_ ham_Res); + if(Mh_ movx_Res) cudaFree(Mh_ movx_Res); + if(Mh_ movy_Res) cudaFree(Mh_ movy_Res); + if(Mh_ movz_Res) cudaFree(Mh_ movz_Res); + if(Mh_ Gmx_Res) cudaFree(Mh_ Gmx_Res); + if(Mh_ Gmy_Res) cudaFree(Mh_ Gmy_Res); + if(Mh_ Gmz_Res) cudaFree(Mh_ Gmz_Res); + if(Mh_ gxx) cudaFree(Mh_ gxx); + if(Mh_ gyy) cudaFree(Mh_ gyy); + if(Mh_ gzz) cudaFree(Mh_ gzz); + if(Mh_ chix) cudaFree(Mh_ chix); + if(Mh_ chiy) cudaFree(Mh_ chiy); + if(Mh_ chiz) cudaFree(Mh_ chiz); + if(Mh_ gxxx) cudaFree(Mh_ gxxx); + if(Mh_ gxyx) cudaFree(Mh_ gxyx); + if(Mh_ gxzx) cudaFree(Mh_ gxzx); + if(Mh_ gyyx) cudaFree(Mh_ gyyx); + if(Mh_ gyzx) cudaFree(Mh_ gyzx); + if(Mh_ gzzx) cudaFree(Mh_ gzzx); + if(Mh_ gxxy) cudaFree(Mh_ gxxy); + if(Mh_ gxyy) cudaFree(Mh_ gxyy); + if(Mh_ gxzy) cudaFree(Mh_ gxzy); + if(Mh_ gyyy) cudaFree(Mh_ gyyy); + if(Mh_ gyzy) cudaFree(Mh_ gyzy); + if(Mh_ gzzy) cudaFree(Mh_ gzzy); + if(Mh_ gxxz) cudaFree(Mh_ gxxz); + if(Mh_ gxyz) cudaFree(Mh_ gxyz); + if(Mh_ gxzz) cudaFree(Mh_ gxzz); + if(Mh_ gyyz) cudaFree(Mh_ gyyz); + if(Mh_ gyzz) cudaFree(Mh_ gyzz); + if(Mh_ gzzz) cudaFree(Mh_ gzzz); + if(Mh_ Lapx) cudaFree(Mh_ Lapx); + if(Mh_ Lapy) cudaFree(Mh_ Lapy); + if(Mh_ Lapz) cudaFree(Mh_ Lapz); + if(Mh_ betaxx) cudaFree(Mh_ betaxx); + if(Mh_ betaxy) cudaFree(Mh_ betaxy); + if(Mh_ betaxz) cudaFree(Mh_ betaxz); + if(Mh_ betayy) cudaFree(Mh_ betayy); + if(Mh_ betayz) cudaFree(Mh_ betayz); + if(Mh_ betazz) cudaFree(Mh_ betazz); + if(Mh_ betayx) cudaFree(Mh_ betayx); + if(Mh_ betazy) cudaFree(Mh_ betazy); + if(Mh_ betazx) cudaFree(Mh_ betazx); + if(Mh_ Kx) cudaFree(Mh_ Kx); + if(Mh_ Ky) cudaFree(Mh_ Ky); + if(Mh_ Kz) cudaFree(Mh_ Kz); + if(Mh_ Gamxx) cudaFree(Mh_ Gamxx); + if(Mh_ Gamxy) cudaFree(Mh_ Gamxy); + if(Mh_ Gamxz) cudaFree(Mh_ Gamxz); + if(Mh_ Gamyy) cudaFree(Mh_ Gamyy); + if(Mh_ Gamyz) cudaFree(Mh_ Gamyz); + if(Mh_ Gamzz) cudaFree(Mh_ Gamzz); + if(Mh_ Gamyx) cudaFree(Mh_ Gamyx); + if(Mh_ Gamzy) cudaFree(Mh_ Gamzy); + if(Mh_ Gamzx) cudaFree(Mh_ Gamzx); + if(Mh_ div_beta) cudaFree(Mh_ div_beta); + if(Mh_ S) cudaFree(Mh_ S); + if(Mh_ f) cudaFree(Mh_ f); + if(Mh_ fxx) cudaFree(Mh_ fxx); + if(Mh_ fxy) cudaFree(Mh_ fxy); + if(Mh_ fxz) cudaFree(Mh_ fxz); + if(Mh_ fyy) cudaFree(Mh_ fyy); + if(Mh_ fyz) cudaFree(Mh_ fyz); + if(Mh_ fzz) cudaFree(Mh_ fzz); + if(Mh_ gupxx) cudaFree(Mh_ gupxx); + if(Mh_ gupxy) cudaFree(Mh_ gupxy); + if(Mh_ gupxz) cudaFree(Mh_ gupxz); + if(Mh_ gupyy) cudaFree(Mh_ gupyy); + if(Mh_ gupyz) cudaFree(Mh_ gupyz); + if(Mh_ gupzz) cudaFree(Mh_ gupzz); + if(Mh_ Gamxa) cudaFree(Mh_ Gamxa); + if(Mh_ Gamya) cudaFree(Mh_ Gamya); + if(Mh_ Gamza) cudaFree(Mh_ Gamza); + if(Mh_ alpn1) cudaFree(Mh_ alpn1); + if(Mh_ chin1) cudaFree(Mh_ chin1); + if(Mh_ fh) cudaFree(Mh_ fh); + if(Mh_ fh2) cudaFree(Mh_ fh2); + if(Mh_ gxx_rhs) cudaFree(Mh_ gxx_rhs); + if(Mh_ gyy_rhs) cudaFree(Mh_ gyy_rhs); + if(Mh_ gzz_rhs) cudaFree(Mh_ gzz_rhs); + + //-----------SS----------------- + if(Msh_ crho) cudaFree(Msh_ crho); + if(Msh_ sigma) cudaFree(Msh_ sigma); + if(Msh_ R) cudaFree(Msh_ R); + if(Msh_ drhodx) cudaFree(Msh_ drhodx); + if(Msh_ drhody) cudaFree(Msh_ drhody); + if(Msh_ drhodz) cudaFree(Msh_ drhodz); + if(Msh_ dsigmadx) cudaFree(Msh_ dsigmadx); + if(Msh_ dsigmady) cudaFree(Msh_ dsigmady); + if(Msh_ dsigmadz) cudaFree(Msh_ dsigmadz); + if(Msh_ dRdx) cudaFree(Msh_ dRdx); + if(Msh_ dRdy) cudaFree(Msh_ dRdy); + if(Msh_ dRdz) cudaFree(Msh_ dRdz); + if(Msh_ drhodxx) cudaFree(Msh_ drhodxx); + if(Msh_ drhodxy) cudaFree(Msh_ drhodxy); + if(Msh_ drhodxz) cudaFree(Msh_ drhodxz); + if(Msh_ drhodyy) cudaFree(Msh_ drhodyy); + if(Msh_ drhodyz) cudaFree(Msh_ drhodyz); + if(Msh_ drhodzz) cudaFree(Msh_ drhodzz); + if(Msh_ dsigmadxx) cudaFree(Msh_ dsigmadxx); + if(Msh_ dsigmadxy) cudaFree(Msh_ dsigmadxy); + if(Msh_ dsigmadxz) cudaFree(Msh_ dsigmadxz); + if(Msh_ dsigmadyy) cudaFree(Msh_ dsigmadyy); + if(Msh_ dsigmadyz) cudaFree(Msh_ dsigmadyz); + if(Msh_ dsigmadzz) cudaFree(Msh_ dsigmadzz); + if(Msh_ dRdxx) cudaFree(Msh_ dRdxx); + if(Msh_ dRdxy) cudaFree(Msh_ dRdxy); + if(Msh_ dRdxz) cudaFree(Msh_ dRdxz); + if(Msh_ dRdyy) cudaFree(Msh_ dRdyy); + if(Msh_ dRdyz) cudaFree(Msh_ dRdyz); + if(Msh_ dRdzz) cudaFree(Msh_ dRdzz); + if(Msh_ gx) cudaFree(Msh_ gx); + if(Msh_ gy) cudaFree(Msh_ gy); + if(Msh_ gz) cudaFree(Msh_ gz); + + if(Msh_ gxx) cudaFree(Msh_ gxx); + if(Msh_ gxy) cudaFree(Msh_ gxy); + if(Msh_ gxz) cudaFree(Msh_ gxz); + if(Msh_ gyy) cudaFree(Msh_ gyy); + if(Msh_ gyz) cudaFree(Msh_ gyz); + if(Msh_ gzz) cudaFree(Msh_ gzz); + +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + if(Mh_ reta) CUDA_SAFE_CALL(cudaFree(Mh_ reta)); + +#endif + + //if(Mh_ other_int) cudaFree(Mh_ other_int); + //if(Mh_ other_double) cudaFree(Mh_ other_double); + //cout<<"Address of meta:"<<&meta<>>(); + cudaThreadSynchronize(); + + sub_fderivs_shc(sst,Mh_ betax,Mh_ fh,Mh_ betaxx,Mh_ betaxy,Mh_ betaxz,ass); + sub_fderivs_shc(sst,Mh_ betay,Mh_ fh,Mh_ betayx,Mh_ betayy,Mh_ betayz,sas); + sub_fderivs_shc(sst,Mh_ betaz,Mh_ fh,Mh_ betazx,Mh_ betazy,Mh_ betazz,ssa); + sub_fderivs_shc(sst,Mh_ chi,Mh_ fh,Mh_ chix,Mh_ chiy,Mh_ chiz, sss); + sub_fderivs_shc(sst,Mh_ Lap,Mh_ fh,Mh_ Lapx,Mh_ Lapy,Mh_ Lapz, sss); + sub_fderivs_shc(sst,Mh_ trK,Mh_ fh,Mh_ Kx,Mh_ Ky,Mh_ Kz, sss); + sub_fderivs_shc(sst,Mh_ dxx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz, sss); + sub_fderivs_shc(sst,Mh_ dyy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz, sss); + sub_fderivs_shc(sst,Mh_ dzz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz, sss); + sub_fderivs_shc(sst,Mh_ gxy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz, aas); + sub_fderivs_shc(sst,Mh_ gxz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz, asa); + sub_fderivs_shc(sst,Mh_ gyz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz, saa); + + compute_rhs_ss_part2<<>>(); + cudaThreadSynchronize(); + + sub_fdderivs_shc(sst,Mh_ betax,Mh_ fh,Mh_ gxxx,Mh_ gxyx,Mh_ gxzx,Mh_ gyyx,Mh_ gyzx,Mh_ gzzx,ass); + sub_fdderivs_shc(sst,Mh_ betay,Mh_ fh,Mh_ gxxy,Mh_ gxyy,Mh_ gxzy,Mh_ gyyy,Mh_ gyzy,Mh_ gzzy,sas); + sub_fdderivs_shc(sst,Mh_ betaz,Mh_ fh,Mh_ gxxz,Mh_ gxyz,Mh_ gxzz,Mh_ gyyz,Mh_ gyzz,Mh_ gzzz,ssa); + sub_fderivs_shc( sst,Mh_ Gamx, Mh_ fh,Mh_ Gamxx, Mh_ Gamxy, Mh_ Gamxz,ass); + sub_fderivs_shc( sst,Mh_ Gamy, Mh_ fh,Mh_ Gamyx, Mh_ Gamyy, Mh_ Gamyz,sas); + sub_fderivs_shc( sst,Mh_ Gamz, Mh_ fh,Mh_ Gamzx, Mh_ Gamzy, Mh_ Gamzz,ssa); + + compute_rhs_ss_part3<<>>(); + cudaThreadSynchronize(); + + computeRicci_ss(sst,Mh_ dxx,Mh_ Rxx,sss, meta); + computeRicci_ss(sst,Mh_ dyy,Mh_ Ryy,sss, meta); + computeRicci_ss(sst,Mh_ dzz,Mh_ Rzz,sss, meta); + computeRicci_ss(sst,Mh_ gxy,Mh_ Rxy,aas, meta); + computeRicci_ss(sst,Mh_ gxz,Mh_ Rxz,asa, meta); + computeRicci_ss(sst,Mh_ gyz,Mh_ Ryz,saa, meta); + cudaThreadSynchronize(); + + compute_rhs_ss_part4<<>>(); + cudaThreadSynchronize(); + + sub_fdderivs_shc(sst,Mh_ chi,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); + + //cudaThreadSynchronize(); + //compare_result_gpu(0,Mh_ chi,h_3D_SIZE[0]); + //compare_result_gpu(1,Mh_ chi,h_3D_SIZE[0]); + //compare_result_gpu(2,Mh_ fyz,h_3D_SIZE[0]); + + compute_rhs_ss_part5<<>>(); + cudaThreadSynchronize(); + + sub_fdderivs_shc(sst,Mh_ Lap,Mh_ fh,Mh_ fxx,Mh_ fxy,Mh_ fxz,Mh_ fyy,Mh_ fyz,Mh_ fzz,sss); + + compute_rhs_ss_part6<<>>(); + cudaThreadSynchronize(); + +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5) + sub_fderivs_shc(sst,Mh_ chi,Mh_ fh, Mh_ dtSfx_rhs, Mh_ dtSfy_rhs, Mh_ dtSfz_rhs,sss); + compute_rhs_bssn_ss_part6_gauge<<>>(); +#endif + //sub_lopsided_ss(int& sst,double *src,double* dst,double *SOA) + sub_lopsided_ss(sst,Mh_ gxx,Mh_ gxx_rhs,sss); + sub_lopsided_ss(sst,Mh_ gxy,Mh_ gxy_rhs,aas); + sub_lopsided_ss(sst,Mh_ gxz,Mh_ gxz_rhs,asa); + sub_lopsided_ss(sst,Mh_ gyy,Mh_ gyy_rhs,sss); + sub_lopsided_ss(sst,Mh_ gyz,Mh_ gyz_rhs,saa); + sub_lopsided_ss(sst,Mh_ gzz,Mh_ gzz_rhs,sss); + sub_lopsided_ss(sst,Mh_ Axx,Mh_ Axx_rhs,sss); + sub_lopsided_ss(sst,Mh_ Axy,Mh_ Axy_rhs,aas); + sub_lopsided_ss(sst,Mh_ Axz,Mh_ Axz_rhs,asa); + sub_lopsided_ss(sst,Mh_ Ayy,Mh_ Ayy_rhs,sss); + sub_lopsided_ss(sst,Mh_ Ayz,Mh_ Ayz_rhs,saa); + sub_lopsided_ss(sst,Mh_ Azz,Mh_ Azz_rhs,sss); + sub_lopsided_ss(sst,Mh_ chi,Mh_ chi_rhs,sss); + sub_lopsided_ss(sst,Mh_ trK,Mh_ trK_rhs,sss); + sub_lopsided_ss(sst,Mh_ Gamx,Mh_ Gamx_rhs,ass); + sub_lopsided_ss(sst,Mh_ Gamy,Mh_ Gamy_rhs,sas); + sub_lopsided_ss(sst,Mh_ Gamz,Mh_ Gamz_rhs,ssa); + sub_lopsided_ss(sst,Mh_ Lap,Mh_ Lap_rhs,sss); +#if (GAUGE == 0 || GAUGE == 1 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + sub_lopsided_ss(sst,Mh_ betax,Mh_ betax_rhs,ass); + sub_lopsided_ss(sst,Mh_ betay,Mh_ betay_rhs,sas); + sub_lopsided_ss(sst,Mh_ betaz,Mh_ betaz_rhs,ssa); +#endif +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + sub_lopsided_ss(sst,Mh_ dtSfx,Mh_ dtSfx_rhs,ass); + sub_lopsided_ss(sst,Mh_ dtSfy,Mh_ dtSfy_rhs,sas); + sub_lopsided_ss(sst,Mh_ dtSfz,Mh_ dtSfz_rhs,ssa); +#endif + if(eps > 0){ + sub_kodis_ss(sst,Mh_ chi,Mh_ fh2, Mh_ chi_rhs,sss); + sub_kodis_ss(sst,Mh_ trK,Mh_ fh2, Mh_ trK_rhs,sss); + sub_kodis_ss(sst,Mh_ dxx,Mh_ fh2, Mh_ gxx_rhs,sss); + sub_kodis_ss(sst,Mh_ gxy,Mh_ fh2, Mh_ gxy_rhs,aas); + sub_kodis_ss(sst,Mh_ gxz,Mh_ fh2, Mh_ gxz_rhs,asa); + sub_kodis_ss(sst,Mh_ dyy,Mh_ fh2, Mh_ gyy_rhs,sss); + sub_kodis_ss(sst,Mh_ gyz,Mh_ fh2, Mh_ gyz_rhs,saa); + sub_kodis_ss(sst,Mh_ dzz,Mh_ fh2, Mh_ gzz_rhs,sss); + sub_kodis_ss(sst,Mh_ Axx,Mh_ fh2, Mh_ Axx_rhs,sss); + sub_kodis_ss(sst,Mh_ Axy,Mh_ fh2, Mh_ Axy_rhs,aas); + sub_kodis_ss(sst,Mh_ Axz,Mh_ fh2, Mh_ Axz_rhs,asa); + sub_kodis_ss(sst,Mh_ Ayy,Mh_ fh2, Mh_ Ayy_rhs,sss); + sub_kodis_ss(sst,Mh_ Ayz,Mh_ fh2, Mh_ Ayz_rhs,saa); + sub_kodis_ss(sst,Mh_ Azz,Mh_ fh2, Mh_ Azz_rhs,sss); + sub_kodis_ss(sst,Mh_ Gamx,Mh_ fh2, Mh_ Gamx_rhs,ass); + sub_kodis_ss(sst,Mh_ Gamy,Mh_ fh2, Mh_ Gamy_rhs,sas); + sub_kodis_ss(sst,Mh_ Gamz,Mh_ fh2, Mh_ Gamz_rhs,ssa); + sub_kodis_ss(sst,Mh_ Lap,Mh_ fh2, Mh_ Lap_rhs,sss); + sub_kodis_ss(sst,Mh_ betax,Mh_ fh2, Mh_ betax_rhs,ass); + sub_kodis_ss(sst,Mh_ betay,Mh_ fh2, Mh_ betay_rhs,sas); + sub_kodis_ss(sst,Mh_ betaz,Mh_ fh2, Mh_ betaz_rhs,ssa); +#if (GAUGE == 0 || GAUGE == 2 || GAUGE == 3 || GAUGE == 6 || GAUGE == 7) + sub_kodis_ss(sst,Mh_ dtSfx,Mh_ fh2, Mh_ dtSfx_rhs,ass); + sub_kodis_ss(sst,Mh_ dtSfy,Mh_ fh2, Mh_ dtSfy_rhs,sas); + sub_kodis_ss(sst,Mh_ dtSfz,Mh_ fh2, Mh_ dtSfz_rhs,ssa); +#endif + } + if(co == 0){ + compute_rhs_ss_part7<<>>(); + cudaThreadSynchronize(); + + sub_fderivs_shc(sst,Mh_ Axx,Mh_ fh,Mh_ gxxx,Mh_ gxxy,Mh_ gxxz,sss); + sub_fderivs_shc(sst,Mh_ Axy,Mh_ fh,Mh_ gxyx,Mh_ gxyy,Mh_ gxyz,aas); + sub_fderivs_shc(sst,Mh_ Axz,Mh_ fh,Mh_ gxzx,Mh_ gxzy,Mh_ gxzz,asa); + sub_fderivs_shc(sst,Mh_ Ayy,Mh_ fh,Mh_ gyyx,Mh_ gyyy,Mh_ gyyz,sss); + sub_fderivs_shc(sst,Mh_ Ayz,Mh_ fh,Mh_ gyzx,Mh_ gyzy,Mh_ gyzz,saa); + sub_fderivs_shc(sst,Mh_ Azz,Mh_ fh,Mh_ gzzx,Mh_ gzzy,Mh_ gzzz,sss); + compute_rhs_ss_part8<<>>(); + cudaThreadSynchronize(); + } + +#if (ABV == 1) + cout<<"TODO: bssn_gpu.cu::2373 (ABV == 1)"< -#include -#include -using namespace std; - -int compare_two_file(char *fname1, char *fname2, int data_num) -{ - // read file - fstream file1(fname1, ios_base::in); - fstream file2(fname2, ios_base::in); - double *d1, *d2; - d1 = (double *)malloc(sizeof(double) * data_num); - d2 = (double *)malloc(sizeof(double) * data_num); - - for (int i = 0; i < data_num; ++i) - { - file1.read((char *)(d1 + i), sizeof(double)); - file2.read((char *)(d2 + i), sizeof(double)); - } - - // compare data - bool is_match = true; - for (int i = 0; i < data_num; ++i) - { - if (d1[i] != d2[i]) - { - is_match = false; - cout << "miss match at position " << i << endl; - break; - } - } - if (is_match) - cout << "Result is right." << endl; - - free(d1); - free(d2); - file1.close(); - file2.close(); - return 0; -} -void printMatrix(int ftag1, int ftag2, double *d1, double *d2, int ord) -{ - char fname1[32]; - char fname2[32]; - // char ftag1[32]; char ftag2[32]; - // sprintf(ftag1,"%d",ftag1); - strcpy(fname1, "matrix_f.show"); - // strcat(fname1,ftag1); - - // sprintf(ftag2,"%d",ftag2); - strcpy(fname2, "matrix_g.show"); - // strcat(fname2,ftag2); - - ofstream fout0, fout1, fout2; - fout1.open(fname1); - fout2.open(fname2); - - for (int k = 0; k < 65; k++) - { - fout1 << "---------square " << k << " ----------" << endl; - fout2 << "---------square " << k << " ----------" << endl; - for (int j = 0; j < 67 + ord * 2; j++) - { - for (int i = 0; i < 67 + ord * 2; i++) - { - fout1 << d1[i + j * (67 + ord * 2) + k * ((67 + ord * 2) * (67 + ord * 2))] << ' '; - fout2 << d2[i + j * (67 + ord * 2) + k * ((67 + ord * 2) * (67 + ord * 2))] << ' '; - // fout1<shape[0]) + k*(_2d_size)] <<' '; - // fout2<shape[0]) + k*(_2d_size)] <<' '; - } - fout1 << endl; - fout2 << endl; - } - } -} - -int compare_result(int ftag1, double *d2, int data_num) -{ - // read file - char fname1[32]; - char ftag[32]; - // itoa(filetag,ftag,10); - sprintf(ftag, "%d", ftag1); - strcpy(fname1, "matrix_f.out"); - strcat(fname1, ftag); - - fstream file1(fname1, ios_base::in); - double *d1; - d1 = (double *)malloc(sizeof(double) * data_num); - - for (int i = 0; i < data_num; ++i) - { - file1.read((char *)(d1 + i), sizeof(double)); - } - - // compare data - bool is_match = true; - double delta; - for (int i = 0; i < data_num; ++i) - { - delta = d1[i] - d2[i]; - if (delta < 0) - delta = -delta; - if (delta > 1e-14) - { - is_match = false; - cout << fname1 << "::miss match at position " << i << endl; - break; - } - // if(i<100 && i>50) - // cout< +#include +#include +using namespace std; + +int compare_two_file(char *fname1, char *fname2, int data_num) +{ + // read file + fstream file1(fname1, ios_base::in); + fstream file2(fname2, ios_base::in); + double *d1, *d2; + d1 = (double *)malloc(sizeof(double) * data_num); + d2 = (double *)malloc(sizeof(double) * data_num); + + for (int i = 0; i < data_num; ++i) + { + file1.read((char *)(d1 + i), sizeof(double)); + file2.read((char *)(d2 + i), sizeof(double)); + } + + // compare data + bool is_match = true; + for (int i = 0; i < data_num; ++i) + { + if (d1[i] != d2[i]) + { + is_match = false; + cout << "miss match at position " << i << endl; + break; + } + } + if (is_match) + cout << "Result is right." << endl; + + free(d1); + free(d2); + file1.close(); + file2.close(); + return 0; +} +void printMatrix(int ftag1, int ftag2, double *d1, double *d2, int ord) +{ + char fname1[32]; + char fname2[32]; + // char ftag1[32]; char ftag2[32]; + // sprintf(ftag1,"%d",ftag1); + strcpy(fname1, "matrix_f.show"); + // strcat(fname1,ftag1); + + // sprintf(ftag2,"%d",ftag2); + strcpy(fname2, "matrix_g.show"); + // strcat(fname2,ftag2); + + ofstream fout0, fout1, fout2; + fout1.open(fname1); + fout2.open(fname2); + + for (int k = 0; k < 65; k++) + { + fout1 << "---------square " << k << " ----------" << endl; + fout2 << "---------square " << k << " ----------" << endl; + for (int j = 0; j < 67 + ord * 2; j++) + { + for (int i = 0; i < 67 + ord * 2; i++) + { + fout1 << d1[i + j * (67 + ord * 2) + k * ((67 + ord * 2) * (67 + ord * 2))] << ' '; + fout2 << d2[i + j * (67 + ord * 2) + k * ((67 + ord * 2) * (67 + ord * 2))] << ' '; + // fout1<shape[0]) + k*(_2d_size)] <<' '; + // fout2<shape[0]) + k*(_2d_size)] <<' '; + } + fout1 << endl; + fout2 << endl; + } + } +} + +int compare_result(int ftag1, double *d2, int data_num) +{ + // read file + char fname1[32]; + char ftag[32]; + // itoa(filetag,ftag,10); + sprintf(ftag, "%d", ftag1); + strcpy(fname1, "matrix_f.out"); + strcat(fname1, ftag); + + fstream file1(fname1, ios_base::in); + double *d1; + d1 = (double *)malloc(sizeof(double) * data_num); + + for (int i = 0; i < data_num; ++i) + { + file1.read((char *)(d1 + i), sizeof(double)); + } + + // compare data + bool is_match = true; + double delta; + for (int i = 0; i < data_num; ++i) + { + delta = d1[i] - d2[i]; + if (delta < 0) + delta = -delta; + if (delta > 1e-14) + { + is_match = false; + cout << fname1 << "::miss match at position " << i << endl; + break; + } + // if(i<100 && i>50) + // cout<shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,pre - -#define RHS_PARA_CALLED_THEN cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi->sgfn],cg->fgfs[trK->sgfn],cg->fgfs[gxx->sgfn],cg->fgfs[gxy->sgfn],cg->fgfs[gxz->sgfn],cg->fgfs[gyy->sgfn],cg->fgfs[gyz->sgfn],cg->fgfs[gzz->sgfn],cg->fgfs[Axx->sgfn],cg->fgfs[Axy->sgfn],cg->fgfs[Axz->sgfn],cg->fgfs[Ayy->sgfn],cg->fgfs[Ayz->sgfn],cg->fgfs[Azz->sgfn],cg->fgfs[Gmx->sgfn],cg->fgfs[Gmy->sgfn],cg->fgfs[Gmz->sgfn],cg->fgfs[Lap->sgfn],cg->fgfs[Sfx->sgfn],cg->fgfs[Sfy->sgfn],cg->fgfs[Sfz->sgfn],cg->fgfs[dtSfx->sgfn],cg->fgfs[dtSfy->sgfn],cg->fgfs[dtSfz->sgfn],cg->fgfs[phi1->sgfn],cg->fgfs[trK1->sgfn],cg->fgfs[gxx1->sgfn],cg->fgfs[gxy1->sgfn],cg->fgfs[gxz1->sgfn],cg->fgfs[gyy1->sgfn],cg->fgfs[gyz1->sgfn],cg->fgfs[gzz1->sgfn],cg->fgfs[Axx1->sgfn],cg->fgfs[Axy1->sgfn],cg->fgfs[Axz1->sgfn],cg->fgfs[Ayy1->sgfn],cg->fgfs[Ayz1->sgfn],cg->fgfs[Azz1->sgfn],cg->fgfs[Gmx1->sgfn],cg->fgfs[Gmy1->sgfn],cg->fgfs[Gmz1->sgfn],cg->fgfs[Lap1->sgfn],cg->fgfs[Sfx1->sgfn],cg->fgfs[Sfy1->sgfn],cg->fgfs[Sfz1->sgfn],cg->fgfs[dtSfx1->sgfn],cg->fgfs[dtSfy1->sgfn],cg->fgfs[dtSfz1->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,cor - -#define RHS_PARA_CALLED_Constraint_Out cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,pre - - -#define RHS_PARA_CALLED_Interp_Constraint cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,pre - -#define RHS_SS_PARA_CALLED_FIRST_TIME cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,pre - -#define RHS_SS_PARA_CALLED_THEN cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi->sgfn],cg->fgfs[trK->sgfn],cg->fgfs[gxx->sgfn],cg->fgfs[gxy->sgfn],cg->fgfs[gxz->sgfn],cg->fgfs[gyy->sgfn],cg->fgfs[gyz->sgfn],cg->fgfs[gzz->sgfn],cg->fgfs[Axx->sgfn],cg->fgfs[Axy->sgfn],cg->fgfs[Axz->sgfn],cg->fgfs[Ayy->sgfn],cg->fgfs[Ayz->sgfn],cg->fgfs[Azz->sgfn],cg->fgfs[Gmx->sgfn],cg->fgfs[Gmy->sgfn],cg->fgfs[Gmz->sgfn],cg->fgfs[Lap->sgfn],cg->fgfs[Sfx->sgfn],cg->fgfs[Sfy->sgfn],cg->fgfs[Sfz->sgfn],cg->fgfs[dtSfx->sgfn],cg->fgfs[dtSfy->sgfn],cg->fgfs[dtSfz->sgfn],cg->fgfs[phi1->sgfn],cg->fgfs[trK1->sgfn],cg->fgfs[gxx1->sgfn],cg->fgfs[gxy1->sgfn],cg->fgfs[gxz1->sgfn],cg->fgfs[gyy1->sgfn],cg->fgfs[gyz1->sgfn],cg->fgfs[gzz1->sgfn],cg->fgfs[Axx1->sgfn],cg->fgfs[Axy1->sgfn],cg->fgfs[Axz1->sgfn],cg->fgfs[Ayy1->sgfn],cg->fgfs[Ayz1->sgfn],cg->fgfs[Azz1->sgfn],cg->fgfs[Gmx1->sgfn],cg->fgfs[Gmy1->sgfn],cg->fgfs[Gmz1->sgfn],cg->fgfs[Lap1->sgfn],cg->fgfs[Sfx1->sgfn],cg->fgfs[Sfy1->sgfn],cg->fgfs[Sfz1->sgfn],cg->fgfs[dtSfx1->sgfn],cg->fgfs[dtSfy1->sgfn],cg->fgfs[dtSfz1->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,cor - - -#define RHS_PARA_CALLED_Constraint_Out_SS cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,pre - -#define RHS_PARA_CALLED_Intrp_Constraint_Out_SS cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,pre -//4------------tool------------------------------ -int compare_result(int ftag1,double * d2,int data_num); - - - -#endif +#ifndef BSSN_STEP_H +#define BSSN_STEP_H +//1---------------------FLAGS--------------------- + +#define USE_GPU +#define MAX_GPU_PROCESS_NUM 1 +#define COUNT_CPU_RHS_TIME + + +//2---------------------TIMER--------------------- +//2.1 TIMER_INIT +//2.2 TIMER_TIC_WITHOUT_OUTPUT +//2.3 TIMER_TIC(tag,order,label) +//2.4 TIMER_TIC_TAIL_OF_FUNC(tag,label) + +#define TIME_COUNT_EACH_RANK 0 + +#define TIMER_INIT \ +double clock_prev,clock_curr,step_begin_clock;\ +if(1 == 1){\ + clock_curr =MPI_Wtime();\ + step_begin_clock = MPI_Wtime();\ +}else{\ +if(myrank == 0){\ + clock_curr= MPI_Wtime();\ + step_begin_clock = MPI_Wtime();\ +}\ +} + +#define TIMER_TIC(tag,order,label) \ +if(TIME_COUNT_EACH_RANK == 1){\ + clock_prev= clock_curr;\ + clock_curr = MPI_Wtime();\ + cout<<#tag <shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,pre + +#define RHS_PARA_CALLED_THEN cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi->sgfn],cg->fgfs[trK->sgfn],cg->fgfs[gxx->sgfn],cg->fgfs[gxy->sgfn],cg->fgfs[gxz->sgfn],cg->fgfs[gyy->sgfn],cg->fgfs[gyz->sgfn],cg->fgfs[gzz->sgfn],cg->fgfs[Axx->sgfn],cg->fgfs[Axy->sgfn],cg->fgfs[Axz->sgfn],cg->fgfs[Ayy->sgfn],cg->fgfs[Ayz->sgfn],cg->fgfs[Azz->sgfn],cg->fgfs[Gmx->sgfn],cg->fgfs[Gmy->sgfn],cg->fgfs[Gmz->sgfn],cg->fgfs[Lap->sgfn],cg->fgfs[Sfx->sgfn],cg->fgfs[Sfy->sgfn],cg->fgfs[Sfz->sgfn],cg->fgfs[dtSfx->sgfn],cg->fgfs[dtSfy->sgfn],cg->fgfs[dtSfz->sgfn],cg->fgfs[phi1->sgfn],cg->fgfs[trK1->sgfn],cg->fgfs[gxx1->sgfn],cg->fgfs[gxy1->sgfn],cg->fgfs[gxz1->sgfn],cg->fgfs[gyy1->sgfn],cg->fgfs[gyz1->sgfn],cg->fgfs[gzz1->sgfn],cg->fgfs[Axx1->sgfn],cg->fgfs[Axy1->sgfn],cg->fgfs[Axz1->sgfn],cg->fgfs[Ayy1->sgfn],cg->fgfs[Ayz1->sgfn],cg->fgfs[Azz1->sgfn],cg->fgfs[Gmx1->sgfn],cg->fgfs[Gmy1->sgfn],cg->fgfs[Gmz1->sgfn],cg->fgfs[Lap1->sgfn],cg->fgfs[Sfx1->sgfn],cg->fgfs[Sfy1->sgfn],cg->fgfs[Sfz1->sgfn],cg->fgfs[dtSfx1->sgfn],cg->fgfs[dtSfy1->sgfn],cg->fgfs[dtSfz1->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,cor + +#define RHS_PARA_CALLED_Constraint_Out cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,pre + + +#define RHS_PARA_CALLED_Interp_Constraint cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,ndeps,pre + +#define RHS_SS_PARA_CALLED_FIRST_TIME cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,pre + +#define RHS_SS_PARA_CALLED_THEN cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi->sgfn],cg->fgfs[trK->sgfn],cg->fgfs[gxx->sgfn],cg->fgfs[gxy->sgfn],cg->fgfs[gxz->sgfn],cg->fgfs[gyy->sgfn],cg->fgfs[gyz->sgfn],cg->fgfs[gzz->sgfn],cg->fgfs[Axx->sgfn],cg->fgfs[Axy->sgfn],cg->fgfs[Axz->sgfn],cg->fgfs[Ayy->sgfn],cg->fgfs[Ayz->sgfn],cg->fgfs[Azz->sgfn],cg->fgfs[Gmx->sgfn],cg->fgfs[Gmy->sgfn],cg->fgfs[Gmz->sgfn],cg->fgfs[Lap->sgfn],cg->fgfs[Sfx->sgfn],cg->fgfs[Sfy->sgfn],cg->fgfs[Sfz->sgfn],cg->fgfs[dtSfx->sgfn],cg->fgfs[dtSfy->sgfn],cg->fgfs[dtSfz->sgfn],cg->fgfs[phi1->sgfn],cg->fgfs[trK1->sgfn],cg->fgfs[gxx1->sgfn],cg->fgfs[gxy1->sgfn],cg->fgfs[gxz1->sgfn],cg->fgfs[gyy1->sgfn],cg->fgfs[gyz1->sgfn],cg->fgfs[gzz1->sgfn],cg->fgfs[Axx1->sgfn],cg->fgfs[Axy1->sgfn],cg->fgfs[Axz1->sgfn],cg->fgfs[Ayy1->sgfn],cg->fgfs[Ayz1->sgfn],cg->fgfs[Azz1->sgfn],cg->fgfs[Gmx1->sgfn],cg->fgfs[Gmy1->sgfn],cg->fgfs[Gmz1->sgfn],cg->fgfs[Lap1->sgfn],cg->fgfs[Sfx1->sgfn],cg->fgfs[Sfy1->sgfn],cg->fgfs[Sfz1->sgfn],cg->fgfs[dtSfx1->sgfn],cg->fgfs[dtSfy1->sgfn],cg->fgfs[dtSfz1->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,cor + + +#define RHS_PARA_CALLED_Constraint_Out_SS cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,pre + +#define RHS_PARA_CALLED_Intrp_Constraint_Out_SS cg->shape,TRK4,cg->X[0],cg->X[1],cg->X[2],cg->fgfs[fngfs+ShellPatch::gx],cg->fgfs[fngfs+ShellPatch::gy],cg->fgfs[fngfs+ShellPatch::gz],cg->fgfs[fngfs+ShellPatch::drhodx],cg->fgfs[fngfs+ShellPatch::drhody],cg->fgfs[fngfs+ShellPatch::drhodz],cg->fgfs[fngfs+ShellPatch::dsigmadx],cg->fgfs[fngfs+ShellPatch::dsigmady],cg->fgfs[fngfs+ShellPatch::dsigmadz],cg->fgfs[fngfs+ShellPatch::dRdx],cg->fgfs[fngfs+ShellPatch::dRdy],cg->fgfs[fngfs+ShellPatch::dRdz],cg->fgfs[fngfs+ShellPatch::drhodxx],cg->fgfs[fngfs+ShellPatch::drhodxy],cg->fgfs[fngfs+ShellPatch::drhodxz],cg->fgfs[fngfs+ShellPatch::drhodyy],cg->fgfs[fngfs+ShellPatch::drhodyz],cg->fgfs[fngfs+ShellPatch::drhodzz],cg->fgfs[fngfs+ShellPatch::dsigmadxx],cg->fgfs[fngfs+ShellPatch::dsigmadxy],cg->fgfs[fngfs+ShellPatch::dsigmadxz],cg->fgfs[fngfs+ShellPatch::dsigmadyy],cg->fgfs[fngfs+ShellPatch::dsigmadyz],cg->fgfs[fngfs+ShellPatch::dsigmadzz],cg->fgfs[fngfs+ShellPatch::dRdxx],cg->fgfs[fngfs+ShellPatch::dRdxy],cg->fgfs[fngfs+ShellPatch::dRdxz],cg->fgfs[fngfs+ShellPatch::dRdyy],cg->fgfs[fngfs+ShellPatch::dRdyz],cg->fgfs[fngfs+ShellPatch::dRdzz],cg->fgfs[phi0->sgfn],cg->fgfs[trK0->sgfn],cg->fgfs[gxx0->sgfn],cg->fgfs[gxy0->sgfn],cg->fgfs[gxz0->sgfn],cg->fgfs[gyy0->sgfn],cg->fgfs[gyz0->sgfn],cg->fgfs[gzz0->sgfn],cg->fgfs[Axx0->sgfn],cg->fgfs[Axy0->sgfn],cg->fgfs[Axz0->sgfn],cg->fgfs[Ayy0->sgfn],cg->fgfs[Ayz0->sgfn],cg->fgfs[Azz0->sgfn],cg->fgfs[Gmx0->sgfn],cg->fgfs[Gmy0->sgfn],cg->fgfs[Gmz0->sgfn],cg->fgfs[Lap0->sgfn],cg->fgfs[Sfx0->sgfn],cg->fgfs[Sfy0->sgfn],cg->fgfs[Sfz0->sgfn],cg->fgfs[dtSfx0->sgfn],cg->fgfs[dtSfy0->sgfn],cg->fgfs[dtSfz0->sgfn],cg->fgfs[phi_rhs->sgfn],cg->fgfs[trK_rhs->sgfn],cg->fgfs[gxx_rhs->sgfn],cg->fgfs[gxy_rhs->sgfn],cg->fgfs[gxz_rhs->sgfn],cg->fgfs[gyy_rhs->sgfn],cg->fgfs[gyz_rhs->sgfn],cg->fgfs[gzz_rhs->sgfn],cg->fgfs[Axx_rhs->sgfn],cg->fgfs[Axy_rhs->sgfn],cg->fgfs[Axz_rhs->sgfn],cg->fgfs[Ayy_rhs->sgfn],cg->fgfs[Ayz_rhs->sgfn],cg->fgfs[Azz_rhs->sgfn],cg->fgfs[Gmx_rhs->sgfn],cg->fgfs[Gmy_rhs->sgfn],cg->fgfs[Gmz_rhs->sgfn],cg->fgfs[Lap_rhs->sgfn],cg->fgfs[Sfx_rhs->sgfn],cg->fgfs[Sfy_rhs->sgfn],cg->fgfs[Sfz_rhs->sgfn],cg->fgfs[dtSfx_rhs->sgfn],cg->fgfs[dtSfy_rhs->sgfn],cg->fgfs[dtSfz_rhs->sgfn],cg->fgfs[rho->sgfn],cg->fgfs[Sx->sgfn],cg->fgfs[Sy->sgfn],cg->fgfs[Sz->sgfn],cg->fgfs[Sxx->sgfn],cg->fgfs[Sxy->sgfn],cg->fgfs[Sxz->sgfn],cg->fgfs[Syy->sgfn],cg->fgfs[Syz->sgfn],cg->fgfs[Szz->sgfn],cg->fgfs[Gamxxx->sgfn],cg->fgfs[Gamxxy->sgfn],cg->fgfs[Gamxxz->sgfn],cg->fgfs[Gamxyy->sgfn],cg->fgfs[Gamxyz->sgfn],cg->fgfs[Gamxzz->sgfn],cg->fgfs[Gamyxx->sgfn],cg->fgfs[Gamyxy->sgfn],cg->fgfs[Gamyxz->sgfn],cg->fgfs[Gamyyy->sgfn],cg->fgfs[Gamyyz->sgfn],cg->fgfs[Gamyzz->sgfn],cg->fgfs[Gamzxx->sgfn],cg->fgfs[Gamzxy->sgfn],cg->fgfs[Gamzxz->sgfn],cg->fgfs[Gamzyy->sgfn],cg->fgfs[Gamzyz->sgfn],cg->fgfs[Gamzzz->sgfn],cg->fgfs[Rxx->sgfn],cg->fgfs[Rxy->sgfn],cg->fgfs[Rxz->sgfn],cg->fgfs[Ryy->sgfn],cg->fgfs[Ryz->sgfn],cg->fgfs[Rzz->sgfn],cg->fgfs[Cons_Ham->sgfn],cg->fgfs[Cons_Px->sgfn],cg->fgfs[Cons_Py->sgfn],cg->fgfs[Cons_Pz->sgfn],cg->fgfs[Cons_Gx->sgfn],cg->fgfs[Cons_Gy->sgfn],cg->fgfs[Cons_Gz->sgfn],Symmetry,lev,numepsh,sPp->data->sst,pre +//4------------tool------------------------------ +int compare_result(int ftag1,double * d2,int data_num); + + + +#endif diff --git a/AMSS_NCKU_source/bssn_step_gpu.C b/AMSS_NCKU_source/BSSN_GPU/bssn_step_gpu.C similarity index 97% rename from AMSS_NCKU_source/bssn_step_gpu.C rename to AMSS_NCKU_source/BSSN_GPU/bssn_step_gpu.C index 45ee555..6029ae0 100644 --- a/AMSS_NCKU_source/bssn_step_gpu.C +++ b/AMSS_NCKU_source/BSSN_GPU/bssn_step_gpu.C @@ -1,1942 +1,1942 @@ -// includes, system -#include -#include -#include -#include -#include -#include - -#ifdef RESULT_CHECK -#include -#endif - -// include BSSN class files -#include "macrodef.h" -#include "fmisc.h" -#include "bssn_gpu_class.h" -#include "bssn_rhs.h" -#include "enforce_algebra.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" - -// include gpu files -#include "bssn_gpu.h" - -#if (PSTR == 0) -#if 1 -void bssn_class::Step_GPU(int lev, int YN) -{ - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - -// new code 2013-2-15, zjcao -#if (MAPBH == 1) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - for (int ith = 0; ith < 3; ith++) - Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } -#endif - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) -#warning "shell part still bam type" - if (lev == 0) // Shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_FIRST_TIME)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check rhs - { - SH->Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } -#endif - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_THEN)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) - if (lev == 1) // shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_THEN)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif - - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } -#endif - } - } -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} -#else // #if 1 -// ICN for bam comparison -void bssn_class::Step_GPU(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif - f_icn_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_FIRST_TIME)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_icn_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check rhs - { - SH->Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } - // corrector - for (iter_count = 1; iter_count < 3; iter_count++) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_THEN)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_icn_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_THEN)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} -#endif - -#elif (PSTR == 1) -void bssn_class::Step_GPU(int lev, int YN) -{ - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); - - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - -// new code 2013-2-15, zjcao -#if (MAPBH == 1) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - for (int ith = 0; ith < 3; ith++) - Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif //(MAPBH == 1) - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) -#warning "shell part still bam type" - if (lev == 0) // Shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Predictor rhs calculation"); - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor sync"); - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } -#endif - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector"); - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"head of Corrector"); - - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_THEN)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (SommerType == 0) -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); - -#if (SommerType == 1) - if (lev == 1) // shibata type sommerfeld - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector error check"); - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector sync"); - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector sync"); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - misc::tillherecheck(GH->Commlev[lev], GH->start_rank[lev], "after Corrector of black hole position"); -#endif - - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after pre cor swap"); - -#if (MAPBH == 0) - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } -#endif - } - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"tail of corrector"); - } -#if (RPS == 0) - // mesh refinement boundary part - misc::tillherecheck(GH->Commlev[lev], GH->start_rank[lev], "before RestrictProlong"); - RestrictProlong(lev, YN, BB); -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - // if(myrank==GH->start_rank[lev]) cout<start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],"complet GH Step"); -} -#endif // PSTR == ? - -//--------------------------With Shell-------------------------- - -#ifdef WithShell -void bssn_class::SHStep() -{ - int lev = 0; - // #if (PSTR == 1) - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); - // #endif - - setpbh(BH_num, Porg0, Mass, BH_num_input); - - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - - // #if (PSTR == 1) - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); - // #endif - -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (gpu_rhs_ss(RHS_SS_PARA_CALLED_FIRST_TIME)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - -#if (PSTR == 1) -// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor's error check"); -#endif - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (gpu_rhs_ss(RHS_SS_PARA_CALLED_THEN)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } - - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#if (RPS == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; - } - } -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -} -d -#endif // withshell +// includes, system +#include +#include +#include +#include +#include +#include + +#ifdef RESULT_CHECK +#include +#endif + +// include BSSN class files +#include "macrodef.h" +#include "fmisc.h" +#include "bssn_gpu_class.h" +#include "bssn_rhs.h" +#include "enforce_algebra.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" + +// include gpu files +#include "bssn_gpu.h" + +#if (PSTR == 0) +#if 1 +void bssn_class::Step_GPU(int lev, int YN) +{ + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + +// new code 2013-2-15, zjcao +#if (MAPBH == 1) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + for (int ith = 0; ith < 3; ith++) + Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } +#endif + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) +#warning "shell part still bam type" + if (lev == 0) // Shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_FIRST_TIME)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check rhs + { + SH->Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } +#endif + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_THEN)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) + if (lev == 1) // shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_THEN)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif + + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } +#endif + } + } +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} +#else // #if 1 +// ICN for bam comparison +void bssn_class::Step_GPU(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif + f_icn_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_FIRST_TIME)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_icn_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check rhs + { + SH->Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } + // corrector + for (iter_count = 1; iter_count < 3; iter_count++) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_THEN)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_icn_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (gpu_rhs_ss(CALLED_BY_STEP, myrank, RHS_SS_PARA_CALLED_THEN)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_icn_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_icn_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} +#endif + +#elif (PSTR == 1) +void bssn_class::Step_GPU(int lev, int YN) +{ + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); + + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + +// new code 2013-2-15, zjcao +#if (MAPBH == 1) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + for (int ith = 0; ith < 3; ith++) + Porg1[ithBH][ith] = Porg0[ithBH][ith] + Porg_rhs[ithBH][ith] * dT_lev; + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif //(MAPBH == 1) + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_FIRST_TIME)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) +#warning "shell part still bam type" + if (lev == 0) // Shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Predictor rhs calculation"); + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor sync"); + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } +#endif + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector"); + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"head of Corrector"); + + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (gpu_rhs(CALLED_BY_STEP, myrank, RHS_PARA_CALLED_THEN)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (SommerType == 0) +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); + +#if (SommerType == 1) + if (lev == 1) // shibata type sommerfeld + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector error check"); + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, GH->Commlev[lev]); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Corrector sync"); + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Corrector sync"); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + misc::tillherecheck(GH->Commlev[lev], GH->start_rank[lev], "after Corrector of black hole position"); +#endif + + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after pre cor swap"); + +#if (MAPBH == 0) + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } +#endif + } + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"tail of corrector"); + } +#if (RPS == 0) + // mesh refinement boundary part + misc::tillherecheck(GH->Commlev[lev], GH->start_rank[lev], "before RestrictProlong"); + RestrictProlong(lev, YN, BB); +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + // if(myrank==GH->start_rank[lev]) cout<start_rank[lev]) cout<mylev<Commlev[lev],GH->start_rank[lev],"complet GH Step"); +} +#endif // PSTR == ? + +//--------------------------With Shell-------------------------- + +#ifdef WithShell +void bssn_class::SHStep() +{ + int lev = 0; + // #if (PSTR == 1) + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start Step"); + // #endif + + setpbh(BH_num, Porg0, Mass, BH_num_input); + + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + + // #if (PSTR == 1) + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor"); + // #endif + +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (gpu_rhs_ss(RHS_SS_PARA_CALLED_FIRST_TIME)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + +#if (PSTR == 1) +// misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Predictor's error check"); +#endif + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (gpu_rhs_ss(RHS_SS_PARA_CALLED_THEN)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } + + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#if (RPS == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << "CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds!" << endl; + } + } +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +} +d +#endif // withshell diff --git a/AMSS_NCKU_source/gpu_mem.h b/AMSS_NCKU_source/BSSN_GPU/gpu_mem.h similarity index 97% rename from AMSS_NCKU_source/gpu_mem.h rename to AMSS_NCKU_source/BSSN_GPU/gpu_mem.h index ff649fd..12e5ca3 100644 --- a/AMSS_NCKU_source/gpu_mem.h +++ b/AMSS_NCKU_source/BSSN_GPU/gpu_mem.h @@ -1,146 +1,146 @@ -#ifndef GPU_MEM_H_ -#define GPU_MEM_H_ -#include "macrodef.fh" -struct Meta -{ - //---------------in/out------------------- - // int * ex; - // int* Symmetry,Lev,co; //not array //in - // double * T; //not array //in - double *X, *Y, *Z; // in - double *chi, *dxx, *dyy, *dzz; // inout - double *trK; // in - double *gxy, *gxz, *gyz; // in - double *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz; // in - double *Gamx, *Gamy, *Gamz; // in - double *Lap, *betax, *betay, *betaz; // inout - double *dtSfx, *dtSfy, *dtSfz; // in - double *chi_rhs, *trK_rhs; // out - double *gxx_rhs, *gxy_rhs, *gxz_rhs; // out - double *gyy_rhs, *gyz_rhs, *gzz_rhs; // out - double *Axx_rhs, *Axy_rhs, *Axz_rhs; // out - double *Ayy_rhs, *Ayz_rhs, *Azz_rhs; // out - double *Gamx_rhs, *Gamy_rhs, *Gamz_rhs; // out - double *Lap_rhs, *betax_rhs, *betay_rhs, *betaz_rhs; // out - double *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs; // out - double *rho, *Sx, *Sy, *Sz; // in - double *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz; // in - - // when out, physical second kind of connection //out - double *Gamxxx, *Gamxxy, *Gamxxz; - double *Gamxyy, *Gamxyz, *Gamxzz; - double *Gamyxx, *Gamyxy, *Gamyxz; - double *Gamyyy, *Gamyyz, *Gamyzz; - double *Gamzxx, *Gamzxy, *Gamzxz; - double *Gamzyy, *Gamzyz, *Gamzzz; - - // when out, physical Ricci tensor - double *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz; // out - // double * eps; //in - double *ham_Res, *movx_Res, *movy_Res, *movz_Res; // inout - double *Gmx_Res, *Gmy_Res, *Gmz_Res; // inout - - //---------------local------------------- - - double *gxx, *gyy, *gzz, *chix, *chiy, *chiz, *gxxx, *gxyx, *gxzx, *gyyx, *gyzx, *gzzx, *gxxy, *gxyy, *gxzy, *gyyy, *gyzy, *gzzy, *gxxz, *gxyz, *gxzz, *gyyz, *gyzz, *gzzz, *Lapx, *Lapy, *Lapz, *betaxx, *betaxy, *betaxz, *betayx, *betayy, *betayz, *betazx, *betazy, *betazz, *Gamxx, *Gamxy, *Gamxz, *Gamyx, *Gamyy, *Gamyz, *Gamzx, *Gamzy, *Gamzz, *Kx, *Ky, *Kz, *div_beta, *S, *f, *fxx, *fxy, *fxz, *fyy, *fyz, *fzz, *Gamxa, *Gamya, *Gamza, *alpn1, *chin1, *gupxx, *gupxy, *gupxz, *gupyy, *gupyz, *gupzz; - - //---------------subroutine---------------- - double *fh; - double *fh2; - - /*double *SSS; - double *AAS; - double *ASA; - double *SAA; - double *ASS; - double *SAS; - double *SSA;*/ -//---------------GAUGE-------------- -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - double *reta; -#endif -}; - -//------init constant memory--------- - -// 1-----for compute_rhs_bssn--------- -__constant__ Meta metac; -__constant__ int ex_c[3]; -__constant__ double T_c; -__constant__ int Symmetry_c; -__constant__ int Lev_c; -__constant__ int co_c; -__constant__ double eps_c; -// local -__constant__ double dX; // dX,dY,dZ -__constant__ double dY; -__constant__ double dZ; -__constant__ double ZEO = 1.0; -__constant__ double ONE = 1.0; -__constant__ double TWO = 2.0; -__constant__ double FOUR = 4.0; -__constant__ double EIGHT = 8.0; -__constant__ double HALF = 0.5; -__constant__ double THR = 3.0; -__constant__ double SYM = 1.0; -__constant__ double ANTI = -1.0; -__constant__ double FF = 0.75; -__constant__ double eta = 2.0; -__constant__ double F1o3; -__constant__ double F2o3; -__constant__ double F3o2 = 1.5; -__constant__ double F1o6; -__constant__ double F8 = 8.0; -__constant__ double F16 = 16.0; -__constant__ double PI; -/*__constant__ double SSS[3] = {1,1,1}; -__constant__ double AAS[3] = {-1,-1,1}; -__constant__ double ASA[3] = {-1,1,-1}; -__constant__ double SAA[3] = {1,-1,-1}; -__constant__ double ASS[3] = {-1,1,1}; -__constant__ double SAS[3] = {1,-1,1}; -__constant__ double SSA[3] = {1,1,-1};*/ - -// 2--------for fderivs------------ -__constant__ int ijk_min[3]; -__constant__ int ijk_min2[3]; -__constant__ int ijk_min3[3]; -__constant__ int ijk_max[3]; -__constant__ double d12dxyz[3]; -__constant__ double d2dxyz[3]; - -// 3--------for fdderivs------------ -__constant__ double Sdxdx; -__constant__ double Sdydy; -__constant__ double Sdzdz; -__constant__ double Fdxdx; -__constant__ double Fdydy; -__constant__ double Fdzdz; -__constant__ double Sdxdy; -__constant__ double Sdxdz; -__constant__ double Sdydz; -__constant__ double Fdxdy; -__constant__ double Fdxdz; -__constant__ double Fdydz; - -// my own -__constant__ int STEP_SIZE; -/*__constant__ int MATRIX_SIZE; -__constant__ int MATRIX_SIZE_FH; -__constant__ int SQUARE_SIZE; -__constant__ int SQUARE_SIZE_FH; -__constant__ int LINE_SIZE_FH;*/ - -__constant__ int _1D_SIZE[4]; // start from 0 !! -__constant__ int _2D_SIZE[4]; ////start from 0 !! -__constant__ int _3D_SIZE[4]; ////start from 0 !! - -#if (GAUGE == 6 || GAUGE == 7) -__constant__ int BHN; -__constant__ double Porg[9]; -__constant__ double Mass[3]; -__constant__ double /*r1,r2*/, M, A, /*w1,w2 (== 12)*/, C1, C2; -#endif - -/**/ -#endif +#ifndef GPU_MEM_H_ +#define GPU_MEM_H_ +#include "macrodef.fh" +struct Meta +{ + //---------------in/out------------------- + // int * ex; + // int* Symmetry,Lev,co; //not array //in + // double * T; //not array //in + double *X, *Y, *Z; // in + double *chi, *dxx, *dyy, *dzz; // inout + double *trK; // in + double *gxy, *gxz, *gyz; // in + double *Axx, *Axy, *Axz, *Ayy, *Ayz, *Azz; // in + double *Gamx, *Gamy, *Gamz; // in + double *Lap, *betax, *betay, *betaz; // inout + double *dtSfx, *dtSfy, *dtSfz; // in + double *chi_rhs, *trK_rhs; // out + double *gxx_rhs, *gxy_rhs, *gxz_rhs; // out + double *gyy_rhs, *gyz_rhs, *gzz_rhs; // out + double *Axx_rhs, *Axy_rhs, *Axz_rhs; // out + double *Ayy_rhs, *Ayz_rhs, *Azz_rhs; // out + double *Gamx_rhs, *Gamy_rhs, *Gamz_rhs; // out + double *Lap_rhs, *betax_rhs, *betay_rhs, *betaz_rhs; // out + double *dtSfx_rhs, *dtSfy_rhs, *dtSfz_rhs; // out + double *rho, *Sx, *Sy, *Sz; // in + double *Sxx, *Sxy, *Sxz, *Syy, *Syz, *Szz; // in + + // when out, physical second kind of connection //out + double *Gamxxx, *Gamxxy, *Gamxxz; + double *Gamxyy, *Gamxyz, *Gamxzz; + double *Gamyxx, *Gamyxy, *Gamyxz; + double *Gamyyy, *Gamyyz, *Gamyzz; + double *Gamzxx, *Gamzxy, *Gamzxz; + double *Gamzyy, *Gamzyz, *Gamzzz; + + // when out, physical Ricci tensor + double *Rxx, *Rxy, *Rxz, *Ryy, *Ryz, *Rzz; // out + // double * eps; //in + double *ham_Res, *movx_Res, *movy_Res, *movz_Res; // inout + double *Gmx_Res, *Gmy_Res, *Gmz_Res; // inout + + //---------------local------------------- + + double *gxx, *gyy, *gzz, *chix, *chiy, *chiz, *gxxx, *gxyx, *gxzx, *gyyx, *gyzx, *gzzx, *gxxy, *gxyy, *gxzy, *gyyy, *gyzy, *gzzy, *gxxz, *gxyz, *gxzz, *gyyz, *gyzz, *gzzz, *Lapx, *Lapy, *Lapz, *betaxx, *betaxy, *betaxz, *betayx, *betayy, *betayz, *betazx, *betazy, *betazz, *Gamxx, *Gamxy, *Gamxz, *Gamyx, *Gamyy, *Gamyz, *Gamzx, *Gamzy, *Gamzz, *Kx, *Ky, *Kz, *div_beta, *S, *f, *fxx, *fxy, *fxz, *fyy, *fyz, *fzz, *Gamxa, *Gamya, *Gamza, *alpn1, *chin1, *gupxx, *gupxy, *gupxz, *gupyy, *gupyz, *gupzz; + + //---------------subroutine---------------- + double *fh; + double *fh2; + + /*double *SSS; + double *AAS; + double *ASA; + double *SAA; + double *ASS; + double *SAS; + double *SSA;*/ +//---------------GAUGE-------------- +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + double *reta; +#endif +}; + +//------init constant memory--------- + +// 1-----for compute_rhs_bssn--------- +__constant__ Meta metac; +__constant__ int ex_c[3]; +__constant__ double T_c; +__constant__ int Symmetry_c; +__constant__ int Lev_c; +__constant__ int co_c; +__constant__ double eps_c; +// local +__constant__ double dX; // dX,dY,dZ +__constant__ double dY; +__constant__ double dZ; +__constant__ double ZEO = 1.0; +__constant__ double ONE = 1.0; +__constant__ double TWO = 2.0; +__constant__ double FOUR = 4.0; +__constant__ double EIGHT = 8.0; +__constant__ double HALF = 0.5; +__constant__ double THR = 3.0; +__constant__ double SYM = 1.0; +__constant__ double ANTI = -1.0; +__constant__ double FF = 0.75; +__constant__ double eta = 2.0; +__constant__ double F1o3; +__constant__ double F2o3; +__constant__ double F3o2 = 1.5; +__constant__ double F1o6; +__constant__ double F8 = 8.0; +__constant__ double F16 = 16.0; +__constant__ double PI; +/*__constant__ double SSS[3] = {1,1,1}; +__constant__ double AAS[3] = {-1,-1,1}; +__constant__ double ASA[3] = {-1,1,-1}; +__constant__ double SAA[3] = {1,-1,-1}; +__constant__ double ASS[3] = {-1,1,1}; +__constant__ double SAS[3] = {1,-1,1}; +__constant__ double SSA[3] = {1,1,-1};*/ + +// 2--------for fderivs------------ +__constant__ int ijk_min[3]; +__constant__ int ijk_min2[3]; +__constant__ int ijk_min3[3]; +__constant__ int ijk_max[3]; +__constant__ double d12dxyz[3]; +__constant__ double d2dxyz[3]; + +// 3--------for fdderivs------------ +__constant__ double Sdxdx; +__constant__ double Sdydy; +__constant__ double Sdzdz; +__constant__ double Fdxdx; +__constant__ double Fdydy; +__constant__ double Fdzdz; +__constant__ double Sdxdy; +__constant__ double Sdxdz; +__constant__ double Sdydz; +__constant__ double Fdxdy; +__constant__ double Fdxdz; +__constant__ double Fdydz; + +// my own +__constant__ int STEP_SIZE; +/*__constant__ int MATRIX_SIZE; +__constant__ int MATRIX_SIZE_FH; +__constant__ int SQUARE_SIZE; +__constant__ int SQUARE_SIZE_FH; +__constant__ int LINE_SIZE_FH;*/ + +__constant__ int _1D_SIZE[4]; // start from 0 !! +__constant__ int _2D_SIZE[4]; ////start from 0 !! +__constant__ int _3D_SIZE[4]; ////start from 0 !! + +#if (GAUGE == 6 || GAUGE == 7) +__constant__ int BHN; +__constant__ double Porg[9]; +__constant__ double Mass[3]; +__constant__ double /*r1,r2*/, M, A, /*w1,w2 (== 12)*/, C1, C2; +#endif + +/**/ +#endif diff --git a/AMSS_NCKU_source/gpu_rhsSS_mem.h b/AMSS_NCKU_source/BSSN_GPU/gpu_rhsSS_mem.h similarity index 96% rename from AMSS_NCKU_source/gpu_rhsSS_mem.h rename to AMSS_NCKU_source/BSSN_GPU/gpu_rhsSS_mem.h index c2b4c2b..9c2d16c 100644 --- a/AMSS_NCKU_source/gpu_rhsSS_mem.h +++ b/AMSS_NCKU_source/BSSN_GPU/gpu_rhsSS_mem.h @@ -1,198 +1,198 @@ -#ifndef GPU_MEM_H_ -#define GPU_MEM_H_ -#include "macrodef.fh" - -#ifdef WithShell -struct Metass -{ - double *crho,* sigma,* R,* - drhodx,* drhody,* drhodz,* - dsigmadx,* dsigmady,* dsigmadz,* - dRdx,* dRdy,* dRdz,* - drhodxx,* drhodxy,* drhodxz,* - drhodyy,* drhodyz,* drhodzz,* - dsigmadxx,* dsigmadxy,* dsigmadxz,* - dsigmadyy,* dsigmadyz,* dsigmadzz,* - dRdxx,* dRdxy,* dRdxz,* - dRdyy,* dRdyz,* dRdzz; - //local - double *gx,*gy,*gz,*gxx,*gxy,*gxz,*gyy,*gyz,*gzz; -}; - -__constant__ Metass metassc; -Metass * metass; - -#endif //WithShell - -struct Meta -{ - //SS - - //---------------in/out------------------- - //int * ex; - //int* Symmetry,Lev,co; //not array //in - //double * T; //not array //in - double * X,*Y,*Z; //in - double * chi,*dxx,*dyy,*dzz; //inout - double * trK ; //in - double * gxy,*gxz,*gyz; //in - double * Axx,*Axy,*Axz,*Ayy,*Ayz,*Azz; //in - double * Gamx,*Gamy,*Gamz ; //in - double * Lap, *betax, *betay, *betaz; //inout - double * dtSfx, *dtSfy, *dtSfz ; //in - double * chi_rhs,*trK_rhs ; //out - double * gxx_rhs,*gxy_rhs,*gxz_rhs; //out - double * gyy_rhs,*gyz_rhs,*gzz_rhs; //out - double * Axx_rhs,*Axy_rhs,*Axz_rhs; //out - double * Ayy_rhs,*Ayz_rhs,*Azz_rhs; //out - double * Gamx_rhs,*Gamy_rhs,*Gamz_rhs;//out - double * Lap_rhs, *betax_rhs, *betay_rhs, *betaz_rhs;//out - double * dtSfx_rhs,*dtSfy_rhs,*dtSfz_rhs;//out - double * rho,*Sx,*Sy,*Sz ; //in - double * Sxx,*Sxy,*Sxz,*Syy,*Syz,*Szz; //in - - // when out, physical second kind of connection //out - double * Gamxxx, *Gamxxy, *Gamxxz; - double * Gamxyy, *Gamxyz, *Gamxzz; - double * Gamyxx, *Gamyxy, *Gamyxz; - double * Gamyyy, *Gamyyz, *Gamyzz; - double * Gamzxx, *Gamzxy,* Gamzxz; - double * Gamzyy, *Gamzyz, *Gamzzz; - - //when out, physical Ricci tensor - double * Rxx,*Rxy,*Rxz,*Ryy,*Ryz,*Rzz; //out - //double * eps; //in - double * ham_Res, *movx_Res, *movy_Res, *movz_Res; //inout - double * Gmx_Res, *Gmy_Res, *Gmz_Res; //inout - - - //---------------local------------------- - - double * gxx,*gyy,*gzz - , *chix,*chiy,*chiz - , *gxxx,*gxyx,*gxzx,*gyyx,*gyzx,*gzzx - , *gxxy,*gxyy,*gxzy,*gyyy,*gyzy,*gzzy - , *gxxz,*gxyz,*gxzz,*gyyz,*gyzz,*gzzz - , *Lapx,*Lapy,*Lapz - , *betaxx,*betaxy,*betaxz - , *betayx,*betayy,*betayz - , *betazx,*betazy,*betazz - , *Gamxx,*Gamxy,*Gamxz - , *Gamyx,*Gamyy,*Gamyz - , *Gamzx,*Gamzy,*Gamzz - , *Kx,*Ky,*Kz,*div_beta,*S - , *f,*fxx,*fxy,*fxz,*fyy,*fyz,*fzz - , *Gamxa,*Gamya,*Gamza,*alpn1,*chin1 - , *gupxx,*gupxy,*gupxz - , *gupyy,*gupyz,*gupzz; - - //---------------subroutine---------------- - double * fh; - double * fh2; - - /*double *SSS; - double *AAS; - double *ASA; - double *SAA; - double *ASS; - double *SAS; - double *SSA;*/ - - //---------------GAUGE-------------- -#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) - double * reta; -#endif - -}; - -//------init constant memory--------- - -//1-----for compute_rhs_bssn--------- -__constant__ Meta metac; - -__constant__ int ex_c[3]; -__constant__ double T_c; -__constant__ int Symmetry_c; -__constant__ int Lev_c; -__constant__ int co_c; -__constant__ double eps_c; -__constant__ int sst_c; -//local -__constant__ double dX; //dX,dY,dZ -__constant__ double dY; -__constant__ double dZ; -__constant__ double ZEO = 1.0; -__constant__ double ONE = 1.0; -__constant__ double TWO = 2.0; -__constant__ double FOUR = 4.0; -__constant__ double EIGHT = 8.0; -__constant__ double HALF = 0.5; -__constant__ double THR = 3.0; -__constant__ double SYM = 1.0; -__constant__ double ANTI = -1.0; -__constant__ double FF = 0.75; -__constant__ double eta = 2.0; -__constant__ double F1o3; -__constant__ double F2o3; -__constant__ double F3o2 = 1.5; -__constant__ double F1o6; -__constant__ double F8 = 8.0; -__constant__ double F16 = 16.0; -__constant__ double PI; -/*__constant__ double SSS[3] = {1,1,1}; -__constant__ double AAS[3] = {-1,-1,1}; -__constant__ double ASA[3] = {-1,1,-1}; -__constant__ double SAA[3] = {1,-1,-1}; -__constant__ double ASS[3] = {-1,1,1}; -__constant__ double SAS[3] = {1,-1,1}; -__constant__ double SSA[3] = {1,1,-1};*/ - -//2--------for fderivs------------ -__constant__ int ijk_min[3]; -__constant__ int ijk_min2[3]; -__constant__ int ijk_min3[3]; -__constant__ int ijk_max[3]; -__constant__ int ijk_max3[3]; -__constant__ double d12dxyz[3]; -__constant__ double d2dxyz[3]; - -//3--------for fdderivs------------ -__constant__ double Sdxdx; -__constant__ double Sdydy; -__constant__ double Sdzdz; -__constant__ double Fdxdx; -__constant__ double Fdydy; -__constant__ double Fdzdz; -__constant__ double Sdxdy; -__constant__ double Sdxdz; -__constant__ double Sdydz; -__constant__ double Fdxdy; -__constant__ double Fdxdz; -__constant__ double Fdydz; - - -//my own -__constant__ int STEP_SIZE; -/*__constant__ int MATRIX_SIZE; -__constant__ int MATRIX_SIZE_FH; -__constant__ int SQUARE_SIZE; -__constant__ int SQUARE_SIZE_FH; -__constant__ int LINE_SIZE_FH;*/ - -__constant__ int _1D_SIZE[4]; //start from 0 !! -__constant__ int _2D_SIZE[4]; ////start from 0 !! -__constant__ int _3D_SIZE[4]; ////start from 0 !! - -int h_1D_SIZE[4]; //start from 0 !! -int h_2D_SIZE[4]; ////start from 0 !! -int h_3D_SIZE[4]; ////start from 0 !! -Meta * meta; - -#if (GAUGE == 6 || GAUGE == 7) -__constant__ int BHN; -__constant__ double Porg[9]; -__constant__ double Mass[3]; -__constant__ double /*r1,r2*/,M,A,/*w1,w2 (== 12)*/,C1,C2; -#endif -/**/ -#endif +#ifndef GPU_MEM_H_ +#define GPU_MEM_H_ +#include "macrodef.fh" + +#ifdef WithShell +struct Metass +{ + double *crho,* sigma,* R,* + drhodx,* drhody,* drhodz,* + dsigmadx,* dsigmady,* dsigmadz,* + dRdx,* dRdy,* dRdz,* + drhodxx,* drhodxy,* drhodxz,* + drhodyy,* drhodyz,* drhodzz,* + dsigmadxx,* dsigmadxy,* dsigmadxz,* + dsigmadyy,* dsigmadyz,* dsigmadzz,* + dRdxx,* dRdxy,* dRdxz,* + dRdyy,* dRdyz,* dRdzz; + //local + double *gx,*gy,*gz,*gxx,*gxy,*gxz,*gyy,*gyz,*gzz; +}; + +__constant__ Metass metassc; +Metass * metass; + +#endif //WithShell + +struct Meta +{ + //SS + + //---------------in/out------------------- + //int * ex; + //int* Symmetry,Lev,co; //not array //in + //double * T; //not array //in + double * X,*Y,*Z; //in + double * chi,*dxx,*dyy,*dzz; //inout + double * trK ; //in + double * gxy,*gxz,*gyz; //in + double * Axx,*Axy,*Axz,*Ayy,*Ayz,*Azz; //in + double * Gamx,*Gamy,*Gamz ; //in + double * Lap, *betax, *betay, *betaz; //inout + double * dtSfx, *dtSfy, *dtSfz ; //in + double * chi_rhs,*trK_rhs ; //out + double * gxx_rhs,*gxy_rhs,*gxz_rhs; //out + double * gyy_rhs,*gyz_rhs,*gzz_rhs; //out + double * Axx_rhs,*Axy_rhs,*Axz_rhs; //out + double * Ayy_rhs,*Ayz_rhs,*Azz_rhs; //out + double * Gamx_rhs,*Gamy_rhs,*Gamz_rhs;//out + double * Lap_rhs, *betax_rhs, *betay_rhs, *betaz_rhs;//out + double * dtSfx_rhs,*dtSfy_rhs,*dtSfz_rhs;//out + double * rho,*Sx,*Sy,*Sz ; //in + double * Sxx,*Sxy,*Sxz,*Syy,*Syz,*Szz; //in + + // when out, physical second kind of connection //out + double * Gamxxx, *Gamxxy, *Gamxxz; + double * Gamxyy, *Gamxyz, *Gamxzz; + double * Gamyxx, *Gamyxy, *Gamyxz; + double * Gamyyy, *Gamyyz, *Gamyzz; + double * Gamzxx, *Gamzxy,* Gamzxz; + double * Gamzyy, *Gamzyz, *Gamzzz; + + //when out, physical Ricci tensor + double * Rxx,*Rxy,*Rxz,*Ryy,*Ryz,*Rzz; //out + //double * eps; //in + double * ham_Res, *movx_Res, *movy_Res, *movz_Res; //inout + double * Gmx_Res, *Gmy_Res, *Gmz_Res; //inout + + + //---------------local------------------- + + double * gxx,*gyy,*gzz + , *chix,*chiy,*chiz + , *gxxx,*gxyx,*gxzx,*gyyx,*gyzx,*gzzx + , *gxxy,*gxyy,*gxzy,*gyyy,*gyzy,*gzzy + , *gxxz,*gxyz,*gxzz,*gyyz,*gyzz,*gzzz + , *Lapx,*Lapy,*Lapz + , *betaxx,*betaxy,*betaxz + , *betayx,*betayy,*betayz + , *betazx,*betazy,*betazz + , *Gamxx,*Gamxy,*Gamxz + , *Gamyx,*Gamyy,*Gamyz + , *Gamzx,*Gamzy,*Gamzz + , *Kx,*Ky,*Kz,*div_beta,*S + , *f,*fxx,*fxy,*fxz,*fyy,*fyz,*fzz + , *Gamxa,*Gamya,*Gamza,*alpn1,*chin1 + , *gupxx,*gupxy,*gupxz + , *gupyy,*gupyz,*gupzz; + + //---------------subroutine---------------- + double * fh; + double * fh2; + + /*double *SSS; + double *AAS; + double *ASA; + double *SAA; + double *ASS; + double *SAS; + double *SSA;*/ + + //---------------GAUGE-------------- +#if (GAUGE == 2 || GAUGE == 3 || GAUGE == 4 || GAUGE == 5 || GAUGE == 6 || GAUGE == 7) + double * reta; +#endif + +}; + +//------init constant memory--------- + +//1-----for compute_rhs_bssn--------- +__constant__ Meta metac; + +__constant__ int ex_c[3]; +__constant__ double T_c; +__constant__ int Symmetry_c; +__constant__ int Lev_c; +__constant__ int co_c; +__constant__ double eps_c; +__constant__ int sst_c; +//local +__constant__ double dX; //dX,dY,dZ +__constant__ double dY; +__constant__ double dZ; +__constant__ double ZEO = 1.0; +__constant__ double ONE = 1.0; +__constant__ double TWO = 2.0; +__constant__ double FOUR = 4.0; +__constant__ double EIGHT = 8.0; +__constant__ double HALF = 0.5; +__constant__ double THR = 3.0; +__constant__ double SYM = 1.0; +__constant__ double ANTI = -1.0; +__constant__ double FF = 0.75; +__constant__ double eta = 2.0; +__constant__ double F1o3; +__constant__ double F2o3; +__constant__ double F3o2 = 1.5; +__constant__ double F1o6; +__constant__ double F8 = 8.0; +__constant__ double F16 = 16.0; +__constant__ double PI; +/*__constant__ double SSS[3] = {1,1,1}; +__constant__ double AAS[3] = {-1,-1,1}; +__constant__ double ASA[3] = {-1,1,-1}; +__constant__ double SAA[3] = {1,-1,-1}; +__constant__ double ASS[3] = {-1,1,1}; +__constant__ double SAS[3] = {1,-1,1}; +__constant__ double SSA[3] = {1,1,-1};*/ + +//2--------for fderivs------------ +__constant__ int ijk_min[3]; +__constant__ int ijk_min2[3]; +__constant__ int ijk_min3[3]; +__constant__ int ijk_max[3]; +__constant__ int ijk_max3[3]; +__constant__ double d12dxyz[3]; +__constant__ double d2dxyz[3]; + +//3--------for fdderivs------------ +__constant__ double Sdxdx; +__constant__ double Sdydy; +__constant__ double Sdzdz; +__constant__ double Fdxdx; +__constant__ double Fdydy; +__constant__ double Fdzdz; +__constant__ double Sdxdy; +__constant__ double Sdxdz; +__constant__ double Sdydz; +__constant__ double Fdxdy; +__constant__ double Fdxdz; +__constant__ double Fdydz; + + +//my own +__constant__ int STEP_SIZE; +/*__constant__ int MATRIX_SIZE; +__constant__ int MATRIX_SIZE_FH; +__constant__ int SQUARE_SIZE; +__constant__ int SQUARE_SIZE_FH; +__constant__ int LINE_SIZE_FH;*/ + +__constant__ int _1D_SIZE[4]; //start from 0 !! +__constant__ int _2D_SIZE[4]; ////start from 0 !! +__constant__ int _3D_SIZE[4]; ////start from 0 !! + +int h_1D_SIZE[4]; //start from 0 !! +int h_2D_SIZE[4]; ////start from 0 !! +int h_3D_SIZE[4]; ////start from 0 !! +Meta * meta; + +#if (GAUGE == 6 || GAUGE == 7) +__constant__ int BHN; +__constant__ double Porg[9]; +__constant__ double Mass[3]; +__constant__ double /*r1,r2*/,M,A,/*w1,w2 (== 12)*/,C1,C2; +#endif +/**/ +#endif diff --git a/AMSS_NCKU_source/checkpoint.C b/AMSS_NCKU_source/Check_Point/checkpoint.C similarity index 96% rename from AMSS_NCKU_source/checkpoint.C rename to AMSS_NCKU_source/Check_Point/checkpoint.C index 25637b6..b8222f2 100644 --- a/AMSS_NCKU_source/checkpoint.C +++ b/AMSS_NCKU_source/Check_Point/checkpoint.C @@ -1,893 +1,893 @@ - -#ifdef newc -#include -using namespace std; -#else -#include -#endif - -#include "checkpoint.h" -#include "misc.h" -#include "fmisc.h" -#include "parameters.h" - -checkpoint::checkpoint(bool checked, const char fname[], int myrank) : filename(0), CheckList(0), checkedrun(checked) -{ - - map::iterator iter; - iter = parameters::str_par.find("output dir"); - - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - cout << "checkpoint 01" << endl; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - I_Print = (myrank == 0); - - int i = strlen(fname); - filename = new char[i+30]; - // cout << filename << endl; - // cout << i << endl; - -#ifdef CHECKDETAIL - char cmd[80]; - if (!checkedrun) - { - sprintf(cmd, "rm -rf %s/%d", out_dir.c_str(), myrank); - system(cmd); - sprintf(cmd, "mkdir %s/%d", out_dir.c_str(), myrank); - system(cmd); - } - sprintf(filename, "%s/%d/%s", out_dir.c_str(), myrank, fname); -#else - // cout << "checkpoint 5" << endl; - sprintf(filename, "%s/%s", out_dir.c_str(), fname); - // cout << "checkpoint 6" << endl; -#endif - if (myrank==0) { - cout << " checkpoint class created " << endl; - } -} -checkpoint::~checkpoint() -{ - CheckList->clearList(); - if (I_Print) - delete[] filename; -} - -void checkpoint::addvariable(var *VV) -{ - if (!VV) - return; - - if (CheckList) - CheckList->insert(VV); - else - CheckList = new MyList(VV); -} -void checkpoint::addvariablelist(MyList *VL) -{ - while (VL) - { - if (CheckList) - CheckList->insert(VL->data); - else - CheckList = new MyList(VL->data); - VL = VL->next; - } -} -#ifndef CHECKDETAIL -void checkpoint::writecheck_cgh(double time, cgh *GH) -{ - ofstream outfile; - - if (I_Print) - { - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_cgh.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.write((char *)&time, sizeof(double)); - outfile.write((char *)&(GH->levels), sizeof(int)); - outfile.write((char *)&(GH->movls), sizeof(int)); - outfile.write((char *)&(GH->BH_num_in), sizeof(int)); - outfile.write((char *)GH->grids, GH->levels * sizeof(int)); - outfile.write((char *)GH->Lt, GH->levels * sizeof(double)); - for (int lev = 0; lev < GH->levels; lev++) - { - for (int grd = 0; grd < GH->grids[lev]; grd++) - { - outfile.write((char *)GH->bbox[lev][grd], 6 * sizeof(double)); - outfile.write((char *)GH->shape[lev][grd], 3 * sizeof(int)); - outfile.write((char *)GH->handle[lev][grd], 3 * sizeof(double)); - } - for (int ibh = 0; ibh < GH->BH_num_in; ibh++) - { - outfile.write((char *)GH->Porgls[lev][ibh], 3 * sizeof(double)); - } - } - } - // write variable data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *PL = GH->PatL[lev]; - while (PL) - { - Patch *PP = PL->data; - int nn = PP->shape[0] * PP->shape[1] * PP->shape[2]; - MyList *VL = CheckList; - while (VL) - { - double *databuffer = Parallel::Collect_Data(PP, VL->data); - if (I_Print) - outfile.write((char *)databuffer, sizeof(double) * nn); - if (databuffer) - delete[] databuffer; - VL = VL->next; - } - PL = PL->next; - } - } - - if (I_Print) - outfile.close(); -} -void checkpoint::readcheck_cgh(double &time, cgh *GH, int myrank, int nprocs, int Symmetry) -{ - int DIM = dim; - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_cgh.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - infile.seekg(0, ios::beg); - infile.read((char *)&time, sizeof(double)); - if (I_Print) - cout << "check cgh in at t = " << time << endl; - infile.read((char *)&(GH->levels), sizeof(int)); - infile.read((char *)&(GH->movls), sizeof(int)); - infile.read((char *)&(GH->BH_num_in), sizeof(int)); - GH->grids = new int[GH->levels]; - GH->bbox = new double **[GH->levels]; - GH->shape = new int **[GH->levels]; - GH->handle = new double **[GH->levels]; - GH->PatL = new MyList *[GH->levels]; - GH->Lt = new double[GH->levels]; - GH->Porgls = new double **[GH->levels]; -#if (RPB == 1) - GH->bdsul = new MyList *[GH->levels]; - GH->rsul = new MyList *[GH->levels]; -#endif - infile.read((char *)GH->grids, GH->levels * sizeof(int)); - infile.read((char *)GH->Lt, GH->levels * sizeof(double)); - for (int lev = 0; lev < GH->levels; lev++) - { - GH->bbox[lev] = new double *[GH->grids[lev]]; - GH->shape[lev] = new int *[GH->grids[lev]]; - GH->handle[lev] = new double *[GH->grids[lev]]; - GH->Porgls[lev] = new double *[GH->BH_num_in]; - for (int grd = 0; grd < GH->grids[lev]; grd++) - { - GH->bbox[lev][grd] = new double[6]; - GH->shape[lev][grd] = new int[3]; - GH->handle[lev][grd] = new double[3]; - infile.read((char *)GH->bbox[lev][grd], 6 * sizeof(double)); - infile.read((char *)GH->shape[lev][grd], 3 * sizeof(int)); - infile.read((char *)GH->handle[lev][grd], 3 * sizeof(double)); - } - for (int ibh = 0; ibh < GH->BH_num_in; ibh++) - { - GH->Porgls[lev][ibh] = new double[dim]; - infile.read((char *)GH->Porgls[lev][ibh], 3 * sizeof(double)); - } - } - - for (int lev = 0; lev < GH->levels; lev++) - GH->PatL[lev] = GH->construct_patchlist(lev, Symmetry); - - GH->compose_cgh(nprocs); - // write variable data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *PL = GH->PatL[lev]; - while (PL) - { - Patch *PP = PL->data; - int nn = PP->shape[0] * PP->shape[1] * PP->shape[2]; - double *databuffer = new double[nn]; - MyList *VL = CheckList; - while (VL) - { - infile.read((char *)databuffer, sizeof(double) * nn); - - { - MyList *BL = PP->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[VL->data->sgfn], - PP->bbox, PP->bbox + DIM, PP->shape, databuffer, - cg->bbox, cg->bbox + DIM); - } - if (BL == PP->ble) - break; - BL = BL->next; - } - } - - VL = VL->next; - } - delete[] databuffer; - PL = PL->next; - } - } - - infile.close(); -} -void checkpoint::writecheck_sh(double time, ShellPatch *SH) -{ - ofstream outfile; - - if (I_Print) - { - char fname[50]; - sprintf(fname, "%s_sh.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.write((char *)&time, sizeof(double)); - } - - // write variable data - MyList *Pp = SH->PatL; - while (Pp) - { - int nn = Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]; - MyList *VL = CheckList; - while (VL) - { - double *databuffer = SH->Collect_Data(Pp->data, VL->data); - if (I_Print) - outfile.write((char *)databuffer, sizeof(double) * nn); - if (databuffer) - delete[] databuffer; - VL = VL->next; - } - Pp = Pp->next; - } - - if (I_Print) - outfile.close(); -} -void checkpoint::readcheck_sh(ShellPatch *SH, int myrank) -{ - int DIM = dim; - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_sh.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - double time; - infile.seekg(0, ios::beg); - infile.read((char *)&time, sizeof(double)); - if (I_Print) - cout << "check ShellPatch in at t = " << time << endl; - - // because we assume the shell patch is fixed we can leave the composing to other routine - - MyList *Pp = SH->PatL; - while (Pp) - { - int nn = Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]; - double *databuffer = new double[nn]; - MyList *VL = CheckList; - while (VL) - { - infile.read((char *)databuffer, sizeof(double) * nn); - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[VL->data->sgfn], - Pp->data->bbox, Pp->data->bbox + DIM, Pp->data->shape, databuffer, - cg->bbox, cg->bbox + DIM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - VL = VL->next; - } - delete[] databuffer; - Pp = Pp->next; - } - - infile.close(); -} -void checkpoint::write_Black_Hole_position(int BH_num_input, int BH_num, double **Porg0, double **Porgbr, double *Mass) -{ - ofstream outfile; - - if (I_Print) - { - char fname[50]; - sprintf(fname, "%s_BHp.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.write((char *)&BH_num_input, sizeof(int)); - outfile.write((char *)&BH_num, sizeof(int)); - outfile.write((char *)Mass, 3 * sizeof(double)); - for (int i = 0; i < BH_num; i++) - { - outfile.write((char *)Porg0[i], 3 * sizeof(double)); - outfile.write((char *)Porgbr[i], 3 * sizeof(double)); - } - - outfile.close(); - } -} -void checkpoint::read_Black_Hole_position(int &BH_num_input, int &BH_num, double **&Porg0, double *&Pmom, - double *&Spin, double *&Mass, double **&Porgbr, double **&Porg, - double **&Porg1, double **&Porg_rhs) -{ - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_BHp.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (I_Print) - cout << "checking in Black_Hole_position" << endl; - - infile.seekg(0, ios::beg); - infile.read((char *)&BH_num_input, sizeof(int)); - infile.read((char *)&BH_num, sizeof(int)); - // these arrays will be deleted when bssn_class is deleted - Pmom = new double[3 * BH_num]; - Spin = new double[3 * BH_num]; - Mass = new double[BH_num]; - Porg0 = new double *[BH_num]; - Porgbr = new double *[BH_num]; - Porg = new double *[BH_num]; - Porg1 = new double *[BH_num]; - Porg_rhs = new double *[BH_num]; - infile.read((char *)Mass, 3 * sizeof(double)); - for (int i = 0; i < BH_num; i++) - { - Porg0[i] = new double[3]; - Porgbr[i] = new double[3]; - Porg[i] = new double[3]; - Porg1[i] = new double[3]; - Porg_rhs[i] = new double[3]; - infile.read((char *)Porg0[i], 3 * sizeof(double)); - infile.read((char *)Porgbr[i], 3 * sizeof(double)); - } - - infile.close(); -} -void checkpoint::write_bssn(double LastDump, double Last2dDump, double LastAnas) -{ - ofstream outfile; - - if (I_Print) - { - char fname[50]; - sprintf(fname, "%s_bssn.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.write((char *)&LastDump, sizeof(double)); - outfile.write((char *)&Last2dDump, sizeof(double)); - outfile.write((char *)&LastAnas, sizeof(double)); - - outfile.close(); - } -} -void checkpoint::read_bssn(double &LastDump, double &Last2dDump, double &LastAnas) -{ - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_bssn.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (I_Print) - cout << "checking in bssn parameters" << endl; - - infile.seekg(0, ios::beg); - infile.read((char *)&LastDump, sizeof(double)); - infile.read((char *)&Last2dDump, sizeof(double)); - infile.read((char *)&LastAnas, sizeof(double)); - - infile.close(); -} -#else -void checkpoint::write_bssn(double LastDump, double Last2dDump, double LastAnas) -{ - ofstream outfile; - - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_bssn.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - outfile << LastDump << " "; - outfile << Last2dDump << " "; - outfile << LastAnas << " " << endl; - - outfile.close(); -} -void checkpoint::read_bssn(double &LastDump, double &Last2dDump, double &LastAnas) -{ - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_bssn.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (I_Print) - cout << "checking in bssn parameters" << endl; - - infile.seekg(0, ios::beg); - infile >> LastDump; - infile >> Last2dDump; - infile >> LastAnas; - - infile.close(); -} -void checkpoint::write_Black_Hole_position(int BH_num_input, int BH_num, double **Porg0, double **Porgbr) -{ - ofstream outfile; - - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_BHp.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - outfile << BH_num_input << " "; - outfile << BH_num << " "; - for (int i = 0; i < BH_num; i++) - { - for (int j = 0; j < 3; j++) - outfile << Porg0[i][j] << " "; - for (int j = 0; j < 3; j++) - outfile << Porgbr[i][j] << " "; - } - - outfile << endl; - outfile.close(); -} -void checkpoint::read_Black_Hole_position(int &BH_num_input, int &BH_num, double **&Porg0, double *&Pmom, - double *&Spin, double *&Mass, double **&Porgbr, double **&Porg, - double **&Porg1, double **&Porg_rhs) -{ - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_BHp.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (I_Print) - cout << "checking in Black_Hole_position" << endl; - - infile.seekg(0, ios::beg); - infile >> BH_num_input; - infile >> BH_num; - // these arrays will be deleted when bssn_class is deleted - Pmom = new double[3 * BH_num]; - Spin = new double[3 * BH_num]; - Mass = new double[BH_num]; - Porg0 = new double *[BH_num]; - Porgbr = new double *[BH_num]; - Porg = new double *[BH_num]; - Porg1 = new double *[BH_num]; - Porg_rhs = new double *[BH_num]; - for (int i = 0; i < BH_num; i++) - { - Porg0[i] = new double[3]; - Porgbr[i] = new double[3]; - Porg[i] = new double[3]; - Porg1[i] = new double[3]; - Porg_rhs[i] = new double[3]; - for (int j = 0; j < 3; j++) - infile >> Porg0[i][j]; - for (int j = 0; j < 3; j++) - infile >> Porgbr[i][j]; - } - - infile.close(); -} -void checkpoint::writecheck_cgh(double time, cgh *GH) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - ofstream outfile; - - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_cgh.CHK", filename); - - outfile.open(fname, ios::out | ios::trunc); - if (!outfile) - { - cout << "Can't open " << fname << " for check point out." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - outfile << time << " "; - outfile << (GH->levels) << " "; - outfile << (GH->movls) << " "; - outfile << (GH->BH_num_in) << " "; - for (int j = 0; j < GH->levels; j++) - outfile << GH->grids[j] << " "; - for (int j = 0; j < GH->levels; j++) - outfile << GH->Lt[j] << " "; - for (int lev = 0; lev < GH->levels; lev++) - { - for (int grd = 0; grd < GH->grids[lev]; grd++) - { - for (int j = 0; j < 6; j++) - outfile << GH->bbox[lev][grd][j] << " "; - for (int j = 0; j < 3; j++) - outfile << GH->shape[lev][grd][j] << " "; - for (int j = 0; j < 3; j++) - outfile << GH->handle[lev][grd][j] << " "; - } - for (int ibh = 0; ibh < GH->BH_num_in; ibh++) - { - for (int j = 0; j < 3; j++) - outfile << GH->Porgls[lev][ibh][j] << " "; - } - } - // write variable data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *PL = GH->PatL[lev]; - int cnt = 0; - while (PL) - { - cnt++; - PL = PL->next; - } - outfile << cnt << " "; - PL = GH->PatL[lev]; - while (PL) - { - Patch *PP = PL->data; - outfile << PP->lev << " "; - for (int j = 0; j < 3; j++) - outfile << PP->shape[j] << " "; - for (int j = 0; j < 6; j++) - outfile << PP->bbox[j] << " "; - for (int j = 0; j < 3; j++) - outfile << PP->lli[j] << " "; - for (int j = 0; j < 3; j++) - outfile << PP->uui[j] << " "; - - MyList *BP = PP->blb; - cnt = 0; - while (BP) - { - Block *cg = BP->data; - cnt++; - if (BP == PP->ble) - break; - BP = BP->next; - } - outfile << cnt << " "; - - BP = PP->blb; - while (BP) - { - Block *cg = BP->data; - for (int j = 0; j < 3; j++) - outfile << cg->shape[j] << " "; - for (int j = 0; j < 6; j++) - outfile << cg->bbox[j] << " "; - outfile << cg->rank << " " << cg->lev << " " << cg->cgpu << " " - << cg->ingfs << " " << cg->fngfs << " "; - if (myrank == cg->rank) - { - MyList *VL = CheckList; - int NN = cg->shape[0] * cg->shape[1] * cg->shape[2]; - while (VL) - { - for (int j = 0; j < NN; j++) - outfile << cg->fgfs[VL->data->sgfn][j] << " "; - VL = VL->next; - } - } - if (BP == PP->ble) - break; - BP = BP->next; - } - PL = PL->next; - } - } - - outfile << endl; - outfile.close(); -} -void checkpoint::readcheck_cgh(double &time, cgh *GH, int myrank, int nprocs, int Symmetry) -{ - int DIM = dim; - ifstream infile; - // char fname[50]; - char fname[50+50]; - sprintf(fname, "%s_cgh.CHK", filename); - - infile.open(fname); - if (!infile) - { - cout << "Can't open " << fname << " for check point in." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - infile.seekg(0, ios::beg); - infile >> time; - if (I_Print) - cout << "check cgh in at t = " << time << endl; - infile >> (GH->levels); - infile >> (GH->movls); - infile >> (GH->BH_num_in); - GH->grids = new int[GH->levels]; - GH->bbox = new double **[GH->levels]; - GH->shape = new int **[GH->levels]; - GH->handle = new double **[GH->levels]; - GH->PatL = new MyList *[GH->levels]; - GH->Lt = new double[GH->levels]; - GH->Porgls = new double **[GH->levels]; -#if (RPB == 1) - GH->bdsul = new MyList *[GH->levels]; - GH->rsul = new MyList *[GH->levels]; -#endif - for (int j = 0; j < GH->levels; j++) - infile >> GH->grids[j]; - for (int j = 0; j < GH->levels; j++) - infile >> GH->Lt[j]; - for (int lev = 0; lev < GH->levels; lev++) - { - GH->bbox[lev] = new double *[GH->grids[lev]]; - GH->shape[lev] = new int *[GH->grids[lev]]; - GH->handle[lev] = new double *[GH->grids[lev]]; - GH->Porgls[lev] = new double *[GH->BH_num_in]; - for (int grd = 0; grd < GH->grids[lev]; grd++) - { - GH->bbox[lev][grd] = new double[6]; - GH->shape[lev][grd] = new int[3]; - GH->handle[lev][grd] = new double[3]; - for (int j = 0; j < 6; j++) - infile >> GH->bbox[lev][grd][j]; - for (int j = 0; j < 3; j++) - infile >> GH->shape[lev][grd][j]; - for (int j = 0; j < 3; j++) - infile >> GH->handle[lev][grd][j]; - } - for (int ibh = 0; ibh < GH->BH_num_in; ibh++) - { - GH->Porgls[lev][ibh] = new double[dim]; - for (int j = 0; j < 3; j++) - infile >> GH->Porgls[lev][ibh][j]; - } - } - - // read variable data - for (int lev = 0; lev < GH->levels; lev++) - { - int cnt; - infile >> cnt; - GH->PatL[lev] = 0; - - MyList *gp; - // loop of patach - for (int cj = 0; cj < cnt; cj++) - { - if (GH->PatL[lev]) - { - gp->next = new MyList; - gp = gp->next; - } - else - { - GH->PatL[lev] = gp = new MyList; - } - gp->data = new Patch(); - infile >> gp->data->lev; - for (int j = 0; j < 3; j++) - infile >> gp->data->shape[j]; - for (int j = 0; j < 6; j++) - infile >> gp->data->bbox[j]; - for (int j = 0; j < 3; j++) - infile >> gp->data->lli[j]; - for (int j = 0; j < 3; j++) - infile >> gp->data->uui[j]; - gp->next = 0; - gp->data->blb = 0; - gp->data->ble = 0; - // loop of Block - int bnt; - infile >> bnt; - - MyList *cg; - for (int bj = 0; bj < bnt; bj++) - { - if (gp->data->blb) - { - cg->next = new MyList; - cg = cg->next; - } - else - { - gp->data->blb = cg = new MyList; - } - double tbbox[6]; - int tshape[3]; - int trank, tlev, tcgpu, tingfs, tfngfs; - for (int j = 0; j < 3; j++) - infile >> tshape[j]; - for (int j = 0; j < 6; j++) - infile >> tbbox[j]; - infile >> trank >> tlev >> tcgpu >> tingfs >> tfngfs; - cg->data = new Block(dim, tshape, tbbox, trank, tingfs, tfngfs, tlev, tcgpu); - cg->next = 0; -// if read fake check data, comment out this part -#if 1 - if (myrank == cg->data->rank) - { - MyList *VL = CheckList; - int NN = cg->data->shape[0] * cg->data->shape[1] * cg->data->shape[2]; - while (VL) - { - for (int j = 0; j < NN; j++) - infile >> cg->data->fgfs[VL->data->sgfn][j]; - VL = VL->next; - } - } -#endif - } - gp->data->ble = cg; - } - -#if (RPB == 1) - // we need distributed box of PatL[lev] and PatL[lev-1] - if (lev > 0) - { - Parallel::Constr_pointstr_OutBdLow2Hi(PatL[lev], PatL[lev - 1], bdsul[lev]); - Parallel::Constr_pointstr_Restrict(PatL[lev], PatL[lev - 1], rsul[lev]); - } - else - { - bdsul[lev] = 0; - rsul[lev] = 0; - } -#endif - } - - infile.close(); -} -#endif + +#ifdef newc +#include +using namespace std; +#else +#include +#endif + +#include "checkpoint.h" +#include "misc.h" +#include "fmisc.h" +#include "parameters.h" + +checkpoint::checkpoint(bool checked, const char fname[], int myrank) : filename(0), CheckList(0), checkedrun(checked) +{ + + map::iterator iter; + iter = parameters::str_par.find("output dir"); + + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + cout << "checkpoint 01" << endl; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + I_Print = (myrank == 0); + + int i = strlen(fname); + filename = new char[i+30]; + // cout << filename << endl; + // cout << i << endl; + +#ifdef CHECKDETAIL + char cmd[80]; + if (!checkedrun) + { + sprintf(cmd, "rm -rf %s/%d", out_dir.c_str(), myrank); + system(cmd); + sprintf(cmd, "mkdir %s/%d", out_dir.c_str(), myrank); + system(cmd); + } + sprintf(filename, "%s/%d/%s", out_dir.c_str(), myrank, fname); +#else + // cout << "checkpoint 5" << endl; + sprintf(filename, "%s/%s", out_dir.c_str(), fname); + // cout << "checkpoint 6" << endl; +#endif + if (myrank==0) { + cout << " checkpoint class created " << endl; + } +} +checkpoint::~checkpoint() +{ + CheckList->clearList(); + if (I_Print) + delete[] filename; +} + +void checkpoint::addvariable(var *VV) +{ + if (!VV) + return; + + if (CheckList) + CheckList->insert(VV); + else + CheckList = new MyList(VV); +} +void checkpoint::addvariablelist(MyList *VL) +{ + while (VL) + { + if (CheckList) + CheckList->insert(VL->data); + else + CheckList = new MyList(VL->data); + VL = VL->next; + } +} +#ifndef CHECKDETAIL +void checkpoint::writecheck_cgh(double time, cgh *GH) +{ + ofstream outfile; + + if (I_Print) + { + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_cgh.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.write((char *)&time, sizeof(double)); + outfile.write((char *)&(GH->levels), sizeof(int)); + outfile.write((char *)&(GH->movls), sizeof(int)); + outfile.write((char *)&(GH->BH_num_in), sizeof(int)); + outfile.write((char *)GH->grids, GH->levels * sizeof(int)); + outfile.write((char *)GH->Lt, GH->levels * sizeof(double)); + for (int lev = 0; lev < GH->levels; lev++) + { + for (int grd = 0; grd < GH->grids[lev]; grd++) + { + outfile.write((char *)GH->bbox[lev][grd], 6 * sizeof(double)); + outfile.write((char *)GH->shape[lev][grd], 3 * sizeof(int)); + outfile.write((char *)GH->handle[lev][grd], 3 * sizeof(double)); + } + for (int ibh = 0; ibh < GH->BH_num_in; ibh++) + { + outfile.write((char *)GH->Porgls[lev][ibh], 3 * sizeof(double)); + } + } + } + // write variable data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *PL = GH->PatL[lev]; + while (PL) + { + Patch *PP = PL->data; + int nn = PP->shape[0] * PP->shape[1] * PP->shape[2]; + MyList *VL = CheckList; + while (VL) + { + double *databuffer = Parallel::Collect_Data(PP, VL->data); + if (I_Print) + outfile.write((char *)databuffer, sizeof(double) * nn); + if (databuffer) + delete[] databuffer; + VL = VL->next; + } + PL = PL->next; + } + } + + if (I_Print) + outfile.close(); +} +void checkpoint::readcheck_cgh(double &time, cgh *GH, int myrank, int nprocs, int Symmetry) +{ + int DIM = dim; + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_cgh.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + infile.seekg(0, ios::beg); + infile.read((char *)&time, sizeof(double)); + if (I_Print) + cout << "check cgh in at t = " << time << endl; + infile.read((char *)&(GH->levels), sizeof(int)); + infile.read((char *)&(GH->movls), sizeof(int)); + infile.read((char *)&(GH->BH_num_in), sizeof(int)); + GH->grids = new int[GH->levels]; + GH->bbox = new double **[GH->levels]; + GH->shape = new int **[GH->levels]; + GH->handle = new double **[GH->levels]; + GH->PatL = new MyList *[GH->levels]; + GH->Lt = new double[GH->levels]; + GH->Porgls = new double **[GH->levels]; +#if (RPB == 1) + GH->bdsul = new MyList *[GH->levels]; + GH->rsul = new MyList *[GH->levels]; +#endif + infile.read((char *)GH->grids, GH->levels * sizeof(int)); + infile.read((char *)GH->Lt, GH->levels * sizeof(double)); + for (int lev = 0; lev < GH->levels; lev++) + { + GH->bbox[lev] = new double *[GH->grids[lev]]; + GH->shape[lev] = new int *[GH->grids[lev]]; + GH->handle[lev] = new double *[GH->grids[lev]]; + GH->Porgls[lev] = new double *[GH->BH_num_in]; + for (int grd = 0; grd < GH->grids[lev]; grd++) + { + GH->bbox[lev][grd] = new double[6]; + GH->shape[lev][grd] = new int[3]; + GH->handle[lev][grd] = new double[3]; + infile.read((char *)GH->bbox[lev][grd], 6 * sizeof(double)); + infile.read((char *)GH->shape[lev][grd], 3 * sizeof(int)); + infile.read((char *)GH->handle[lev][grd], 3 * sizeof(double)); + } + for (int ibh = 0; ibh < GH->BH_num_in; ibh++) + { + GH->Porgls[lev][ibh] = new double[dim]; + infile.read((char *)GH->Porgls[lev][ibh], 3 * sizeof(double)); + } + } + + for (int lev = 0; lev < GH->levels; lev++) + GH->PatL[lev] = GH->construct_patchlist(lev, Symmetry); + + GH->compose_cgh(nprocs); + // write variable data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *PL = GH->PatL[lev]; + while (PL) + { + Patch *PP = PL->data; + int nn = PP->shape[0] * PP->shape[1] * PP->shape[2]; + double *databuffer = new double[nn]; + MyList *VL = CheckList; + while (VL) + { + infile.read((char *)databuffer, sizeof(double) * nn); + + { + MyList *BL = PP->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[VL->data->sgfn], + PP->bbox, PP->bbox + DIM, PP->shape, databuffer, + cg->bbox, cg->bbox + DIM); + } + if (BL == PP->ble) + break; + BL = BL->next; + } + } + + VL = VL->next; + } + delete[] databuffer; + PL = PL->next; + } + } + + infile.close(); +} +void checkpoint::writecheck_sh(double time, ShellPatch *SH) +{ + ofstream outfile; + + if (I_Print) + { + char fname[50]; + sprintf(fname, "%s_sh.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.write((char *)&time, sizeof(double)); + } + + // write variable data + MyList *Pp = SH->PatL; + while (Pp) + { + int nn = Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]; + MyList *VL = CheckList; + while (VL) + { + double *databuffer = SH->Collect_Data(Pp->data, VL->data); + if (I_Print) + outfile.write((char *)databuffer, sizeof(double) * nn); + if (databuffer) + delete[] databuffer; + VL = VL->next; + } + Pp = Pp->next; + } + + if (I_Print) + outfile.close(); +} +void checkpoint::readcheck_sh(ShellPatch *SH, int myrank) +{ + int DIM = dim; + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_sh.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + double time; + infile.seekg(0, ios::beg); + infile.read((char *)&time, sizeof(double)); + if (I_Print) + cout << "check ShellPatch in at t = " << time << endl; + + // because we assume the shell patch is fixed we can leave the composing to other routine + + MyList *Pp = SH->PatL; + while (Pp) + { + int nn = Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]; + double *databuffer = new double[nn]; + MyList *VL = CheckList; + while (VL) + { + infile.read((char *)databuffer, sizeof(double) * nn); + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[VL->data->sgfn], + Pp->data->bbox, Pp->data->bbox + DIM, Pp->data->shape, databuffer, + cg->bbox, cg->bbox + DIM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + VL = VL->next; + } + delete[] databuffer; + Pp = Pp->next; + } + + infile.close(); +} +void checkpoint::write_Black_Hole_position(int BH_num_input, int BH_num, double **Porg0, double **Porgbr, double *Mass) +{ + ofstream outfile; + + if (I_Print) + { + char fname[50]; + sprintf(fname, "%s_BHp.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.write((char *)&BH_num_input, sizeof(int)); + outfile.write((char *)&BH_num, sizeof(int)); + outfile.write((char *)Mass, 3 * sizeof(double)); + for (int i = 0; i < BH_num; i++) + { + outfile.write((char *)Porg0[i], 3 * sizeof(double)); + outfile.write((char *)Porgbr[i], 3 * sizeof(double)); + } + + outfile.close(); + } +} +void checkpoint::read_Black_Hole_position(int &BH_num_input, int &BH_num, double **&Porg0, double *&Pmom, + double *&Spin, double *&Mass, double **&Porgbr, double **&Porg, + double **&Porg1, double **&Porg_rhs) +{ + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_BHp.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (I_Print) + cout << "checking in Black_Hole_position" << endl; + + infile.seekg(0, ios::beg); + infile.read((char *)&BH_num_input, sizeof(int)); + infile.read((char *)&BH_num, sizeof(int)); + // these arrays will be deleted when bssn_class is deleted + Pmom = new double[3 * BH_num]; + Spin = new double[3 * BH_num]; + Mass = new double[BH_num]; + Porg0 = new double *[BH_num]; + Porgbr = new double *[BH_num]; + Porg = new double *[BH_num]; + Porg1 = new double *[BH_num]; + Porg_rhs = new double *[BH_num]; + infile.read((char *)Mass, 3 * sizeof(double)); + for (int i = 0; i < BH_num; i++) + { + Porg0[i] = new double[3]; + Porgbr[i] = new double[3]; + Porg[i] = new double[3]; + Porg1[i] = new double[3]; + Porg_rhs[i] = new double[3]; + infile.read((char *)Porg0[i], 3 * sizeof(double)); + infile.read((char *)Porgbr[i], 3 * sizeof(double)); + } + + infile.close(); +} +void checkpoint::write_bssn(double LastDump, double Last2dDump, double LastAnas) +{ + ofstream outfile; + + if (I_Print) + { + char fname[50]; + sprintf(fname, "%s_bssn.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.write((char *)&LastDump, sizeof(double)); + outfile.write((char *)&Last2dDump, sizeof(double)); + outfile.write((char *)&LastAnas, sizeof(double)); + + outfile.close(); + } +} +void checkpoint::read_bssn(double &LastDump, double &Last2dDump, double &LastAnas) +{ + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_bssn.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (I_Print) + cout << "checking in bssn parameters" << endl; + + infile.seekg(0, ios::beg); + infile.read((char *)&LastDump, sizeof(double)); + infile.read((char *)&Last2dDump, sizeof(double)); + infile.read((char *)&LastAnas, sizeof(double)); + + infile.close(); +} +#else +void checkpoint::write_bssn(double LastDump, double Last2dDump, double LastAnas) +{ + ofstream outfile; + + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_bssn.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + outfile << LastDump << " "; + outfile << Last2dDump << " "; + outfile << LastAnas << " " << endl; + + outfile.close(); +} +void checkpoint::read_bssn(double &LastDump, double &Last2dDump, double &LastAnas) +{ + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_bssn.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (I_Print) + cout << "checking in bssn parameters" << endl; + + infile.seekg(0, ios::beg); + infile >> LastDump; + infile >> Last2dDump; + infile >> LastAnas; + + infile.close(); +} +void checkpoint::write_Black_Hole_position(int BH_num_input, int BH_num, double **Porg0, double **Porgbr) +{ + ofstream outfile; + + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_BHp.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + outfile << BH_num_input << " "; + outfile << BH_num << " "; + for (int i = 0; i < BH_num; i++) + { + for (int j = 0; j < 3; j++) + outfile << Porg0[i][j] << " "; + for (int j = 0; j < 3; j++) + outfile << Porgbr[i][j] << " "; + } + + outfile << endl; + outfile.close(); +} +void checkpoint::read_Black_Hole_position(int &BH_num_input, int &BH_num, double **&Porg0, double *&Pmom, + double *&Spin, double *&Mass, double **&Porgbr, double **&Porg, + double **&Porg1, double **&Porg_rhs) +{ + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_BHp.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (I_Print) + cout << "checking in Black_Hole_position" << endl; + + infile.seekg(0, ios::beg); + infile >> BH_num_input; + infile >> BH_num; + // these arrays will be deleted when bssn_class is deleted + Pmom = new double[3 * BH_num]; + Spin = new double[3 * BH_num]; + Mass = new double[BH_num]; + Porg0 = new double *[BH_num]; + Porgbr = new double *[BH_num]; + Porg = new double *[BH_num]; + Porg1 = new double *[BH_num]; + Porg_rhs = new double *[BH_num]; + for (int i = 0; i < BH_num; i++) + { + Porg0[i] = new double[3]; + Porgbr[i] = new double[3]; + Porg[i] = new double[3]; + Porg1[i] = new double[3]; + Porg_rhs[i] = new double[3]; + for (int j = 0; j < 3; j++) + infile >> Porg0[i][j]; + for (int j = 0; j < 3; j++) + infile >> Porgbr[i][j]; + } + + infile.close(); +} +void checkpoint::writecheck_cgh(double time, cgh *GH) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + ofstream outfile; + + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_cgh.CHK", filename); + + outfile.open(fname, ios::out | ios::trunc); + if (!outfile) + { + cout << "Can't open " << fname << " for check point out." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + outfile << time << " "; + outfile << (GH->levels) << " "; + outfile << (GH->movls) << " "; + outfile << (GH->BH_num_in) << " "; + for (int j = 0; j < GH->levels; j++) + outfile << GH->grids[j] << " "; + for (int j = 0; j < GH->levels; j++) + outfile << GH->Lt[j] << " "; + for (int lev = 0; lev < GH->levels; lev++) + { + for (int grd = 0; grd < GH->grids[lev]; grd++) + { + for (int j = 0; j < 6; j++) + outfile << GH->bbox[lev][grd][j] << " "; + for (int j = 0; j < 3; j++) + outfile << GH->shape[lev][grd][j] << " "; + for (int j = 0; j < 3; j++) + outfile << GH->handle[lev][grd][j] << " "; + } + for (int ibh = 0; ibh < GH->BH_num_in; ibh++) + { + for (int j = 0; j < 3; j++) + outfile << GH->Porgls[lev][ibh][j] << " "; + } + } + // write variable data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *PL = GH->PatL[lev]; + int cnt = 0; + while (PL) + { + cnt++; + PL = PL->next; + } + outfile << cnt << " "; + PL = GH->PatL[lev]; + while (PL) + { + Patch *PP = PL->data; + outfile << PP->lev << " "; + for (int j = 0; j < 3; j++) + outfile << PP->shape[j] << " "; + for (int j = 0; j < 6; j++) + outfile << PP->bbox[j] << " "; + for (int j = 0; j < 3; j++) + outfile << PP->lli[j] << " "; + for (int j = 0; j < 3; j++) + outfile << PP->uui[j] << " "; + + MyList *BP = PP->blb; + cnt = 0; + while (BP) + { + Block *cg = BP->data; + cnt++; + if (BP == PP->ble) + break; + BP = BP->next; + } + outfile << cnt << " "; + + BP = PP->blb; + while (BP) + { + Block *cg = BP->data; + for (int j = 0; j < 3; j++) + outfile << cg->shape[j] << " "; + for (int j = 0; j < 6; j++) + outfile << cg->bbox[j] << " "; + outfile << cg->rank << " " << cg->lev << " " << cg->cgpu << " " + << cg->ingfs << " " << cg->fngfs << " "; + if (myrank == cg->rank) + { + MyList *VL = CheckList; + int NN = cg->shape[0] * cg->shape[1] * cg->shape[2]; + while (VL) + { + for (int j = 0; j < NN; j++) + outfile << cg->fgfs[VL->data->sgfn][j] << " "; + VL = VL->next; + } + } + if (BP == PP->ble) + break; + BP = BP->next; + } + PL = PL->next; + } + } + + outfile << endl; + outfile.close(); +} +void checkpoint::readcheck_cgh(double &time, cgh *GH, int myrank, int nprocs, int Symmetry) +{ + int DIM = dim; + ifstream infile; + // char fname[50]; + char fname[50+50]; + sprintf(fname, "%s_cgh.CHK", filename); + + infile.open(fname); + if (!infile) + { + cout << "Can't open " << fname << " for check point in." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + infile.seekg(0, ios::beg); + infile >> time; + if (I_Print) + cout << "check cgh in at t = " << time << endl; + infile >> (GH->levels); + infile >> (GH->movls); + infile >> (GH->BH_num_in); + GH->grids = new int[GH->levels]; + GH->bbox = new double **[GH->levels]; + GH->shape = new int **[GH->levels]; + GH->handle = new double **[GH->levels]; + GH->PatL = new MyList *[GH->levels]; + GH->Lt = new double[GH->levels]; + GH->Porgls = new double **[GH->levels]; +#if (RPB == 1) + GH->bdsul = new MyList *[GH->levels]; + GH->rsul = new MyList *[GH->levels]; +#endif + for (int j = 0; j < GH->levels; j++) + infile >> GH->grids[j]; + for (int j = 0; j < GH->levels; j++) + infile >> GH->Lt[j]; + for (int lev = 0; lev < GH->levels; lev++) + { + GH->bbox[lev] = new double *[GH->grids[lev]]; + GH->shape[lev] = new int *[GH->grids[lev]]; + GH->handle[lev] = new double *[GH->grids[lev]]; + GH->Porgls[lev] = new double *[GH->BH_num_in]; + for (int grd = 0; grd < GH->grids[lev]; grd++) + { + GH->bbox[lev][grd] = new double[6]; + GH->shape[lev][grd] = new int[3]; + GH->handle[lev][grd] = new double[3]; + for (int j = 0; j < 6; j++) + infile >> GH->bbox[lev][grd][j]; + for (int j = 0; j < 3; j++) + infile >> GH->shape[lev][grd][j]; + for (int j = 0; j < 3; j++) + infile >> GH->handle[lev][grd][j]; + } + for (int ibh = 0; ibh < GH->BH_num_in; ibh++) + { + GH->Porgls[lev][ibh] = new double[dim]; + for (int j = 0; j < 3; j++) + infile >> GH->Porgls[lev][ibh][j]; + } + } + + // read variable data + for (int lev = 0; lev < GH->levels; lev++) + { + int cnt; + infile >> cnt; + GH->PatL[lev] = 0; + + MyList *gp; + // loop of patach + for (int cj = 0; cj < cnt; cj++) + { + if (GH->PatL[lev]) + { + gp->next = new MyList; + gp = gp->next; + } + else + { + GH->PatL[lev] = gp = new MyList; + } + gp->data = new Patch(); + infile >> gp->data->lev; + for (int j = 0; j < 3; j++) + infile >> gp->data->shape[j]; + for (int j = 0; j < 6; j++) + infile >> gp->data->bbox[j]; + for (int j = 0; j < 3; j++) + infile >> gp->data->lli[j]; + for (int j = 0; j < 3; j++) + infile >> gp->data->uui[j]; + gp->next = 0; + gp->data->blb = 0; + gp->data->ble = 0; + // loop of Block + int bnt; + infile >> bnt; + + MyList *cg; + for (int bj = 0; bj < bnt; bj++) + { + if (gp->data->blb) + { + cg->next = new MyList; + cg = cg->next; + } + else + { + gp->data->blb = cg = new MyList; + } + double tbbox[6]; + int tshape[3]; + int trank, tlev, tcgpu, tingfs, tfngfs; + for (int j = 0; j < 3; j++) + infile >> tshape[j]; + for (int j = 0; j < 6; j++) + infile >> tbbox[j]; + infile >> trank >> tlev >> tcgpu >> tingfs >> tfngfs; + cg->data = new Block(dim, tshape, tbbox, trank, tingfs, tfngfs, tlev, tcgpu); + cg->next = 0; +// if read fake check data, comment out this part +#if 1 + if (myrank == cg->data->rank) + { + MyList *VL = CheckList; + int NN = cg->data->shape[0] * cg->data->shape[1] * cg->data->shape[2]; + while (VL) + { + for (int j = 0; j < NN; j++) + infile >> cg->data->fgfs[VL->data->sgfn][j]; + VL = VL->next; + } + } +#endif + } + gp->data->ble = cg; + } + +#if (RPB == 1) + // we need distributed box of PatL[lev] and PatL[lev-1] + if (lev > 0) + { + Parallel::Constr_pointstr_OutBdLow2Hi(PatL[lev], PatL[lev - 1], bdsul[lev]); + Parallel::Constr_pointstr_Restrict(PatL[lev], PatL[lev - 1], rsul[lev]); + } + else + { + bdsul[lev] = 0; + rsul[lev] = 0; + } +#endif + } + + infile.close(); +} +#endif diff --git a/AMSS_NCKU_source/checkpoint.h b/AMSS_NCKU_source/Check_Point/checkpoint.h similarity index 96% rename from AMSS_NCKU_source/checkpoint.h rename to AMSS_NCKU_source/Check_Point/checkpoint.h index 6571766..bf14c62 100644 --- a/AMSS_NCKU_source/checkpoint.h +++ b/AMSS_NCKU_source/Check_Point/checkpoint.h @@ -1,60 +1,60 @@ - -#ifndef CHECKPOINT_H -#define CHECKPOINT_H - -#ifdef newc -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#endif -#include -#include - -#include - -#include "var.h" -#include "MyList.h" -#include "cgh.h" -#include "macrodef.h" -#include "ShellPatch.h" - -class checkpoint -{ - -public: - bool checkedrun; - bool I_Print; - char *filename; - MyList *CheckList; - string out_dir; - -public: - checkpoint(bool checked, const char fname[], int myrank); - // checkpoint(bool checked, char fname[50], int myrank); - - ~checkpoint(); - void addvariable(var *VV); - void addvariablelist(MyList *VL); - - void write_Black_Hole_position(int BH_num_input, int BH_num, double **Porg0, double **Porgbr, double *Mass); - void read_Black_Hole_position(int &BH_num_input, int &BH_num, double **&Porg0, double *&Pmom, - double *&Spin, double *&Mass, double **&Porgbr, double **&Porg, - double **&Porg1, double **&Porg_rhs); - void writecheck_cgh(double time, cgh *GH); - void readcheck_cgh(double &time, cgh *GH, int myrank, int nprocs, int Symmetry); - void writecheck_sh(double time, ShellPatch *SH); - void readcheck_sh(ShellPatch *SH, int myrank); - void write_bssn(double LastDump, double Last2dDump, double LastAnas); - void read_bssn(double &LastDump, double &Last2dDump, double &LastAnas); -}; - -#endif /* CHECKPOINT */ + +#ifndef CHECKPOINT_H +#define CHECKPOINT_H + +#ifdef newc +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#endif +#include +#include + +#include + +#include "var.h" +#include "MyList.h" +#include "cgh.h" +#include "macrodef.h" +#include "ShellPatch.h" + +class checkpoint +{ + +public: + bool checkedrun; + bool I_Print; + char *filename; + MyList *CheckList; + string out_dir; + +public: + checkpoint(bool checked, const char fname[], int myrank); + // checkpoint(bool checked, char fname[50], int myrank); + + ~checkpoint(); + void addvariable(var *VV); + void addvariablelist(MyList *VL); + + void write_Black_Hole_position(int BH_num_input, int BH_num, double **Porg0, double **Porgbr, double *Mass); + void read_Black_Hole_position(int &BH_num_input, int &BH_num, double **&Porg0, double *&Pmom, + double *&Spin, double *&Mass, double **&Porgbr, double **&Porg, + double **&Porg1, double **&Porg_rhs); + void writecheck_cgh(double time, cgh *GH); + void readcheck_cgh(double &time, cgh *GH, int myrank, int nprocs, int Symmetry); + void writecheck_sh(double time, ShellPatch *SH); + void readcheck_sh(ShellPatch *SH, int myrank); + void write_bssn(double LastDump, double Last2dDump, double LastAnas); + void read_bssn(double &LastDump, double &Last2dDump, double &LastAnas); +}; + +#endif /* CHECKPOINT */ diff --git a/AMSS_NCKU_source/derivatives.h b/AMSS_NCKU_source/Derivative/derivatives.h similarity index 96% rename from AMSS_NCKU_source/derivatives.h rename to AMSS_NCKU_source/Derivative/derivatives.h index 2f2f6ce..668975b 100644 --- a/AMSS_NCKU_source/derivatives.h +++ b/AMSS_NCKU_source/Derivative/derivatives.h @@ -1,76 +1,76 @@ - -#ifndef DERIVATIVES -#define DERIVATIVES - -#ifdef fortran1 -#define f_fderivs fderivs -#define f_fderivs_sh fderivs_sh -#define f_fderivs_shc fderivs_shc -#define f_fdderivs_shc fdderivs_shc -#define f_fdderivs fdderivs -#endif -#ifdef fortran2 -#define f_fderivs FDERIVS -#define f_fderivs_sh FDERIVS_SH -#define f_fderivs_shc FDERIVS_SHC -#define f_fdderivs_shc FDDERIVS_SHC -#define f_fdderivs FDDERIVS -#endif -#ifdef fortran3 -#define f_fderivs fderivs_ -#define f_fderivs_sh fderivs_sh_ -#define f_fderivs_shc fderivs_shc_ -#define f_fdderivs_shc fdderivs_shc_ -#define f_fdderivs fdderivs_ -#endif - -extern "C" -{ - void f_fderivs(int *, double *, - double *, double *, double *, - double *, double *, double *, - double &, double &, double &, int &, int &); -} - -extern "C" -{ - void f_fderivs_sh(int *, double *, - double *, double *, double *, - double *, double *, double *, - double &, double &, double &, int &, int &, int &); -} - -extern "C" -{ - void f_fderivs_shc(int *, double *, - double *, double *, double *, - double *, double *, double *, - double &, double &, double &, int &, int &, int &, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *); -} - -extern "C" -{ - void f_fdderivs_shc(int *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double &, double &, double &, int &, int &, int &, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_fdderivs(int *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double &, double &, double &, int &, int &); -} - -#endif /* DERIVATIVES */ + +#ifndef DERIVATIVES +#define DERIVATIVES + +#ifdef fortran1 +#define f_fderivs fderivs +#define f_fderivs_sh fderivs_sh +#define f_fderivs_shc fderivs_shc +#define f_fdderivs_shc fdderivs_shc +#define f_fdderivs fdderivs +#endif +#ifdef fortran2 +#define f_fderivs FDERIVS +#define f_fderivs_sh FDERIVS_SH +#define f_fderivs_shc FDERIVS_SHC +#define f_fdderivs_shc FDDERIVS_SHC +#define f_fdderivs FDDERIVS +#endif +#ifdef fortran3 +#define f_fderivs fderivs_ +#define f_fderivs_sh fderivs_sh_ +#define f_fderivs_shc fderivs_shc_ +#define f_fdderivs_shc fdderivs_shc_ +#define f_fdderivs fdderivs_ +#endif + +extern "C" +{ + void f_fderivs(int *, double *, + double *, double *, double *, + double *, double *, double *, + double &, double &, double &, int &, int &); +} + +extern "C" +{ + void f_fderivs_sh(int *, double *, + double *, double *, double *, + double *, double *, double *, + double &, double &, double &, int &, int &, int &); +} + +extern "C" +{ + void f_fderivs_shc(int *, double *, + double *, double *, double *, + double *, double *, double *, + double &, double &, double &, int &, int &, int &, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *); +} + +extern "C" +{ + void f_fdderivs_shc(int *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double &, double &, double &, int &, int &, int &, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_fdderivs(int *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double &, double &, double &, int &, int &); +} + +#endif /* DERIVATIVES */ diff --git a/AMSS_NCKU_source/diff_new.f90 b/AMSS_NCKU_source/Derivative/diff_new.f90 similarity index 97% rename from AMSS_NCKU_source/diff_new.f90 rename to AMSS_NCKU_source/Derivative/diff_new.f90 index ad4c2d8..dd33560 100644 --- a/AMSS_NCKU_source/diff_new.f90 +++ b/AMSS_NCKU_source/Derivative/diff_new.f90 @@ -1,4307 +1,4307 @@ - - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 2_nd oder accurate -! -! f(i+1) - f(i-1) -! fx(i) = ----------------------- -! 2 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) -!DIR$ UNROLL PARTIAL(4) - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 2_nd oder accurate -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 -! -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) -!DIR$ UNROLL PARTIAL(4) - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 2_nd oder accurate -! -! f(i-2) - 2 f(i) + f(i+2) -! fxx(i) = -------------------------------- -! 4 dx^2 -! -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivsdavid(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdx = F1o4 /( dX * dX ) - Sdydy = F1o4 /( dY * dY ) - Sdzdz = F1o4 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 2 f(i) + f(i+2) -! fxx(i) = -------------------------------- -! 4 dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-2,j,k)-TWO*fh(i,j,k) & - +fh(i+2,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = (fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) )/dX/dX - endif - - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-2,k)-TWO*fh(i,j,k) & - +fh(i,j+2,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - fyy(i,j,k) = (fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) )/dY/dY - endif - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k) & - +fh(i,j,k+2) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - fzz(i,j,k) = (fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) )/dZ/dZ - endif -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivsdavid - -#elif (ghost_width == 3) -! fourth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 4_th oder accurate -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -#if 0 -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif -#elif 0 -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+3 <= imax .and. i-1 >= imin)then - fx(i,j,k)=d12dx*(-3.d0*fh(i-1,j,k)-1.d1*fh(i,j,k)+1.8d1*fh(i+1,j,k)-6.d0*fh(i+2,j,k)+fh(i+3,j,k)) - elseif(i+1 <= imax .and. i-3 >= imin)then - fx(i,j,k)=d12dx*( 3.d0*fh(i+1,j,k)+1.d1*fh(i,j,k)-1.8d1*fh(i-1,j,k)+6.d0*fh(i-2,j,k)-fh(i-3,j,k)) -! set imax and imin 0 - endif -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+3 <= jmax .and. j-1 >= jmin)then - fy(i,j,k)=d12dy*(-3.d0*fh(i,j-1,k)-1.d1*fh(i,j,k)+1.8d1*fh(i,j+1,k)-6.d0*fh(i,j+2,k)+fh(i,j+3,k)) - elseif(j+1 <= jmax .and. j-3 >= jmin)then - fy(i,j,k)=d12dy*( 3.d0*fh(i,j+1,k)+1.d1*fh(i,j,k)-1.8d1*fh(i,j-1,k)+6.d0*fh(i,j-2,k)-fh(i,j-3,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+3 <= kmax .and. k-1 >= kmin)then - fz(i,j,k)=d12dz*(-3.d0*fh(i,j,k-1)-1.d1*fh(i,j,k)+1.8d1*fh(i,j,k+1)-6.d0*fh(i,j,k+2)+fh(i,j,k+3)) - elseif(k+1 <= kmax .and. k-3 >= kmin)then - fz(i,j,k)=d12dz*( 3.d0*fh(i,j,k+1)+1.d1*fh(i,j,k)-1.8d1*fh(i,j,k-1)+6.d0*fh(i,j,k-2)-fh(i,j,k-3)) - -! set kmax and kmin 0 - endif -#else -! for bam comparison - if(i+2 <= imax .and. i-2 >= imin .and. & - j+2 <= jmax .and. j-2 >= jmin .and. & - k+2 <= kmax .and. k-2 >= kmin) then - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - elseif(i+1 <= imax .and. i-1 >= imin .and. & - j+1 <= jmax .and. j-1 >= jmin .and. & - k+1 <= kmax .and. k-1 >= kmin) then - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - endif -#endif - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 4_th oder accurate -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 -! -! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) -! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) -! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) -! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -#if 0 -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif -#else -! for bam comparison - if(i+2 <= imax .and. i-2 >= imin .and. & - j+2 <= jmax .and. j-2 >= jmin .and. & - k+2 <= kmax .and. k-2 >= kmin) then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. & - j+1 <= jmax .and. j-1 >= jmin .and. & - k+1 <= kmax .and. k-1 >= kmin) then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif -#endif - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz - -#elif (ghost_width == 4) -! sixth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 6_th oder accurate -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 6_th oder accurate -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx,Xdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy,Xdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz,Xdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy,Xdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz,Xdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz - -#elif (ghost_width == 5) -! eighth order code - -! PRD 77, 024034 (2008) -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 8_th oder accurate -! -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dx,d840dy,d840dz - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dx = ONE/F840/dX - d840dy = ONE/F840/dY - d840dz = ONE/F840/dZ - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dx,d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dx = ONE/F840/dX - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dy,d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dy = ONE/F840/dY - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dz,d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dz = ONE/F840/dZ - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 8_th oder accurate -! -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 -! -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Edxdx = F1o5040 /( dX * dX ) - Edydy = F1o5040 /( dY * dY ) - Edzdz = F1o5040 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - Edxdy = F1o705600 /( dX * dY ) - Edxdz = F1o705600 /( dX * dZ ) - Edydz = F1o705600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - Edxdx = F1o5040 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - - fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy,Xdydy,Edydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - Edydy = F1o5040 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - Edzdz = F1o5040 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - Edxdy = F1o705600 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - - fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - Edxdz = F1o705600 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz,Xdydz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - Edydz = F1o705600 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz - -#endif + + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 2_nd oder accurate +! +! f(i+1) - f(i-1) +! fx(i) = ----------------------- +! 2 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) +!DIR$ UNROLL PARTIAL(4) + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 2_nd oder accurate +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 +! +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) +!DIR$ UNROLL PARTIAL(4) + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 2_nd oder accurate +! +! f(i-2) - 2 f(i) + f(i+2) +! fxx(i) = -------------------------------- +! 4 dx^2 +! +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivsdavid(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdx = F1o4 /( dX * dX ) + Sdydy = F1o4 /( dY * dY ) + Sdzdz = F1o4 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 2 f(i) + f(i+2) +! fxx(i) = -------------------------------- +! 4 dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-2,j,k)-TWO*fh(i,j,k) & + +fh(i+2,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = (fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) )/dX/dX + endif + + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-2,k)-TWO*fh(i,j,k) & + +fh(i,j+2,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + fyy(i,j,k) = (fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) )/dY/dY + endif + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k) & + +fh(i,j,k+2) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + fzz(i,j,k) = (fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) )/dZ/dZ + endif +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivsdavid + +#elif (ghost_width == 3) +! fourth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 4_th oder accurate +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +#if 0 +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif +#elif 0 +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+3 <= imax .and. i-1 >= imin)then + fx(i,j,k)=d12dx*(-3.d0*fh(i-1,j,k)-1.d1*fh(i,j,k)+1.8d1*fh(i+1,j,k)-6.d0*fh(i+2,j,k)+fh(i+3,j,k)) + elseif(i+1 <= imax .and. i-3 >= imin)then + fx(i,j,k)=d12dx*( 3.d0*fh(i+1,j,k)+1.d1*fh(i,j,k)-1.8d1*fh(i-1,j,k)+6.d0*fh(i-2,j,k)-fh(i-3,j,k)) +! set imax and imin 0 + endif +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+3 <= jmax .and. j-1 >= jmin)then + fy(i,j,k)=d12dy*(-3.d0*fh(i,j-1,k)-1.d1*fh(i,j,k)+1.8d1*fh(i,j+1,k)-6.d0*fh(i,j+2,k)+fh(i,j+3,k)) + elseif(j+1 <= jmax .and. j-3 >= jmin)then + fy(i,j,k)=d12dy*( 3.d0*fh(i,j+1,k)+1.d1*fh(i,j,k)-1.8d1*fh(i,j-1,k)+6.d0*fh(i,j-2,k)-fh(i,j-3,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+3 <= kmax .and. k-1 >= kmin)then + fz(i,j,k)=d12dz*(-3.d0*fh(i,j,k-1)-1.d1*fh(i,j,k)+1.8d1*fh(i,j,k+1)-6.d0*fh(i,j,k+2)+fh(i,j,k+3)) + elseif(k+1 <= kmax .and. k-3 >= kmin)then + fz(i,j,k)=d12dz*( 3.d0*fh(i,j,k+1)+1.d1*fh(i,j,k)-1.8d1*fh(i,j,k-1)+6.d0*fh(i,j,k-2)-fh(i,j,k-3)) + +! set kmax and kmin 0 + endif +#else +! for bam comparison + if(i+2 <= imax .and. i-2 >= imin .and. & + j+2 <= jmax .and. j-2 >= jmin .and. & + k+2 <= kmax .and. k-2 >= kmin) then + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + elseif(i+1 <= imax .and. i-1 >= imin .and. & + j+1 <= jmax .and. j-1 >= jmin .and. & + k+1 <= kmax .and. k-1 >= kmin) then + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + endif +#endif + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 4_th oder accurate +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 +! +! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) +! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) +! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) +! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +#if 0 +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif +#else +! for bam comparison + if(i+2 <= imax .and. i-2 >= imin .and. & + j+2 <= jmax .and. j-2 >= jmin .and. & + k+2 <= kmax .and. k-2 >= kmin) then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. & + j+1 <= jmax .and. j-1 >= jmin .and. & + k+1 <= kmax .and. k-1 >= kmin) then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif +#endif + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz + +#elif (ghost_width == 4) +! sixth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 6_th oder accurate +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 6_th oder accurate +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx,Xdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy,Xdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz,Xdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy,Xdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz,Xdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz + +#elif (ghost_width == 5) +! eighth order code + +! PRD 77, 024034 (2008) +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 8_th oder accurate +! +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dx,d840dy,d840dz + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dx = ONE/F840/dX + d840dy = ONE/F840/dY + d840dz = ONE/F840/dZ + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dx,d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dx = ONE/F840/dX + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dy,d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dy = ONE/F840/dY + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dz,d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dz = ONE/F840/dZ + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 8_th oder accurate +! +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 +! +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Edxdx = F1o5040 /( dX * dX ) + Edydy = F1o5040 /( dY * dY ) + Edzdz = F1o5040 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + Edxdy = F1o705600 /( dX * dY ) + Edxdz = F1o705600 /( dX * dZ ) + Edydz = F1o705600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + Edxdx = F1o5040 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + + fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy,Xdydy,Edydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + Edydy = F1o5040 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + Edzdz = F1o5040 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + Edxdy = F1o705600 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + + fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + Edxdz = F1o705600 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz,Xdydz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + Edydz = F1o705600 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz + +#endif diff --git a/AMSS_NCKU_source/diff_new_sh.f90 b/AMSS_NCKU_source/Derivative/diff_new_sh.f90 similarity index 97% rename from AMSS_NCKU_source/diff_new_sh.f90 rename to AMSS_NCKU_source/Derivative/diff_new_sh.f90 index 91d21d7..b14a40a 100644 --- a/AMSS_NCKU_source/diff_new_sh.f90 +++ b/AMSS_NCKU_source/Derivative/diff_new_sh.f90 @@ -1,4777 +1,4777 @@ - - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 2_nd oder accurate -! -! f(i+1) - f(i-1) -! fx(i) = ----------------------- -! 2 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 2_nd oder accurate -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 -! -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx_sh - - subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy_sh - - subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz_sh - - subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy_sh - - subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz_sh - - subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz_sh - -#elif (ghost_width == 3) -! fourth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 4_th oder accurate -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 4_th oder accurate -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 -! -! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) -! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) -! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) -! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx_sh - - subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy_sh - - subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz_sh - - subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy_sh - - subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz_sh - - subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz_sh - -#elif (ghost_width == 4) -! sixth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 6_th oder accurate -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 6_th oder accurate -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx,Xdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx_sh - - subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy,Xdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy_sh - - subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz,Xdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz_sh - - subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy,Xdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy_sh - - subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz,Xdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz_sh - - subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz_sh - -#elif (ghost_width == 5) -! eighth order code - -! PRD 77, 024034 (2008) -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 8_th oder accurate -! -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dx,d840dy,d840dz - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - d840dx = ONE/F840/dX - d840dy = ONE/F840/dY - d840dz = ONE/F840/dZ - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dx,d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - d840dx = ONE/F840/dX - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dy,d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - d840dy = ONE/F840/dY - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dz,d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - d840dz = ONE/F840/dZ - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - enddo - enddo - enddo - - return - - end subroutine fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 8_th oder accurate -! -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 -! -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Edxdx = F1o5040 /( dX * dX ) - Edydy = F1o5040 /( dY * dY ) - Edzdz = F1o5040 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - Edxdy = F1o705600 /( dX * dY ) - Edxdz = F1o705600 /( dX * dZ ) - Edydz = F1o705600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - Edxdx = F1o5040 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - - fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx_sh - - subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy,Xdydy,Edydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - Edydy = F1o5040 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy_sh - - subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - Edzdz = F1o5040 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz_sh - - subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - Edxdy = F1o705600 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - - fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy_sh - - subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - Edxdz = F1o705600 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz_sh - - subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz,Xdydz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - Edydz = F1o705600 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz_sh - -#endif - -!common code for different finite difference order -subroutine fderivs_shc(ex,f,fx,fy,fz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - implicit none - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,intent(in ):: SYM1,SYM2,SYM3 - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(out),dimension(ex(1),ex(2),ex(3))::fx,fy,fz - -#if 0 - integer :: i,j,k - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - call point_fderivs_shc(ex,f,fx(i,j,k),fy(i,j,k),fz(i,j,k),crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - enddo - enddo - enddo -#else - double precision,dimension(ex(1),ex(2),ex(3))::gx,gy,gz - - call fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst) - - fx = dRdx*gz+drhodx*gx+dsigmadx*gy - fy = dRdy*gz+drhody*gx+dsigmady*gy - fz = dRdz*gz+drhodz*gx+dsigmadz*gy -#endif - - return - -end subroutine fderivs_shc - -subroutine fdderivs_shc(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - implicit none - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,intent(in ):: SYM1,SYM2,SYM3 - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double precision,intent(out),dimension(ex(1),ex(2),ex(3))::fxx,fxy,fxz,fyy,fyz,fzz - -#if 0 - integer :: i,j,k - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - call point_fdderivs_shc(ex,f,fxx(i,j,k),fxy(i,j,k),fxz(i,j,k),fyy(i,j,k),fyz(i,j,k),fzz(i,j,k),crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - enddo - enddo - enddo -#else - double precision,dimension(ex(1),ex(2),ex(3))::gx,gy,gz,gxx,gxy,gxz,gyy,gyz,gzz - real*8,parameter :: TWO = 2.d0 - - call fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst) - call fdderivs_sh(ex,f,gxx,gxy,gxz,gyy,gyz,gzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst) - - fxx = dRdxx*gz+drhodxx*gx+dsigmadxx*gy + & - dRdx*dRdx*gzz+drhodx*drhodx*gxx+dsigmadx*dsigmadx*gyy + & - TWO*(dRdx*drhodx*gxz+dRdx*dsigmadx*gyz+drhodx*dsigmadx*gxy) - fyy = dRdyy*gz+drhodyy*gx+dsigmadyy*gy + & - dRdy*dRdy*gzz+drhody*drhody*gxx+dsigmady*dsigmady*gyy + & - TWO*(dRdy*drhody*gxz+dRdy*dsigmady*gyz+drhody*dsigmady*gxy) - fzz = dRdzz*gz+drhodzz*gx+dsigmadzz*gy + & - dRdz*dRdz*gzz+drhodz*drhodz*gxx+dsigmadz*dsigmadz*gyy + & - TWO*(dRdz*drhodz*gxz+dRdz*dsigmadz*gyz+drhodz*dsigmadz*gxy) - fxy = dRdxy*gz+drhodxy*gx+dsigmadxy*gy + & - dRdx*drhody*gxz+dRdx*dsigmady*gyz+drhodx*dsigmady*gxy + & - dRdy*drhodx*gxz+dRdy*dsigmadx*gyz+drhody*dsigmadx*gxy + & - dRdx*dRdy*gzz+drhodx*drhody*gxx+dsigmadx*dsigmady*gyy - fxz = dRdxz*gz+drhodxz*gx+dsigmadxz*gy + & - dRdx*drhodz*gxz+dRdx*dsigmadz*gyz+drhodx*dsigmadz*gxy + & - dRdz*drhodx*gxz+dRdz*dsigmadx*gyz+drhodz*dsigmadx*gxy + & - dRdx*dRdz*gzz+drhodx*drhodz*gxx+dsigmadx*dsigmadz*gyy - fyz = dRdyz*gz+drhodyz*gx+dsigmadyz*gy + & - dRdz*drhody*gxz+dRdz*dsigmady*gyz+drhodz*dsigmady*gxy + & - dRdy*drhodz*gxz+dRdy*dsigmadz*gyz+drhody*dsigmadz*gxy + & - dRdz*dRdy*gzz+drhodz*drhody*gxx+dsigmadz*dsigmady*gyy -#endif - - return - -end subroutine fdderivs_shc + + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 2_nd oder accurate +! +! f(i+1) - f(i-1) +! fx(i) = ----------------------- +! 2 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 2_nd oder accurate +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 +! +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx_sh + + subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy_sh + + subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz_sh + + subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy_sh + + subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz_sh + + subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz_sh + +#elif (ghost_width == 3) +! fourth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 4_th oder accurate +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 4_th oder accurate +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 +! +! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) +! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) +! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) +! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx_sh + + subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy_sh + + subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz_sh + + subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy_sh + + subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz_sh + + subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz_sh + +#elif (ghost_width == 4) +! sixth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 6_th oder accurate +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 6_th oder accurate +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx,Xdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx_sh + + subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy,Xdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy_sh + + subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz,Xdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz_sh + + subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy,Xdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy_sh + + subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz,Xdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz_sh + + subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz_sh + +#elif (ghost_width == 5) +! eighth order code + +! PRD 77, 024034 (2008) +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 8_th oder accurate +! +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dx,d840dy,d840dz + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + d840dx = ONE/F840/dX + d840dy = ONE/F840/dY + d840dz = ONE/F840/dZ + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dx,d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + d840dx = ONE/F840/dX + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dy,d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + d840dy = ONE/F840/dY + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dz,d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + d840dz = ONE/F840/dZ + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + enddo + enddo + enddo + + return + + end subroutine fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 8_th oder accurate +! +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 +! +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Edxdx = F1o5040 /( dX * dX ) + Edydy = F1o5040 /( dY * dY ) + Edzdz = F1o5040 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + Edxdy = F1o705600 /( dX * dY ) + Edxdz = F1o705600 /( dX * dZ ) + Edydz = F1o705600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + Edxdx = F1o5040 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + + fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx_sh + + subroutine fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy,Xdydy,Edydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + Edydy = F1o5040 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy_sh + + subroutine fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + Edzdz = F1o5040 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz_sh + + subroutine fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + Edxdy = F1o705600 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + + fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy_sh + + subroutine fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + Edxdz = F1o705600 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz_sh + + subroutine fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz,Xdydz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + Edydz = F1o705600 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz_sh + +#endif + +!common code for different finite difference order +subroutine fderivs_shc(ex,f,fx,fy,fz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + implicit none + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,intent(in ):: SYM1,SYM2,SYM3 + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(out),dimension(ex(1),ex(2),ex(3))::fx,fy,fz + +#if 0 + integer :: i,j,k + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + call point_fderivs_shc(ex,f,fx(i,j,k),fy(i,j,k),fz(i,j,k),crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + enddo + enddo + enddo +#else + double precision,dimension(ex(1),ex(2),ex(3))::gx,gy,gz + + call fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst) + + fx = dRdx*gz+drhodx*gx+dsigmadx*gy + fy = dRdy*gz+drhody*gx+dsigmady*gy + fz = dRdz*gz+drhodz*gx+dsigmadz*gy +#endif + + return + +end subroutine fderivs_shc + +subroutine fdderivs_shc(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + implicit none + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,intent(in ):: SYM1,SYM2,SYM3 + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double precision,intent(out),dimension(ex(1),ex(2),ex(3))::fxx,fxy,fxz,fyy,fyz,fzz + +#if 0 + integer :: i,j,k + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + call point_fdderivs_shc(ex,f,fxx(i,j,k),fxy(i,j,k),fxz(i,j,k),fyy(i,j,k),fyz(i,j,k),fzz(i,j,k),crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + enddo + enddo + enddo +#else + double precision,dimension(ex(1),ex(2),ex(3))::gx,gy,gz,gxx,gxy,gxz,gyy,gyz,gzz + real*8,parameter :: TWO = 2.d0 + + call fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst) + call fdderivs_sh(ex,f,gxx,gxy,gxz,gyy,gyz,gzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst) + + fxx = dRdxx*gz+drhodxx*gx+dsigmadxx*gy + & + dRdx*dRdx*gzz+drhodx*drhodx*gxx+dsigmadx*dsigmadx*gyy + & + TWO*(dRdx*drhodx*gxz+dRdx*dsigmadx*gyz+drhodx*dsigmadx*gxy) + fyy = dRdyy*gz+drhodyy*gx+dsigmadyy*gy + & + dRdy*dRdy*gzz+drhody*drhody*gxx+dsigmady*dsigmady*gyy + & + TWO*(dRdy*drhody*gxz+dRdy*dsigmady*gyz+drhody*dsigmady*gxy) + fzz = dRdzz*gz+drhodzz*gx+dsigmadzz*gy + & + dRdz*dRdz*gzz+drhodz*drhodz*gxx+dsigmadz*dsigmadz*gyy + & + TWO*(dRdz*drhodz*gxz+dRdz*dsigmadz*gyz+drhodz*dsigmadz*gxy) + fxy = dRdxy*gz+drhodxy*gx+dsigmadxy*gy + & + dRdx*drhody*gxz+dRdx*dsigmady*gyz+drhodx*dsigmady*gxy + & + dRdy*drhodx*gxz+dRdy*dsigmadx*gyz+drhody*dsigmadx*gxy + & + dRdx*dRdy*gzz+drhodx*drhody*gxx+dsigmadx*dsigmady*gyy + fxz = dRdxz*gz+drhodxz*gx+dsigmadxz*gy + & + dRdx*drhodz*gxz+dRdx*dsigmadz*gyz+drhodx*dsigmadz*gxy + & + dRdz*drhodx*gxz+dRdz*dsigmadx*gyz+drhodz*dsigmadx*gxy + & + dRdx*dRdz*gzz+drhodx*drhodz*gxx+dsigmadx*dsigmadz*gyy + fyz = dRdyz*gz+drhodyz*gx+dsigmadyz*gy + & + dRdz*drhody*gxz+dRdz*dsigmady*gyz+drhodz*dsigmady*gxy + & + dRdy*drhodz*gxz+dRdy*dsigmadz*gyz+drhody*dsigmadz*gxy + & + dRdz*dRdy*gzz+drhodz*drhody*gxx+dsigmadz*dsigmady*gyy +#endif + + return + +end subroutine fdderivs_shc diff --git a/AMSS_NCKU_source/diff_newwb.f90 b/AMSS_NCKU_source/Derivative/diff_newwb.f90 similarity index 97% rename from AMSS_NCKU_source/diff_newwb.f90 rename to AMSS_NCKU_source/Derivative/diff_newwb.f90 index 1fbbcd2..9e2ab29 100644 --- a/AMSS_NCKU_source/diff_newwb.f90 +++ b/AMSS_NCKU_source/Derivative/diff_newwb.f90 @@ -1,1566 +1,1566 @@ - - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 2_nd oder accurate -! -! f(i+1) - f(i-1) -! fx(i) = ----------------------- -! 2 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA + + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 2_nd oder accurate +! +! f(i+1) - f(i-1) +! fx(i) = ----------------------- +! 2 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fderivs i= ",i - endif -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fderivs j= ",j - endif -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fderivs k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA + real*8 :: d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fderivs i= ",i + endif +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fderivs j= ",j + endif +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fderivs k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fdx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fdy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fdz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 2_nd oder accurate -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 -! -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs i= ",i - endif - - -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs j= ",j - endif - -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs k= ",k - endif -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j - endif -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddxx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddyy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddzz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:xy: i,j = ",i,j - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 2_nd oder accurate -! -! f(i-2) - 2 f(i) + f(i+2) -! fxx(i) = -------------------------------- -! 4 dx^2 -! -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivsdavid(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(1,ex,f,fh,SoA) - - Sdxdx = F1o4 /( dX * dX ) - Sdydy = F1o4 /( dY * dY ) - Sdzdz = F1o4 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3)-1 - do j=1,ex(2)-1 - do i=1,ex(1)-1 -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 2 f(i) + f(i+2) -! fxx(i) = -------------------------------- -! 4 dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-2,j,k)-TWO*fh(i,j,k) & - +fh(i+2,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = (fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) )/dX/dX - endif - - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-2,k)-TWO*fh(i,j,k) & - +fh(i,j+2,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - fyy(i,j,k) = (fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) )/dY/dY - endif - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k) & - +fh(i,j,k+2) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - fzz(i,j,k) = (fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) )/dZ/dZ - endif -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivsdavid - -#elif (ghost_width == 3) -! fourth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 4_th oder accurate -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fderivs i= ",i - endif -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fderivs j= ",j - endif -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fderivs k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fdx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fdy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fdz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 4_th oder accurate -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 -! -! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) -! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) -! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) -! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA + real*8 :: d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fdx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fdy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fdz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 2_nd oder accurate +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 +! +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs i= ",i + endif + + +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs j= ",j + endif + +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs k= ",k + endif +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j + endif +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddxx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddyy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddzz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:xy: i,j = ",i,j + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 2_nd oder accurate +! +! f(i-2) - 2 f(i) + f(i+2) +! fxx(i) = -------------------------------- +! 4 dx^2 +! +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivsdavid(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1),0:ex(2),0:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = 0 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = 0 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = 0 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(1,ex,f,fh,SoA) + + Sdxdx = F1o4 /( dX * dX ) + Sdydy = F1o4 /( dY * dY ) + Sdzdz = F1o4 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3)-1 + do j=1,ex(2)-1 + do i=1,ex(1)-1 +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 2 f(i) + f(i+2) +! fxx(i) = -------------------------------- +! 4 dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-2,j,k)-TWO*fh(i,j,k) & + +fh(i+2,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = (fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) )/dX/dX + endif + + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-2,k)-TWO*fh(i,j,k) & + +fh(i,j+2,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + fyy(i,j,k) = (fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) )/dY/dY + endif + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k) & + +fh(i,j,k+2) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + fzz(i,j,k) = (fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) )/dZ/dZ + endif +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivsdavid + +#elif (ghost_width == 3) +! fourth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 4_th oder accurate +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fderivs i= ",i + endif +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fderivs j= ",j + endif +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fderivs k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fdx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fdy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fdz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 4_th oder accurate +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 +! +! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) +! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) +! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) +! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k integer :: i_core_min,i_core_max,j_core_min,j_core_max,k_core_min,k_core_max real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO fzz = ZEO fxy = ZEO fxz = ZEO @@ -1610,3388 +1610,3388 @@ !~~~~~~ fxx if(i+2 <= imax .and. i-2 >= imin)then ! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs i= ",i - endif - - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs j= ",j - endif - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs k= ",k - endif -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j - endif -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddxx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddyy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddzz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:xy: i,j = ",i,j - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(2,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz - -#elif (ghost_width == 4) -! sixth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 6_th oder accurate -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fderivs i= ",i - endif -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fderivs j= ",j - endif -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fderivs k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fdx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fdy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fdz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 6_th oder accurate -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs i= ",i - endif - - -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs j= ",j - endif - -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs k= ",k - endif -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j - endif -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx,Xdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddxx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy,Xdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddyy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz,Xdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddzz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy,Xdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:xy: i,j = ",i,j - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz,Xdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(3,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz - -#elif (ghost_width == 5) -! eighth order code - -! PRD 77, 024034 (2008) -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 8_th oder accurate -! -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dx,d840dy,d840dz - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dx = ONE/F840/dX - d840dy = ONE/F840/dY - d840dz = ONE/F840/dZ - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fderivs i= ",i - endif -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fderivs j= ",j - endif -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fderivs k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fderivs -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx - real*8, intent(in ):: X(ex(1)),SYM1 - -!~~~~~~ other variables - - real*8 :: dX - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dx,d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - - SoA(1) = SYM1 -! no use - SoA(2) = SYM1 - SoA(3) = SYM1 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dx = ONE/F840/dX - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - - elseif(i==imin)then - fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX - elseif(i==imax)then - fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX - else - write(*,*)"error in diff_new.f90:fdx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fdx -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy - real*8, intent(in ):: Y(ex(2)),SYM2 - -!~~~~~~ other variables - - real*8 :: dY - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dy,d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dY = Y(2)-Y(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM2 - SoA(2) = SYM2 - SoA(3) = SYM2 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dy = ONE/F840/dY - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - - elseif(j==jmin)then - fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY - elseif(j==jmax)then - fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY - else - write(*,*)"error in diff_new.f90:fdy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fdy -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz - real*8, intent(in ):: Z(ex(3)),SYM3 - -!~~~~~~ other variables - - real*8 :: dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: d840dz,d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - - SoA(1) = SYM3 - SoA(2) = SYM3 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - d840dz = ONE/F840/dZ - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - - elseif(k==kmin)then - fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ - elseif(k==kmax)then - fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ - else - write(*,*)"error in diff_new.f90:fdz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fdz -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 8_th oder accurate -! -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 -! -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Edxdx = F1o5040 /( dX * dX ) - Edydy = F1o5040 /( dY * dY ) - Edzdz = F1o5040 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - Edxdy = F1o705600 /( dX * dY ) - Edxdz = F1o705600 /( dX * dZ ) - Edydz = F1o705600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs i= ",i - endif - -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs j= ",j - endif - -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fdderivs k= ",k - endif -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j - endif -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fdderivs -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - Edxdx = F1o5040 /( dX * dX ) - - fxx = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - - fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - elseif(i==imin)then - fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & - +fh(i+2,j,k) ) - elseif(i==imax)then - fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddxx i= ",i - endif - - enddo - enddo - enddo - - return - - end subroutine fddxx - - subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydy,Fdydy,Xdydy,Edydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - Edydy = F1o5040 /( dY * dY ) - - fyy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - elseif(j==jmin)then - fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & - +fh(i,j+2,k) ) - elseif(j==jmax)then - fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddyy j= ",j - endif - - enddo - enddo - enddo - - return - - end subroutine fddyy - - subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - Edzdz = F1o5040 /( dZ * dZ ) - - fzz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - elseif(k==kmin)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & - +fh(i,j,k+2) ) - elseif(k==kmax)then - fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & - +fh(i,j,k) ) - else - write(*,*)"error in diff_new.f90:fddzz k= ",k - endif - - enddo - enddo - enddo - - return - - end subroutine fddzz - - subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - Edxdy = F1o705600 /( dX * dY ) - - fxy = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - - fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY - elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY - elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then - fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY - elseif(i==imin .and. j==jmin)then - fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY - elseif(i==imin .and. j==jmax)then - fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY - elseif(i==imax .and. j==jmin)then - fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY - elseif(i==imax .and. j==jmax)then - fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY - else - write(*,*)"error in diff_new.f90:xy: i,j = ",i,j - endif - - enddo - enddo - enddo - - return - - end subroutine fddxy - - subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - Edxdz = F1o705600 /( dX * dZ ) - - fxz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ - elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ - elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then - fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ - elseif(i==imin .and. k==kmin)then - fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ - elseif(i==imin .and. k==kmax)then - fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ - elseif(i==imax .and. k==kmin)then - fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ - elseif(i==imax .and. k==kmax)then - fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddxz - - subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) - implicit none - - integer, intent(in ):: ex(1:3),symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - real*8, dimension(3) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k - real*8 :: Sdydz,Fdydz,Xdydz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - SoA(1) = SYM1 - SoA(2) = SYM2 - SoA(3) = SYM3 - - call symmetry_bd(4,ex,f,fh,SoA) - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - Edydz = F1o705600 /( dY * dZ ) - - fyz = ZEO - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ - elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ - elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ - elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then - fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ - elseif(j==jmin .and. k==kmin)then - fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ - elseif(j==jmin .and. k==kmax)then - fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ - elseif(j==jmax .and. k==kmin)then - fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ - elseif(j==jmax .and. k==kmax)then - fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ - else - write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k - endif - - enddo - enddo - enddo - - return - - end subroutine fddyz - -#endif +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs i= ",i + endif + + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs j= ",j + endif + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs k= ",k + endif +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j + endif +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddxx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddyy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddzz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:xy: i,j = ",i,j + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(2,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz + +#elif (ghost_width == 4) +! sixth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 6_th oder accurate +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fderivs i= ",i + endif +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fderivs j= ",j + endif +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fderivs k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fdx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fdy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fdz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 6_th oder accurate +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs i= ",i + endif + + +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs j= ",j + endif + +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs k= ",k + endif +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j + endif +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx,Xdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddxx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy,Xdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddyy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz,Xdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddzz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy,Xdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:xy: i,j = ",i,j + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz,Xdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -2 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(3,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz + +#elif (ghost_width == 5) +! eighth order code + +! PRD 77, 024034 (2008) +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 8_th oder accurate +! +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine fderivs(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dx,d840dy,d840dz + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dx = ONE/F840/dX + d840dy = ONE/F840/dY + d840dz = ONE/F840/dZ + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fderivs i= ",i + endif +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fderivs j= ",j + endif +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fderivs k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fderivs +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine fdx(ex,f,fx,X,SYM1,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fx + real*8, intent(in ):: X(ex(1)),SYM1 + +!~~~~~~ other variables + + real*8 :: dX + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dx,d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + + SoA(1) = SYM1 +! no use + SoA(2) = SYM1 + SoA(3) = SYM1 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dx = ONE/F840/dX + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx(i,j,k)=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx(i,j,k)=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx(i,j,k)=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx(i,j,k)=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + + elseif(i==imin)then + fx(i,j,k)=(-fh(i,j,k)+fh(i+1,j,k))/dX + elseif(i==imax)then + fx(i,j,k)=(-fh(i-1,j,k)+fh(i,j,k))/dX + else + write(*,*)"error in diff_new.f90:fdx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fdx +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine fdy(ex,f,fy,Y,SYM2,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fy + real*8, intent(in ):: Y(ex(2)),SYM2 + +!~~~~~~ other variables + + real*8 :: dY + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dy,d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dY = Y(2)-Y(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM2 + SoA(2) = SYM2 + SoA(3) = SYM2 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dy = ONE/F840/dY + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy(i,j,k)=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy(i,j,k)=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy(i,j,k)=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy(i,j,k)=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + + elseif(j==jmin)then + fy(i,j,k)=(-fh(i,j,k)+fh(i,j+1,k))/dY + elseif(j==jmax)then + fy(i,j,k)=(-fh(i,j-1,k)+fh(i,j,k))/dY + else + write(*,*)"error in diff_new.f90:fdy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fdy +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine fdz(ex,f,fz,Z,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: fz + real*8, intent(in ):: Z(ex(3)),SYM3 + +!~~~~~~ other variables + + real*8 :: dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: d840dz,d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + + SoA(1) = SYM3 + SoA(2) = SYM3 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + d840dz = ONE/F840/dZ + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz(i,j,k)=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz(i,j,k)=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz(i,j,k)=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz(i,j,k)=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + + elseif(k==kmin)then + fz(i,j,k)=(-fh(i,j,k)+fh(i,j,k+1))/dZ + elseif(k==kmax)then + fz(i,j,k)=(-fh(i,j,k-1)+fh(i,j,k))/dZ + else + write(*,*)"error in diff_new.f90:fdz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fdz +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 8_th oder accurate +! +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 +! +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine fdderivs(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Edxdx = F1o5040 /( dX * dX ) + Edydy = F1o5040 /( dY * dY ) + Edzdz = F1o5040 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + Edxdy = F1o705600 /( dX * dY ) + Edxdz = F1o705600 /( dX * dZ ) + Edydz = F1o705600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs i= ",i + endif + +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs j= ",j + endif + +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fdderivs k= ",k + endif +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:fdderivs: i,j = ",i,j + endif +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fdderivs +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine fddxx(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + Edxdx = F1o5040 /( dX * dX ) + + fxx = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + + fxx(i,j,k) = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + fxx(i,j,k) = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx(i,j,k) = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx(i,j,k) = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + elseif(i==imin)then + fxx(i,j,k)=Sdxdx*(fh(i,j,k)-TWO*fh(i+1,j,k) & + +fh(i+2,j,k) ) + elseif(i==imax)then + fxx(i,j,k)=Sdxdx*(fh(i-2,j,k)-TWO*fh(i-1,j,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddxx i= ",i + endif + + enddo + enddo + enddo + + return + + end subroutine fddxx + + subroutine fddyy(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydy,Fdydy,Xdydy,Edydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + Edydy = F1o5040 /( dY * dY ) + + fyy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy(i,j,k) = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy(i,j,k) = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy(i,j,k) = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy(i,j,k) = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + elseif(j==jmin)then + fyy(i,j,k)=Sdydy*(fh(i,j,k)-TWO*fh(i,j+1,k) & + +fh(i,j+2,k) ) + elseif(j==jmax)then + fyy(i,j,k)=Sdydy*(fh(i,j-2,k)-TWO*fh(i,j-1,k) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddyy j= ",j + endif + + enddo + enddo + enddo + + return + + end subroutine fddyy + + subroutine fddzz(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + Edzdz = F1o5040 /( dZ * dZ ) + + fzz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz(i,j,k) = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz(i,j,k) = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz(i,j,k) = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz(i,j,k) = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + elseif(k==kmin)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k)-TWO*fh(i,j,k+1) & + +fh(i,j,k+2) ) + elseif(k==kmax)then + fzz(i,j,k)=Sdzdz*(fh(i,j,k-2)-TWO*fh(i,j,k-1) & + +fh(i,j,k) ) + else + write(*,*)"error in diff_new.f90:fddzz k= ",k + endif + + enddo + enddo + enddo + + return + + end subroutine fddzz + + subroutine fddxy(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + Edxdy = F1o705600 /( dX * dY ) + + fxy = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + + fxy(i,j,k) = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy(i,j,k) = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy(i,j,k) = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy(i,j,k) = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + elseif(i==imin .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i,j-1,k)-fh(i+1,j-1,k)-fh(i,j+1,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(i==imax .and. j+1 <= jmax .and. j-1 >= jmin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i,j-1,k)-fh(i-1,j+1,k)+fh(i,j+1,k))/TWO/dX/dY + elseif(j==jmin .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j,k)-fh(i-1,j+1,k)-fh(i+1,j,k)+fh(i+1,j+1,k))/TWO/dX/dY + elseif(j==jmax .and. i+1 <= imax .and. i-1 >= imin)then + fxy(i,j,k) = (fh(i-1,j-1,k)-fh(i-1,j,k)-fh(i+1,j-1,k)+fh(i+1,j,k))/TWO/dX/dY + elseif(i==imin .and. j==jmin)then + fxy(i,j,k) = (fh(i+1,j+1,k)-fh(i+1,j,k)-fh(i,j+1,k)+fh(i,j,k))/dX/dY + elseif(i==imin .and. j==jmax)then + fxy(i,j,k) = (fh(i+1,j,k)-fh(i+1,j-1,k)-fh(i,j,k)+fh(i,j-1,k))/dX/dY + elseif(i==imax .and. j==jmin)then + fxy(i,j,k) = (fh(i,j+1,k)-fh(i,j,k)-fh(i-1,j+1,k)+fh(i-1,j,k))/dX/dY + elseif(i==imax .and. j==jmax)then + fxy(i,j,k) = (fh(i,j,k)-fh(i,j-1,k)-fh(i-1,j,k)+fh(i-1,j-1,k))/dX/dY + else + write(*,*)"error in diff_new.f90:xy: i,j = ",i,j + endif + + enddo + enddo + enddo + + return + + end subroutine fddxy + + subroutine fddxz(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + Edxdz = F1o705600 /( dX * dZ ) + + fxz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz(i,j,k) = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz(i,j,k) = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz(i,j,k) = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + elseif(i==imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i,j,k-1)-fh(i+1,j,k-1)-fh(i,j,k+1)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(i==imax .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i,j,k-1)-fh(i-1,j,k+1)+fh(i,j,k+1))/TWO/dX/dZ + elseif(k==kmin .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dX/dZ + elseif(k==kmax .and. i+1 <= imax .and. i-1 >= imin)then + fxz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dX/dZ + elseif(i==imin .and. k==kmin)then + fxz(i,j,k) = (fh(i+1,j,k+1)-fh(i+1,j,k)-fh(i,j,k+1)+fh(i,j,k))/dX/dZ + elseif(i==imin .and. k==kmax)then + fxz(i,j,k) = (fh(i+1,j,k)-fh(i+1,j,k-1)-fh(i,j,k)+fh(i,j,k-1))/dX/dZ + elseif(i==imax .and. k==kmin)then + fxz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i-1,j,k+1)+fh(i-1,j,k))/dX/dZ + elseif(i==imax .and. k==kmax)then + fxz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i-1,j,k)+fh(i-1,j,k-1))/dX/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: i,k = ",i,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddxz + + subroutine fddyz(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry) + implicit none + + integer, intent(in ):: ex(1:3),symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, dimension(ex(1),ex(2),ex(3)),intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + real*8, dimension(3) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax,i,j,k + real*8 :: Sdydz,Fdydz,Xdydz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + SoA(1) = SYM1 + SoA(2) = SYM2 + SoA(3) = SYM3 + + call symmetry_bd(4,ex,f,fh,SoA) + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + Edydz = F1o705600 /( dY * dZ ) + + fyz = ZEO + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz(i,j,k) = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz(i,j,k) = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz(i,j,k) = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + elseif(j==jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j,k-1)-fh(i,j+1,k-1)-fh(i,j,k+1)+fh(i,j+1,k+1))/TWO/dY/dZ + elseif(j==jmax .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz(i,j,k) = (fh(i,j-1,k-1)-fh(i,j,k-1)-fh(i,j-1,k+1)+fh(i,j,k+1))/TWO/dY/dZ + elseif(k==kmin .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k)-fh(i-1,j,k+1)-fh(i+1,j,k)+fh(i+1,j,k+1))/TWO/dY/dZ + elseif(k==kmax .and. j+1 <= jmax .and. j-1 >= jmin)then + fyz(i,j,k) = (fh(i-1,j,k-1)-fh(i-1,j,k)-fh(i+1,j,k-1)+fh(i+1,j,k))/TWO/dY/dZ + elseif(j==jmin .and. k==kmin)then + fyz(i,j,k) = (fh(i,j+1,k+1)-fh(i,j+1,k)-fh(i,j,k+1)+fh(i,j,k))/dY/dZ + elseif(j==jmin .and. k==kmax)then + fyz(i,j,k) = (fh(i,j+1,k)-fh(i,j+1,k-1)-fh(i,j,k)+fh(i,j,k-1))/dY/dZ + elseif(j==jmax .and. k==kmin)then + fyz(i,j,k) = (fh(i,j,k+1)-fh(i,j,k)-fh(i,j-1,k+1)+fh(i,j-1,k))/dY/dZ + elseif(j==jmax .and. k==kmax)then + fyz(i,j,k) = (fh(i,j,k)-fh(i,j,k-1)-fh(i,j-1,k)+fh(i,j-1,k-1))/dY/dZ + else + write(*,*)"error in diff_new.f90:fdderivs: j,k = ",j,k + endif + + enddo + enddo + enddo + + return + + end subroutine fddyz + +#endif diff --git a/AMSS_NCKU_source/fdderivs_c.C b/AMSS_NCKU_source/Derivative/fdderivs_c.C similarity index 100% rename from AMSS_NCKU_source/fdderivs_c.C rename to AMSS_NCKU_source/Derivative/fdderivs_c.C diff --git a/AMSS_NCKU_source/fderivs_c.C b/AMSS_NCKU_source/Derivative/fderivs_c.C similarity index 100% rename from AMSS_NCKU_source/fderivs_c.C rename to AMSS_NCKU_source/Derivative/fderivs_c.C diff --git a/AMSS_NCKU_source/point_diff_new_sh.f90 b/AMSS_NCKU_source/Derivative/point_diff_new_sh.f90 similarity index 97% rename from AMSS_NCKU_source/point_diff_new_sh.f90 rename to AMSS_NCKU_source/Derivative/point_diff_new_sh.f90 index ff7a815..9e0352f 100644 --- a/AMSS_NCKU_source/point_diff_new_sh.f90 +++ b/AMSS_NCKU_source/Derivative/point_diff_new_sh.f90 @@ -1,5287 +1,5287 @@ - - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 2_nd oder accurate -! -! f(i+1) - f(i-1) -! fx(i) = ----------------------- -! 2 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - -! if inner point - if(i+1 <= imax .and. i-1 >= imin & - .and. j+1 <= jmax .and. j-1 >= jmin & - .and. k+1 <= kmax .and. k-1 >= kmin )then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-f(i-1,j,k)+f(i+1,j,k)) - - fy=d2dy*(-f(i,j-1,k)+f(i,j+1,k)) - - fz=d2dz*(-f(i,j,k-1)+f(i,j,k+1)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d2dx = ONE/TWO/dX - - fx = ZEO - -! if inner point - if(i+1 <= imax .and. i-1 >= imin )then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-f(i-1,j,k)+f(i+1,j,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -! x direction - if(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - return - - end subroutine point_fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d2dy = ONE/TWO/dY - - fy = ZEO - -! if inner point - if(j+1 <= jmax .and. j-1 >= jmin )then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - - fy=d2dy*(-f(i,j-1,k)+f(i,j+1,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -! y direction - if(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - return - - end subroutine point_fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d2dz = ONE/TWO/dZ - - fz = ZEO - -! if inner point - if( k+1 <= kmax .and. k-1 >= kmin )then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - - fz=d2dz*(-f(i,j,k-1)+f(i,j,k+1)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -! z direction - if(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 2_nd oder accurate -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 -! -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Sdydy,Sdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - -! if inner point - if(i+1 <= imax .and. i-1 >= imin & - .and. j+1 <= jmax .and. j-1 >= jmin & - .and. k+1 <= kmax .and. k-1 >= kmin )then -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx = Sdxdx*(f(i-1,j,k)-TWO*f(i,j,k) & - +f(i+1,j,k) ) - - fyy = Sdydy*(f(i,j-1,k)-TWO*f(i,j,k) & - +f(i,j+1,k) ) - - fzz = Sdzdz*(f(i,j,k-1)-TWO*f(i,j,k) & - +f(i,j,k+1) ) -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy = Sdxdy*(f(i-1,j-1,k)-f(i+1,j-1,k)-f(i-1,j+1,k)+f(i+1,j+1,k)) - - fxz = Sdxdz*(f(i-1,j,k-1)-f(i+1,j,k-1)-f(i-1,j,k+1)+f(i+1,j,k+1)) - - fyz = Sdydz*(f(i,j-1,k-1)-f(i,j+1,k-1)-f(i,j-1,k+1)+f(i,j+1,k+1)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - - fxx = ZEO - -! if inner point - if(i+1 <= imax .and. i-1 >= imin )then -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx = Sdxdx*(f(i-1,j,k)-TWO*f(i,j,k) & - +f(i+1,j,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+1 <= imax .and. i-1 >= imin)then - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - return - - end subroutine point_fddxx_sh - - subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydy = ONE /( dY * dY ) - - fyy = ZEO - -! if inner point - if(j+1 <= jmax .and. j-1 >= jmin )then -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - - fyy = Sdydy*(f(i,j-1,k)-TWO*f(i,j,k) & - +f(i,j+1,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fyy - if(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - return - - end subroutine point_fddyy_sh - - subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdzdz = ONE /( dZ * dZ ) - - fzz = ZEO - -! if inner point - if( k+1 <= kmax .and. k-1 >= kmin )then -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - - fzz = Sdzdz*(f(i,j,k-1)-TWO*f(i,j,k) & - +f(i,j,k+1) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fzz - if(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - return - - end subroutine point_fddzz_sh - - subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdy = F1o4 /( dX * dY ) - - fxy = ZEO - -! if inner point - if(i+1 <= imax .and. i-1 >= imin & - .and. j+1 <= jmax .and. j-1 >= jmin )then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy = Sdxdy*(f(i-1,j-1,k)-f(i+1,j-1,k)-f(i-1,j+1,k)+f(i+1,j+1,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fxy - if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - return - - end subroutine point_fddxy_sh - - subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdz = F1o4 /( dX * dZ ) - - fxz = ZEO - -! if inner point - if(i+1 <= imax .and. i-1 >= imin & - .and. k+1 <= kmax .and. k-1 >= kmin )then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - - fxz = Sdxdz*(f(i-1,j,k-1)-f(i+1,j,k-1)-f(i-1,j,k+1)+f(i+1,j,k+1)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fxz - if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - return - - end subroutine point_fddxz_sh - - subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydz = F1o4 /( dY * dZ ) - - fyz = ZEO - -! if inner point - if(j+1 <= jmax .and. j-1 >= jmin & - .and. k+1 <= kmax .and. k-1 >= kmin )then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - - fyz = Sdydz*(f(i,j-1,k-1)-f(i,j+1,k-1)-f(i,j-1,k+1)+f(i,j+1,k+1)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = 0 - if(dabs(Y(1)) < dY) jmin = 0 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(1,ex,f,fh,SoA) - -!~~~~~~ fyz - if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fddyz_sh - -#elif (ghost_width == 3) -! fourth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 4_th oder accurate -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - -! if inner point - if(i+2 <= imax .and. i-2 >= imin & - .and. j+2 <= jmax .and. j-2 >= jmin & - .and. k+2 <= kmax .and. k-2 >= kmin )then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(f(i-2,j,k)-EIT*f(i-1,j,k)+EIT*f(i+1,j,k)-f(i+2,j,k)) - fy=d12dy*(f(i,j-2,k)-EIT*f(i,j-1,k)+EIT*f(i,j+1,k)-f(i,j+2,k)) - fz=d12dz*(f(i,j,k-2)-EIT*f(i,j,k-1)+EIT*f(i,j,k+1)-f(i,j,k+2)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - -! if inner point - if(i+2 <= imax .and. i-2 >= imin )then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(f(i-2,j,k)-EIT*f(i-1,j,k)+EIT*f(i+1,j,k)-f(i+2,j,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -! x direction - if(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - return - - end subroutine point_fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - -! if inner point - if(j+2 <= jmax .and. j-2 >= jmin )then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fy=d12dy*(f(i,j-2,k)-EIT*f(i,j-1,k)+EIT*f(i,j+1,k)-f(i,j+2,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -! y direction - if(j+2 <= jmax .and. j-2 >= jmin)then - - fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - return - - end subroutine point_fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - -! if inner point - if( k+2 <= kmax .and. k-2 >= kmin )then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fz=d12dz*(f(i,j,k-2)-EIT*f(i,j,k-1)+EIT*f(i,j,k+1)-f(i,j,k+2)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -! z direction - if(k+2 <= kmax .and. k-2 >= kmin)then - - fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 4_th oder accurate -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 -! -! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) -! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) -! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) -! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - -! if inner point - if(i+2 <= imax .and. i-2 >= imin & - .and. j+2 <= jmax .and. j-2 >= jmin & - .and. k+2 <= kmax .and. k-2 >= kmin )then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx = Fdxdx*(-f(i-2,j,k)+F16*f(i-1,j,k)-F30*f(i,j,k) & - -f(i+2,j,k)+F16*f(i+1,j,k) ) - - fyy = Fdydy*(-f(i,j-2,k)+F16*f(i,j-1,k)-F30*f(i,j,k) & - -f(i,j+2,k)+F16*f(i,j+1,k) ) - - fzz = Fdzdz*(-f(i,j,k-2)+F16*f(i,j,k-1)-F30*f(i,j,k) & - -f(i,j,k+2)+F16*f(i,j,k+1) ) - -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy = Fdxdy*( (f(i-2,j-2,k)-F8*f(i-1,j-2,k)+F8*f(i+1,j-2,k)-f(i+2,j-2,k)) & - -F8 *(f(i-2,j-1,k)-F8*f(i-1,j-1,k)+F8*f(i+1,j-1,k)-f(i+2,j-1,k)) & - +F8 *(f(i-2,j+1,k)-F8*f(i-1,j+1,k)+F8*f(i+1,j+1,k)-f(i+2,j+1,k)) & - - (f(i-2,j+2,k)-F8*f(i-1,j+2,k)+F8*f(i+1,j+2,k)-f(i+2,j+2,k))) - - fxz = Fdxdz*( (f(i-2,j,k-2)-F8*f(i-1,j,k-2)+F8*f(i+1,j,k-2)-f(i+2,j,k-2)) & - -F8 *(f(i-2,j,k-1)-F8*f(i-1,j,k-1)+F8*f(i+1,j,k-1)-f(i+2,j,k-1)) & - +F8 *(f(i-2,j,k+1)-F8*f(i-1,j,k+1)+F8*f(i+1,j,k+1)-f(i+2,j,k+1)) & - - (f(i-2,j,k+2)-F8*f(i-1,j,k+2)+F8*f(i+1,j,k+2)-f(i+2,j,k+2))) - - fyz = Fdydz*( (f(i,j-2,k-2)-F8*f(i,j-1,k-2)+F8*f(i,j+1,k-2)-f(i,j+2,k-2)) & - -F8 *(f(i,j-2,k-1)-F8*f(i,j-1,k-1)+F8*f(i,j+1,k-1)-f(i,j+2,k-1)) & - +F8 *(f(i,j-2,k+1)-F8*f(i,j-1,k+1)+F8*f(i,j+1,k+1)-f(i,j+2,k+1)) & - - (f(i,j-2,k+2)-F8*f(i,j-1,k+2)+F8*f(i,j+1,k+2)-f(i,j+2,k+2))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Fdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - fxx = ZEO - -! if inner point - if(i+2 <= imax .and. i-2 >= imin )then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx = Fdxdx*(-f(i-2,j,k)+F16*f(i-1,j,k)-F30*f(i,j,k) & - -f(i+2,j,k)+F16*f(i+1,j,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+2 <= imax .and. i-2 >= imin)then - fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - return - - end subroutine point_fddxx_sh - - subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydy,Fdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - fyy = ZEO - -! if inner point - if(j+2 <= jmax .and. j-2 >= jmin )then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - - fyy = Fdydy*(-f(i,j-2,k)+F16*f(i,j-1,k)-F30*f(i,j,k) & - -f(i,j+2,k)+F16*f(i,j+1,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fyy - if(j+2 <= jmax .and. j-2 >= jmin)then - - fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - return - - end subroutine point_fddyy_sh - - subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdzdz,Fdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - fzz = ZEO - -! if inner point - if( k+2 <= kmax .and. k-2 >= kmin )then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - - fzz = Fdzdz*(-f(i,j,k-2)+F16*f(i,j,k-1)-F30*f(i,j,k) & - -f(i,j,k+2)+F16*f(i,j,k+1) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fzz - if(k+2 <= kmax .and. k-2 >= kmin)then - - fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - return - - end subroutine point_fddzz_sh - - subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdy,Fdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - fxy = ZEO - -! if inner point - if(i+2 <= imax .and. i-2 >= imin & - .and. j+2 <= jmax .and. j-2 >= jmin )then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy = Fdxdy*( (f(i-2,j-2,k)-F8*f(i-1,j-2,k)+F8*f(i+1,j-2,k)-f(i+2,j-2,k)) & - -F8 *(f(i-2,j-1,k)-F8*f(i-1,j-1,k)+F8*f(i+1,j-1,k)-f(i+2,j-1,k)) & - +F8 *(f(i-2,j+1,k)-F8*f(i-1,j+1,k)+F8*f(i+1,j+1,k)-f(i+2,j+1,k)) & - - (f(i-2,j+2,k)-F8*f(i-1,j+2,k)+F8*f(i+1,j+2,k)-f(i+2,j+2,k))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fxy - if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - return - - end subroutine point_fddxy_sh - - subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdz,Fdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - fxz = ZEO - -! if inner point - if(i+2 <= imax .and. i-2 >= imin & - .and. k+2 <= kmax .and. k-2 >= kmin )then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - - fxz = Fdxdz*( (f(i-2,j,k-2)-F8*f(i-1,j,k-2)+F8*f(i+1,j,k-2)-f(i+2,j,k-2)) & - -F8 *(f(i-2,j,k-1)-F8*f(i-1,j,k-1)+F8*f(i+1,j,k-1)-f(i+2,j,k-1)) & - +F8 *(f(i-2,j,k+1)-F8*f(i-1,j,k+1)+F8*f(i+1,j,k+1)-f(i+2,j,k+1)) & - - (f(i-2,j,k+2)-F8*f(i-1,j,k+2)+F8*f(i+1,j,k+2)-f(i+2,j,k+2))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fxz - if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - return - - end subroutine point_fddxz_sh - - subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydz,Fdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - fyz = ZEO - -! if inner point - if(j+2 <= jmax .and. j-2 >= jmin & - .and. k+2 <= kmax .and. k-2 >= kmin )then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - - fyz = Fdydz*( (f(i,j-2,k-2)-F8*f(i,j-1,k-2)+F8*f(i,j+1,k-2)-f(i,j+2,k-2)) & - -F8 *(f(i,j-2,k-1)-F8*f(i,j-1,k-1)+F8*f(i,j+1,k-1)-f(i,j+2,k-1)) & - +F8 *(f(i,j-2,k+1)-F8*f(i,j-1,k+1)+F8*f(i,j+1,k+1)-f(i,j+2,k+1)) & - - (f(i,j-2,k+2)-F8*f(i,j-1,k+2)+F8*f(i,j+1,k+2)-f(i,j+2,k+2))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -!~~~~~~ fyz - if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fddyz_sh - -#elif (ghost_width == 4) -! sixth order code - -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 6_th oder accurate -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - -! if inner point - if(i+3 <= imax .and. i-3 >= imin & - .and. j+3 <= jmax .and. j-3 >= jmin & - .and. k+3 <= kmax .and. k-3 >= kmin )then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx=d60dx*(-f(i-3,j,k)+F9*f(i-2,j,k)-F45*f(i-1,j,k)+F45*f(i+1,j,k)-F9*f(i+2,j,k)+f(i+3,j,k)) - - fy=d60dy*(-f(i,j-3,k)+F9*f(i,j-2,k)-F45*f(i,j-1,k)+F45*f(i,j+1,k)-F9*f(i,j+2,k)+f(i,j+3,k)) - - fz=d60dz*(-f(i,j,k-3)+F9*f(i,j,k-2)-F45*f(i,j,k-1)+F45*f(i,j,k+1)-F9*f(i,j,k+2)+f(i,j,k+3)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - -! if inner point - if(i+3 <= imax .and. i-3 >= imin )then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx=d60dx*(-f(i-3,j,k)+F9*f(i-2,j,k)-F45*f(i-1,j,k)+F45*f(i+1,j,k)-F9*f(i+2,j,k)+f(i+3,j,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -! x direction - if(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - return - - end subroutine point_fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - -! if inner point - if(j+3 <= jmax .and. j-3 >= jmin )then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - - fy=d60dy*(-f(i,j-3,k)+F9*f(i,j-2,k)-F45*f(i,j-1,k)+F45*f(i,j+1,k)-F9*f(i,j+2,k)+f(i,j+3,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -! y direction - if(j+3 <= jmax .and. j-3 >= jmin)then - - fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - return - - end subroutine point_fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 - real*8, parameter :: TWO=2.d0,EIT=8.d0 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - -! if inner point - if( k+3 <= kmax .and. k-3 >= kmin )then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - - fz=d60dz*(-f(i,j,k-3)+F9*f(i,j,k-2)-F45*f(i,j,k-1)+F45*f(i,j,k+1)-F9*f(i,j,k+2)+f(i,j,k+3)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -! z direction - if(k+3 <= kmax .and. k-3 >= kmin)then - - fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 6_th oder accurate -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - -! if inner point - if(i+3 <= imax .and. i-3 >= imin & - .and. j+3 <= jmax .and. j-3 >= jmin & - .and. k+3 <= kmax .and. k-3 >= kmin )then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx = Xdxdx*(TWO*f(i-3,j,k)-F27*f(i-2,j,k)+F270*f(i-1,j,k)-F490*f(i,j,k) & - +TWO*f(i+3,j,k)-F27*f(i+2,j,k)+F270*f(i+1,j,k) ) - - fyy = Xdydy*(TWO*f(i,j-3,k)-F27*f(i,j-2,k)+F270*f(i,j-1,k)-F490*f(i,j,k) & - +TWO*f(i,j+3,k)-F27*f(i,j+2,k)+F270*f(i,j+1,k) ) - - fzz = Xdzdz*(TWO*f(i,j,k-3)-F27*f(i,j,k-2)+F270*f(i,j,k-1)-F490*f(i,j,k) & - +TWO*f(i,j,k+3)-F27*f(i,j,k+2)+F270*f(i,j,k+1) ) - -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy = Xdxdy*(- (-f(i-3,j-3,k)+F9*f(i-2,j-3,k)-F45*f(i-1,j-3,k)+F45*f(i+1,j-3,k)-F9*f(i+2,j-3,k)+f(i+3,j-3,k)) & - +F9 *(-f(i-3,j-2,k)+F9*f(i-2,j-2,k)-F45*f(i-1,j-2,k)+F45*f(i+1,j-2,k)-F9*f(i+2,j-2,k)+f(i+3,j-2,k)) & - -F45*(-f(i-3,j-1,k)+F9*f(i-2,j-1,k)-F45*f(i-1,j-1,k)+F45*f(i+1,j-1,k)-F9*f(i+2,j-1,k)+f(i+3,j-1,k)) & - +F45*(-f(i-3,j+1,k)+F9*f(i-2,j+1,k)-F45*f(i-1,j+1,k)+F45*f(i+1,j+1,k)-F9*f(i+2,j+1,k)+f(i+3,j+1,k)) & - -F9 *(-f(i-3,j+2,k)+F9*f(i-2,j+2,k)-F45*f(i-1,j+2,k)+F45*f(i+1,j+2,k)-F9*f(i+2,j+2,k)+f(i+3,j+2,k)) & - + (-f(i-3,j+3,k)+F9*f(i-2,j+3,k)-F45*f(i-1,j+3,k)+F45*f(i+1,j+3,k)-F9*f(i+2,j+3,k)+f(i+3,j+3,k))) - - fxz = Xdxdz*(- (-f(i-3,j,k-3)+F9*f(i-2,j,k-3)-F45*f(i-1,j,k-3)+F45*f(i+1,j,k-3)-F9*f(i+2,j,k-3)+f(i+3,j,k-3)) & - +F9 *(-f(i-3,j,k-2)+F9*f(i-2,j,k-2)-F45*f(i-1,j,k-2)+F45*f(i+1,j,k-2)-F9*f(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-f(i-3,j,k-1)+F9*f(i-2,j,k-1)-F45*f(i-1,j,k-1)+F45*f(i+1,j,k-1)-F9*f(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-f(i-3,j,k+1)+F9*f(i-2,j,k+1)-F45*f(i-1,j,k+1)+F45*f(i+1,j,k+1)-F9*f(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-f(i-3,j,k+2)+F9*f(i-2,j,k+2)-F45*f(i-1,j,k+2)+F45*f(i+1,j,k+2)-F9*f(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-f(i-3,j,k+3)+F9*f(i-2,j,k+3)-F45*f(i-1,j,k+3)+F45*f(i+1,j,k+3)-F9*f(i+2,j,k+3)+fh(i+3,j,k+3))) - - fyz = Xdydz*(- (-f(i,j-3,k-3)+F9*f(i,j-2,k-3)-F45*f(i,j-1,k-3)+F45*f(i,j+1,k-3)-F9*f(i,j+2,k-3)+f(i,j+3,k-3)) & - +F9 *(-f(i,j-3,k-2)+F9*f(i,j-2,k-2)-F45*f(i,j-1,k-2)+F45*f(i,j+1,k-2)-F9*f(i,j+2,k-2)+f(i,j+3,k-2)) & - -F45*(-f(i,j-3,k-1)+F9*f(i,j-2,k-1)-F45*f(i,j-1,k-1)+F45*f(i,j+1,k-1)-F9*f(i,j+2,k-1)+f(i,j+3,k-1)) & - +F45*(-f(i,j-3,k+1)+F9*f(i,j-2,k+1)-F45*f(i,j-1,k+1)+F45*f(i,j+1,k+1)-F9*f(i,j+2,k+1)+f(i,j+3,k+1)) & - -F9 *(-f(i,j-3,k+2)+F9*f(i,j-2,k+2)-F45*f(i,j-1,k+2)+F45*f(i,j+1,k+2)-F9*f(i,j+2,k+2)+f(i,j+3,k+2)) & - + (-f(i,j-3,k+3)+F9*f(i,j-2,k+3)-F45*f(i,j-1,k+3)+F45*f(i,j+1,k+3)-F9*f(i,j+2,k+3)+f(i,j+3,k+3))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Fdxdx,Xdxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - fxx = ZEO - -! if inner point - if(i+3 <= imax .and. i-3 >= imin )then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx = Xdxdx*(TWO*f(i-3,j,k)-F27*f(i-2,j,k)+F270*f(i-1,j,k)-F490*f(i,j,k) & - +TWO*f(i+3,j,k)-F27*f(i+2,j,k)+F270*f(i+1,j,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+3 <= imax .and. i-3 >= imin)then - fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - return - - end subroutine point_fddxx_sh - - subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydy,Fdydy,Xdydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - fyy = ZEO - -! if inner point - if(j+3 <= jmax .and. j-3 >= jmin )then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - - fyy = Xdydy*(TWO*f(i,j-3,k)-F27*f(i,j-2,k)+F270*f(i,j-1,k)-F490*f(i,j,k) & - +TWO*f(i,j+3,k)-F27*f(i,j+2,k)+F270*f(i,j+1,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fyy - if(j+3 <= jmax .and. j-3 >= jmin)then - - fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - return - - end subroutine point_fddyy_sh - - subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdzdz,Fdzdz,Xdzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - fzz = ZEO - -! if inner point - if( k+3 <= kmax .and. k-3 >= kmin )then -! -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - - fzz = Xdzdz*(TWO*f(i,j,k-3)-F27*f(i,j,k-2)+F270*f(i,j,k-1)-F490*f(i,j,k) & - +TWO*f(i,j,k+3)-F27*f(i,j,k+2)+F270*f(i,j,k+1) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fzz - if(k+3 <= kmax .and. k-3 >= kmin)then - - fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - return - - end subroutine point_fddzz_sh - - subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdy,Fdxdy,Xdxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - fxy = ZEO - -! if inner point - if(i+3 <= imax .and. i-3 >= imin & - .and. j+3 <= jmax .and. j-3 >= jmin )then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy = Xdxdy*(- (-f(i-3,j-3,k)+F9*f(i-2,j-3,k)-F45*f(i-1,j-3,k)+F45*f(i+1,j-3,k)-F9*f(i+2,j-3,k)+f(i+3,j-3,k)) & - +F9 *(-f(i-3,j-2,k)+F9*f(i-2,j-2,k)-F45*f(i-1,j-2,k)+F45*f(i+1,j-2,k)-F9*f(i+2,j-2,k)+f(i+3,j-2,k)) & - -F45*(-f(i-3,j-1,k)+F9*f(i-2,j-1,k)-F45*f(i-1,j-1,k)+F45*f(i+1,j-1,k)-F9*f(i+2,j-1,k)+f(i+3,j-1,k)) & - +F45*(-f(i-3,j+1,k)+F9*f(i-2,j+1,k)-F45*f(i-1,j+1,k)+F45*f(i+1,j+1,k)-F9*f(i+2,j+1,k)+f(i+3,j+1,k)) & - -F9 *(-f(i-3,j+2,k)+F9*f(i-2,j+2,k)-F45*f(i-1,j+2,k)+F45*f(i+1,j+2,k)-F9*f(i+2,j+2,k)+f(i+3,j+2,k)) & - + (-f(i-3,j+3,k)+F9*f(i-2,j+3,k)-F45*f(i-1,j+3,k)+F45*f(i+1,j+3,k)-F9*f(i+2,j+3,k)+f(i+3,j+3,k))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fxy - if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - return - - end subroutine point_fddxy_sh - - subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdz,Fdxdz,Xdxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - fxz = ZEO - -! if inner point - if(i+3 <= imax .and. i-3 >= imin & - .and. k+3 <= kmax .and. k-3 >= kmin )then - -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - - fxz = Xdxdz*(- (-f(i-3,j,k-3)+F9*f(i-2,j,k-3)-F45*f(i-1,j,k-3)+F45*f(i+1,j,k-3)-F9*f(i+2,j,k-3)+f(i+3,j,k-3)) & - +F9 *(-f(i-3,j,k-2)+F9*f(i-2,j,k-2)-F45*f(i-1,j,k-2)+F45*f(i+1,j,k-2)-F9*f(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-f(i-3,j,k-1)+F9*f(i-2,j,k-1)-F45*f(i-1,j,k-1)+F45*f(i+1,j,k-1)-F9*f(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-f(i-3,j,k+1)+F9*f(i-2,j,k+1)-F45*f(i-1,j,k+1)+F45*f(i+1,j,k+1)-F9*f(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-f(i-3,j,k+2)+F9*f(i-2,j,k+2)-F45*f(i-1,j,k+2)+F45*f(i+1,j,k+2)-F9*f(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-f(i-3,j,k+3)+F9*f(i-2,j,k+3)-F45*f(i-1,j,k+3)+F45*f(i+1,j,k+3)-F9*f(i+2,j,k+3)+fh(i+3,j,k+3))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fxz - if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - return - - end subroutine point_fddxz_sh - - subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydz,Fdydz,Xdydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - fyz = ZEO - -! if inner point - if(j+3 <= jmax .and. j-3 >= jmin & - .and. k+3 <= kmax .and. k-3 >= kmin )then - -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - - fyz = Xdydz*(- (-f(i,j-3,k-3)+F9*f(i,j-2,k-3)-F45*f(i,j-1,k-3)+F45*f(i,j+1,k-3)-F9*f(i,j+2,k-3)+f(i,j+3,k-3)) & - +F9 *(-f(i,j-3,k-2)+F9*f(i,j-2,k-2)-F45*f(i,j-1,k-2)+F45*f(i,j+1,k-2)-F9*f(i,j+2,k-2)+f(i,j+3,k-2)) & - -F45*(-f(i,j-3,k-1)+F9*f(i,j-2,k-1)-F45*f(i,j-1,k-1)+F45*f(i,j+1,k-1)-F9*f(i,j+2,k-1)+f(i,j+3,k-1)) & - +F45*(-f(i,j-3,k+1)+F9*f(i,j-2,k+1)-F45*f(i,j-1,k+1)+F45*f(i,j+1,k+1)-F9*f(i,j+2,k+1)+f(i,j+3,k+1)) & - -F9 *(-f(i,j-3,k+2)+F9*f(i,j-2,k+2)-F45*f(i,j-1,k+2)+F45*f(i,j+1,k+2)-F9*f(i,j+2,k+2)+f(i,j+3,k+2)) & - + (-f(i,j-3,k+3)+F9*f(i,j-2,k+3)-F45*f(i,j-1,k+3)+F45*f(i,j+1,k+3)-F9*f(i,j+2,k+3)+f(i,j+3,k+3))) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - -!~~~~~~ fyz - if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fddyz_sh - -#elif (ghost_width == 5) -! eighth order code - -! PRD 77, 024034 (2008) -!----------------------------------------------------------------------------------------------------------------- -! -! General first derivatives of 8_th oder accurate -! -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx -! -!----------------------------------------------------------------------------------------------------------------- - - subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx,fy,fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d840dx,d840dy,d840dz - real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d840dx = ONE/F840/dX - d840dy = ONE/F840/dY - d840dz = ONE/F840/dZ - - d60dx = ONE/F60/dX - d60dy = ONE/F60/dY - d60dz = ONE/F60/dZ - - d12dx = ONE/F12/dX - d12dy = ONE/F12/dY - d12dz = ONE/F12/dZ - - d2dx = ONE/TWO/dX - d2dy = ONE/TWO/dY - d2dz = ONE/TWO/dZ - - fx = ZEO - fy = ZEO - fz = ZEO - -! if inner point - if(i+4 <= imax .and. i-4 >= imin & - .and. j+4 <= jmax .and. j-4 >= jmin & - .and. k+4 <= kmax .and. k-4 >= kmin )then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx=d840dx*( THR*f(i-4,j,k)-F32 *f(i-3,j,k)+F168*f(i-2,j,k)-F672*f(i-1,j,k)+ & - F672*f(i+1,j,k)-F168*f(i+2,j,k)+F32 *f(i+3,j,k)-THR *f(i+4,j,k)) - - fy=d840dy*( THR*f(i,j-4,k)-F32 *f(i,j-3,k)+F168*f(i,j-2,k)-F672*f(i,j-1,k)+ & - F672*f(i,j+1,k)-F168*f(i,j+2,k)+F32 *f(i,j+3,k)-THR *f(i,j+4,k)) - - fz=d840dz*( THR*f(i,j,k-4)-F32 *f(i,j,k-3)+F168*f(i,j,k-2)-F672*f(i,j,k-1)+ & - F672*f(i,j,k+1)-F168*f(i,j,k+2)+F32 *f(i,j,k+3)-THR *f(i,j,k+4)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fderivs_sh -!----------------------------------------------------------------------------- -! -! single derivatives dx -! -!----------------------------------------------------------------------------- - subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fx - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d840dx,d60dx,d12dx,d2dx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d840dx = ONE/F840/dX - - d60dx = ONE/F60/dX - - d12dx = ONE/F12/dX - - d2dx = ONE/TWO/dX - - fx = ZEO - -! if inner point - if(i+4 <= imax .and. i-4 >= imin )then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx=d840dx*( THR*f(i-4,j,k)-F32 *f(i-3,j,k)+F168*f(i-2,j,k)-F672*f(i-1,j,k)+ & - F672*f(i+1,j,k)-F168*f(i+2,j,k)+F32 *f(i+3,j,k)-THR *f(i+4,j,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -! x direction - if(i+4 <= imax .and. i-4 >= imin)then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - fx=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & - F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) - - elseif(i+3 <= imax .and. i-3 >= imin)then -! -! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) -! fx(i) = ----------------------------------------------------------------- -! 60 dx - fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) - - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) -! fx(i) = --------------------------------------------- -! 12 dx - fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) - - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! - f(i-1) + f(i+1) -! fx(i) = -------------------------------- -! 2 dx - fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) - -! set imax and imin 0 - endif - - return - - end subroutine point_fdx_sh -!----------------------------------------------------------------------------- -! -! single derivatives dy -! -!----------------------------------------------------------------------------- - subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fy - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d840dy,d60dy,d12dy,d2dy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d840dy = ONE/F840/dY - - d60dy = ONE/F60/dY - - d12dy = ONE/F12/dY - - d2dy = ONE/TWO/dY - - fy = ZEO - -! if inner point - if(j+4 <= jmax .and. j-4 >= jmin )then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - - fy=d840dy*( THR*f(i,j-4,k)-F32 *f(i,j-3,k)+F168*f(i,j-2,k)-F672*f(i,j-1,k)+ & - F672*f(i,j+1,k)-F168*f(i,j+2,k)+F32 *f(i,j+3,k)-THR *f(i,j+4,k)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -! y direction - if(j+4 <= jmax .and. j-4 >= jmin)then - - fy=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & - F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) - - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) - - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) - -! set jmax and jmin 0 - endif - - return - - end subroutine point_fdy_sh -!----------------------------------------------------------------------------- -! -! single derivatives dz -! -!----------------------------------------------------------------------------- - subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f - real*8, intent(out):: fz - real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, intent(in ):: SYM1,SYM2,SYM3 - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: d840dz,d60dz,d12dz,d2dz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 - real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 - real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 - real*8, parameter :: F840=8.4d2 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - d840dz = ONE/F840/dZ - - d60dz = ONE/F60/dZ - - d12dz = ONE/F12/dZ - - d2dz = ONE/TWO/dZ - - fz = ZEO - -! if inner point - if( k+4 <= kmax .and. k-4 >= kmin )then -! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) -! fx(i) = ------------------------------------------------------------------------------------------------- -! 840 dx - - fz=d840dz*( THR*f(i,j,k-4)-F32 *f(i,j,k-3)+F168*f(i,j,k-2)-F672*f(i,j,k-1)+ & - F672*f(i,j,k+1)-F168*f(i,j,k+2)+F32 *f(i,j,k+3)-THR *f(i,j,k+4)) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -! z direction - if(k+4 <= kmax .and. k-4 >= kmin)then - - fz=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & - F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) - - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) - - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) - -! set kmax and kmin 0 - endif - - return - - end subroutine point_fdz_sh -!----------------------------------------------------------------------------------------------------------------- -! -! General second derivatives of 8_th oder accurate -! -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 -! -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy -! -!----------------------------------------------------------------------------------------------------------------- - subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz - real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - Sdydy = ONE /( dY * dY ) - Sdzdz = ONE /( dZ * dZ ) - - Fdxdx = F1o12 /( dX * dX ) - Fdydy = F1o12 /( dY * dY ) - Fdzdz = F1o12 /( dZ * dZ ) - - Xdxdx = F1o180 /( dX * dX ) - Xdydy = F1o180 /( dY * dY ) - Xdzdz = F1o180 /( dZ * dZ ) - - Edxdx = F1o5040 /( dX * dX ) - Edydy = F1o5040 /( dY * dY ) - Edzdz = F1o5040 /( dZ * dZ ) - - Sdxdy = F1o4 /( dX * dY ) - Sdxdz = F1o4 /( dX * dZ ) - Sdydz = F1o4 /( dY * dZ ) - - Fdxdy = F1o144 /( dX * dY ) - Fdxdz = F1o144 /( dX * dZ ) - Fdydz = F1o144 /( dY * dZ ) - - Xdxdy = F1o3600 /( dX * dY ) - Xdxdz = F1o3600 /( dX * dZ ) - Xdydz = F1o3600 /( dY * dZ ) - - Edxdy = F1o705600 /( dX * dY ) - Edxdz = F1o705600 /( dX * dZ ) - Edydz = F1o705600 /( dY * dZ ) - - fxx = ZEO - fyy = ZEO - fzz = ZEO - fxy = ZEO - fxz = ZEO - fyz = ZEO - -! if inner point - if(i+4 <= imax .and. i-4 >= imin & - .and. j+4 <= jmax .and. j-4 >= jmin & - .and. k+4 <= kmax .and. k-4 >= kmin )then -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - fxx = Edxdx*(-F9*f(i-4,j,k)+F128*f(i-3,j,k)-F1008*f(i-2,j,k)+F8064*f(i-1,j,k)-F14350*f(i,j,k) & - -F9*f(i+4,j,k)+F128*f(i+3,j,k)-F1008*f(i+2,j,k)+F8064*f(i+1,j,k) ) - - fyy = Edydy*(-F9*f(i,j-4,k)+F128*f(i,j-3,k)-F1008*f(i,j-2,k)+F8064*f(i,j-1,k)-F14350*f(i,j,k) & - -F9*f(i,j+4,k)+F128*f(i,j+3,k)-F1008*f(i,j+2,k)+F8064*f(i,j+1,k) ) - - fzz = Edzdz*(-F9*f(i,j,k-4)+F128*f(i,j,k-3)-F1008*f(i,j,k-2)+F8064*f(i,j,k-1)-F14350*f(i,j,k) & - -F9*f(i,j,k+4)+F128*f(i,j,k+3)-F1008*f(i,j,k+2)+F8064*f(i,j,k+1) ) - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - fxy = Edxdy*( THR *( THR*f(i-4,j-4,k)-F32*f(i-3,j-4,k)+F168*f(i-2,j-4,k)-F672*f(i-1,j-4,k) & - -THR*f(i+4,j-4,k)+F32*f(i+3,j-4,k)-F168*f(i+2,j-4,k)+F672*f(i+1,j-4,k)) & - -F32 *( THR*f(i-4,j-3,k)-F32*f(i-3,j-3,k)+F168*f(i-2,j-3,k)-F672*f(i-1,j-3,k) & - -THR*f(i+4,j-3,k)+F32*f(i+3,j-3,k)-F168*f(i+2,j-3,k)+F672*f(i+1,j-3,k)) & - +F168*( THR*f(i-4,j-2,k)-F32*f(i-3,j-2,k)+F168*f(i-2,j-2,k)-F672*f(i-1,j-2,k) & - -THR*f(i+4,j-2,k)+F32*f(i+3,j-2,k)-F168*f(i+2,j-2,k)+F672*f(i+1,j-2,k)) & - -F672*( THR*f(i-4,j-1,k)-F32*f(i-3,j-1,k)+F168*f(i-2,j-1,k)-F672*f(i-1,j-1,k) & - -THR*f(i+4,j-1,k)+F32*f(i+3,j-1,k)-F168*f(i+2,j-1,k)+F672*f(i+1,j-1,k)) & - +F672*( THR*f(i-4,j+1,k)-F32*f(i-3,j+1,k)+F168*f(i-2,j+1,k)-F672*f(i-1,j+1,k) & - -THR*f(i+4,j+1,k)+F32*f(i+3,j+1,k)-F168*f(i+2,j+1,k)+F672*f(i+1,j+1,k)) & - -F168*( THR*f(i-4,j+2,k)-F32*f(i-3,j+2,k)+F168*f(i-2,j+2,k)-F672*f(i-1,j+2,k) & - -THR*f(i+4,j+2,k)+F32*f(i+3,j+2,k)-F168*f(i+2,j+2,k)+F672*f(i+1,j+2,k)) & - +F32 *( THR*f(i-4,j+3,k)-F32*f(i-3,j+3,k)+F168*f(i-2,j+3,k)-F672*f(i-1,j+3,k) & - -THR*f(i+4,j+3,k)+F32*f(i+3,j+3,k)-F168*f(i+2,j+3,k)+F672*f(i+1,j+3,k)) & - -THR *( THR*f(i-4,j+4,k)-F32*f(i-3,j+4,k)+F168*f(i-2,j+4,k)-F672*f(i-1,j+4,k) & - -THR*f(i+4,j+4,k)+F32*f(i+3,j+4,k)-F168*f(i+2,j+4,k)+F672*f(i+1,j+4,k)) ) - - fxz = Edxdz*( THR *( THR*f(i-4,j,k-4)-F32*f(i-3,j,k-4)+F168*f(i-2,j,k-4)-F672*f(i-1,j,k-4) & - -THR*f(i+4,j,k-4)+F32*f(i+3,j,k-4)-F168*f(i+2,j,k-4)+F672*f(i+1,j,k-4)) & - -F32 *( THR*f(i-4,j,k-3)-F32*f(i-3,j,k-3)+F168*f(i-2,j,k-3)-F672*f(i-1,j,k-3) & - -THR*f(i+4,j,k-3)+F32*f(i+3,j,k-3)-F168*f(i+2,j,k-3)+F672*f(i+1,j,k-3)) & - +F168*( THR*f(i-4,j,k-2)-F32*f(i-3,j,k-2)+F168*f(i-2,j,k-2)-F672*f(i-1,j,k-2) & - -THR*f(i+4,j,k-2)+F32*f(i+3,j,k-2)-F168*f(i+2,j,k-2)+F672*f(i+1,j,k-2)) & - -F672*( THR*f(i-4,j,k-1)-F32*f(i-3,j,k-1)+F168*f(i-2,j,k-1)-F672*f(i-1,j,k-1) & - -THR*f(i+4,j,k-1)+F32*f(i+3,j,k-1)-F168*f(i+2,j,k-1)+F672*f(i+1,j,k-1)) & - +F672*( THR*f(i-4,j,k+1)-F32*f(i-3,j,k+1)+F168*f(i-2,j,k+1)-F672*f(i-1,j,k+1) & - -THR*f(i+4,j,k+1)+F32*f(i+3,j,k+1)-F168*f(i+2,j,k+1)+F672*f(i+1,j,k+1)) & - -F168*( THR*f(i-4,j,k+2)-F32*f(i-3,j,k+2)+F168*f(i-2,j,k+2)-F672*f(i-1,j,k+2) & - -THR*f(i+4,j,k+2)+F32*f(i+3,j,k+2)-F168*f(i+2,j,k+2)+F672*f(i+1,j,k+2)) & - +F32 *( THR*f(i-4,j,k+3)-F32*f(i-3,j,k+3)+F168*f(i-2,j,k+3)-F672*f(i-1,j,k+3) & - -THR*f(i+4,j,k+3)+F32*f(i+3,j,k+3)-F168*f(i+2,j,k+3)+F672*f(i+1,j,k+3)) & - -THR *( THR*f(i-4,j,k+4)-F32*f(i-3,j,k+4)+F168*f(i-2,j,k+4)-F672*f(i-1,j,k+4) & - -THR*f(i+4,j,k+4)+F32*f(i+3,j,k+4)-F168*f(i+2,j,k+4)+F672*f(i+1,j,k+4)) ) - - fyz = Edydz*( THR *( THR*f(i,j-4,k-4)-F32*f(i,j-3,k-4)+F168*f(i,j-2,k-4)-F672*f(i,j-1,k-4) & - -THR*f(i,j+4,k-4)+F32*f(i,j+3,k-4)-F168*f(i,j+2,k-4)+F672*f(i,j+1,k-4)) & - -F32 *( THR*f(i,j-4,k-3)-F32*f(i,j-3,k-3)+F168*f(i,j-2,k-3)-F672*f(i,j-1,k-3) & - -THR*f(i,j+4,k-3)+F32*f(i,j+3,k-3)-F168*f(i,j+2,k-3)+F672*f(i,j+1,k-3)) & - +F168*( THR*f(i,j-4,k-2)-F32*f(i,j-3,k-2)+F168*f(i,j-2,k-2)-F672*f(i,j-1,k-2) & - -THR*f(i,j+4,k-2)+F32*f(i,j+3,k-2)-F168*f(i,j+2,k-2)+F672*f(i,j+1,k-2)) & - -F672*( THR*f(i,j-4,k-1)-F32*f(i,j-3,k-1)+F168*f(i,j-2,k-1)-F672*f(i,j-1,k-1) & - -THR*f(i,j+4,k-1)+F32*f(i,j+3,k-1)-F168*f(i,j+2,k-1)+F672*f(i,j+1,k-1)) & - +F672*( THR*f(i,j-4,k+1)-F32*f(i,j-3,k+1)+F168*f(i,j-2,k+1)-F672*f(i,j-1,k+1) & - -THR*f(i,j+4,k+1)+F32*f(i,j+3,k+1)-F168*f(i,j+2,k+1)+F672*f(i,j+1,k+1)) & - -F168*( THR*f(i,j-4,k+2)-F32*f(i,j-3,k+2)+F168*f(i,j-2,k+2)-F672*f(i,j-1,k+2) & - -THR*f(i,j+4,k+2)+F32*f(i,j+3,k+2)-F168*f(i,j+2,k+2)+F672*f(i,j+1,k+2)) & - +F32 *( THR*f(i,j-4,k+3)-F32*f(i,j-3,k+3)+F168*f(i,j-2,k+3)-F672*f(i,j-1,k+3) & - -THR*f(i,j+4,k+3)+F32*f(i,j+3,k+3)-F168*f(i,j+2,k+3)+F672*f(i,j+1,k+3)) & - -THR *( THR*f(i,j-4,k+4)-F32*f(i,j-3,k+4)+F168*f(i,j-2,k+4)-F672*f(i,j-1,k+4) & - -THR*f(i,j+4,k+4)+F32*f(i,j+3,k+4)-F168*f(i,j+2,k+4)+F672*f(i,j+1,k+4)) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - fxx = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - -! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) -! fxx(i) = ----------------------------------------------------------------------------------- -! 180 dx^2 - fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then -! -! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) -! fxx(i) = ---------------------------------------------------------- -! 12 dx^2 - fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then -! -! f(i-1) - 2 f(i) + f(i+1) -! fxx(i) = -------------------------------- -! dx^2 - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - fxy = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then -! -! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) -! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) -! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) -! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) -! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) -! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------ -! 3600 dx dy - fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then -! -! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) -! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) -! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) -! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) -! fxy(i,j) = ---------------------------------------------------------------- -! 144 dx dy - fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then -! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) -! fxy(i,j) = ----------------------------------------------------------- -! 4 dx dy - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - !! enddo - !! enddo - !! enddo - - return - - end subroutine point_fdderivs_sh -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! only for compute_ricci.f90 usage -!----------------------------------------------------------------------------- - subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxx - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdx = ONE /( dX * dX ) - - Fdxdx = F1o12 /( dX * dX ) - - Xdxdx = F1o180 /( dX * dX ) - - Edxdx = F1o5040 /( dX * dX ) - - fxx = ZEO - -! if inner point - if(i+4 <= imax .and. i-4 >= imin )then -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - fxx = Edxdx*(-F9*f(i-4,j,k)+F128*f(i-3,j,k)-F1008*f(i-2,j,k)+F8064*f(i-1,j,k)-F14350*f(i,j,k) & - -F9*f(i+4,j,k)+F128*f(i+3,j,k)-F1008*f(i+2,j,k)+F8064*f(i+1,j,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fxx - if(i+4 <= imax .and. i-4 >= imin)then - - fxx = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & - -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) - - elseif(i+3 <= imax .and. i-3 >= imin)then - fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & - +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) - elseif(i+2 <= imax .and. i-2 >= imin)then - fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & - -fh(i+2,j,k)+F16*fh(i+1,j,k) ) - elseif(i+1 <= imax .and. i-1 >= imin)then - fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & - +fh(i+1,j,k) ) - endif - - return - - end subroutine point_fddxx_sh - - subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydy,Fdydy,Xdydy,Edydy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydy = ONE /( dY * dY ) - - Fdydy = F1o12 /( dY * dY ) - - Xdydy = F1o180 /( dY * dY ) - - Edydy = F1o5040 /( dY * dY ) - - fyy = ZEO - -! if inner point - if(j+4 <= jmax .and. j-4 >= jmin )then -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - - fyy = Edydy*(-F9*f(i,j-4,k)+F128*f(i,j-3,k)-F1008*f(i,j-2,k)+F8064*f(i,j-1,k)-F14350*f(i,j,k) & - -F9*f(i,j+4,k)+F128*f(i,j+3,k)-F1008*f(i,j+2,k)+F8064*f(i,j+1,k) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fyy - if(j+4 <= jmax .and. j-4 >= jmin)then - - fyy = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & - -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) - - elseif(j+3 <= jmax .and. j-3 >= jmin)then - - fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & - +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) - elseif(j+2 <= jmax .and. j-2 >= jmin)then - - fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & - -fh(i,j+2,k)+F16*fh(i,j+1,k) ) - elseif(j+1 <= jmax .and. j-1 >= jmin)then - - fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & - +fh(i,j+1,k) ) - endif - - return - - end subroutine point_fddyy_sh - - subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fzz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdzdz = ONE /( dZ * dZ ) - - Fdzdz = F1o12 /( dZ * dZ ) - - Xdzdz = F1o180 /( dZ * dZ ) - - Edzdz = F1o5040 /( dZ * dZ ) - - fzz = ZEO - -! if inner point - if( k+4 <= kmax .and. k-4 >= kmin )then -! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) -! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- -! 5040 dx^2 - - fzz = Edzdz*(-F9*f(i,j,k-4)+F128*f(i,j,k-3)-F1008*f(i,j,k-2)+F8064*f(i,j,k-1)-F14350*f(i,j,k) & - -F9*f(i,j,k+4)+F128*f(i,j,k+3)-F1008*f(i,j,k+2)+F8064*f(i,j,k+1) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fzz - if(k+4 <= kmax .and. k-4 >= kmin)then - - fzz = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & - -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) - - elseif(k+3 <= kmax .and. k-3 >= kmin)then - - fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & - +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) - elseif(k+2 <= kmax .and. k-2 >= kmin)then - - fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & - -fh(i,j,k+2)+F16*fh(i,j,k+1) ) - elseif(k+1 <= kmax .and. k-1 >= kmin)then - - fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & - +fh(i,j,k+1) ) - endif - - return - - end subroutine point_fddzz_sh - - subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxy - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdy = F1o4 /( dX * dY ) - - Fdxdy = F1o144 /( dX * dY ) - - Xdxdy = F1o3600 /( dX * dY ) - - Edxdy = F1o705600 /( dX * dY ) - - fxy = ZEO - -! if inner point - if(i+4 <= imax .and. i-4 >= imin & - .and. j+4 <= jmax .and. j-4 >= jmin )then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - fxy = Edxdy*( THR *( THR*f(i-4,j-4,k)-F32*f(i-3,j-4,k)+F168*f(i-2,j-4,k)-F672*f(i-1,j-4,k) & - -THR*f(i+4,j-4,k)+F32*f(i+3,j-4,k)-F168*f(i+2,j-4,k)+F672*f(i+1,j-4,k)) & - -F32 *( THR*f(i-4,j-3,k)-F32*f(i-3,j-3,k)+F168*f(i-2,j-3,k)-F672*f(i-1,j-3,k) & - -THR*f(i+4,j-3,k)+F32*f(i+3,j-3,k)-F168*f(i+2,j-3,k)+F672*f(i+1,j-3,k)) & - +F168*( THR*f(i-4,j-2,k)-F32*f(i-3,j-2,k)+F168*f(i-2,j-2,k)-F672*f(i-1,j-2,k) & - -THR*f(i+4,j-2,k)+F32*f(i+3,j-2,k)-F168*f(i+2,j-2,k)+F672*f(i+1,j-2,k)) & - -F672*( THR*f(i-4,j-1,k)-F32*f(i-3,j-1,k)+F168*f(i-2,j-1,k)-F672*f(i-1,j-1,k) & - -THR*f(i+4,j-1,k)+F32*f(i+3,j-1,k)-F168*f(i+2,j-1,k)+F672*f(i+1,j-1,k)) & - +F672*( THR*f(i-4,j+1,k)-F32*f(i-3,j+1,k)+F168*f(i-2,j+1,k)-F672*f(i-1,j+1,k) & - -THR*f(i+4,j+1,k)+F32*f(i+3,j+1,k)-F168*f(i+2,j+1,k)+F672*f(i+1,j+1,k)) & - -F168*( THR*f(i-4,j+2,k)-F32*f(i-3,j+2,k)+F168*f(i-2,j+2,k)-F672*f(i-1,j+2,k) & - -THR*f(i+4,j+2,k)+F32*f(i+3,j+2,k)-F168*f(i+2,j+2,k)+F672*f(i+1,j+2,k)) & - +F32 *( THR*f(i-4,j+3,k)-F32*f(i-3,j+3,k)+F168*f(i-2,j+3,k)-F672*f(i-1,j+3,k) & - -THR*f(i+4,j+3,k)+F32*f(i+3,j+3,k)-F168*f(i+2,j+3,k)+F672*f(i+1,j+3,k)) & - -THR *( THR*f(i-4,j+4,k)-F32*f(i-3,j+4,k)+F168*f(i-2,j+4,k)-F672*f(i-1,j+4,k) & - -THR*f(i+4,j+4,k)+F32*f(i+3,j+4,k)-F168*f(i+2,j+4,k)+F672*f(i+1,j+4,k)) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fxy - if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then - - fxy = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & - -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & - -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & - -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & - +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & - -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & - -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & - -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & - +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & - -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & - -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & - -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & - +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & - -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & - -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & - -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then - - fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & - +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & - -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & - +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & - -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & - + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) - elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then - - fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & - -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & - +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & - - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) - elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then - - fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) - endif - - return - - end subroutine point_fddxy_sh - - subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fxz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdxdz = F1o4 /( dX * dZ ) - - Fdxdz = F1o144 /( dX * dZ ) - - Xdxdz = F1o3600 /( dX * dZ ) - - Edxdz = F1o705600 /( dX * dZ ) - - fxz = ZEO - -! if inner point - if(i+4 <= imax .and. i-4 >= imin & - .and. k+4 <= kmax .and. k-4 >= kmin )then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - - fxz = Edxdz*( THR *( THR*f(i-4,j,k-4)-F32*f(i-3,j,k-4)+F168*f(i-2,j,k-4)-F672*f(i-1,j,k-4) & - -THR*f(i+4,j,k-4)+F32*f(i+3,j,k-4)-F168*f(i+2,j,k-4)+F672*f(i+1,j,k-4)) & - -F32 *( THR*f(i-4,j,k-3)-F32*f(i-3,j,k-3)+F168*f(i-2,j,k-3)-F672*f(i-1,j,k-3) & - -THR*f(i+4,j,k-3)+F32*f(i+3,j,k-3)-F168*f(i+2,j,k-3)+F672*f(i+1,j,k-3)) & - +F168*( THR*f(i-4,j,k-2)-F32*f(i-3,j,k-2)+F168*f(i-2,j,k-2)-F672*f(i-1,j,k-2) & - -THR*f(i+4,j,k-2)+F32*f(i+3,j,k-2)-F168*f(i+2,j,k-2)+F672*f(i+1,j,k-2)) & - -F672*( THR*f(i-4,j,k-1)-F32*f(i-3,j,k-1)+F168*f(i-2,j,k-1)-F672*f(i-1,j,k-1) & - -THR*f(i+4,j,k-1)+F32*f(i+3,j,k-1)-F168*f(i+2,j,k-1)+F672*f(i+1,j,k-1)) & - +F672*( THR*f(i-4,j,k+1)-F32*f(i-3,j,k+1)+F168*f(i-2,j,k+1)-F672*f(i-1,j,k+1) & - -THR*f(i+4,j,k+1)+F32*f(i+3,j,k+1)-F168*f(i+2,j,k+1)+F672*f(i+1,j,k+1)) & - -F168*( THR*f(i-4,j,k+2)-F32*f(i-3,j,k+2)+F168*f(i-2,j,k+2)-F672*f(i-1,j,k+2) & - -THR*f(i+4,j,k+2)+F32*f(i+3,j,k+2)-F168*f(i+2,j,k+2)+F672*f(i+1,j,k+2)) & - +F32 *( THR*f(i-4,j,k+3)-F32*f(i-3,j,k+3)+F168*f(i-2,j,k+3)-F672*f(i-1,j,k+3) & - -THR*f(i+4,j,k+3)+F32*f(i+3,j,k+3)-F168*f(i+2,j,k+3)+F672*f(i+1,j,k+3)) & - -THR *( THR*f(i-4,j,k+4)-F32*f(i-3,j,k+4)+F168*f(i-2,j,k+4)-F672*f(i-1,j,k+4) & - -THR*f(i+4,j,k+4)+F32*f(i+3,j,k+4)-F168*f(i+2,j,k+4)+F672*f(i+1,j,k+4)) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fxz - if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fxz = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & - -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & - -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & - -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & - +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & - -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & - -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & - -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & - +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & - -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & - -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & - -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & - +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & - -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & - -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & - -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) - elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & - +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & - -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & - +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & - -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & - + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) - elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then - fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & - -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & - +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & - - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) - elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then - fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) - endif - - return - - end subroutine point_fddxz_sh - - subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) - implicit none - - integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f - real*8, intent(out):: fyz - real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 - -!~~~~~~ other variables - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - real*8, dimension(2) :: SoA - integer :: imin,jmin,kmin,imax,jmax,kmax - real*8 :: Sdydz,Fdydz,Xdydz,Edydz - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 - real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 - real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 - real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 - real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 - real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - Sdydz = F1o4 /( dY * dZ ) - - Fdydz = F1o144 /( dY * dZ ) - - Xdydz = F1o3600 /( dY * dZ ) - - Edydz = F1o705600 /( dY * dZ ) - - fyz = ZEO - -! if inner point - if(j+4 <= jmax .and. j-4 >= jmin & - .and. k+4 <= kmax .and. k-4 >= kmin )then - -! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) -! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) -! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) -! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) -! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) -! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) -! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) -! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) -! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ -! 705600 dx dy - - fyz = Edydz*( THR *( THR*f(i,j-4,k-4)-F32*f(i,j-3,k-4)+F168*f(i,j-2,k-4)-F672*f(i,j-1,k-4) & - -THR*f(i,j+4,k-4)+F32*f(i,j+3,k-4)-F168*f(i,j+2,k-4)+F672*f(i,j+1,k-4)) & - -F32 *( THR*f(i,j-4,k-3)-F32*f(i,j-3,k-3)+F168*f(i,j-2,k-3)-F672*f(i,j-1,k-3) & - -THR*f(i,j+4,k-3)+F32*f(i,j+3,k-3)-F168*f(i,j+2,k-3)+F672*f(i,j+1,k-3)) & - +F168*( THR*f(i,j-4,k-2)-F32*f(i,j-3,k-2)+F168*f(i,j-2,k-2)-F672*f(i,j-1,k-2) & - -THR*f(i,j+4,k-2)+F32*f(i,j+3,k-2)-F168*f(i,j+2,k-2)+F672*f(i,j+1,k-2)) & - -F672*( THR*f(i,j-4,k-1)-F32*f(i,j-3,k-1)+F168*f(i,j-2,k-1)-F672*f(i,j-1,k-1) & - -THR*f(i,j+4,k-1)+F32*f(i,j+3,k-1)-F168*f(i,j+2,k-1)+F672*f(i,j+1,k-1)) & - +F672*( THR*f(i,j-4,k+1)-F32*f(i,j-3,k+1)+F168*f(i,j-2,k+1)-F672*f(i,j-1,k+1) & - -THR*f(i,j+4,k+1)+F32*f(i,j+3,k+1)-F168*f(i,j+2,k+1)+F672*f(i,j+1,k+1)) & - -F168*( THR*f(i,j-4,k+2)-F32*f(i,j-3,k+2)+F168*f(i,j-2,k+2)-F672*f(i,j-1,k+2) & - -THR*f(i,j+4,k+2)+F32*f(i,j+3,k+2)-F168*f(i,j+2,k+2)+F672*f(i,j+1,k+2)) & - +F32 *( THR*f(i,j-4,k+3)-F32*f(i,j-3,k+3)+F168*f(i,j-2,k+3)-F672*f(i,j-1,k+3) & - -THR*f(i,j+4,k+3)+F32*f(i,j+3,k+3)-F168*f(i,j+2,k+3)+F672*f(i,j+1,k+3)) & - -THR *( THR*f(i,j-4,k+4)-F32*f(i,j-3,k+4)+F168*f(i,j-2,k+4)-F672*f(i,j-1,k+4) & - -THR*f(i,j+4,k+4)+F32*f(i,j+3,k+4)-F168*f(i,j+2,k+4)+F672*f(i,j+1,k+4)) ) - - return - endif - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA(1) = SYM1 - SoA(2) = SYM2 - elseif(sst==2.or.sst==3)then - SoA(1) = SYM2 - SoA(2) = SYM3 - elseif(sst==4.or.sst==5)then - SoA(1) = SYM1 - SoA(2) = SYM3 - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -!~~~~~~ fyz - if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then - - fyz = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & - -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & - -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & - -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & - +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & - -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & - -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & - -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & - +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & - -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & - -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & - -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & - +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & - -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & - -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & - -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) - elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then - - fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & - +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & - -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & - +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & - -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & - + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) - elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then - fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & - -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & - +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & - - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) - elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then - fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) - endif - - return - - end subroutine point_fddyz_sh - -#endif - -!common code for different finite difference order -subroutine point_fderivs_shc(ex,f,fx,fy,fz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - - implicit none - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,i,j,k - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,intent(in ):: SYM1,SYM2,SYM3 - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(out) :: fx,fy,fz - -#if 0 - double precision,dimension(ex(1),ex(2),ex(3))::gx,gy,gz - call fderivs_shc(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - fx = gx(i,j,k) - fy = gy(i,j,k) - fz = gz(i,j,k) - -#else - double precision :: gx,gy,gz - - call point_fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst,i,j,k) - - fx = dRdx(i,j,k)*gz+drhodx(i,j,k)*gx+dsigmadx(i,j,k)*gy - fy = dRdy(i,j,k)*gz+drhody(i,j,k)*gx+dsigmady(i,j,k)*gy - fz = dRdz(i,j,k)*gz+drhodz(i,j,k)*gx+dsigmadz(i,j,k)*gy -#endif - - return - -end subroutine point_fderivs_shc - -subroutine point_fdderivs_shc(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - - implicit none - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,i,j,k - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,intent(in ):: SYM1,SYM2,SYM3 - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double precision,intent(out) :: fxx,fxy,fxz,fyy,fyz,fzz - real*8,parameter :: TWO = 2.d0 - -#if 0 - double precision,dimension(ex(1),ex(2),ex(3))::gxx,gxy,gxz,gyy,gyz,gzz - - call fdderivs_shc(ex,f,gxx,gxy,gxz,gyy,gyz,gzz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = gxx(i,j,k) - fyy = gyy(i,j,k) - fzz = gzz(i,j,k) - fxy = gxy(i,j,k) - fxz = gxz(i,j,k) - fyz = gyz(i,j,k) - -#else - double precision :: gx,gy,gz,gxx,gxy,gxz,gyy,gyz,gzz - - call point_fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst,i,j,k) - call point_fdderivs_sh(ex,f,gxx,gxy,gxz,gyy,gyz,gzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,i,j,k) - - fxx = dRdxx(i,j,k)*gz+drhodxx(i,j,k)*gx+dsigmadxx(i,j,k)*gy + & - dRdx(i,j,k)*dRdx(i,j,k)*gzz+drhodx(i,j,k)*drhodx(i,j,k)*gxx+dsigmadx(i,j,k)*dsigmadx(i,j,k)*gyy + & - TWO*(dRdx(i,j,k)*drhodx(i,j,k)*gxz+dRdx(i,j,k)*dsigmadx(i,j,k)*gyz+drhodx(i,j,k)*dsigmadx(i,j,k)*gxy) - fyy = dRdyy(i,j,k)*gz+drhodyy(i,j,k)*gx+dsigmadyy(i,j,k)*gy + & - dRdy(i,j,k)*dRdy(i,j,k)*gzz+drhody(i,j,k)*drhody(i,j,k)*gxx+dsigmady(i,j,k)*dsigmady(i,j,k)*gyy + & - TWO*(dRdy(i,j,k)*drhody(i,j,k)*gxz+dRdy(i,j,k)*dsigmady(i,j,k)*gyz+drhody(i,j,k)*dsigmady(i,j,k)*gxy) - fzz = dRdzz(i,j,k)*gz+drhodzz(i,j,k)*gx+dsigmadzz(i,j,k)*gy + & - dRdz(i,j,k)*dRdz(i,j,k)*gzz+drhodz(i,j,k)*drhodz(i,j,k)*gxx+dsigmadz(i,j,k)*dsigmadz(i,j,k)*gyy + & - TWO*(dRdz(i,j,k)*drhodz(i,j,k)*gxz+dRdz(i,j,k)*dsigmadz(i,j,k)*gyz+drhodz(i,j,k)*dsigmadz(i,j,k)*gxy) - fxy = dRdxy(i,j,k)*gz+drhodxy(i,j,k)*gx+dsigmadxy(i,j,k)*gy + & - dRdx(i,j,k)*drhody(i,j,k)*gxz+dRdx(i,j,k)*dsigmady(i,j,k)*gyz+drhodx(i,j,k)*dsigmady(i,j,k)*gxy + & - dRdy(i,j,k)*drhodx(i,j,k)*gxz+dRdy(i,j,k)*dsigmadx(i,j,k)*gyz+drhody(i,j,k)*dsigmadx(i,j,k)*gxy + & - dRdx(i,j,k)*dRdy(i,j,k)*gzz+drhodx(i,j,k)*drhody(i,j,k)*gxx+dsigmadx(i,j,k)*dsigmady(i,j,k)*gyy - fxz = dRdxz(i,j,k)*gz+drhodxz(i,j,k)*gx+dsigmadxz(i,j,k)*gy + & - dRdx(i,j,k)*drhodz(i,j,k)*gxz+dRdx(i,j,k)*dsigmadz(i,j,k)*gyz+drhodx(i,j,k)*dsigmadz(i,j,k)*gxy + & - dRdz(i,j,k)*drhodx(i,j,k)*gxz+dRdz(i,j,k)*dsigmadx(i,j,k)*gyz+drhodz(i,j,k)*dsigmadx(i,j,k)*gxy + & - dRdx(i,j,k)*dRdz(i,j,k)*gzz+drhodx(i,j,k)*drhodz(i,j,k)*gxx+dsigmadx(i,j,k)*dsigmadz(i,j,k)*gyy - fyz = dRdyz(i,j,k)*gz+drhodyz(i,j,k)*gx+dsigmadyz(i,j,k)*gy + & - dRdz(i,j,k)*drhody(i,j,k)*gxz+dRdz(i,j,k)*dsigmady(i,j,k)*gyz+drhodz(i,j,k)*dsigmady(i,j,k)*gxy + & - dRdy(i,j,k)*drhodz(i,j,k)*gxz+dRdy(i,j,k)*dsigmadz(i,j,k)*gyz+drhody(i,j,k)*dsigmadz(i,j,k)*gxy + & - dRdz(i,j,k)*dRdy(i,j,k)*gzz+drhodz(i,j,k)*drhody(i,j,k)*gxx+dsigmadz(i,j,k)*dsigmady(i,j,k)*gyy -#endif - - return - -end subroutine point_fdderivs_shc + + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 2_nd oder accurate +! +! f(i+1) - f(i-1) +! fx(i) = ----------------------- +! 2 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + +! if inner point + if(i+1 <= imax .and. i-1 >= imin & + .and. j+1 <= jmax .and. j-1 >= jmin & + .and. k+1 <= kmax .and. k-1 >= kmin )then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-f(i-1,j,k)+f(i+1,j,k)) + + fy=d2dy*(-f(i,j-1,k)+f(i,j+1,k)) + + fz=d2dz*(-f(i,j,k-1)+f(i,j,k+1)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d2dx = ONE/TWO/dX + + fx = ZEO + +! if inner point + if(i+1 <= imax .and. i-1 >= imin )then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-f(i-1,j,k)+f(i+1,j,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +! x direction + if(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + return + + end subroutine point_fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d2dy = ONE/TWO/dY + + fy = ZEO + +! if inner point + if(j+1 <= jmax .and. j-1 >= jmin )then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + + fy=d2dy*(-f(i,j-1,k)+f(i,j+1,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +! y direction + if(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + return + + end subroutine point_fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d2dz = ONE/TWO/dZ + + fz = ZEO + +! if inner point + if( k+1 <= kmax .and. k-1 >= kmin )then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + + fz=d2dz*(-f(i,j,k-1)+f(i,j,k+1)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +! z direction + if(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 2_nd oder accurate +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 +! +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Sdydy,Sdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + +! if inner point + if(i+1 <= imax .and. i-1 >= imin & + .and. j+1 <= jmax .and. j-1 >= jmin & + .and. k+1 <= kmax .and. k-1 >= kmin )then +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx = Sdxdx*(f(i-1,j,k)-TWO*f(i,j,k) & + +f(i+1,j,k) ) + + fyy = Sdydy*(f(i,j-1,k)-TWO*f(i,j,k) & + +f(i,j+1,k) ) + + fzz = Sdzdz*(f(i,j,k-1)-TWO*f(i,j,k) & + +f(i,j,k+1) ) +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy = Sdxdy*(f(i-1,j-1,k)-f(i+1,j-1,k)-f(i-1,j+1,k)+f(i+1,j+1,k)) + + fxz = Sdxdz*(f(i-1,j,k-1)-f(i+1,j,k-1)-f(i-1,j,k+1)+f(i+1,j,k+1)) + + fyz = Sdydz*(f(i,j-1,k-1)-f(i,j+1,k-1)-f(i,j-1,k+1)+f(i,j+1,k+1)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + + fxx = ZEO + +! if inner point + if(i+1 <= imax .and. i-1 >= imin )then +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx = Sdxdx*(f(i-1,j,k)-TWO*f(i,j,k) & + +f(i+1,j,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+1 <= imax .and. i-1 >= imin)then + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + return + + end subroutine point_fddxx_sh + + subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydy = ONE /( dY * dY ) + + fyy = ZEO + +! if inner point + if(j+1 <= jmax .and. j-1 >= jmin )then +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + + fyy = Sdydy*(f(i,j-1,k)-TWO*f(i,j,k) & + +f(i,j+1,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fyy + if(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + return + + end subroutine point_fddyy_sh + + subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdzdz = ONE /( dZ * dZ ) + + fzz = ZEO + +! if inner point + if( k+1 <= kmax .and. k-1 >= kmin )then +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + + fzz = Sdzdz*(f(i,j,k-1)-TWO*f(i,j,k) & + +f(i,j,k+1) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fzz + if(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + return + + end subroutine point_fddzz_sh + + subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdy = F1o4 /( dX * dY ) + + fxy = ZEO + +! if inner point + if(i+1 <= imax .and. i-1 >= imin & + .and. j+1 <= jmax .and. j-1 >= jmin )then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy = Sdxdy*(f(i-1,j-1,k)-f(i+1,j-1,k)-f(i-1,j+1,k)+f(i+1,j+1,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fxy + if(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + return + + end subroutine point_fddxy_sh + + subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdz = F1o4 /( dX * dZ ) + + fxz = ZEO + +! if inner point + if(i+1 <= imax .and. i-1 >= imin & + .and. k+1 <= kmax .and. k-1 >= kmin )then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + + fxz = Sdxdz*(f(i-1,j,k-1)-f(i+1,j,k-1)-f(i-1,j,k+1)+f(i+1,j,k+1)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fxz + if(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + return + + end subroutine point_fddxz_sh + + subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(0:ex(1)+1,0:ex(2)+1,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydz = F1o4 /( dY * dZ ) + + fyz = ZEO + +! if inner point + if(j+1 <= jmax .and. j-1 >= jmin & + .and. k+1 <= kmax .and. k-1 >= kmin )then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + + fyz = Sdydz*(f(i,j-1,k-1)-f(i,j+1,k-1)-f(i,j-1,k+1)+f(i,j+1,k+1)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = 0 + if(dabs(Y(1)) < dY) jmin = 0 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = 0 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+1 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(1,ex,f,fh,SoA) + +!~~~~~~ fyz + if(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fddyz_sh + +#elif (ghost_width == 3) +! fourth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 4_th oder accurate +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + +! if inner point + if(i+2 <= imax .and. i-2 >= imin & + .and. j+2 <= jmax .and. j-2 >= jmin & + .and. k+2 <= kmax .and. k-2 >= kmin )then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(f(i-2,j,k)-EIT*f(i-1,j,k)+EIT*f(i+1,j,k)-f(i+2,j,k)) + fy=d12dy*(f(i,j-2,k)-EIT*f(i,j-1,k)+EIT*f(i,j+1,k)-f(i,j+2,k)) + fz=d12dz*(f(i,j,k-2)-EIT*f(i,j,k-1)+EIT*f(i,j,k+1)-f(i,j,k+2)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + +! if inner point + if(i+2 <= imax .and. i-2 >= imin )then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(f(i-2,j,k)-EIT*f(i-1,j,k)+EIT*f(i+1,j,k)-f(i+2,j,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +! x direction + if(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + return + + end subroutine point_fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + +! if inner point + if(j+2 <= jmax .and. j-2 >= jmin )then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fy=d12dy*(f(i,j-2,k)-EIT*f(i,j-1,k)+EIT*f(i,j+1,k)-f(i,j+2,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +! y direction + if(j+2 <= jmax .and. j-2 >= jmin)then + + fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + return + + end subroutine point_fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + +! if inner point + if( k+2 <= kmax .and. k-2 >= kmin )then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fz=d12dz*(f(i,j,k-2)-EIT*f(i,j,k-1)+EIT*f(i,j,k+1)-f(i,j,k+2)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +! z direction + if(k+2 <= kmax .and. k-2 >= kmin)then + + fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 4_th oder accurate +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 +! +! - ( - f(i+2,j+2) + 8 f(i+1,j+2) - 8 f(i-1,j+2) + f(i-2,j+2) ) +! + 8 ( - f(i+2,j+1) + 8 f(i+1,j+1) - 8 f(i-1,j+1) + f(i-2,j+1) ) +! - 8 ( - f(i+2,j-1) + 8 f(i+1,j-1) - 8 f(i-1,j-1) + f(i-2,j-1) ) +! + ( - f(i+2,j-2) + 8 f(i+1,j-2) - 8 f(i-1,j-2) + f(i-2,j-2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + +! if inner point + if(i+2 <= imax .and. i-2 >= imin & + .and. j+2 <= jmax .and. j-2 >= jmin & + .and. k+2 <= kmax .and. k-2 >= kmin )then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx = Fdxdx*(-f(i-2,j,k)+F16*f(i-1,j,k)-F30*f(i,j,k) & + -f(i+2,j,k)+F16*f(i+1,j,k) ) + + fyy = Fdydy*(-f(i,j-2,k)+F16*f(i,j-1,k)-F30*f(i,j,k) & + -f(i,j+2,k)+F16*f(i,j+1,k) ) + + fzz = Fdzdz*(-f(i,j,k-2)+F16*f(i,j,k-1)-F30*f(i,j,k) & + -f(i,j,k+2)+F16*f(i,j,k+1) ) + +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy = Fdxdy*( (f(i-2,j-2,k)-F8*f(i-1,j-2,k)+F8*f(i+1,j-2,k)-f(i+2,j-2,k)) & + -F8 *(f(i-2,j-1,k)-F8*f(i-1,j-1,k)+F8*f(i+1,j-1,k)-f(i+2,j-1,k)) & + +F8 *(f(i-2,j+1,k)-F8*f(i-1,j+1,k)+F8*f(i+1,j+1,k)-f(i+2,j+1,k)) & + - (f(i-2,j+2,k)-F8*f(i-1,j+2,k)+F8*f(i+1,j+2,k)-f(i+2,j+2,k))) + + fxz = Fdxdz*( (f(i-2,j,k-2)-F8*f(i-1,j,k-2)+F8*f(i+1,j,k-2)-f(i+2,j,k-2)) & + -F8 *(f(i-2,j,k-1)-F8*f(i-1,j,k-1)+F8*f(i+1,j,k-1)-f(i+2,j,k-1)) & + +F8 *(f(i-2,j,k+1)-F8*f(i-1,j,k+1)+F8*f(i+1,j,k+1)-f(i+2,j,k+1)) & + - (f(i-2,j,k+2)-F8*f(i-1,j,k+2)+F8*f(i+1,j,k+2)-f(i+2,j,k+2))) + + fyz = Fdydz*( (f(i,j-2,k-2)-F8*f(i,j-1,k-2)+F8*f(i,j+1,k-2)-f(i,j+2,k-2)) & + -F8 *(f(i,j-2,k-1)-F8*f(i,j-1,k-1)+F8*f(i,j+1,k-1)-f(i,j+2,k-1)) & + +F8 *(f(i,j-2,k+1)-F8*f(i,j-1,k+1)+F8*f(i,j+1,k+1)-f(i,j+2,k+1)) & + - (f(i,j-2,k+2)-F8*f(i,j-1,k+2)+F8*f(i,j+1,k+2)-f(i,j+2,k+2))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Fdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + fxx = ZEO + +! if inner point + if(i+2 <= imax .and. i-2 >= imin )then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx = Fdxdx*(-f(i-2,j,k)+F16*f(i-1,j,k)-F30*f(i,j,k) & + -f(i+2,j,k)+F16*f(i+1,j,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+2 <= imax .and. i-2 >= imin)then + fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + return + + end subroutine point_fddxx_sh + + subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydy,Fdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + fyy = ZEO + +! if inner point + if(j+2 <= jmax .and. j-2 >= jmin )then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + + fyy = Fdydy*(-f(i,j-2,k)+F16*f(i,j-1,k)-F30*f(i,j,k) & + -f(i,j+2,k)+F16*f(i,j+1,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fyy + if(j+2 <= jmax .and. j-2 >= jmin)then + + fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + return + + end subroutine point_fddyy_sh + + subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdzdz,Fdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + fzz = ZEO + +! if inner point + if( k+2 <= kmax .and. k-2 >= kmin )then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + + fzz = Fdzdz*(-f(i,j,k-2)+F16*f(i,j,k-1)-F30*f(i,j,k) & + -f(i,j,k+2)+F16*f(i,j,k+1) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fzz + if(k+2 <= kmax .and. k-2 >= kmin)then + + fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + return + + end subroutine point_fddzz_sh + + subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdy,Fdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + fxy = ZEO + +! if inner point + if(i+2 <= imax .and. i-2 >= imin & + .and. j+2 <= jmax .and. j-2 >= jmin )then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy = Fdxdy*( (f(i-2,j-2,k)-F8*f(i-1,j-2,k)+F8*f(i+1,j-2,k)-f(i+2,j-2,k)) & + -F8 *(f(i-2,j-1,k)-F8*f(i-1,j-1,k)+F8*f(i+1,j-1,k)-f(i+2,j-1,k)) & + +F8 *(f(i-2,j+1,k)-F8*f(i-1,j+1,k)+F8*f(i+1,j+1,k)-f(i+2,j+1,k)) & + - (f(i-2,j+2,k)-F8*f(i-1,j+2,k)+F8*f(i+1,j+2,k)-f(i+2,j+2,k))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fxy + if(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + return + + end subroutine point_fddxy_sh + + subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdz,Fdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + fxz = ZEO + +! if inner point + if(i+2 <= imax .and. i-2 >= imin & + .and. k+2 <= kmax .and. k-2 >= kmin )then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + + fxz = Fdxdz*( (f(i-2,j,k-2)-F8*f(i-1,j,k-2)+F8*f(i+1,j,k-2)-f(i+2,j,k-2)) & + -F8 *(f(i-2,j,k-1)-F8*f(i-1,j,k-1)+F8*f(i+1,j,k-1)-f(i+2,j,k-1)) & + +F8 *(f(i-2,j,k+1)-F8*f(i-1,j,k+1)+F8*f(i+1,j,k+1)-f(i+2,j,k+1)) & + - (f(i-2,j,k+2)-F8*f(i-1,j,k+2)+F8*f(i+1,j,k+2)-f(i+2,j,k+2))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fxz + if(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + return + + end subroutine point_fddxz_sh + + subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydz,Fdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + fyz = ZEO + +! if inner point + if(j+2 <= jmax .and. j-2 >= jmin & + .and. k+2 <= kmax .and. k-2 >= kmin )then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + + fyz = Fdydz*( (f(i,j-2,k-2)-F8*f(i,j-1,k-2)+F8*f(i,j+1,k-2)-f(i,j+2,k-2)) & + -F8 *(f(i,j-2,k-1)-F8*f(i,j-1,k-1)+F8*f(i,j+1,k-1)-f(i,j+2,k-1)) & + +F8 *(f(i,j-2,k+1)-F8*f(i,j-1,k+1)+F8*f(i,j+1,k+1)-f(i,j+2,k+1)) & + - (f(i,j-2,k+2)-F8*f(i,j-1,k+2)+F8*f(i,j+1,k+2)-f(i,j+2,k+2))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +!~~~~~~ fyz + if(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fddyz_sh + +#elif (ghost_width == 4) +! sixth order code + +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 6_th oder accurate +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + +! if inner point + if(i+3 <= imax .and. i-3 >= imin & + .and. j+3 <= jmax .and. j-3 >= jmin & + .and. k+3 <= kmax .and. k-3 >= kmin )then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx=d60dx*(-f(i-3,j,k)+F9*f(i-2,j,k)-F45*f(i-1,j,k)+F45*f(i+1,j,k)-F9*f(i+2,j,k)+f(i+3,j,k)) + + fy=d60dy*(-f(i,j-3,k)+F9*f(i,j-2,k)-F45*f(i,j-1,k)+F45*f(i,j+1,k)-F9*f(i,j+2,k)+f(i,j+3,k)) + + fz=d60dz*(-f(i,j,k-3)+F9*f(i,j,k-2)-F45*f(i,j,k-1)+F45*f(i,j,k+1)-F9*f(i,j,k+2)+f(i,j,k+3)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + +! if inner point + if(i+3 <= imax .and. i-3 >= imin )then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx=d60dx*(-f(i-3,j,k)+F9*f(i-2,j,k)-F45*f(i-1,j,k)+F45*f(i+1,j,k)-F9*f(i+2,j,k)+f(i+3,j,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +! x direction + if(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + return + + end subroutine point_fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + +! if inner point + if(j+3 <= jmax .and. j-3 >= jmin )then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + + fy=d60dy*(-f(i,j-3,k)+F9*f(i,j-2,k)-F45*f(i,j-1,k)+F45*f(i,j+1,k)-F9*f(i,j+2,k)+f(i,j+3,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +! y direction + if(j+3 <= jmax .and. j-3 >= jmin)then + + fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + return + + end subroutine point_fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1 + real*8, parameter :: TWO=2.d0,EIT=8.d0 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + +! if inner point + if( k+3 <= kmax .and. k-3 >= kmin )then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + + fz=d60dz*(-f(i,j,k-3)+F9*f(i,j,k-2)-F45*f(i,j,k-1)+F45*f(i,j,k+1)-F9*f(i,j,k+2)+f(i,j,k+3)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +! z direction + if(k+3 <= kmax .and. k-3 >= kmin)then + + fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 6_th oder accurate +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + +! if inner point + if(i+3 <= imax .and. i-3 >= imin & + .and. j+3 <= jmax .and. j-3 >= jmin & + .and. k+3 <= kmax .and. k-3 >= kmin )then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx = Xdxdx*(TWO*f(i-3,j,k)-F27*f(i-2,j,k)+F270*f(i-1,j,k)-F490*f(i,j,k) & + +TWO*f(i+3,j,k)-F27*f(i+2,j,k)+F270*f(i+1,j,k) ) + + fyy = Xdydy*(TWO*f(i,j-3,k)-F27*f(i,j-2,k)+F270*f(i,j-1,k)-F490*f(i,j,k) & + +TWO*f(i,j+3,k)-F27*f(i,j+2,k)+F270*f(i,j+1,k) ) + + fzz = Xdzdz*(TWO*f(i,j,k-3)-F27*f(i,j,k-2)+F270*f(i,j,k-1)-F490*f(i,j,k) & + +TWO*f(i,j,k+3)-F27*f(i,j,k+2)+F270*f(i,j,k+1) ) + +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy = Xdxdy*(- (-f(i-3,j-3,k)+F9*f(i-2,j-3,k)-F45*f(i-1,j-3,k)+F45*f(i+1,j-3,k)-F9*f(i+2,j-3,k)+f(i+3,j-3,k)) & + +F9 *(-f(i-3,j-2,k)+F9*f(i-2,j-2,k)-F45*f(i-1,j-2,k)+F45*f(i+1,j-2,k)-F9*f(i+2,j-2,k)+f(i+3,j-2,k)) & + -F45*(-f(i-3,j-1,k)+F9*f(i-2,j-1,k)-F45*f(i-1,j-1,k)+F45*f(i+1,j-1,k)-F9*f(i+2,j-1,k)+f(i+3,j-1,k)) & + +F45*(-f(i-3,j+1,k)+F9*f(i-2,j+1,k)-F45*f(i-1,j+1,k)+F45*f(i+1,j+1,k)-F9*f(i+2,j+1,k)+f(i+3,j+1,k)) & + -F9 *(-f(i-3,j+2,k)+F9*f(i-2,j+2,k)-F45*f(i-1,j+2,k)+F45*f(i+1,j+2,k)-F9*f(i+2,j+2,k)+f(i+3,j+2,k)) & + + (-f(i-3,j+3,k)+F9*f(i-2,j+3,k)-F45*f(i-1,j+3,k)+F45*f(i+1,j+3,k)-F9*f(i+2,j+3,k)+f(i+3,j+3,k))) + + fxz = Xdxdz*(- (-f(i-3,j,k-3)+F9*f(i-2,j,k-3)-F45*f(i-1,j,k-3)+F45*f(i+1,j,k-3)-F9*f(i+2,j,k-3)+f(i+3,j,k-3)) & + +F9 *(-f(i-3,j,k-2)+F9*f(i-2,j,k-2)-F45*f(i-1,j,k-2)+F45*f(i+1,j,k-2)-F9*f(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-f(i-3,j,k-1)+F9*f(i-2,j,k-1)-F45*f(i-1,j,k-1)+F45*f(i+1,j,k-1)-F9*f(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-f(i-3,j,k+1)+F9*f(i-2,j,k+1)-F45*f(i-1,j,k+1)+F45*f(i+1,j,k+1)-F9*f(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-f(i-3,j,k+2)+F9*f(i-2,j,k+2)-F45*f(i-1,j,k+2)+F45*f(i+1,j,k+2)-F9*f(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-f(i-3,j,k+3)+F9*f(i-2,j,k+3)-F45*f(i-1,j,k+3)+F45*f(i+1,j,k+3)-F9*f(i+2,j,k+3)+fh(i+3,j,k+3))) + + fyz = Xdydz*(- (-f(i,j-3,k-3)+F9*f(i,j-2,k-3)-F45*f(i,j-1,k-3)+F45*f(i,j+1,k-3)-F9*f(i,j+2,k-3)+f(i,j+3,k-3)) & + +F9 *(-f(i,j-3,k-2)+F9*f(i,j-2,k-2)-F45*f(i,j-1,k-2)+F45*f(i,j+1,k-2)-F9*f(i,j+2,k-2)+f(i,j+3,k-2)) & + -F45*(-f(i,j-3,k-1)+F9*f(i,j-2,k-1)-F45*f(i,j-1,k-1)+F45*f(i,j+1,k-1)-F9*f(i,j+2,k-1)+f(i,j+3,k-1)) & + +F45*(-f(i,j-3,k+1)+F9*f(i,j-2,k+1)-F45*f(i,j-1,k+1)+F45*f(i,j+1,k+1)-F9*f(i,j+2,k+1)+f(i,j+3,k+1)) & + -F9 *(-f(i,j-3,k+2)+F9*f(i,j-2,k+2)-F45*f(i,j-1,k+2)+F45*f(i,j+1,k+2)-F9*f(i,j+2,k+2)+f(i,j+3,k+2)) & + + (-f(i,j-3,k+3)+F9*f(i,j-2,k+3)-F45*f(i,j-1,k+3)+F45*f(i,j+1,k+3)-F9*f(i,j+2,k+3)+f(i,j+3,k+3))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Fdxdx,Xdxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + fxx = ZEO + +! if inner point + if(i+3 <= imax .and. i-3 >= imin )then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx = Xdxdx*(TWO*f(i-3,j,k)-F27*f(i-2,j,k)+F270*f(i-1,j,k)-F490*f(i,j,k) & + +TWO*f(i+3,j,k)-F27*f(i+2,j,k)+F270*f(i+1,j,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+3 <= imax .and. i-3 >= imin)then + fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + return + + end subroutine point_fddxx_sh + + subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydy,Fdydy,Xdydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + fyy = ZEO + +! if inner point + if(j+3 <= jmax .and. j-3 >= jmin )then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + + fyy = Xdydy*(TWO*f(i,j-3,k)-F27*f(i,j-2,k)+F270*f(i,j-1,k)-F490*f(i,j,k) & + +TWO*f(i,j+3,k)-F27*f(i,j+2,k)+F270*f(i,j+1,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fyy + if(j+3 <= jmax .and. j-3 >= jmin)then + + fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + return + + end subroutine point_fddyy_sh + + subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdzdz,Fdzdz,Xdzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + fzz = ZEO + +! if inner point + if( k+3 <= kmax .and. k-3 >= kmin )then +! +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + + fzz = Xdzdz*(TWO*f(i,j,k-3)-F27*f(i,j,k-2)+F270*f(i,j,k-1)-F490*f(i,j,k) & + +TWO*f(i,j,k+3)-F27*f(i,j,k+2)+F270*f(i,j,k+1) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fzz + if(k+3 <= kmax .and. k-3 >= kmin)then + + fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + return + + end subroutine point_fddzz_sh + + subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdy,Fdxdy,Xdxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + fxy = ZEO + +! if inner point + if(i+3 <= imax .and. i-3 >= imin & + .and. j+3 <= jmax .and. j-3 >= jmin )then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy = Xdxdy*(- (-f(i-3,j-3,k)+F9*f(i-2,j-3,k)-F45*f(i-1,j-3,k)+F45*f(i+1,j-3,k)-F9*f(i+2,j-3,k)+f(i+3,j-3,k)) & + +F9 *(-f(i-3,j-2,k)+F9*f(i-2,j-2,k)-F45*f(i-1,j-2,k)+F45*f(i+1,j-2,k)-F9*f(i+2,j-2,k)+f(i+3,j-2,k)) & + -F45*(-f(i-3,j-1,k)+F9*f(i-2,j-1,k)-F45*f(i-1,j-1,k)+F45*f(i+1,j-1,k)-F9*f(i+2,j-1,k)+f(i+3,j-1,k)) & + +F45*(-f(i-3,j+1,k)+F9*f(i-2,j+1,k)-F45*f(i-1,j+1,k)+F45*f(i+1,j+1,k)-F9*f(i+2,j+1,k)+f(i+3,j+1,k)) & + -F9 *(-f(i-3,j+2,k)+F9*f(i-2,j+2,k)-F45*f(i-1,j+2,k)+F45*f(i+1,j+2,k)-F9*f(i+2,j+2,k)+f(i+3,j+2,k)) & + + (-f(i-3,j+3,k)+F9*f(i-2,j+3,k)-F45*f(i-1,j+3,k)+F45*f(i+1,j+3,k)-F9*f(i+2,j+3,k)+f(i+3,j+3,k))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fxy + if(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + return + + end subroutine point_fddxy_sh + + subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdz,Fdxdz,Xdxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + fxz = ZEO + +! if inner point + if(i+3 <= imax .and. i-3 >= imin & + .and. k+3 <= kmax .and. k-3 >= kmin )then + +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + + fxz = Xdxdz*(- (-f(i-3,j,k-3)+F9*f(i-2,j,k-3)-F45*f(i-1,j,k-3)+F45*f(i+1,j,k-3)-F9*f(i+2,j,k-3)+f(i+3,j,k-3)) & + +F9 *(-f(i-3,j,k-2)+F9*f(i-2,j,k-2)-F45*f(i-1,j,k-2)+F45*f(i+1,j,k-2)-F9*f(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-f(i-3,j,k-1)+F9*f(i-2,j,k-1)-F45*f(i-1,j,k-1)+F45*f(i+1,j,k-1)-F9*f(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-f(i-3,j,k+1)+F9*f(i-2,j,k+1)-F45*f(i-1,j,k+1)+F45*f(i+1,j,k+1)-F9*f(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-f(i-3,j,k+2)+F9*f(i-2,j,k+2)-F45*f(i-1,j,k+2)+F45*f(i+1,j,k+2)-F9*f(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-f(i-3,j,k+3)+F9*f(i-2,j,k+3)-F45*f(i-1,j,k+3)+F45*f(i+1,j,k+3)-F9*f(i+2,j,k+3)+fh(i+3,j,k+3))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fxz + if(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + return + + end subroutine point_fddxz_sh + + subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydz,Fdydz,Xdydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + fyz = ZEO + +! if inner point + if(j+3 <= jmax .and. j-3 >= jmin & + .and. k+3 <= kmax .and. k-3 >= kmin )then + +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + + fyz = Xdydz*(- (-f(i,j-3,k-3)+F9*f(i,j-2,k-3)-F45*f(i,j-1,k-3)+F45*f(i,j+1,k-3)-F9*f(i,j+2,k-3)+f(i,j+3,k-3)) & + +F9 *(-f(i,j-3,k-2)+F9*f(i,j-2,k-2)-F45*f(i,j-1,k-2)+F45*f(i,j+1,k-2)-F9*f(i,j+2,k-2)+f(i,j+3,k-2)) & + -F45*(-f(i,j-3,k-1)+F9*f(i,j-2,k-1)-F45*f(i,j-1,k-1)+F45*f(i,j+1,k-1)-F9*f(i,j+2,k-1)+f(i,j+3,k-1)) & + +F45*(-f(i,j-3,k+1)+F9*f(i,j-2,k+1)-F45*f(i,j-1,k+1)+F45*f(i,j+1,k+1)-F9*f(i,j+2,k+1)+f(i,j+3,k+1)) & + -F9 *(-f(i,j-3,k+2)+F9*f(i,j-2,k+2)-F45*f(i,j-1,k+2)+F45*f(i,j+1,k+2)-F9*f(i,j+2,k+2)+f(i,j+3,k+2)) & + + (-f(i,j-3,k+3)+F9*f(i,j-2,k+3)-F45*f(i,j-1,k+3)+F45*f(i,j+1,k+3)-F9*f(i,j+2,k+3)+f(i,j+3,k+3))) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + +!~~~~~~ fyz + if(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fddyz_sh + +#elif (ghost_width == 5) +! eighth order code + +! PRD 77, 024034 (2008) +!----------------------------------------------------------------------------------------------------------------- +! +! General first derivatives of 8_th oder accurate +! +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx +! +!----------------------------------------------------------------------------------------------------------------- + + subroutine point_fderivs_sh(ex,f,fx,fy,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx,fy,fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d840dx,d840dy,d840dz + real*8 :: d60dx,d60dy,d60dz,d12dx,d12dy,d12dz,d2dx,d2dy,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d840dx = ONE/F840/dX + d840dy = ONE/F840/dY + d840dz = ONE/F840/dZ + + d60dx = ONE/F60/dX + d60dy = ONE/F60/dY + d60dz = ONE/F60/dZ + + d12dx = ONE/F12/dX + d12dy = ONE/F12/dY + d12dz = ONE/F12/dZ + + d2dx = ONE/TWO/dX + d2dy = ONE/TWO/dY + d2dz = ONE/TWO/dZ + + fx = ZEO + fy = ZEO + fz = ZEO + +! if inner point + if(i+4 <= imax .and. i-4 >= imin & + .and. j+4 <= jmax .and. j-4 >= jmin & + .and. k+4 <= kmax .and. k-4 >= kmin )then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx=d840dx*( THR*f(i-4,j,k)-F32 *f(i-3,j,k)+F168*f(i-2,j,k)-F672*f(i-1,j,k)+ & + F672*f(i+1,j,k)-F168*f(i+2,j,k)+F32 *f(i+3,j,k)-THR *f(i+4,j,k)) + + fy=d840dy*( THR*f(i,j-4,k)-F32 *f(i,j-3,k)+F168*f(i,j-2,k)-F672*f(i,j-1,k)+ & + F672*f(i,j+1,k)-F168*f(i,j+2,k)+F32 *f(i,j+3,k)-THR *f(i,j+4,k)) + + fz=d840dz*( THR*f(i,j,k-4)-F32 *f(i,j,k-3)+F168*f(i,j,k-2)-F672*f(i,j,k-1)+ & + F672*f(i,j,k+1)-F168*f(i,j,k+2)+F32 *f(i,j,k+3)-THR *f(i,j,k+4)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fderivs_sh +!----------------------------------------------------------------------------- +! +! single derivatives dx +! +!----------------------------------------------------------------------------- + subroutine point_fdx_sh(ex,f,fx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fx + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d840dx,d60dx,d12dx,d2dx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d840dx = ONE/F840/dX + + d60dx = ONE/F60/dX + + d12dx = ONE/F12/dX + + d2dx = ONE/TWO/dX + + fx = ZEO + +! if inner point + if(i+4 <= imax .and. i-4 >= imin )then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx=d840dx*( THR*f(i-4,j,k)-F32 *f(i-3,j,k)+F168*f(i-2,j,k)-F672*f(i-1,j,k)+ & + F672*f(i+1,j,k)-F168*f(i+2,j,k)+F32 *f(i+3,j,k)-THR *f(i+4,j,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +! x direction + if(i+4 <= imax .and. i-4 >= imin)then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + fx=d840dx*( THR*fh(i-4,j,k)-F32 *fh(i-3,j,k)+F168*fh(i-2,j,k)-F672*fh(i-1,j,k)+ & + F672*fh(i+1,j,k)-F168*fh(i+2,j,k)+F32 *fh(i+3,j,k)-THR *fh(i+4,j,k)) + + elseif(i+3 <= imax .and. i-3 >= imin)then +! +! - f(i-3) + 9 f(i-2) - 45 f(i-1) + 45 f(i+1) - 9 f(i+2) + f(i+3) +! fx(i) = ----------------------------------------------------------------- +! 60 dx + fx=d60dx*(-fh(i-3,j,k)+F9*fh(i-2,j,k)-F45*fh(i-1,j,k)+F45*fh(i+1,j,k)-F9*fh(i+2,j,k)+fh(i+3,j,k)) + + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! f(i-2) - 8 f(i-1) + 8 f(i+1) - f(i+2) +! fx(i) = --------------------------------------------- +! 12 dx + fx=d12dx*(fh(i-2,j,k)-EIT*fh(i-1,j,k)+EIT*fh(i+1,j,k)-fh(i+2,j,k)) + + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! - f(i-1) + f(i+1) +! fx(i) = -------------------------------- +! 2 dx + fx=d2dx*(-fh(i-1,j,k)+fh(i+1,j,k)) + +! set imax and imin 0 + endif + + return + + end subroutine point_fdx_sh +!----------------------------------------------------------------------------- +! +! single derivatives dy +! +!----------------------------------------------------------------------------- + subroutine point_fdy_sh(ex,f,fy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fy + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d840dy,d60dy,d12dy,d2dy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d840dy = ONE/F840/dY + + d60dy = ONE/F60/dY + + d12dy = ONE/F12/dY + + d2dy = ONE/TWO/dY + + fy = ZEO + +! if inner point + if(j+4 <= jmax .and. j-4 >= jmin )then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + + fy=d840dy*( THR*f(i,j-4,k)-F32 *f(i,j-3,k)+F168*f(i,j-2,k)-F672*f(i,j-1,k)+ & + F672*f(i,j+1,k)-F168*f(i,j+2,k)+F32 *f(i,j+3,k)-THR *f(i,j+4,k)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +! y direction + if(j+4 <= jmax .and. j-4 >= jmin)then + + fy=d840dy*( THR*fh(i,j-4,k)-F32 *fh(i,j-3,k)+F168*fh(i,j-2,k)-F672*fh(i,j-1,k)+ & + F672*fh(i,j+1,k)-F168*fh(i,j+2,k)+F32 *fh(i,j+3,k)-THR *fh(i,j+4,k)) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fy=d60dy*(-fh(i,j-3,k)+F9*fh(i,j-2,k)-F45*fh(i,j-1,k)+F45*fh(i,j+1,k)-F9*fh(i,j+2,k)+fh(i,j+3,k)) + + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fy=d12dy*(fh(i,j-2,k)-EIT*fh(i,j-1,k)+EIT*fh(i,j+1,k)-fh(i,j+2,k)) + + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fy=d2dy*(-fh(i,j-1,k)+fh(i,j+1,k)) + +! set jmax and jmin 0 + endif + + return + + end subroutine point_fdy_sh +!----------------------------------------------------------------------------- +! +! single derivatives dz +! +!----------------------------------------------------------------------------- + subroutine point_fdz_sh(ex,f,fz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: f + real*8, intent(out):: fz + real*8, intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, intent(in ):: SYM1,SYM2,SYM3 + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: d840dz,d60dz,d12dz,d2dz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0,ONE=1.d0, F60=6.d1, F32 = 3.2d1 + real*8, parameter :: TWO=2.d0,THR=3.d0, EIT=8.d0, F168=1.68d2 + real*8, parameter :: F9=9.d0,F45=4.5d1,F12=1.2d1,F672=6.72d2 + real*8, parameter :: F840=8.4d2 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + d840dz = ONE/F840/dZ + + d60dz = ONE/F60/dZ + + d12dz = ONE/F12/dZ + + d2dz = ONE/TWO/dZ + + fz = ZEO + +! if inner point + if( k+4 <= kmax .and. k-4 >= kmin )then +! 3 f(i-4) - 32 f(i-3) + 168 f(i-2) - 672 f(i-1) + 672 f(i+1) - 168 f(i+2) + 32 f(i+3) - 3 f(i+4) +! fx(i) = ------------------------------------------------------------------------------------------------- +! 840 dx + + fz=d840dz*( THR*f(i,j,k-4)-F32 *f(i,j,k-3)+F168*f(i,j,k-2)-F672*f(i,j,k-1)+ & + F672*f(i,j,k+1)-F168*f(i,j,k+2)+F32 *f(i,j,k+3)-THR *f(i,j,k+4)) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +! z direction + if(k+4 <= kmax .and. k-4 >= kmin)then + + fz=d840dz*( THR*fh(i,j,k-4)-F32 *fh(i,j,k-3)+F168*fh(i,j,k-2)-F672*fh(i,j,k-1)+ & + F672*fh(i,j,k+1)-F168*fh(i,j,k+2)+F32 *fh(i,j,k+3)-THR *fh(i,j,k+4)) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fz=d60dz*(-fh(i,j,k-3)+F9*fh(i,j,k-2)-F45*fh(i,j,k-1)+F45*fh(i,j,k+1)-F9*fh(i,j,k+2)+fh(i,j,k+3)) + + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fz=d12dz*(fh(i,j,k-2)-EIT*fh(i,j,k-1)+EIT*fh(i,j,k+1)-fh(i,j,k+2)) + + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fz=d2dz*(-fh(i,j,k-1)+fh(i,j,k+1)) + +! set kmax and kmin 0 + endif + + return + + end subroutine point_fdz_sh +!----------------------------------------------------------------------------------------------------------------- +! +! General second derivatives of 8_th oder accurate +! +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 +! +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy +! +!----------------------------------------------------------------------------------------------------------------- + subroutine point_fdderivs_sh(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM1,SYM2,SYM3,symmetry,onoff,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,onoff,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx,fxy,fxz,fyy,fyz,fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Sdydy,Sdzdz,Fdxdx,Fdydy,Fdzdz,Xdxdx,Xdydy,Xdzdz,Edxdx,Edydy,Edzdz + real*8 :: Sdxdy,Sdxdz,Sdydz,Fdxdy,Fdxdz,Fdydz,Xdxdy,Xdxdz,Xdydz,Edxdy,Edxdz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + Sdydy = ONE /( dY * dY ) + Sdzdz = ONE /( dZ * dZ ) + + Fdxdx = F1o12 /( dX * dX ) + Fdydy = F1o12 /( dY * dY ) + Fdzdz = F1o12 /( dZ * dZ ) + + Xdxdx = F1o180 /( dX * dX ) + Xdydy = F1o180 /( dY * dY ) + Xdzdz = F1o180 /( dZ * dZ ) + + Edxdx = F1o5040 /( dX * dX ) + Edydy = F1o5040 /( dY * dY ) + Edzdz = F1o5040 /( dZ * dZ ) + + Sdxdy = F1o4 /( dX * dY ) + Sdxdz = F1o4 /( dX * dZ ) + Sdydz = F1o4 /( dY * dZ ) + + Fdxdy = F1o144 /( dX * dY ) + Fdxdz = F1o144 /( dX * dZ ) + Fdydz = F1o144 /( dY * dZ ) + + Xdxdy = F1o3600 /( dX * dY ) + Xdxdz = F1o3600 /( dX * dZ ) + Xdydz = F1o3600 /( dY * dZ ) + + Edxdy = F1o705600 /( dX * dY ) + Edxdz = F1o705600 /( dX * dZ ) + Edydz = F1o705600 /( dY * dZ ) + + fxx = ZEO + fyy = ZEO + fzz = ZEO + fxy = ZEO + fxz = ZEO + fyz = ZEO + +! if inner point + if(i+4 <= imax .and. i-4 >= imin & + .and. j+4 <= jmax .and. j-4 >= jmin & + .and. k+4 <= kmax .and. k-4 >= kmin )then +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + fxx = Edxdx*(-F9*f(i-4,j,k)+F128*f(i-3,j,k)-F1008*f(i-2,j,k)+F8064*f(i-1,j,k)-F14350*f(i,j,k) & + -F9*f(i+4,j,k)+F128*f(i+3,j,k)-F1008*f(i+2,j,k)+F8064*f(i+1,j,k) ) + + fyy = Edydy*(-F9*f(i,j-4,k)+F128*f(i,j-3,k)-F1008*f(i,j-2,k)+F8064*f(i,j-1,k)-F14350*f(i,j,k) & + -F9*f(i,j+4,k)+F128*f(i,j+3,k)-F1008*f(i,j+2,k)+F8064*f(i,j+1,k) ) + + fzz = Edzdz*(-F9*f(i,j,k-4)+F128*f(i,j,k-3)-F1008*f(i,j,k-2)+F8064*f(i,j,k-1)-F14350*f(i,j,k) & + -F9*f(i,j,k+4)+F128*f(i,j,k+3)-F1008*f(i,j,k+2)+F8064*f(i,j,k+1) ) + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + fxy = Edxdy*( THR *( THR*f(i-4,j-4,k)-F32*f(i-3,j-4,k)+F168*f(i-2,j-4,k)-F672*f(i-1,j-4,k) & + -THR*f(i+4,j-4,k)+F32*f(i+3,j-4,k)-F168*f(i+2,j-4,k)+F672*f(i+1,j-4,k)) & + -F32 *( THR*f(i-4,j-3,k)-F32*f(i-3,j-3,k)+F168*f(i-2,j-3,k)-F672*f(i-1,j-3,k) & + -THR*f(i+4,j-3,k)+F32*f(i+3,j-3,k)-F168*f(i+2,j-3,k)+F672*f(i+1,j-3,k)) & + +F168*( THR*f(i-4,j-2,k)-F32*f(i-3,j-2,k)+F168*f(i-2,j-2,k)-F672*f(i-1,j-2,k) & + -THR*f(i+4,j-2,k)+F32*f(i+3,j-2,k)-F168*f(i+2,j-2,k)+F672*f(i+1,j-2,k)) & + -F672*( THR*f(i-4,j-1,k)-F32*f(i-3,j-1,k)+F168*f(i-2,j-1,k)-F672*f(i-1,j-1,k) & + -THR*f(i+4,j-1,k)+F32*f(i+3,j-1,k)-F168*f(i+2,j-1,k)+F672*f(i+1,j-1,k)) & + +F672*( THR*f(i-4,j+1,k)-F32*f(i-3,j+1,k)+F168*f(i-2,j+1,k)-F672*f(i-1,j+1,k) & + -THR*f(i+4,j+1,k)+F32*f(i+3,j+1,k)-F168*f(i+2,j+1,k)+F672*f(i+1,j+1,k)) & + -F168*( THR*f(i-4,j+2,k)-F32*f(i-3,j+2,k)+F168*f(i-2,j+2,k)-F672*f(i-1,j+2,k) & + -THR*f(i+4,j+2,k)+F32*f(i+3,j+2,k)-F168*f(i+2,j+2,k)+F672*f(i+1,j+2,k)) & + +F32 *( THR*f(i-4,j+3,k)-F32*f(i-3,j+3,k)+F168*f(i-2,j+3,k)-F672*f(i-1,j+3,k) & + -THR*f(i+4,j+3,k)+F32*f(i+3,j+3,k)-F168*f(i+2,j+3,k)+F672*f(i+1,j+3,k)) & + -THR *( THR*f(i-4,j+4,k)-F32*f(i-3,j+4,k)+F168*f(i-2,j+4,k)-F672*f(i-1,j+4,k) & + -THR*f(i+4,j+4,k)+F32*f(i+3,j+4,k)-F168*f(i+2,j+4,k)+F672*f(i+1,j+4,k)) ) + + fxz = Edxdz*( THR *( THR*f(i-4,j,k-4)-F32*f(i-3,j,k-4)+F168*f(i-2,j,k-4)-F672*f(i-1,j,k-4) & + -THR*f(i+4,j,k-4)+F32*f(i+3,j,k-4)-F168*f(i+2,j,k-4)+F672*f(i+1,j,k-4)) & + -F32 *( THR*f(i-4,j,k-3)-F32*f(i-3,j,k-3)+F168*f(i-2,j,k-3)-F672*f(i-1,j,k-3) & + -THR*f(i+4,j,k-3)+F32*f(i+3,j,k-3)-F168*f(i+2,j,k-3)+F672*f(i+1,j,k-3)) & + +F168*( THR*f(i-4,j,k-2)-F32*f(i-3,j,k-2)+F168*f(i-2,j,k-2)-F672*f(i-1,j,k-2) & + -THR*f(i+4,j,k-2)+F32*f(i+3,j,k-2)-F168*f(i+2,j,k-2)+F672*f(i+1,j,k-2)) & + -F672*( THR*f(i-4,j,k-1)-F32*f(i-3,j,k-1)+F168*f(i-2,j,k-1)-F672*f(i-1,j,k-1) & + -THR*f(i+4,j,k-1)+F32*f(i+3,j,k-1)-F168*f(i+2,j,k-1)+F672*f(i+1,j,k-1)) & + +F672*( THR*f(i-4,j,k+1)-F32*f(i-3,j,k+1)+F168*f(i-2,j,k+1)-F672*f(i-1,j,k+1) & + -THR*f(i+4,j,k+1)+F32*f(i+3,j,k+1)-F168*f(i+2,j,k+1)+F672*f(i+1,j,k+1)) & + -F168*( THR*f(i-4,j,k+2)-F32*f(i-3,j,k+2)+F168*f(i-2,j,k+2)-F672*f(i-1,j,k+2) & + -THR*f(i+4,j,k+2)+F32*f(i+3,j,k+2)-F168*f(i+2,j,k+2)+F672*f(i+1,j,k+2)) & + +F32 *( THR*f(i-4,j,k+3)-F32*f(i-3,j,k+3)+F168*f(i-2,j,k+3)-F672*f(i-1,j,k+3) & + -THR*f(i+4,j,k+3)+F32*f(i+3,j,k+3)-F168*f(i+2,j,k+3)+F672*f(i+1,j,k+3)) & + -THR *( THR*f(i-4,j,k+4)-F32*f(i-3,j,k+4)+F168*f(i-2,j,k+4)-F672*f(i-1,j,k+4) & + -THR*f(i+4,j,k+4)+F32*f(i+3,j,k+4)-F168*f(i+2,j,k+4)+F672*f(i+1,j,k+4)) ) + + fyz = Edydz*( THR *( THR*f(i,j-4,k-4)-F32*f(i,j-3,k-4)+F168*f(i,j-2,k-4)-F672*f(i,j-1,k-4) & + -THR*f(i,j+4,k-4)+F32*f(i,j+3,k-4)-F168*f(i,j+2,k-4)+F672*f(i,j+1,k-4)) & + -F32 *( THR*f(i,j-4,k-3)-F32*f(i,j-3,k-3)+F168*f(i,j-2,k-3)-F672*f(i,j-1,k-3) & + -THR*f(i,j+4,k-3)+F32*f(i,j+3,k-3)-F168*f(i,j+2,k-3)+F672*f(i,j+1,k-3)) & + +F168*( THR*f(i,j-4,k-2)-F32*f(i,j-3,k-2)+F168*f(i,j-2,k-2)-F672*f(i,j-1,k-2) & + -THR*f(i,j+4,k-2)+F32*f(i,j+3,k-2)-F168*f(i,j+2,k-2)+F672*f(i,j+1,k-2)) & + -F672*( THR*f(i,j-4,k-1)-F32*f(i,j-3,k-1)+F168*f(i,j-2,k-1)-F672*f(i,j-1,k-1) & + -THR*f(i,j+4,k-1)+F32*f(i,j+3,k-1)-F168*f(i,j+2,k-1)+F672*f(i,j+1,k-1)) & + +F672*( THR*f(i,j-4,k+1)-F32*f(i,j-3,k+1)+F168*f(i,j-2,k+1)-F672*f(i,j-1,k+1) & + -THR*f(i,j+4,k+1)+F32*f(i,j+3,k+1)-F168*f(i,j+2,k+1)+F672*f(i,j+1,k+1)) & + -F168*( THR*f(i,j-4,k+2)-F32*f(i,j-3,k+2)+F168*f(i,j-2,k+2)-F672*f(i,j-1,k+2) & + -THR*f(i,j+4,k+2)+F32*f(i,j+3,k+2)-F168*f(i,j+2,k+2)+F672*f(i,j+1,k+2)) & + +F32 *( THR*f(i,j-4,k+3)-F32*f(i,j-3,k+3)+F168*f(i,j-2,k+3)-F672*f(i,j-1,k+3) & + -THR*f(i,j+4,k+3)+F32*f(i,j+3,k+3)-F168*f(i,j+2,k+3)+F672*f(i,j+1,k+3)) & + -THR *( THR*f(i,j-4,k+4)-F32*f(i,j-3,k+4)+F168*f(i,j-2,k+4)-F672*f(i,j-1,k+4) & + -THR*f(i,j+4,k+4)+F32*f(i,j+3,k+4)-F168*f(i,j+2,k+4)+F672*f(i,j+1,k+4)) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + fxx = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + +! 2 f(i-3) - 27 f(i-2) + 270 f(i-1) - 490 f(i) + 270 f(i+1) - 27 f(i+2) + 2 f(i+3) +! fxx(i) = ----------------------------------------------------------------------------------- +! 180 dx^2 + fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then +! +! - f(i-2) + 16 f(i-1) - 30 f(i) + 16 f(i+1) - f(i+2) +! fxx(i) = ---------------------------------------------------------- +! 12 dx^2 + fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then +! +! f(i-1) - 2 f(i) + f(i+1) +! fxx(i) = -------------------------------- +! dx^2 + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + fxy = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then +! +! - ( - f(i-3,j-3) + 9 f(i-2,j-3) - 45 f(i-1,j-3) + 45 f(i+1,j-3) - 9 f(i+2,j-3) + f(i+3,j-3) ) +! + 9 ( - f(i-3,j-2) + 9 f(i-2,j-2) - 45 f(i-1,j-2) + 45 f(i+1,j-2) - 9 f(i+2,j-2) + f(i+3,j-2) ) +! - 45 ( - f(i-3,j-1) + 9 f(i-2,j-1) - 45 f(i-1,j-1) + 45 f(i+1,j-1) - 9 f(i+2,j-1) + f(i+3,j-1) ) +! + 45 ( - f(i-3,j+1) + 9 f(i-2,j+1) - 45 f(i-1,j+1) + 45 f(i+1,j+1) - 9 f(i+2,j+1) + f(i+3,j+1) ) +! - 9 ( - f(i-3,j+2) + 9 f(i-2,j+2) - 45 f(i-1,j+2) + 45 f(i+1,j+2) - 9 f(i+2,j+2) + f(i+3,j+2) ) +! + ( - f(i-3,j+3) + 9 f(i-2,j+3) - 45 f(i-1,j+3) + 45 f(i+1,j+3) - 9 f(i+2,j+3) + f(i+3,j+3) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------ +! 3600 dx dy + fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then +! +! ( f(i-2,j-2) - 8 f(i-1,j-2) + 8 f(i+1,j-2) - f(i+2,j-2) ) +! - 8 ( f(i-2,j-1) - 8 f(i-1,j-1) + 8 f(i+1,j-1) - f(i+2,j-1) ) +! + 8 ( f(i-2,j+1) - 8 f(i-1,j+1) + 8 f(i+1,j+1) - f(i+2,j+1) ) +! - ( f(i-2,j+2) - 8 f(i-1,j+2) + 8 f(i+1,j+2) - f(i+2,j+2) ) +! fxy(i,j) = ---------------------------------------------------------------- +! 144 dx dy + fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then +! f(i-1,j-1) - f(i+1,j-1) - f(i-1,j+1) + f(i+1,j+1) +! fxy(i,j) = ----------------------------------------------------------- +! 4 dx dy + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + !! enddo + !! enddo + !! enddo + + return + + end subroutine point_fdderivs_sh +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! only for compute_ricci.f90 usage +!----------------------------------------------------------------------------- + subroutine point_fddxx_sh(ex,f,fxx,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxx + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdx,Fdxdx,Xdxdx,Edxdx + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdx = ONE /( dX * dX ) + + Fdxdx = F1o12 /( dX * dX ) + + Xdxdx = F1o180 /( dX * dX ) + + Edxdx = F1o5040 /( dX * dX ) + + fxx = ZEO + +! if inner point + if(i+4 <= imax .and. i-4 >= imin )then +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + fxx = Edxdx*(-F9*f(i-4,j,k)+F128*f(i-3,j,k)-F1008*f(i-2,j,k)+F8064*f(i-1,j,k)-F14350*f(i,j,k) & + -F9*f(i+4,j,k)+F128*f(i+3,j,k)-F1008*f(i+2,j,k)+F8064*f(i+1,j,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fxx + if(i+4 <= imax .and. i-4 >= imin)then + + fxx = Edxdx*(-F9*fh(i-4,j,k)+F128*fh(i-3,j,k)-F1008*fh(i-2,j,k)+F8064*fh(i-1,j,k)-F14350*fh(i,j,k) & + -F9*fh(i+4,j,k)+F128*fh(i+3,j,k)-F1008*fh(i+2,j,k)+F8064*fh(i+1,j,k) ) + + elseif(i+3 <= imax .and. i-3 >= imin)then + fxx = Xdxdx*(TWO*fh(i-3,j,k)-F27*fh(i-2,j,k)+F270*fh(i-1,j,k)-F490*fh(i,j,k) & + +TWO*fh(i+3,j,k)-F27*fh(i+2,j,k)+F270*fh(i+1,j,k) ) + elseif(i+2 <= imax .and. i-2 >= imin)then + fxx = Fdxdx*(-fh(i-2,j,k)+F16*fh(i-1,j,k)-F30*fh(i,j,k) & + -fh(i+2,j,k)+F16*fh(i+1,j,k) ) + elseif(i+1 <= imax .and. i-1 >= imin)then + fxx = Sdxdx*(fh(i-1,j,k)-TWO*fh(i,j,k) & + +fh(i+1,j,k) ) + endif + + return + + end subroutine point_fddxx_sh + + subroutine point_fddyy_sh(ex,f,fyy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydy,Fdydy,Xdydy,Edydy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydy = ONE /( dY * dY ) + + Fdydy = F1o12 /( dY * dY ) + + Xdydy = F1o180 /( dY * dY ) + + Edydy = F1o5040 /( dY * dY ) + + fyy = ZEO + +! if inner point + if(j+4 <= jmax .and. j-4 >= jmin )then +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + + fyy = Edydy*(-F9*f(i,j-4,k)+F128*f(i,j-3,k)-F1008*f(i,j-2,k)+F8064*f(i,j-1,k)-F14350*f(i,j,k) & + -F9*f(i,j+4,k)+F128*f(i,j+3,k)-F1008*f(i,j+2,k)+F8064*f(i,j+1,k) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fyy + if(j+4 <= jmax .and. j-4 >= jmin)then + + fyy = Edydy*(-F9*fh(i,j-4,k)+F128*fh(i,j-3,k)-F1008*fh(i,j-2,k)+F8064*fh(i,j-1,k)-F14350*fh(i,j,k) & + -F9*fh(i,j+4,k)+F128*fh(i,j+3,k)-F1008*fh(i,j+2,k)+F8064*fh(i,j+1,k) ) + + elseif(j+3 <= jmax .and. j-3 >= jmin)then + + fyy = Xdydy*(TWO*fh(i,j-3,k)-F27*fh(i,j-2,k)+F270*fh(i,j-1,k)-F490*fh(i,j,k) & + +TWO*fh(i,j+3,k)-F27*fh(i,j+2,k)+F270*fh(i,j+1,k) ) + elseif(j+2 <= jmax .and. j-2 >= jmin)then + + fyy = Fdydy*(-fh(i,j-2,k)+F16*fh(i,j-1,k)-F30*fh(i,j,k) & + -fh(i,j+2,k)+F16*fh(i,j+1,k) ) + elseif(j+1 <= jmax .and. j-1 >= jmin)then + + fyy = Sdydy*(fh(i,j-1,k)-TWO*fh(i,j,k) & + +fh(i,j+1,k) ) + endif + + return + + end subroutine point_fddyy_sh + + subroutine point_fddzz_sh(ex,f,fzz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fzz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdzdz,Fdzdz,Xdzdz,Edzdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdzdz = ONE /( dZ * dZ ) + + Fdzdz = F1o12 /( dZ * dZ ) + + Xdzdz = F1o180 /( dZ * dZ ) + + Edzdz = F1o5040 /( dZ * dZ ) + + fzz = ZEO + +! if inner point + if( k+4 <= kmax .and. k-4 >= kmin )then +! - 9 f(i-4) + 128 f(i-3) - 1008 f(i-2) + 8064 f(i-1) - 14350 f(i) + 8064 f(i+1) - 1008 f(i+2) + 128 f(i+3) - 9 f(i+4) +! fxx(i) = ---------------------------------------------------------------------------------------------------------------------- +! 5040 dx^2 + + fzz = Edzdz*(-F9*f(i,j,k-4)+F128*f(i,j,k-3)-F1008*f(i,j,k-2)+F8064*f(i,j,k-1)-F14350*f(i,j,k) & + -F9*f(i,j,k+4)+F128*f(i,j,k+3)-F1008*f(i,j,k+2)+F8064*f(i,j,k+1) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fzz + if(k+4 <= kmax .and. k-4 >= kmin)then + + fzz = Edzdz*(-F9*fh(i,j,k-4)+F128*fh(i,j,k-3)-F1008*fh(i,j,k-2)+F8064*fh(i,j,k-1)-F14350*fh(i,j,k) & + -F9*fh(i,j,k+4)+F128*fh(i,j,k+3)-F1008*fh(i,j,k+2)+F8064*fh(i,j,k+1) ) + + elseif(k+3 <= kmax .and. k-3 >= kmin)then + + fzz = Xdzdz*(TWO*fh(i,j,k-3)-F27*fh(i,j,k-2)+F270*fh(i,j,k-1)-F490*fh(i,j,k) & + +TWO*fh(i,j,k+3)-F27*fh(i,j,k+2)+F270*fh(i,j,k+1) ) + elseif(k+2 <= kmax .and. k-2 >= kmin)then + + fzz = Fdzdz*(-fh(i,j,k-2)+F16*fh(i,j,k-1)-F30*fh(i,j,k) & + -fh(i,j,k+2)+F16*fh(i,j,k+1) ) + elseif(k+1 <= kmax .and. k-1 >= kmin)then + + fzz = Sdzdz*(fh(i,j,k-1)-TWO*fh(i,j,k) & + +fh(i,j,k+1) ) + endif + + return + + end subroutine point_fddzz_sh + + subroutine point_fddxy_sh(ex,f,fxy,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxy + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdy,Fdxdy,Xdxdy,Edxdy + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdy = F1o4 /( dX * dY ) + + Fdxdy = F1o144 /( dX * dY ) + + Xdxdy = F1o3600 /( dX * dY ) + + Edxdy = F1o705600 /( dX * dY ) + + fxy = ZEO + +! if inner point + if(i+4 <= imax .and. i-4 >= imin & + .and. j+4 <= jmax .and. j-4 >= jmin )then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + fxy = Edxdy*( THR *( THR*f(i-4,j-4,k)-F32*f(i-3,j-4,k)+F168*f(i-2,j-4,k)-F672*f(i-1,j-4,k) & + -THR*f(i+4,j-4,k)+F32*f(i+3,j-4,k)-F168*f(i+2,j-4,k)+F672*f(i+1,j-4,k)) & + -F32 *( THR*f(i-4,j-3,k)-F32*f(i-3,j-3,k)+F168*f(i-2,j-3,k)-F672*f(i-1,j-3,k) & + -THR*f(i+4,j-3,k)+F32*f(i+3,j-3,k)-F168*f(i+2,j-3,k)+F672*f(i+1,j-3,k)) & + +F168*( THR*f(i-4,j-2,k)-F32*f(i-3,j-2,k)+F168*f(i-2,j-2,k)-F672*f(i-1,j-2,k) & + -THR*f(i+4,j-2,k)+F32*f(i+3,j-2,k)-F168*f(i+2,j-2,k)+F672*f(i+1,j-2,k)) & + -F672*( THR*f(i-4,j-1,k)-F32*f(i-3,j-1,k)+F168*f(i-2,j-1,k)-F672*f(i-1,j-1,k) & + -THR*f(i+4,j-1,k)+F32*f(i+3,j-1,k)-F168*f(i+2,j-1,k)+F672*f(i+1,j-1,k)) & + +F672*( THR*f(i-4,j+1,k)-F32*f(i-3,j+1,k)+F168*f(i-2,j+1,k)-F672*f(i-1,j+1,k) & + -THR*f(i+4,j+1,k)+F32*f(i+3,j+1,k)-F168*f(i+2,j+1,k)+F672*f(i+1,j+1,k)) & + -F168*( THR*f(i-4,j+2,k)-F32*f(i-3,j+2,k)+F168*f(i-2,j+2,k)-F672*f(i-1,j+2,k) & + -THR*f(i+4,j+2,k)+F32*f(i+3,j+2,k)-F168*f(i+2,j+2,k)+F672*f(i+1,j+2,k)) & + +F32 *( THR*f(i-4,j+3,k)-F32*f(i-3,j+3,k)+F168*f(i-2,j+3,k)-F672*f(i-1,j+3,k) & + -THR*f(i+4,j+3,k)+F32*f(i+3,j+3,k)-F168*f(i+2,j+3,k)+F672*f(i+1,j+3,k)) & + -THR *( THR*f(i-4,j+4,k)-F32*f(i-3,j+4,k)+F168*f(i-2,j+4,k)-F672*f(i-1,j+4,k) & + -THR*f(i+4,j+4,k)+F32*f(i+3,j+4,k)-F168*f(i+2,j+4,k)+F672*f(i+1,j+4,k)) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fxy + if(i+4 <= imax .and. i-4 >= imin .and. j+4 <= jmax .and. j-4 >= jmin)then + + fxy = Edxdy*( THR *( THR*fh(i-4,j-4,k)-F32*fh(i-3,j-4,k)+F168*fh(i-2,j-4,k)-F672*fh(i-1,j-4,k) & + -THR*fh(i+4,j-4,k)+F32*fh(i+3,j-4,k)-F168*fh(i+2,j-4,k)+F672*fh(i+1,j-4,k)) & + -F32 *( THR*fh(i-4,j-3,k)-F32*fh(i-3,j-3,k)+F168*fh(i-2,j-3,k)-F672*fh(i-1,j-3,k) & + -THR*fh(i+4,j-3,k)+F32*fh(i+3,j-3,k)-F168*fh(i+2,j-3,k)+F672*fh(i+1,j-3,k)) & + +F168*( THR*fh(i-4,j-2,k)-F32*fh(i-3,j-2,k)+F168*fh(i-2,j-2,k)-F672*fh(i-1,j-2,k) & + -THR*fh(i+4,j-2,k)+F32*fh(i+3,j-2,k)-F168*fh(i+2,j-2,k)+F672*fh(i+1,j-2,k)) & + -F672*( THR*fh(i-4,j-1,k)-F32*fh(i-3,j-1,k)+F168*fh(i-2,j-1,k)-F672*fh(i-1,j-1,k) & + -THR*fh(i+4,j-1,k)+F32*fh(i+3,j-1,k)-F168*fh(i+2,j-1,k)+F672*fh(i+1,j-1,k)) & + +F672*( THR*fh(i-4,j+1,k)-F32*fh(i-3,j+1,k)+F168*fh(i-2,j+1,k)-F672*fh(i-1,j+1,k) & + -THR*fh(i+4,j+1,k)+F32*fh(i+3,j+1,k)-F168*fh(i+2,j+1,k)+F672*fh(i+1,j+1,k)) & + -F168*( THR*fh(i-4,j+2,k)-F32*fh(i-3,j+2,k)+F168*fh(i-2,j+2,k)-F672*fh(i-1,j+2,k) & + -THR*fh(i+4,j+2,k)+F32*fh(i+3,j+2,k)-F168*fh(i+2,j+2,k)+F672*fh(i+1,j+2,k)) & + +F32 *( THR*fh(i-4,j+3,k)-F32*fh(i-3,j+3,k)+F168*fh(i-2,j+3,k)-F672*fh(i-1,j+3,k) & + -THR*fh(i+4,j+3,k)+F32*fh(i+3,j+3,k)-F168*fh(i+2,j+3,k)+F672*fh(i+1,j+3,k)) & + -THR *( THR*fh(i-4,j+4,k)-F32*fh(i-3,j+4,k)+F168*fh(i-2,j+4,k)-F672*fh(i-1,j+4,k) & + -THR*fh(i+4,j+4,k)+F32*fh(i+3,j+4,k)-F168*fh(i+2,j+4,k)+F672*fh(i+1,j+4,k)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. j+3 <= jmax .and. j-3 >= jmin)then + + fxy = Xdxdy*(- (-fh(i-3,j-3,k)+F9*fh(i-2,j-3,k)-F45*fh(i-1,j-3,k)+F45*fh(i+1,j-3,k)-F9*fh(i+2,j-3,k)+fh(i+3,j-3,k)) & + +F9 *(-fh(i-3,j-2,k)+F9*fh(i-2,j-2,k)-F45*fh(i-1,j-2,k)+F45*fh(i+1,j-2,k)-F9*fh(i+2,j-2,k)+fh(i+3,j-2,k)) & + -F45*(-fh(i-3,j-1,k)+F9*fh(i-2,j-1,k)-F45*fh(i-1,j-1,k)+F45*fh(i+1,j-1,k)-F9*fh(i+2,j-1,k)+fh(i+3,j-1,k)) & + +F45*(-fh(i-3,j+1,k)+F9*fh(i-2,j+1,k)-F45*fh(i-1,j+1,k)+F45*fh(i+1,j+1,k)-F9*fh(i+2,j+1,k)+fh(i+3,j+1,k)) & + -F9 *(-fh(i-3,j+2,k)+F9*fh(i-2,j+2,k)-F45*fh(i-1,j+2,k)+F45*fh(i+1,j+2,k)-F9*fh(i+2,j+2,k)+fh(i+3,j+2,k)) & + + (-fh(i-3,j+3,k)+F9*fh(i-2,j+3,k)-F45*fh(i-1,j+3,k)+F45*fh(i+1,j+3,k)-F9*fh(i+2,j+3,k)+fh(i+3,j+3,k))) + elseif(i+2 <= imax .and. i-2 >= imin .and. j+2 <= jmax .and. j-2 >= jmin)then + + fxy = Fdxdy*( (fh(i-2,j-2,k)-F8*fh(i-1,j-2,k)+F8*fh(i+1,j-2,k)-fh(i+2,j-2,k)) & + -F8 *(fh(i-2,j-1,k)-F8*fh(i-1,j-1,k)+F8*fh(i+1,j-1,k)-fh(i+2,j-1,k)) & + +F8 *(fh(i-2,j+1,k)-F8*fh(i-1,j+1,k)+F8*fh(i+1,j+1,k)-fh(i+2,j+1,k)) & + - (fh(i-2,j+2,k)-F8*fh(i-1,j+2,k)+F8*fh(i+1,j+2,k)-fh(i+2,j+2,k))) + elseif(i+1 <= imax .and. i-1 >= imin .and. j+1 <= jmax .and. j-1 >= jmin)then + + fxy = Sdxdy*(fh(i-1,j-1,k)-fh(i+1,j-1,k)-fh(i-1,j+1,k)+fh(i+1,j+1,k)) + endif + + return + + end subroutine point_fddxy_sh + + subroutine point_fddxz_sh(ex,f,fxz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fxz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdxdz,Fdxdz,Xdxdz,Edxdz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdxdz = F1o4 /( dX * dZ ) + + Fdxdz = F1o144 /( dX * dZ ) + + Xdxdz = F1o3600 /( dX * dZ ) + + Edxdz = F1o705600 /( dX * dZ ) + + fxz = ZEO + +! if inner point + if(i+4 <= imax .and. i-4 >= imin & + .and. k+4 <= kmax .and. k-4 >= kmin )then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + + fxz = Edxdz*( THR *( THR*f(i-4,j,k-4)-F32*f(i-3,j,k-4)+F168*f(i-2,j,k-4)-F672*f(i-1,j,k-4) & + -THR*f(i+4,j,k-4)+F32*f(i+3,j,k-4)-F168*f(i+2,j,k-4)+F672*f(i+1,j,k-4)) & + -F32 *( THR*f(i-4,j,k-3)-F32*f(i-3,j,k-3)+F168*f(i-2,j,k-3)-F672*f(i-1,j,k-3) & + -THR*f(i+4,j,k-3)+F32*f(i+3,j,k-3)-F168*f(i+2,j,k-3)+F672*f(i+1,j,k-3)) & + +F168*( THR*f(i-4,j,k-2)-F32*f(i-3,j,k-2)+F168*f(i-2,j,k-2)-F672*f(i-1,j,k-2) & + -THR*f(i+4,j,k-2)+F32*f(i+3,j,k-2)-F168*f(i+2,j,k-2)+F672*f(i+1,j,k-2)) & + -F672*( THR*f(i-4,j,k-1)-F32*f(i-3,j,k-1)+F168*f(i-2,j,k-1)-F672*f(i-1,j,k-1) & + -THR*f(i+4,j,k-1)+F32*f(i+3,j,k-1)-F168*f(i+2,j,k-1)+F672*f(i+1,j,k-1)) & + +F672*( THR*f(i-4,j,k+1)-F32*f(i-3,j,k+1)+F168*f(i-2,j,k+1)-F672*f(i-1,j,k+1) & + -THR*f(i+4,j,k+1)+F32*f(i+3,j,k+1)-F168*f(i+2,j,k+1)+F672*f(i+1,j,k+1)) & + -F168*( THR*f(i-4,j,k+2)-F32*f(i-3,j,k+2)+F168*f(i-2,j,k+2)-F672*f(i-1,j,k+2) & + -THR*f(i+4,j,k+2)+F32*f(i+3,j,k+2)-F168*f(i+2,j,k+2)+F672*f(i+1,j,k+2)) & + +F32 *( THR*f(i-4,j,k+3)-F32*f(i-3,j,k+3)+F168*f(i-2,j,k+3)-F672*f(i-1,j,k+3) & + -THR*f(i+4,j,k+3)+F32*f(i+3,j,k+3)-F168*f(i+2,j,k+3)+F672*f(i+1,j,k+3)) & + -THR *( THR*f(i-4,j,k+4)-F32*f(i-3,j,k+4)+F168*f(i-2,j,k+4)-F672*f(i-1,j,k+4) & + -THR*f(i+4,j,k+4)+F32*f(i+3,j,k+4)-F168*f(i+2,j,k+4)+F672*f(i+1,j,k+4)) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fxz + if(i+4 <= imax .and. i-4 >= imin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fxz = Edxdz*( THR *( THR*fh(i-4,j,k-4)-F32*fh(i-3,j,k-4)+F168*fh(i-2,j,k-4)-F672*fh(i-1,j,k-4) & + -THR*fh(i+4,j,k-4)+F32*fh(i+3,j,k-4)-F168*fh(i+2,j,k-4)+F672*fh(i+1,j,k-4)) & + -F32 *( THR*fh(i-4,j,k-3)-F32*fh(i-3,j,k-3)+F168*fh(i-2,j,k-3)-F672*fh(i-1,j,k-3) & + -THR*fh(i+4,j,k-3)+F32*fh(i+3,j,k-3)-F168*fh(i+2,j,k-3)+F672*fh(i+1,j,k-3)) & + +F168*( THR*fh(i-4,j,k-2)-F32*fh(i-3,j,k-2)+F168*fh(i-2,j,k-2)-F672*fh(i-1,j,k-2) & + -THR*fh(i+4,j,k-2)+F32*fh(i+3,j,k-2)-F168*fh(i+2,j,k-2)+F672*fh(i+1,j,k-2)) & + -F672*( THR*fh(i-4,j,k-1)-F32*fh(i-3,j,k-1)+F168*fh(i-2,j,k-1)-F672*fh(i-1,j,k-1) & + -THR*fh(i+4,j,k-1)+F32*fh(i+3,j,k-1)-F168*fh(i+2,j,k-1)+F672*fh(i+1,j,k-1)) & + +F672*( THR*fh(i-4,j,k+1)-F32*fh(i-3,j,k+1)+F168*fh(i-2,j,k+1)-F672*fh(i-1,j,k+1) & + -THR*fh(i+4,j,k+1)+F32*fh(i+3,j,k+1)-F168*fh(i+2,j,k+1)+F672*fh(i+1,j,k+1)) & + -F168*( THR*fh(i-4,j,k+2)-F32*fh(i-3,j,k+2)+F168*fh(i-2,j,k+2)-F672*fh(i-1,j,k+2) & + -THR*fh(i+4,j,k+2)+F32*fh(i+3,j,k+2)-F168*fh(i+2,j,k+2)+F672*fh(i+1,j,k+2)) & + +F32 *( THR*fh(i-4,j,k+3)-F32*fh(i-3,j,k+3)+F168*fh(i-2,j,k+3)-F672*fh(i-1,j,k+3) & + -THR*fh(i+4,j,k+3)+F32*fh(i+3,j,k+3)-F168*fh(i+2,j,k+3)+F672*fh(i+1,j,k+3)) & + -THR *( THR*fh(i-4,j,k+4)-F32*fh(i-3,j,k+4)+F168*fh(i-2,j,k+4)-F672*fh(i-1,j,k+4) & + -THR*fh(i+4,j,k+4)+F32*fh(i+3,j,k+4)-F168*fh(i+2,j,k+4)+F672*fh(i+1,j,k+4)) ) + elseif(i+3 <= imax .and. i-3 >= imin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fxz = Xdxdz*(- (-fh(i-3,j,k-3)+F9*fh(i-2,j,k-3)-F45*fh(i-1,j,k-3)+F45*fh(i+1,j,k-3)-F9*fh(i+2,j,k-3)+fh(i+3,j,k-3)) & + +F9 *(-fh(i-3,j,k-2)+F9*fh(i-2,j,k-2)-F45*fh(i-1,j,k-2)+F45*fh(i+1,j,k-2)-F9*fh(i+2,j,k-2)+fh(i+3,j,k-2)) & + -F45*(-fh(i-3,j,k-1)+F9*fh(i-2,j,k-1)-F45*fh(i-1,j,k-1)+F45*fh(i+1,j,k-1)-F9*fh(i+2,j,k-1)+fh(i+3,j,k-1)) & + +F45*(-fh(i-3,j,k+1)+F9*fh(i-2,j,k+1)-F45*fh(i-1,j,k+1)+F45*fh(i+1,j,k+1)-F9*fh(i+2,j,k+1)+fh(i+3,j,k+1)) & + -F9 *(-fh(i-3,j,k+2)+F9*fh(i-2,j,k+2)-F45*fh(i-1,j,k+2)+F45*fh(i+1,j,k+2)-F9*fh(i+2,j,k+2)+fh(i+3,j,k+2)) & + + (-fh(i-3,j,k+3)+F9*fh(i-2,j,k+3)-F45*fh(i-1,j,k+3)+F45*fh(i+1,j,k+3)-F9*fh(i+2,j,k+3)+fh(i+3,j,k+3))) + elseif(i+2 <= imax .and. i-2 >= imin .and. k+2 <= kmax .and. k-2 >= kmin)then + fxz = Fdxdz*( (fh(i-2,j,k-2)-F8*fh(i-1,j,k-2)+F8*fh(i+1,j,k-2)-fh(i+2,j,k-2)) & + -F8 *(fh(i-2,j,k-1)-F8*fh(i-1,j,k-1)+F8*fh(i+1,j,k-1)-fh(i+2,j,k-1)) & + +F8 *(fh(i-2,j,k+1)-F8*fh(i-1,j,k+1)+F8*fh(i+1,j,k+1)-fh(i+2,j,k+1)) & + - (fh(i-2,j,k+2)-F8*fh(i-1,j,k+2)+F8*fh(i+1,j,k+2)-fh(i+2,j,k+2))) + elseif(i+1 <= imax .and. i-1 >= imin .and. k+1 <= kmax .and. k-1 >= kmin)then + fxz = Sdxdz*(fh(i-1,j,k-1)-fh(i+1,j,k-1)-fh(i-1,j,k+1)+fh(i+1,j,k+1)) + endif + + return + + end subroutine point_fddxz_sh + + subroutine point_fddyz_sh(ex,f,fyz,X,Y,Z,SYM1,SYM2,SYM3,symmetry,sst,i,j,k) + implicit none + + integer, intent(in ):: ex(1:3),symmetry,sst,i,j,k + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ):: f + real*8, intent(out):: fyz + real*8, intent(in ):: X(ex(1)),Y(ex(2)),Z(ex(3)),SYM1,SYM2,SYM3 + +!~~~~~~ other variables + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + real*8, dimension(2) :: SoA + integer :: imin,jmin,kmin,imax,jmax,kmax + real*8 :: Sdydz,Fdydz,Xdydz,Edydz + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: ZEO=0.d0, ONE=1.d0, TWO=2.d0, F1o4=2.5d-1, F9=9.d0, F45=4.5d1, F128=1.28d2 + real*8, parameter :: F8=8.d0, F16=1.6d1, F30=3.d1, F27=2.7d1, F270=2.7d2, F490=4.9d2,F1008=1.008d3 + real*8, parameter :: F8064=8.064d3,F14350=1.435d4,THR=3.d0,F32=3.2d1,F168=1.68d2,F672=6.72d2 + real*8, parameter :: F1o6=ONE/6.d0, F1o12=ONE/1.2d1, F1o144=ONE/1.44d2 + real*8, parameter :: F1o180=ONE/1.8d2,F1o3600=ONE/3.6d3 + real*8, parameter :: F1o5040=ONE/5.04d3,F1o705600=ONE/7.056d5 + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + Sdydz = F1o4 /( dY * dZ ) + + Fdydz = F1o144 /( dY * dZ ) + + Xdydz = F1o3600 /( dY * dZ ) + + Edydz = F1o705600 /( dY * dZ ) + + fyz = ZEO + +! if inner point + if(j+4 <= jmax .and. j-4 >= jmin & + .and. k+4 <= kmax .and. k-4 >= kmin )then + +! + 3 ( 3 f(i-4,j-4) - 32 f(i-3,j-4) + 168 f(i-2,j-4) - 672 f(i-1,j-4) + 672 f(i+1,j-4) - 168 f(i+2,j-4) + 32 f(i+3,j-4) - 3 f(i+4,j-4) ) +! - 32 ( 3 f(i-4,j-3) - 32 f(i-3,j-3) + 168 f(i-2,j-3) - 672 f(i-1,j-3) + 672 f(i+1,j-3) - 168 f(i+2,j-3) + 32 f(i+3,j-3) - 3 f(i+4,j-3) ) +! + 168 ( 3 f(i-4,j-2) - 32 f(i-3,j-2) + 168 f(i-2,j-2) - 672 f(i-1,j-2) + 672 f(i+1,j-2) - 168 f(i+2,j-2) + 32 f(i+3,j-2) - 3 f(i+4,j-2) ) +! - 672 ( 3 f(i-4,j-1) - 32 f(i-3,j-1) + 168 f(i-2,j-1) - 672 f(i-1,j-1) + 672 f(i+1,j-1) - 168 f(i+2,j-1) + 32 f(i+3,j-1) - 3 f(i+4,j-1) ) +! + 672 ( 3 f(i-4,j+1) - 32 f(i-3,j+1) + 168 f(i-2,j+1) - 672 f(i-1,j+1) + 672 f(i+1,j+1) - 168 f(i+2,j+1) + 32 f(i+3,j+1) - 3 f(i+4,j+1) ) +! - 168 ( 3 f(i-4,j+2) - 32 f(i-3,j+2) + 168 f(i-2,j+2) - 672 f(i-1,j+2) + 672 f(i+1,j+2) - 168 f(i+2,j+2) + 32 f(i+3,j+2) - 3 f(i+4,j+2) ) +! + 32 ( 3 f(i-4,j+3) - 32 f(i-3,j+3) + 168 f(i-2,j+3) - 672 f(i-1,j+3) + 672 f(i+1,j+3) - 168 f(i+2,j+3) + 32 f(i+3,j+3) - 3 f(i+4,j+3) ) +! - 3 ( 3 f(i-4,j+4) - 32 f(i-3,j+4) + 168 f(i-2,j+4) - 672 f(i-1,j+4) + 672 f(i+1,j+4) - 168 f(i+2,j+4) + 32 f(i+3,j+4) - 3 f(i+4,j+4) ) +! fxy(i,j) = ------------------------------------------------------------------------------------------------------------------------------------------ +! 705600 dx dy + + fyz = Edydz*( THR *( THR*f(i,j-4,k-4)-F32*f(i,j-3,k-4)+F168*f(i,j-2,k-4)-F672*f(i,j-1,k-4) & + -THR*f(i,j+4,k-4)+F32*f(i,j+3,k-4)-F168*f(i,j+2,k-4)+F672*f(i,j+1,k-4)) & + -F32 *( THR*f(i,j-4,k-3)-F32*f(i,j-3,k-3)+F168*f(i,j-2,k-3)-F672*f(i,j-1,k-3) & + -THR*f(i,j+4,k-3)+F32*f(i,j+3,k-3)-F168*f(i,j+2,k-3)+F672*f(i,j+1,k-3)) & + +F168*( THR*f(i,j-4,k-2)-F32*f(i,j-3,k-2)+F168*f(i,j-2,k-2)-F672*f(i,j-1,k-2) & + -THR*f(i,j+4,k-2)+F32*f(i,j+3,k-2)-F168*f(i,j+2,k-2)+F672*f(i,j+1,k-2)) & + -F672*( THR*f(i,j-4,k-1)-F32*f(i,j-3,k-1)+F168*f(i,j-2,k-1)-F672*f(i,j-1,k-1) & + -THR*f(i,j+4,k-1)+F32*f(i,j+3,k-1)-F168*f(i,j+2,k-1)+F672*f(i,j+1,k-1)) & + +F672*( THR*f(i,j-4,k+1)-F32*f(i,j-3,k+1)+F168*f(i,j-2,k+1)-F672*f(i,j-1,k+1) & + -THR*f(i,j+4,k+1)+F32*f(i,j+3,k+1)-F168*f(i,j+2,k+1)+F672*f(i,j+1,k+1)) & + -F168*( THR*f(i,j-4,k+2)-F32*f(i,j-3,k+2)+F168*f(i,j-2,k+2)-F672*f(i,j-1,k+2) & + -THR*f(i,j+4,k+2)+F32*f(i,j+3,k+2)-F168*f(i,j+2,k+2)+F672*f(i,j+1,k+2)) & + +F32 *( THR*f(i,j-4,k+3)-F32*f(i,j-3,k+3)+F168*f(i,j-2,k+3)-F672*f(i,j-1,k+3) & + -THR*f(i,j+4,k+3)+F32*f(i,j+3,k+3)-F168*f(i,j+2,k+3)+F672*f(i,j+1,k+3)) & + -THR *( THR*f(i,j-4,k+4)-F32*f(i,j-3,k+4)+F168*f(i,j-2,k+4)-F672*f(i,j-1,k+4) & + -THR*f(i,j+4,k+4)+F32*f(i,j+3,k+4)-F168*f(i,j+2,k+4)+F672*f(i,j+1,k+4)) ) + + return + endif + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA(1) = SYM1 + SoA(2) = SYM2 + elseif(sst==2.or.sst==3)then + SoA(1) = SYM2 + SoA(2) = SYM3 + elseif(sst==4.or.sst==5)then + SoA(1) = SYM1 + SoA(2) = SYM3 + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +!~~~~~~ fyz + if(j+4 <= jmax .and. j-4 >= jmin .and. k+4 <= kmax .and. k-4 >= kmin)then + + fyz = Edydz*( THR *( THR*fh(i,j-4,k-4)-F32*fh(i,j-3,k-4)+F168*fh(i,j-2,k-4)-F672*fh(i,j-1,k-4) & + -THR*fh(i,j+4,k-4)+F32*fh(i,j+3,k-4)-F168*fh(i,j+2,k-4)+F672*fh(i,j+1,k-4)) & + -F32 *( THR*fh(i,j-4,k-3)-F32*fh(i,j-3,k-3)+F168*fh(i,j-2,k-3)-F672*fh(i,j-1,k-3) & + -THR*fh(i,j+4,k-3)+F32*fh(i,j+3,k-3)-F168*fh(i,j+2,k-3)+F672*fh(i,j+1,k-3)) & + +F168*( THR*fh(i,j-4,k-2)-F32*fh(i,j-3,k-2)+F168*fh(i,j-2,k-2)-F672*fh(i,j-1,k-2) & + -THR*fh(i,j+4,k-2)+F32*fh(i,j+3,k-2)-F168*fh(i,j+2,k-2)+F672*fh(i,j+1,k-2)) & + -F672*( THR*fh(i,j-4,k-1)-F32*fh(i,j-3,k-1)+F168*fh(i,j-2,k-1)-F672*fh(i,j-1,k-1) & + -THR*fh(i,j+4,k-1)+F32*fh(i,j+3,k-1)-F168*fh(i,j+2,k-1)+F672*fh(i,j+1,k-1)) & + +F672*( THR*fh(i,j-4,k+1)-F32*fh(i,j-3,k+1)+F168*fh(i,j-2,k+1)-F672*fh(i,j-1,k+1) & + -THR*fh(i,j+4,k+1)+F32*fh(i,j+3,k+1)-F168*fh(i,j+2,k+1)+F672*fh(i,j+1,k+1)) & + -F168*( THR*fh(i,j-4,k+2)-F32*fh(i,j-3,k+2)+F168*fh(i,j-2,k+2)-F672*fh(i,j-1,k+2) & + -THR*fh(i,j+4,k+2)+F32*fh(i,j+3,k+2)-F168*fh(i,j+2,k+2)+F672*fh(i,j+1,k+2)) & + +F32 *( THR*fh(i,j-4,k+3)-F32*fh(i,j-3,k+3)+F168*fh(i,j-2,k+3)-F672*fh(i,j-1,k+3) & + -THR*fh(i,j+4,k+3)+F32*fh(i,j+3,k+3)-F168*fh(i,j+2,k+3)+F672*fh(i,j+1,k+3)) & + -THR *( THR*fh(i,j-4,k+4)-F32*fh(i,j-3,k+4)+F168*fh(i,j-2,k+4)-F672*fh(i,j-1,k+4) & + -THR*fh(i,j+4,k+4)+F32*fh(i,j+3,k+4)-F168*fh(i,j+2,k+4)+F672*fh(i,j+1,k+4)) ) + elseif(j+3 <= jmax .and. j-3 >= jmin .and. k+3 <= kmax .and. k-3 >= kmin)then + + fyz = Xdydz*(- (-fh(i,j-3,k-3)+F9*fh(i,j-2,k-3)-F45*fh(i,j-1,k-3)+F45*fh(i,j+1,k-3)-F9*fh(i,j+2,k-3)+fh(i,j+3,k-3)) & + +F9 *(-fh(i,j-3,k-2)+F9*fh(i,j-2,k-2)-F45*fh(i,j-1,k-2)+F45*fh(i,j+1,k-2)-F9*fh(i,j+2,k-2)+fh(i,j+3,k-2)) & + -F45*(-fh(i,j-3,k-1)+F9*fh(i,j-2,k-1)-F45*fh(i,j-1,k-1)+F45*fh(i,j+1,k-1)-F9*fh(i,j+2,k-1)+fh(i,j+3,k-1)) & + +F45*(-fh(i,j-3,k+1)+F9*fh(i,j-2,k+1)-F45*fh(i,j-1,k+1)+F45*fh(i,j+1,k+1)-F9*fh(i,j+2,k+1)+fh(i,j+3,k+1)) & + -F9 *(-fh(i,j-3,k+2)+F9*fh(i,j-2,k+2)-F45*fh(i,j-1,k+2)+F45*fh(i,j+1,k+2)-F9*fh(i,j+2,k+2)+fh(i,j+3,k+2)) & + + (-fh(i,j-3,k+3)+F9*fh(i,j-2,k+3)-F45*fh(i,j-1,k+3)+F45*fh(i,j+1,k+3)-F9*fh(i,j+2,k+3)+fh(i,j+3,k+3))) + elseif(j+2 <= jmax .and. j-2 >= jmin .and. k+2 <= kmax .and. k-2 >= kmin)then + fyz = Fdydz*( (fh(i,j-2,k-2)-F8*fh(i,j-1,k-2)+F8*fh(i,j+1,k-2)-fh(i,j+2,k-2)) & + -F8 *(fh(i,j-2,k-1)-F8*fh(i,j-1,k-1)+F8*fh(i,j+1,k-1)-fh(i,j+2,k-1)) & + +F8 *(fh(i,j-2,k+1)-F8*fh(i,j-1,k+1)+F8*fh(i,j+1,k+1)-fh(i,j+2,k+1)) & + - (fh(i,j-2,k+2)-F8*fh(i,j-1,k+2)+F8*fh(i,j+1,k+2)-fh(i,j+2,k+2))) + elseif(j+1 <= jmax .and. j-1 >= jmin .and. k+1 <= kmax .and. k-1 >= kmin)then + fyz = Sdydz*(fh(i,j-1,k-1)-fh(i,j+1,k-1)-fh(i,j-1,k+1)+fh(i,j+1,k+1)) + endif + + return + + end subroutine point_fddyz_sh + +#endif + +!common code for different finite difference order +subroutine point_fderivs_shc(ex,f,fx,fy,fz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + + implicit none + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,i,j,k + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,intent(in ):: SYM1,SYM2,SYM3 + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(out) :: fx,fy,fz + +#if 0 + double precision,dimension(ex(1),ex(2),ex(3))::gx,gy,gz + call fderivs_shc(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + fx = gx(i,j,k) + fy = gy(i,j,k) + fz = gz(i,j,k) + +#else + double precision :: gx,gy,gz + + call point_fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst,i,j,k) + + fx = dRdx(i,j,k)*gz+drhodx(i,j,k)*gx+dsigmadx(i,j,k)*gy + fy = dRdy(i,j,k)*gz+drhody(i,j,k)*gx+dsigmady(i,j,k)*gy + fz = dRdz(i,j,k)*gz+drhodz(i,j,k)*gx+dsigmadz(i,j,k)*gy +#endif + + return + +end subroutine point_fderivs_shc + +subroutine point_fdderivs_shc(ex,f,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + + implicit none + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,i,j,k + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,intent(in ):: SYM1,SYM2,SYM3 + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double precision,intent(out) :: fxx,fxy,fxz,fyy,fyz,fzz + real*8,parameter :: TWO = 2.d0 + +#if 0 + double precision,dimension(ex(1),ex(2),ex(3))::gxx,gxy,gxz,gyy,gyz,gzz + + call fdderivs_shc(ex,f,gxx,gxy,gxz,gyy,gyz,gzz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = gxx(i,j,k) + fyy = gyy(i,j,k) + fzz = gzz(i,j,k) + fxy = gxy(i,j,k) + fxz = gxz(i,j,k) + fyz = gyz(i,j,k) + +#else + double precision :: gx,gy,gz,gxx,gxy,gxz,gyy,gyz,gzz + + call point_fderivs_sh(ex,f,gx,gy,gz,crho,sigma,R,SYM1, SYM2,SYM3,Symmetry,Lev,sst,i,j,k) + call point_fdderivs_sh(ex,f,gxx,gxy,gxz,gyy,gyz,gzz,crho,sigma,R,SYM1,SYM2,SYM3,Symmetry,Lev,sst,i,j,k) + + fxx = dRdxx(i,j,k)*gz+drhodxx(i,j,k)*gx+dsigmadxx(i,j,k)*gy + & + dRdx(i,j,k)*dRdx(i,j,k)*gzz+drhodx(i,j,k)*drhodx(i,j,k)*gxx+dsigmadx(i,j,k)*dsigmadx(i,j,k)*gyy + & + TWO*(dRdx(i,j,k)*drhodx(i,j,k)*gxz+dRdx(i,j,k)*dsigmadx(i,j,k)*gyz+drhodx(i,j,k)*dsigmadx(i,j,k)*gxy) + fyy = dRdyy(i,j,k)*gz+drhodyy(i,j,k)*gx+dsigmadyy(i,j,k)*gy + & + dRdy(i,j,k)*dRdy(i,j,k)*gzz+drhody(i,j,k)*drhody(i,j,k)*gxx+dsigmady(i,j,k)*dsigmady(i,j,k)*gyy + & + TWO*(dRdy(i,j,k)*drhody(i,j,k)*gxz+dRdy(i,j,k)*dsigmady(i,j,k)*gyz+drhody(i,j,k)*dsigmady(i,j,k)*gxy) + fzz = dRdzz(i,j,k)*gz+drhodzz(i,j,k)*gx+dsigmadzz(i,j,k)*gy + & + dRdz(i,j,k)*dRdz(i,j,k)*gzz+drhodz(i,j,k)*drhodz(i,j,k)*gxx+dsigmadz(i,j,k)*dsigmadz(i,j,k)*gyy + & + TWO*(dRdz(i,j,k)*drhodz(i,j,k)*gxz+dRdz(i,j,k)*dsigmadz(i,j,k)*gyz+drhodz(i,j,k)*dsigmadz(i,j,k)*gxy) + fxy = dRdxy(i,j,k)*gz+drhodxy(i,j,k)*gx+dsigmadxy(i,j,k)*gy + & + dRdx(i,j,k)*drhody(i,j,k)*gxz+dRdx(i,j,k)*dsigmady(i,j,k)*gyz+drhodx(i,j,k)*dsigmady(i,j,k)*gxy + & + dRdy(i,j,k)*drhodx(i,j,k)*gxz+dRdy(i,j,k)*dsigmadx(i,j,k)*gyz+drhody(i,j,k)*dsigmadx(i,j,k)*gxy + & + dRdx(i,j,k)*dRdy(i,j,k)*gzz+drhodx(i,j,k)*drhody(i,j,k)*gxx+dsigmadx(i,j,k)*dsigmady(i,j,k)*gyy + fxz = dRdxz(i,j,k)*gz+drhodxz(i,j,k)*gx+dsigmadxz(i,j,k)*gy + & + dRdx(i,j,k)*drhodz(i,j,k)*gxz+dRdx(i,j,k)*dsigmadz(i,j,k)*gyz+drhodx(i,j,k)*dsigmadz(i,j,k)*gxy + & + dRdz(i,j,k)*drhodx(i,j,k)*gxz+dRdz(i,j,k)*dsigmadx(i,j,k)*gyz+drhodz(i,j,k)*dsigmadx(i,j,k)*gxy + & + dRdx(i,j,k)*dRdz(i,j,k)*gzz+drhodx(i,j,k)*drhodz(i,j,k)*gxx+dsigmadx(i,j,k)*dsigmadz(i,j,k)*gyy + fyz = dRdyz(i,j,k)*gz+drhodyz(i,j,k)*gx+dsigmadyz(i,j,k)*gy + & + dRdz(i,j,k)*drhody(i,j,k)*gxz+dRdz(i,j,k)*dsigmady(i,j,k)*gyz+drhodz(i,j,k)*dsigmady(i,j,k)*gxy + & + dRdy(i,j,k)*drhodz(i,j,k)*gxz+dRdy(i,j,k)*dsigmadz(i,j,k)*gyz+drhody(i,j,k)*dsigmadz(i,j,k)*gxy + & + dRdz(i,j,k)*dRdy(i,j,k)*gzz+drhodz(i,j,k)*drhody(i,j,k)*gxx+dsigmadz(i,j,k)*dsigmady(i,j,k)*gyy +#endif + + return + +end subroutine point_fdderivs_shc diff --git a/AMSS_NCKU_source/Ansorg.C b/AMSS_NCKU_source/Initial_Data_Solver/Ansorg.C similarity index 95% rename from AMSS_NCKU_source/Ansorg.C rename to AMSS_NCKU_source/Initial_Data_Solver/Ansorg.C index e95776b..ffe372c 100644 --- a/AMSS_NCKU_source/Ansorg.C +++ b/AMSS_NCKU_source/Initial_Data_Solver/Ansorg.C @@ -1,690 +1,690 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include "Ansorg.h" -#include -/* read spectral data from file - special: pad phi direction with ghosts for periodic interpolation - order = 4: (-2 -1) 0 ... n-1 (n n+1) -*/ -Ansorg::Ansorg(char *filename, int orderi) : pu_ps(0), coordA(0), coordB(0), coordphi(0) -{ - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - order = orderi / 2 * 2; // order must be even - PIh = PI / 2.0; - char s[1000], *t; - FILE *fp; - double *v; - int nghosts; - int i; - - double x1, y1, z1, x2, y2, z2, dx, dy; - - /* open file */ - fp = fopen(filename, "r"); - if (myrank == 0 && !fp) - { - cout << "could not open " << filename << " for reading Ansorg" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (myrank == 0) - printf(" reading data from %s\n", filename); - - /* skip to line starting with data, extract size info */ - n1 = n2 = n3 = ntotal = -1; - while (fgets(s, 1000, fp)) - { - t = strstr(s, "bhx1 "); - if (t == s) - sscanf(s + 15, "%lf", &x1); - t = strstr(s, "bhy1 "); - if (t == s) - sscanf(s + 15, "%lf", &y1); - t = strstr(s, "bhz1 "); - if (t == s) - sscanf(s + 15, "%lf", &z1); - t = strstr(s, "bhx2 "); - if (t == s) - sscanf(s + 15, "%lf", &x2); - t = strstr(s, "bhy2 "); - if (t == s) - sscanf(s + 15, "%lf", &y2); - t = strstr(s, "bhz2 "); - if (t == s) - sscanf(s + 15, "%lf", &z2); - - t = strstr(s, "data "); - if (t != s) - continue; - sscanf(s + 5, "%d%d%d", &n1, &n2, &n3); - ntotal = n1 * n2 * n3; - if (myrank == 0) - printf(" found data with dimensions %d x %d x %d = %d\n", - n1, n2, n3, ntotal); - break; - } - - if (myrank == 0) - cout << " bhx1 = " << x1 << endl - << " bhy1 = " << y1 << endl - << " bhz1 = " << z1 << endl - << " bhx2 = " << x2 << endl - << " bhy2 = " << y2 << endl - << " bhz2 = " << z2 << endl; - - dx = x1 - x2; - dy = y1 - y2; - - /* x-axis */ - if (dx != 0 && y1 == 0 && y2 == 0 && z1 == 0 && z2 == 0) - { - ps_b = dx / 2; - ps_dx = (x1 + x2) / 2; - ps_rxx = 1; - ps_rxy = 0; - ps_ryx = 0; - ps_ryy = 1; - } - - /* y-axis */ - else if (dy != 0 && x1 == 0 && x2 == 0 && z1 == 0 && z2 == 0) - { - ps_b = dy / 2; - ps_dx = (y1 + y2) / 2; - ps_rxx = 0; - ps_rxy = +1; - ps_ryx = -1; - ps_ryy = 0; - } - - /* else */ - else if (myrank == 0) - { - cout << "puncture location not allowed" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (ntotal == -1 && myrank == 0) - { - cout << "file does not contain the expected data" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - /* get storage if needed */ - int pad = order / 2; - nghosts = n1 * n2 * pad; - if (!(pu_ps)) - pu_ps = new double[ntotal + 2 * nghosts]; - v = pu_ps + nghosts; - - /* read data */ - i = 0; - while (fgets(s, 1000, fp)) - { - if (i < ntotal) - v[i] = atof(t); - i++; - } - if (myrank == 0) - { - printf(" read %d data lines\n", i); - cout << endl; - } - if (myrank == 0 && i < ntotal) - { - cout << "file contains too few data lines" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (myrank == 0 && i > ntotal) - { - cout << "file contains too many data lines" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - /* copy data into ghosts */ - for (i = 0; i < nghosts; i++) - { - (pu_ps)[i] = v[i + ntotal - nghosts]; - (pu_ps)[i + ntotal + nghosts] = v[i]; - } - - if (0) - for (i = 0; i < ntotal + 2 * nghosts; i++) - printf("yoyo %10d %.16e\n", i - nghosts, (pu_ps)[i]); - - /* done */ - fclose(fp); - - set_ABp(); - - if (0) - { - if (myrank == 0) - { - cout << ps_u_at_xyz(0.015625, -4.578125, 0.015625) << endl; - cout << ps_u_at_xyz(0.046875, -4.578125, 0.015625) << endl; - cout << ps_u_at_xyz(0.078125, -4.578125, 0.015625) << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else - for (int i = 0;; i++) - ; - } -} -Ansorg::~Ansorg() -{ - if (coordA) - delete[] coordA; - if (coordB) - delete[] coordB; - if (coordphi) - delete[] coordphi; - if (pu_ps) - delete[] pu_ps; -} -/* interpolate to point given in Cartesian coordinates - calls function in utility/interpolation/barycentric.c -*/ -double Ansorg::ps_u_at_xyz(double x, double y, double z) -{ - double A, B, phi, u, U; - /* - // rotate THETA along clockwise direction - #define THETA (PI*0.25) - A = x; - B = y; - x = A*cos(THETA)+B*sin(THETA); - y =-A*sin(THETA)+B*cos(THETA); - */ - xyz_to_ABp(x, y, z, &A, &B, &phi); - if (0) - printf("x %f y %f z %f phi %f %.1f\n", x, y, z, phi, 180 * phi / PI); - if (0) - printf("A %f B %f phi %f\n", A, B, phi); - - U = interpolate_tri_bar(A, B, phi, n1, n2, n3 + (order / 2) * 2, - coordA, coordB, coordphi, pu_ps); - u = 2 * (A - 1) * U; - if (U > 0.025) - cout << x << "," << y << "," << z << "," << A << "," << B << "," << phi << "," << U << "," << u << endl; - if (!finite(u)) - { - cout << "find NaN in Ansorg::ps_u_at_xyz at (" << x << "," << y << "," << z << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - return u; -} -/* set 1d arrays for spectral coordinates - see Punctures_functions.c for reference - special: pad phi direction with ghosts for periodicity -*/ -void Ansorg::set_ABp() -{ - int pad = order / 2; - int i; - double Acode; - int pr = 0; - - coordA = new double[n1]; - coordB = new double[n2]; - coordphi = new double[n3 + 2 * pad]; - - for (i = 0; i < n1; i++) - { - Acode = -cos(PIh * (2 * i + 1) / n1); - coordA[i] = (Acode + 1) / 2; - if (pr && myrank == 0) - printf("coordA[%2d] = %f\n", i, coordA[i]); - } - - for (i = 0; i < n2; i++) - { - coordB[i] = -cos(PIh * (2 * i + 1) / n2); - if (pr && myrank == 0) - printf("coordB[%2d] = %f\n", i, coordB[i]); - } - - for (i = 0; i < n3 + 2 * pad; i++) - { - coordphi[i] = 2 * PI * (i - pad) / n3; - if (pr && myrank == 0) - printf("coordphi[%2d] = %f %f\n", - i, coordphi[i], coordphi[i] * 180 / PI); - } -} -/* from cartesian to spectral - see coordtrans.m etc - The problem is that the inverse transformation requires several - nested square roots with 8 possible solutions, only one of them relevant. - We have picked the correct solution by testing in Mathematica. - Furthermore, there are special coordinates where the formulas have - to be specialized. - - fixme: needs proper treatment of quantities that are almost zero/singular -*/ -#if 0 -void Ansorg::xyz_to_ABp(double x, double y, double z, - double *A, double *B, double *phi) -{ - const double s2 = sqrt(2.0); - double r, rr, xx; - double t, st, u, su, v, sv, w, sw; - - /* rotate onto x-axis if required */ - w = x; - x = ps_rxx * w + ps_rxy * y; - y = ps_ryx * w + ps_ryy * y; - - /* center black holes at +b and -b */ - x -= ps_dx; - - /* offset parameter b rescales the coordinates */ - x /= ps_b; - y /= ps_b; - z /= ps_b; - - /* helpers */ - r = sqrt(y*y + z*z); - rr = r*r; - xx = x*x; - - - /* phi as in cylindrical coordinates about x-axis - acos covers [0,pi], we need [0,2pi) - */ - if (r>0.0) - *phi = (z < 0.0) ? 2*PI - acos(y/r) : acos(y/r); - else - *phi = 0; - - - /* r > 0 */ - if (r>0.0) { - - /* x != 0, r > 0 */ - if (x != 0.0) { - - t = (1+rr)*(1+rr) + 2*(-1 + rr)*xx + xx*xx; - st = sqrt(t); - u = 1 - xx + rr*(2 + rr + xx + st) + st; - su = sqrt(u); - v = 1 + rr*rr - xx + rr*(2 + xx + st) + st; - sv = sqrt(v); - w = 1 + rr - s2*su + st; - sw = sqrt(w); - - *A = (2*sw*(1 + rr + st - xx) + s2*sv*(-1 - rr + 2*sw + st - xx)) - /(4.*r*xx); - - *B = -(sw/x); - } - - /* x == 0, r > 0 */ - else { - *A = (sqrt(1+rr) - 1)/r; - *B = 0; - } - } - - /* r == 0 */ - else { - - /* x > 1, r == 0 */ - if (x>1.0) { - *A = sqrt(x-1)/sqrt(x+1); - *B = -1; - } - - /* x < -1, r == 0 */ - else if (x<-1.0) { - *A = sqrt(-x-1)/sqrt(-x+1); - *B = +1; - } - - /* -1 <= x <= 1, r == 0 */ - else { - *A = 0; - - /* x != 0 */ - if (x != 0.0) - *B = (sqrt(1-xx) - 1)/x; - - /* x == 0 */ - else - *B = 0; - } - } - if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) {*A = 1; *B = 0;} -if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1 || (*phi)<0 || (*phi)>2*PI){ - cout<<"find ("<<*A<<","<<*B<<","<<*phi<<") in Ansorg::xyz_to_ABp at ("<0) - *phi = (z<0) ? 2*PI - acos(y/r) : acos(y/r); - else - *phi = 0; - - /* r > 0 */ - { - - /* x != 0, r > 0 */ - { - t = (1+rr)*(1+rr) + 2*(-1 + rr)*xx + xx*xx; - st = sqrt(t); - u = rr*(2 + rr + xx + st) + st + 1.0 - xx; - su = sqrt(u); - v = rr*rr + rr*(2 + xx + st) + st + 1.0 - xx; - sv = sqrt(v); - w = rr - s2*su + st + 1.0; - sw = sqrt(w); - - *A = (2*sw*(rr + st + 1 - xx) + s2*sv*(st - rr - 1 + 2*sw - xx)) - /(4.*r*xx); - - *B = -(sw/x); - } - /* x == 0, r > 0 */ - if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) - { - *A = (sqrt(1 + rr) - 1)/r + ((sqrt(1 + rr) - 1)*xx)/(2*r*pow((1 + rr),exp)); - - *B = -x/(2*sqrt(1 + rr)); - } - } - - /* r == 0 */ - if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) - { - - /* x > 1, r == 0 */ - if (x>1) { - *A = sqrt(x-1)/sqrt(x+1); - *B = -1; - } - - /* x < -1, r == 0 */ - else if (x<-1) { - *A = sqrt(-x-1)/sqrt(-x+1); - *B = +1; - } - - /* -1 <= x <= 1, r == 0 */ - else { - *A = 0; - - /* x != 0 */ - if (x != 0) - *B = (sqrt(1-xx) - 1)/x; - - /* x == 0 */ - else - *B = 0; - } - } - - double aux1 = 0.5 * (x * x + rr - 1); - double aux2 = sqrt (aux1 * aux1 + rr); - double X = asinh (sqrt (aux1 + aux2)); - double R = asin (min(1.0, sqrt (-aux1 + aux2))); - if (x < 0) R = PI - R; - - *A = tanh (0.5 * X); - *B = tan (0.5 * R - PI/4); - -if((*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1 || (*phi)<0 || (*phi)>2*PI){ - cout<<"find ("<<*A<<","<<*B<<","<<*phi<<") in Ansorg::xyz_to_ABp at ("< 0) - *phi = (z < 0) ? 2 * PI - acos(y / r) : acos(y / r); - else - *phi = 0; - - double aux1 = 0.5 * (x * x + rr - 1); - double aux2 = sqrt(aux1 * aux1 + rr); - double X = asinh(sqrt(aux1 + aux2)); - double R = asin(min(1.0, sqrt(-aux1 + aux2))); - if (x < 0) - R = PI - R; - - *A = tanh(0.5 * X); - *B = tan(0.5 * R - PI / 4); -} -#endif -/* three dimensional polynomial interpolation, barycentric */ -double Ansorg::interpolate_tri_bar(double x, double y, double z, - int n1, int n2, int n3, - double *x1, double *x2, double *x3, double *yp) -{ - double u; - double *w, *omega; - double **v; - - int i, j, k, ijk; - int i1, i2, i3; - int di = 1, dj = n1, dk = n1 * n2; - int order1 = order > n1 ? n1 : order; - int order2 = order > n2 ? n2 : order; - int order3 = order > n3 ? n3 : order; - - w = new double[order]; - omega = new double[order]; - v = new double *[order]; - for (int i = 0; i < order; i++) - v[i] = new double[order]; - - i1 = find_point_bisection(x, n1, x1, order1 / 2); - i2 = find_point_bisection(y, n2, x2, order2 / 2); - i3 = find_point_bisection(z, n3, x3, order3 / 2); - ijk = i1 * di + i2 * dj + i3 * dk; - if (0) - printf("%d %d %d\n", i1, i2, i3); - - barycentric_omega(order1, 1, &x1[i1], omega); - for (k = 0; k < order3; k++) - for (j = 0; j < order2; j++) - v[k][j] = barycentric(x, order1, 1, &x1[i1], &yp[ijk + j * dj + k * dk], omega); - - if (0) - for (k = 0; k < order3; k++) - for (j = 0; j < order2; j++) - printf("%2d %2d %.15f\n", k, j, v[k][j]); - - barycentric_omega(order2, 1, &x2[i2], omega); - for (k = 0; k < order3; k++) - w[k] = barycentric(y, order2, 1, &x2[i2], &v[k][0], omega); - - if (0) - for (k = 0; k < order3; k++) - printf("%2d %.15f\n", k, w[k]); - - barycentric_omega(order3, 1, &x3[i3], omega); - u = barycentric(z, order3, 1, &x3[i3], w, omega); - - if (!finite(u)) - { - cout << "find NaN in Ansorg::interpolate_tri_bar at (" << x << "," << y << "," << z << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (i = 0; i < order; i++) - delete[] v[i]; - - delete[] w; - delete[] omega; - delete[] v; - - return u; -} -/* find index such that xp[i] <= x < xp[i+1] - uses bisection, which relies on x being ordered - o is "offset", number of points smaller than x that are required - returns j = i-(o-1), i.e. if o = 2, then - xp[j] < xp[j+1] <= x < xp[j+2] < xp[j+3] - which is useful for interpolation -*/ -int Ansorg::find_point_bisection(double x, int n, double *xp, int o) -{ - int i0 = o - 1, i1 = n - o; - int i; - - if (n < 2 * o) - { - cout << "bisection failed" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (x <= xp[i0]) - return 0; - if (x > xp[i1]) - return n - 2 * o; - - while (i0 != i1 - 1) - { - i = (i0 + i1) / 2; - if (x < xp[i]) - i1 = i; - else - i0 = i; - } - - return i0 - o + 1; -} -/* compute omega[] for barycentric interpolation */ -// SIAM_review 46, 501 (2004) -void Ansorg::barycentric_omega(int n, int s, double *x, double *omega) -{ - double o; - int i, j; - - if (0) - printf("%d %d %p %p\n", n, s, x, omega); - - for (i = 0; i < n; i += s) - { - o = 1; - for (j = 0; j < n; j += s) - { - if (j != i) - { - o /= (x[i] - x[j]); - } - } - omega[i / s] = o; - - if (0) - printf("x[%d] = %9.6f omega[%d] = %13.6e\n", i / s, x[i], i / s, o); - } -} -/* barycentric interpolation with precomputed omega */ -double Ansorg::barycentric(double x0, int n, int s, double *x, double *y, - double *omega) -{ - double a, b, c, d; - int i; - - if (0) - printf("%f %d %d %p %p %p\n", x0, n, s, x, y, omega); - - a = b = 0; - for (i = 0; i < n; i += s) - { - d = x0 - x[i]; - if (d == 0) - return y[i]; - c = omega[i / s] / d; - b += c; - a += c * y[i]; - } - - return a / b; -} + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include "Ansorg.h" +#include +/* read spectral data from file + special: pad phi direction with ghosts for periodic interpolation + order = 4: (-2 -1) 0 ... n-1 (n n+1) +*/ +Ansorg::Ansorg(char *filename, int orderi) : pu_ps(0), coordA(0), coordB(0), coordphi(0) +{ + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + order = orderi / 2 * 2; // order must be even + PIh = PI / 2.0; + char s[1000], *t; + FILE *fp; + double *v; + int nghosts; + int i; + + double x1, y1, z1, x2, y2, z2, dx, dy; + + /* open file */ + fp = fopen(filename, "r"); + if (myrank == 0 && !fp) + { + cout << "could not open " << filename << " for reading Ansorg" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (myrank == 0) + printf(" reading data from %s\n", filename); + + /* skip to line starting with data, extract size info */ + n1 = n2 = n3 = ntotal = -1; + while (fgets(s, 1000, fp)) + { + t = strstr(s, "bhx1 "); + if (t == s) + sscanf(s + 15, "%lf", &x1); + t = strstr(s, "bhy1 "); + if (t == s) + sscanf(s + 15, "%lf", &y1); + t = strstr(s, "bhz1 "); + if (t == s) + sscanf(s + 15, "%lf", &z1); + t = strstr(s, "bhx2 "); + if (t == s) + sscanf(s + 15, "%lf", &x2); + t = strstr(s, "bhy2 "); + if (t == s) + sscanf(s + 15, "%lf", &y2); + t = strstr(s, "bhz2 "); + if (t == s) + sscanf(s + 15, "%lf", &z2); + + t = strstr(s, "data "); + if (t != s) + continue; + sscanf(s + 5, "%d%d%d", &n1, &n2, &n3); + ntotal = n1 * n2 * n3; + if (myrank == 0) + printf(" found data with dimensions %d x %d x %d = %d\n", + n1, n2, n3, ntotal); + break; + } + + if (myrank == 0) + cout << " bhx1 = " << x1 << endl + << " bhy1 = " << y1 << endl + << " bhz1 = " << z1 << endl + << " bhx2 = " << x2 << endl + << " bhy2 = " << y2 << endl + << " bhz2 = " << z2 << endl; + + dx = x1 - x2; + dy = y1 - y2; + + /* x-axis */ + if (dx != 0 && y1 == 0 && y2 == 0 && z1 == 0 && z2 == 0) + { + ps_b = dx / 2; + ps_dx = (x1 + x2) / 2; + ps_rxx = 1; + ps_rxy = 0; + ps_ryx = 0; + ps_ryy = 1; + } + + /* y-axis */ + else if (dy != 0 && x1 == 0 && x2 == 0 && z1 == 0 && z2 == 0) + { + ps_b = dy / 2; + ps_dx = (y1 + y2) / 2; + ps_rxx = 0; + ps_rxy = +1; + ps_ryx = -1; + ps_ryy = 0; + } + + /* else */ + else if (myrank == 0) + { + cout << "puncture location not allowed" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (ntotal == -1 && myrank == 0) + { + cout << "file does not contain the expected data" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + /* get storage if needed */ + int pad = order / 2; + nghosts = n1 * n2 * pad; + if (!(pu_ps)) + pu_ps = new double[ntotal + 2 * nghosts]; + v = pu_ps + nghosts; + + /* read data */ + i = 0; + while (fgets(s, 1000, fp)) + { + if (i < ntotal) + v[i] = atof(t); + i++; + } + if (myrank == 0) + { + printf(" read %d data lines\n", i); + cout << endl; + } + if (myrank == 0 && i < ntotal) + { + cout << "file contains too few data lines" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (myrank == 0 && i > ntotal) + { + cout << "file contains too many data lines" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + /* copy data into ghosts */ + for (i = 0; i < nghosts; i++) + { + (pu_ps)[i] = v[i + ntotal - nghosts]; + (pu_ps)[i + ntotal + nghosts] = v[i]; + } + + if (0) + for (i = 0; i < ntotal + 2 * nghosts; i++) + printf("yoyo %10d %.16e\n", i - nghosts, (pu_ps)[i]); + + /* done */ + fclose(fp); + + set_ABp(); + + if (0) + { + if (myrank == 0) + { + cout << ps_u_at_xyz(0.015625, -4.578125, 0.015625) << endl; + cout << ps_u_at_xyz(0.046875, -4.578125, 0.015625) << endl; + cout << ps_u_at_xyz(0.078125, -4.578125, 0.015625) << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else + for (int i = 0;; i++) + ; + } +} +Ansorg::~Ansorg() +{ + if (coordA) + delete[] coordA; + if (coordB) + delete[] coordB; + if (coordphi) + delete[] coordphi; + if (pu_ps) + delete[] pu_ps; +} +/* interpolate to point given in Cartesian coordinates + calls function in utility/interpolation/barycentric.c +*/ +double Ansorg::ps_u_at_xyz(double x, double y, double z) +{ + double A, B, phi, u, U; + /* + // rotate THETA along clockwise direction + #define THETA (PI*0.25) + A = x; + B = y; + x = A*cos(THETA)+B*sin(THETA); + y =-A*sin(THETA)+B*cos(THETA); + */ + xyz_to_ABp(x, y, z, &A, &B, &phi); + if (0) + printf("x %f y %f z %f phi %f %.1f\n", x, y, z, phi, 180 * phi / PI); + if (0) + printf("A %f B %f phi %f\n", A, B, phi); + + U = interpolate_tri_bar(A, B, phi, n1, n2, n3 + (order / 2) * 2, + coordA, coordB, coordphi, pu_ps); + u = 2 * (A - 1) * U; + if (U > 0.025) + cout << x << "," << y << "," << z << "," << A << "," << B << "," << phi << "," << U << "," << u << endl; + if (!finite(u)) + { + cout << "find NaN in Ansorg::ps_u_at_xyz at (" << x << "," << y << "," << z << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + return u; +} +/* set 1d arrays for spectral coordinates + see Punctures_functions.c for reference + special: pad phi direction with ghosts for periodicity +*/ +void Ansorg::set_ABp() +{ + int pad = order / 2; + int i; + double Acode; + int pr = 0; + + coordA = new double[n1]; + coordB = new double[n2]; + coordphi = new double[n3 + 2 * pad]; + + for (i = 0; i < n1; i++) + { + Acode = -cos(PIh * (2 * i + 1) / n1); + coordA[i] = (Acode + 1) / 2; + if (pr && myrank == 0) + printf("coordA[%2d] = %f\n", i, coordA[i]); + } + + for (i = 0; i < n2; i++) + { + coordB[i] = -cos(PIh * (2 * i + 1) / n2); + if (pr && myrank == 0) + printf("coordB[%2d] = %f\n", i, coordB[i]); + } + + for (i = 0; i < n3 + 2 * pad; i++) + { + coordphi[i] = 2 * PI * (i - pad) / n3; + if (pr && myrank == 0) + printf("coordphi[%2d] = %f %f\n", + i, coordphi[i], coordphi[i] * 180 / PI); + } +} +/* from cartesian to spectral + see coordtrans.m etc + The problem is that the inverse transformation requires several + nested square roots with 8 possible solutions, only one of them relevant. + We have picked the correct solution by testing in Mathematica. + Furthermore, there are special coordinates where the formulas have + to be specialized. + + fixme: needs proper treatment of quantities that are almost zero/singular +*/ +#if 0 +void Ansorg::xyz_to_ABp(double x, double y, double z, + double *A, double *B, double *phi) +{ + const double s2 = sqrt(2.0); + double r, rr, xx; + double t, st, u, su, v, sv, w, sw; + + /* rotate onto x-axis if required */ + w = x; + x = ps_rxx * w + ps_rxy * y; + y = ps_ryx * w + ps_ryy * y; + + /* center black holes at +b and -b */ + x -= ps_dx; + + /* offset parameter b rescales the coordinates */ + x /= ps_b; + y /= ps_b; + z /= ps_b; + + /* helpers */ + r = sqrt(y*y + z*z); + rr = r*r; + xx = x*x; + + + /* phi as in cylindrical coordinates about x-axis + acos covers [0,pi], we need [0,2pi) + */ + if (r>0.0) + *phi = (z < 0.0) ? 2*PI - acos(y/r) : acos(y/r); + else + *phi = 0; + + + /* r > 0 */ + if (r>0.0) { + + /* x != 0, r > 0 */ + if (x != 0.0) { + + t = (1+rr)*(1+rr) + 2*(-1 + rr)*xx + xx*xx; + st = sqrt(t); + u = 1 - xx + rr*(2 + rr + xx + st) + st; + su = sqrt(u); + v = 1 + rr*rr - xx + rr*(2 + xx + st) + st; + sv = sqrt(v); + w = 1 + rr - s2*su + st; + sw = sqrt(w); + + *A = (2*sw*(1 + rr + st - xx) + s2*sv*(-1 - rr + 2*sw + st - xx)) + /(4.*r*xx); + + *B = -(sw/x); + } + + /* x == 0, r > 0 */ + else { + *A = (sqrt(1+rr) - 1)/r; + *B = 0; + } + } + + /* r == 0 */ + else { + + /* x > 1, r == 0 */ + if (x>1.0) { + *A = sqrt(x-1)/sqrt(x+1); + *B = -1; + } + + /* x < -1, r == 0 */ + else if (x<-1.0) { + *A = sqrt(-x-1)/sqrt(-x+1); + *B = +1; + } + + /* -1 <= x <= 1, r == 0 */ + else { + *A = 0; + + /* x != 0 */ + if (x != 0.0) + *B = (sqrt(1-xx) - 1)/x; + + /* x == 0 */ + else + *B = 0; + } + } + if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) {*A = 1; *B = 0;} +if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1 || (*phi)<0 || (*phi)>2*PI){ + cout<<"find ("<<*A<<","<<*B<<","<<*phi<<") in Ansorg::xyz_to_ABp at ("<0) + *phi = (z<0) ? 2*PI - acos(y/r) : acos(y/r); + else + *phi = 0; + + /* r > 0 */ + { + + /* x != 0, r > 0 */ + { + t = (1+rr)*(1+rr) + 2*(-1 + rr)*xx + xx*xx; + st = sqrt(t); + u = rr*(2 + rr + xx + st) + st + 1.0 - xx; + su = sqrt(u); + v = rr*rr + rr*(2 + xx + st) + st + 1.0 - xx; + sv = sqrt(v); + w = rr - s2*su + st + 1.0; + sw = sqrt(w); + + *A = (2*sw*(rr + st + 1 - xx) + s2*sv*(st - rr - 1 + 2*sw - xx)) + /(4.*r*xx); + + *B = -(sw/x); + } + /* x == 0, r > 0 */ + if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) + { + *A = (sqrt(1 + rr) - 1)/r + ((sqrt(1 + rr) - 1)*xx)/(2*r*pow((1 + rr),exp)); + + *B = -x/(2*sqrt(1 + rr)); + } + } + + /* r == 0 */ + if(!finite(*A) || !finite(*B) || (*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1) + { + + /* x > 1, r == 0 */ + if (x>1) { + *A = sqrt(x-1)/sqrt(x+1); + *B = -1; + } + + /* x < -1, r == 0 */ + else if (x<-1) { + *A = sqrt(-x-1)/sqrt(-x+1); + *B = +1; + } + + /* -1 <= x <= 1, r == 0 */ + else { + *A = 0; + + /* x != 0 */ + if (x != 0) + *B = (sqrt(1-xx) - 1)/x; + + /* x == 0 */ + else + *B = 0; + } + } + + double aux1 = 0.5 * (x * x + rr - 1); + double aux2 = sqrt (aux1 * aux1 + rr); + double X = asinh (sqrt (aux1 + aux2)); + double R = asin (min(1.0, sqrt (-aux1 + aux2))); + if (x < 0) R = PI - R; + + *A = tanh (0.5 * X); + *B = tan (0.5 * R - PI/4); + +if((*A)<0 || (*A)>1 || (*B)<-1 || (*B)>1 || (*phi)<0 || (*phi)>2*PI){ + cout<<"find ("<<*A<<","<<*B<<","<<*phi<<") in Ansorg::xyz_to_ABp at ("< 0) + *phi = (z < 0) ? 2 * PI - acos(y / r) : acos(y / r); + else + *phi = 0; + + double aux1 = 0.5 * (x * x + rr - 1); + double aux2 = sqrt(aux1 * aux1 + rr); + double X = asinh(sqrt(aux1 + aux2)); + double R = asin(min(1.0, sqrt(-aux1 + aux2))); + if (x < 0) + R = PI - R; + + *A = tanh(0.5 * X); + *B = tan(0.5 * R - PI / 4); +} +#endif +/* three dimensional polynomial interpolation, barycentric */ +double Ansorg::interpolate_tri_bar(double x, double y, double z, + int n1, int n2, int n3, + double *x1, double *x2, double *x3, double *yp) +{ + double u; + double *w, *omega; + double **v; + + int i, j, k, ijk; + int i1, i2, i3; + int di = 1, dj = n1, dk = n1 * n2; + int order1 = order > n1 ? n1 : order; + int order2 = order > n2 ? n2 : order; + int order3 = order > n3 ? n3 : order; + + w = new double[order]; + omega = new double[order]; + v = new double *[order]; + for (int i = 0; i < order; i++) + v[i] = new double[order]; + + i1 = find_point_bisection(x, n1, x1, order1 / 2); + i2 = find_point_bisection(y, n2, x2, order2 / 2); + i3 = find_point_bisection(z, n3, x3, order3 / 2); + ijk = i1 * di + i2 * dj + i3 * dk; + if (0) + printf("%d %d %d\n", i1, i2, i3); + + barycentric_omega(order1, 1, &x1[i1], omega); + for (k = 0; k < order3; k++) + for (j = 0; j < order2; j++) + v[k][j] = barycentric(x, order1, 1, &x1[i1], &yp[ijk + j * dj + k * dk], omega); + + if (0) + for (k = 0; k < order3; k++) + for (j = 0; j < order2; j++) + printf("%2d %2d %.15f\n", k, j, v[k][j]); + + barycentric_omega(order2, 1, &x2[i2], omega); + for (k = 0; k < order3; k++) + w[k] = barycentric(y, order2, 1, &x2[i2], &v[k][0], omega); + + if (0) + for (k = 0; k < order3; k++) + printf("%2d %.15f\n", k, w[k]); + + barycentric_omega(order3, 1, &x3[i3], omega); + u = barycentric(z, order3, 1, &x3[i3], w, omega); + + if (!finite(u)) + { + cout << "find NaN in Ansorg::interpolate_tri_bar at (" << x << "," << y << "," << z << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (i = 0; i < order; i++) + delete[] v[i]; + + delete[] w; + delete[] omega; + delete[] v; + + return u; +} +/* find index such that xp[i] <= x < xp[i+1] + uses bisection, which relies on x being ordered + o is "offset", number of points smaller than x that are required + returns j = i-(o-1), i.e. if o = 2, then + xp[j] < xp[j+1] <= x < xp[j+2] < xp[j+3] + which is useful for interpolation +*/ +int Ansorg::find_point_bisection(double x, int n, double *xp, int o) +{ + int i0 = o - 1, i1 = n - o; + int i; + + if (n < 2 * o) + { + cout << "bisection failed" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (x <= xp[i0]) + return 0; + if (x > xp[i1]) + return n - 2 * o; + + while (i0 != i1 - 1) + { + i = (i0 + i1) / 2; + if (x < xp[i]) + i1 = i; + else + i0 = i; + } + + return i0 - o + 1; +} +/* compute omega[] for barycentric interpolation */ +// SIAM_review 46, 501 (2004) +void Ansorg::barycentric_omega(int n, int s, double *x, double *omega) +{ + double o; + int i, j; + + if (0) + printf("%d %d %p %p\n", n, s, x, omega); + + for (i = 0; i < n; i += s) + { + o = 1; + for (j = 0; j < n; j += s) + { + if (j != i) + { + o /= (x[i] - x[j]); + } + } + omega[i / s] = o; + + if (0) + printf("x[%d] = %9.6f omega[%d] = %13.6e\n", i / s, x[i], i / s, o); + } +} +/* barycentric interpolation with precomputed omega */ +double Ansorg::barycentric(double x0, int n, int s, double *x, double *y, + double *omega) +{ + double a, b, c, d; + int i; + + if (0) + printf("%f %d %d %p %p %p\n", x0, n, s, x, y, omega); + + a = b = 0; + for (i = 0; i < n; i += s) + { + d = x0 - x[i]; + if (d == 0) + return y[i]; + c = omega[i / s] / d; + b += c; + a += c * y[i]; + } + + return a / b; +} diff --git a/AMSS_NCKU_source/Ansorg.h b/AMSS_NCKU_source/Initial_Data_Solver/Ansorg.h similarity index 95% rename from AMSS_NCKU_source/Ansorg.h rename to AMSS_NCKU_source/Initial_Data_Solver/Ansorg.h index 557043c..3a953c6 100644 --- a/AMSS_NCKU_source/Ansorg.h +++ b/AMSS_NCKU_source/Initial_Data_Solver/Ansorg.h @@ -1,53 +1,53 @@ - -#ifndef Ansorg_H -#define Ansorg_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#define PI M_PI - -class Ansorg -{ -protected: - int n1, n2, n3, ntotal; - int order; - double *coordA, *coordB, *coordphi; - int ps_rxx, ps_rxy, ps_ryx, ps_ryy; - double ps_b, ps_dx; - double PIh; - double *pu_ps; - int myrank; - -public: - Ansorg(char *filename, int orderi); - ~Ansorg(); - double ps_u_at_xyz(double x, double y, double z); - void set_ABp(); - void xyz_to_ABp(double x, double y, double z, - double *A, double *B, double *phi); - double interpolate_tri_bar(double x, double y, double z, - int n1, int n2, int n3, - double *x1, double *x2, double *x3, double *yp); - int find_point_bisection(double x, int n, double *xp, int o); - void barycentric_omega(int n, int s, double *x, double *omega); - double barycentric(double x0, int n, int s, double *x, double *y, - double *omega); -}; -#endif /* Ansorg_H */ + +#ifndef Ansorg_H +#define Ansorg_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#define PI M_PI + +class Ansorg +{ +protected: + int n1, n2, n3, ntotal; + int order; + double *coordA, *coordB, *coordphi; + int ps_rxx, ps_rxy, ps_ryx, ps_ryy; + double ps_b, ps_dx; + double PIh; + double *pu_ps; + int myrank; + +public: + Ansorg(char *filename, int orderi); + ~Ansorg(); + double ps_u_at_xyz(double x, double y, double z); + void set_ABp(); + void xyz_to_ABp(double x, double y, double z, + double *A, double *B, double *phi); + double interpolate_tri_bar(double x, double y, double z, + int n1, int n2, int n3, + double *x1, double *x2, double *x3, double *yp); + int find_point_bisection(double x, int n, double *xp, int o); + void barycentric_omega(int n, int s, double *x, double *omega); + double barycentric(double x0, int n, int s, double *x, double *y, + double *omega); +}; +#endif /* Ansorg_H */ diff --git a/AMSS_NCKU_source/initial_maxwell.f90 b/AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.f90 similarity index 96% rename from AMSS_NCKU_source/initial_maxwell.f90 rename to AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.f90 index 7ee6f0d..f05d6f3 100644 --- a/AMSS_NCKU_source/initial_maxwell.f90 +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.f90 @@ -1,977 +1,977 @@ - -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n charged black holes -!PRD 80, 104022 -!----------------------------------------------------------------------------------- - - subroutine get_initial_nbhsem(ext,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,& - Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& - Mass,Qchar,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ext - real*8, dimension(ext(1)), intent(in) :: X - real*8, dimension(ext(2)), intent(in) :: Y - real*8, dimension(ext(3)), intent(in) :: Z - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: chi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass,Qchar - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ext(1),ext(2),ext(3))::psi,phi - integer :: i,j,k,bhi - real*8 :: M,Q,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 - real*8,parameter::TINYRR=1.d-14 -!sanity check: M/Q = constant - M = mass(1) - Q = Qchar(1) - u1 = M/Q - u2 = M/Q - do bhi=2,N - M = mass(bhi) - Q = Qchar(bhi) - u1 = min(u1,M/Q) - u2 = max(u2,M/Q) - enddo - if(u2-u1.gt.TINYRR)then - write(*,*)"error in initial_punctureem.f90: get_initial_nbhsem; we need constant Mi/Qi, but" - write(*,*)"Mass = ",mass - write(*,*)"Qchar = ",Qchar - stop - endif - - do k = 1,ext(3) - do j = 1,ext(2) - do i = 1,ext(1) -! black hole 1 - M = mass(1) - Q = Qchar(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - phi(i,j,k) = Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Q*nx/rr/rr - Ey(i,j,k) = Q*ny/rr/rr - Ez(i,j,k) = Q*nz/rr/rr -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - Q = Qchar(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - phi(i,j,k) = phi(i,j,k) + Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr - Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr - Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr - enddo - enddo - enddo - enddo - - psi = dsqrt(psi**2 - phi*phi/FOUR) - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - Ex = Ex / psi - Ey = Ey / psi - Ez = Ez / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - Bx = ZEO - By = ZEO - Bz = ZEO - - Kpsi = ZEO - Kphi = ZEO - - return - - end subroutine get_initial_nbhsem -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n charged black holes -!PRD 80, 104022 -! for shell -!----------------------------------------------------------------------------------- - - subroutine get_initial_nbhsem_ss(ext,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,& - Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& - Mass,Qchar,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ext - real*8, dimension(ext(1),ext(2),ext(3)), intent(in) :: X,Y,Z - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: chi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass,Qchar - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ext(1),ext(2),ext(3))::psi,phi - integer :: i,j,k,bhi - real*8 :: M,Q,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 - real*8,parameter::TINYRR=1.d-14 -!sanity check: M/Q = constant - M = mass(1) - Q = Qchar(1) - u1 = M/Q - u2 = M/Q - do bhi=2,N - M = mass(bhi) - Q = Qchar(bhi) - u1 = min(u1,M/Q) - u2 = max(u2,M/Q) - enddo - if(u2-u1.gt.TINYRR)then - write(*,*)"error in initial_punctureem.f90: get_initial_nbhsem; we need constant Mi/Qi, but" - write(*,*)"Mass = ",mass - write(*,*)"Qchar = ",Qchar - stop - endif - - do k = 1,ext(3) - do j = 1,ext(2) - do i = 1,ext(1) -! black hole 1 - M = mass(1) - Q = Qchar(1) - nx = x(i,j,k) - Porg(1) - ny = y(i,j,k) - Porg(2) - nz = z(i,j,k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - phi(i,j,k) = Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Q*nx/rr/rr - Ey(i,j,k) = Q*ny/rr/rr - Ez(i,j,k) = Q*nz/rr/rr -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - Q = Qchar(bhi) - nx = x(i,j,k) - Porg(3*(bhi-1)+1) - ny = y(i,j,k) - Porg(3*(bhi-1)+2) - nz = z(i,j,k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - phi(i,j,k) = phi(i,j,k) + Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr - Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr - Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr - enddo - enddo - enddo - enddo - - psi = dsqrt(psi**2 - phi*phi/FOUR) - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - Ex = Ex / psi - Ey = Ey / psi - Ez = Ez / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - Bx = ZEO - By = ZEO - Bz = ZEO - - Kpsi = ZEO - Kphi = ZEO - - return - - end subroutine get_initial_nbhsem_ss -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n charged black holes -!aided with Ansorg's solver -!----------------------------------------------------------------------------------- - - subroutine get_ansorg_nbhs_em(ext,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,& - Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& - Mass,Qchar,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ext - real*8, dimension(ext(1)), intent(in) :: X - real*8, dimension(ext(2)), intent(in) :: Y - real*8, dimension(ext(3)), intent(in) :: Z - real*8, dimension(ext(1),ext(2),ext(3)), intent(inout) :: chi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass,Qchar - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ext(1),ext(2),ext(3))::psi,phi - integer :: i,j,k,bhi - real*8 :: M,Q,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ext(3) - do j = 1,ext(2) - do i = 1,ext(1) -! black hole 1 - M = mass(1) - Q = Qchar(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr - phi(i,j,k) = Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Q*nx/rr/rr - Ey(i,j,k) = Q*ny/rr/rr - Ez(i,j,k) = Q*nz/rr/rr -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - Q = Qchar(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - phi(i,j,k) = phi(i,j,k) + Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr - Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr - Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr - enddo - enddo - enddo - enddo - - psi = dsqrt(psi**2 - phi*phi/FOUR) - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - Ex = Ex / psi - Ey = Ey / psi - Ez = Ez / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - Bx = ZEO - By = ZEO - Bz = ZEO - - Kpsi = ZEO - Kphi = ZEO - - return - - end subroutine get_ansorg_nbhs_em -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n charged black holes -!aided with Ansorg's solver -! for shell -!----------------------------------------------------------------------------------- - - subroutine get_ansorg_nbhs_ss_em(ext,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,& - Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& - Mass,Qchar,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ext - real*8, dimension(ext(1),ext(2),ext(3)), intent(in) :: X,Y,Z - real*8, dimension(ext(1),ext(2),ext(3)), intent(inout) :: chi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass,Qchar - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ext(1),ext(2),ext(3))::psi,phi - integer :: i,j,k,bhi - real*8 :: M,Q,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ext(3) - do j = 1,ext(2) - do i = 1,ext(1) -! black hole 1 - M = mass(1) - Q = Qchar(1) - nx = x(i,j,k) - Porg(1) - ny = y(i,j,k) - Porg(2) - nz = z(i,j,k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr - phi(i,j,k) = Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Q*nx/rr/rr - Ey(i,j,k) = Q*ny/rr/rr - Ez(i,j,k) = Q*nz/rr/rr -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - Q = Qchar(bhi) - nx = x(i,j,k) - Porg(3*(bhi-1)+1) - ny = y(i,j,k) - Porg(3*(bhi-1)+2) - nz = z(i,j,k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - phi(i,j,k) = phi(i,j,k) + Q/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr - Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr - Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr - enddo - enddo - enddo - enddo - - psi = dsqrt(psi**2 - phi*phi/FOUR) - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - Ex = Ex / psi - Ey = Ey / psi - Ez = Ez / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - Bx = ZEO - By = ZEO - Bz = ZEO - - Kpsi = ZEO - Kphi = ZEO - - return - - end subroutine get_ansorg_nbhs_ss_em + +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n charged black holes +!PRD 80, 104022 +!----------------------------------------------------------------------------------- + + subroutine get_initial_nbhsem(ext,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,& + Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& + Mass,Qchar,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ext + real*8, dimension(ext(1)), intent(in) :: X + real*8, dimension(ext(2)), intent(in) :: Y + real*8, dimension(ext(3)), intent(in) :: Z + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: chi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass,Qchar + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ext(1),ext(2),ext(3))::psi,phi + integer :: i,j,k,bhi + real*8 :: M,Q,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 + real*8,parameter::TINYRR=1.d-14 +!sanity check: M/Q = constant + M = mass(1) + Q = Qchar(1) + u1 = M/Q + u2 = M/Q + do bhi=2,N + M = mass(bhi) + Q = Qchar(bhi) + u1 = min(u1,M/Q) + u2 = max(u2,M/Q) + enddo + if(u2-u1.gt.TINYRR)then + write(*,*)"error in initial_punctureem.f90: get_initial_nbhsem; we need constant Mi/Qi, but" + write(*,*)"Mass = ",mass + write(*,*)"Qchar = ",Qchar + stop + endif + + do k = 1,ext(3) + do j = 1,ext(2) + do i = 1,ext(1) +! black hole 1 + M = mass(1) + Q = Qchar(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + phi(i,j,k) = Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Q*nx/rr/rr + Ey(i,j,k) = Q*ny/rr/rr + Ez(i,j,k) = Q*nz/rr/rr +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + Q = Qchar(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + phi(i,j,k) = phi(i,j,k) + Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr + Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr + Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr + enddo + enddo + enddo + enddo + + psi = dsqrt(psi**2 - phi*phi/FOUR) + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + Ex = Ex / psi + Ey = Ey / psi + Ez = Ez / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + Bx = ZEO + By = ZEO + Bz = ZEO + + Kpsi = ZEO + Kphi = ZEO + + return + + end subroutine get_initial_nbhsem +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n charged black holes +!PRD 80, 104022 +! for shell +!----------------------------------------------------------------------------------- + + subroutine get_initial_nbhsem_ss(ext,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,& + Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& + Mass,Qchar,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ext + real*8, dimension(ext(1),ext(2),ext(3)), intent(in) :: X,Y,Z + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: chi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass,Qchar + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ext(1),ext(2),ext(3))::psi,phi + integer :: i,j,k,bhi + real*8 :: M,Q,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 + real*8,parameter::TINYRR=1.d-14 +!sanity check: M/Q = constant + M = mass(1) + Q = Qchar(1) + u1 = M/Q + u2 = M/Q + do bhi=2,N + M = mass(bhi) + Q = Qchar(bhi) + u1 = min(u1,M/Q) + u2 = max(u2,M/Q) + enddo + if(u2-u1.gt.TINYRR)then + write(*,*)"error in initial_punctureem.f90: get_initial_nbhsem; we need constant Mi/Qi, but" + write(*,*)"Mass = ",mass + write(*,*)"Qchar = ",Qchar + stop + endif + + do k = 1,ext(3) + do j = 1,ext(2) + do i = 1,ext(1) +! black hole 1 + M = mass(1) + Q = Qchar(1) + nx = x(i,j,k) - Porg(1) + ny = y(i,j,k) - Porg(2) + nz = z(i,j,k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + phi(i,j,k) = Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Q*nx/rr/rr + Ey(i,j,k) = Q*ny/rr/rr + Ez(i,j,k) = Q*nz/rr/rr +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + Q = Qchar(bhi) + nx = x(i,j,k) - Porg(3*(bhi-1)+1) + ny = y(i,j,k) - Porg(3*(bhi-1)+2) + nz = z(i,j,k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + phi(i,j,k) = phi(i,j,k) + Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr + Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr + Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr + enddo + enddo + enddo + enddo + + psi = dsqrt(psi**2 - phi*phi/FOUR) + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + Ex = Ex / psi + Ey = Ey / psi + Ez = Ez / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + Bx = ZEO + By = ZEO + Bz = ZEO + + Kpsi = ZEO + Kphi = ZEO + + return + + end subroutine get_initial_nbhsem_ss +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n charged black holes +!aided with Ansorg's solver +!----------------------------------------------------------------------------------- + + subroutine get_ansorg_nbhs_em(ext,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,& + Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& + Mass,Qchar,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ext + real*8, dimension(ext(1)), intent(in) :: X + real*8, dimension(ext(2)), intent(in) :: Y + real*8, dimension(ext(3)), intent(in) :: Z + real*8, dimension(ext(1),ext(2),ext(3)), intent(inout) :: chi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass,Qchar + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ext(1),ext(2),ext(3))::psi,phi + integer :: i,j,k,bhi + real*8 :: M,Q,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ext(3) + do j = 1,ext(2) + do i = 1,ext(1) +! black hole 1 + M = mass(1) + Q = Qchar(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr + phi(i,j,k) = Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Q*nx/rr/rr + Ey(i,j,k) = Q*ny/rr/rr + Ez(i,j,k) = Q*nz/rr/rr +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + Q = Qchar(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + phi(i,j,k) = phi(i,j,k) + Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr + Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr + Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr + enddo + enddo + enddo + enddo + + psi = dsqrt(psi**2 - phi*phi/FOUR) + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + Ex = Ex / psi + Ey = Ey / psi + Ez = Ez / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + Bx = ZEO + By = ZEO + Bz = ZEO + + Kpsi = ZEO + Kphi = ZEO + + return + + end subroutine get_ansorg_nbhs_em +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n charged black holes +!aided with Ansorg's solver +! for shell +!----------------------------------------------------------------------------------- + + subroutine get_ansorg_nbhs_ss_em(ext,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,& + Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi,& + Mass,Qchar,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ext + real*8, dimension(ext(1),ext(2),ext(3)), intent(in) :: X,Y,Z + real*8, dimension(ext(1),ext(2),ext(3)), intent(inout) :: chi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Ex,Ey,Ez,Bx,By,Bz,Kpsi,Kphi + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass,Qchar + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ext(1),ext(2),ext(3))::psi,phi + integer :: i,j,k,bhi + real*8 :: M,Q,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0,FOUR=4.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ext(3) + do j = 1,ext(2) + do i = 1,ext(1) +! black hole 1 + M = mass(1) + Q = Qchar(1) + nx = x(i,j,k) - Porg(1) + ny = y(i,j,k) - Porg(2) + nz = z(i,j,k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr + phi(i,j,k) = Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Q*nx/rr/rr + Ey(i,j,k) = Q*ny/rr/rr + Ez(i,j,k) = Q*nz/rr/rr +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + Q = Qchar(bhi) + nx = x(i,j,k) - Porg(3*(bhi-1)+1) + ny = y(i,j,k) - Porg(3*(bhi-1)+2) + nz = z(i,j,k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + phi(i,j,k) = phi(i,j,k) + Q/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Ex(i,j,k) = Ex(i,j,k) + Q*nx/rr/rr + Ey(i,j,k) = Ey(i,j,k) + Q*ny/rr/rr + Ez(i,j,k) = Ez(i,j,k) + Q*nz/rr/rr + enddo + enddo + enddo + enddo + + psi = dsqrt(psi**2 - phi*phi/FOUR) + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + Ex = Ex / psi + Ey = Ey / psi + Ez = Ez / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + Bx = ZEO + By = ZEO + Bz = ZEO + + Kpsi = ZEO + Kphi = ZEO + + return + + end subroutine get_ansorg_nbhs_ss_em diff --git a/AMSS_NCKU_source/initial_maxwell.h b/AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.h similarity index 97% rename from AMSS_NCKU_source/initial_maxwell.h rename to AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.h index e00f8ee..71bf758 100644 --- a/AMSS_NCKU_source/initial_maxwell.h +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_maxwell.h @@ -1,76 +1,76 @@ - -#ifndef GET_INITIAL_MAXWELL_H -#define GET_INITIAL_MAXWELL_H - -#ifdef fortran1 -#define f_get_initial_nbhsem get_initial_nbhsem -#define f_get_initial_nbhsem_ss get_initial_nbhsem_ss -#define f_get_ansorg_nbhs_em get_ansorg_nbhs_em -#define f_get_ansorg_nbhs_ss_em get_ansorg_nbhs_ss_em -#endif -#ifdef fortran2 -#define f_get_initial_nbhsem GET_INITIAL_NBHSEM -#define f_get_initial_nbhsem_ss GET_INITIAL_NBHSEM_SS -#define f_get_ansorg_nbhs_em GET_ANSORG_NBHS_EM -#define f_get_ansorg_nbhs_ss_em GET_ANSORG_NBHS_SS_EM -#endif -#ifdef fortran3 -#define f_get_initial_nbhsem get_initial_nbhsem_ -#define f_get_initial_nbhsem_ss get_initial_nbhsem_ss_ -#define f_get_ansorg_nbhs_em get_ansorg_nbhs_em_ -#define f_get_ansorg_nbhs_ss_em get_ansorg_nbhs_ss_em_ -#endif - -extern "C" -{ - void f_get_initial_nbhsem(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_initial_nbhsem_ss(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_ansorg_nbhs_em(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_ansorg_nbhs_ss_em(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, int &); -} - -#endif /* GET_INITIAL_MAXWELL_H */ + +#ifndef GET_INITIAL_MAXWELL_H +#define GET_INITIAL_MAXWELL_H + +#ifdef fortran1 +#define f_get_initial_nbhsem get_initial_nbhsem +#define f_get_initial_nbhsem_ss get_initial_nbhsem_ss +#define f_get_ansorg_nbhs_em get_ansorg_nbhs_em +#define f_get_ansorg_nbhs_ss_em get_ansorg_nbhs_ss_em +#endif +#ifdef fortran2 +#define f_get_initial_nbhsem GET_INITIAL_NBHSEM +#define f_get_initial_nbhsem_ss GET_INITIAL_NBHSEM_SS +#define f_get_ansorg_nbhs_em GET_ANSORG_NBHS_EM +#define f_get_ansorg_nbhs_ss_em GET_ANSORG_NBHS_SS_EM +#endif +#ifdef fortran3 +#define f_get_initial_nbhsem get_initial_nbhsem_ +#define f_get_initial_nbhsem_ss get_initial_nbhsem_ss_ +#define f_get_ansorg_nbhs_em get_ansorg_nbhs_em_ +#define f_get_ansorg_nbhs_ss_em get_ansorg_nbhs_ss_em_ +#endif + +extern "C" +{ + void f_get_initial_nbhsem(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_initial_nbhsem_ss(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_ansorg_nbhs_em(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_ansorg_nbhs_ss_em(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, int &); +} + +#endif /* GET_INITIAL_MAXWELL_H */ diff --git a/AMSS_NCKU_source/initial_null.f90 b/AMSS_NCKU_source/Initial_Data_Solver/initial_null.f90 similarity index 96% rename from AMSS_NCKU_source/initial_null.f90 rename to AMSS_NCKU_source/Initial_Data_Solver/initial_null.f90 index 848191c..418ad05 100644 --- a/AMSS_NCKU_source/initial_null.f90 +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_null.f90 @@ -1,1869 +1,1869 @@ - - -#include "macrodef.fh" - - subroutine get_initial_nbhs_null(ex,crho,sigma,x,RJ,IJ,omega,sst,Rmin) - - implicit none -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),sst - real*8,intent(in ) :: Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::x - double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::RJ,IJ,omega - -!~~~~~~> Other variables: - real*8 :: xe - real*8,dimension(ex(1),ex(2)) :: RJe,IJe - integer :: k - - xe = x(1) - RJe = RJ(:,:,1) - IJe = IJ(:,:,1) - - do k=1,ex(3) - RJ(:,:,k) = RJe*(1.d0-x(k))*xe/(1-xe)/x(k) - IJ(:,:,k) = IJe*(1.d0-x(k))*xe/(1-xe)/x(k) - enddo - - omega = 1.d0 - - return - - end subroutine get_initial_nbhs_null -!----------------------------------- -!Eq.(10) of CQG 24, S327 (2007) -!---------------------------------- - function Zslm(s,l,m,the,phi) result(gont) - implicit none - integer,intent(in) :: s,l,m - real*8,intent(in) :: the,phi - - double complex :: Yslm,gont,II - - II=dcmplx(0.d0,1.d0) - - if(m>0)then - gont = Yslm(s,l,m,the,phi) - if(m/2*2==m)then - gont = gont+Yslm(s,l,-m,the,phi) - else - gont = gont-Yslm(s,l,-m,the,phi) - endif - gont = gont/dsqrt(2.d0) - elseif(m<0)then - gont = -Yslm(s,l,-m,the,phi) - if(m/2*2==m)then - gont = gont+Yslm(s,l,m,the,phi) - else - gont = gont-Yslm(s,l,m,the,phi) - endif - gont = II*gont/dsqrt(2.d0) - else - gont = Yslm(s,l,m,the,phi) - endif - - return - - end function Zslm - -!#define SCH - -#ifdef SCH - -subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ - -RJ = 0.d0 -IJ = 0.d0 - -return - -end subroutine get_initial_null -!------------------------- - subroutine get_null_boundary(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - - integer :: k - k=1 - - beta(:,:,k) = 0.d0 - W(:,:,k) =-2.d0/R(k)**2/Rmin**2*(1.d0-R(k))**2 - - RQ(:,:,k) = 0.d0 - IQ(:,:,k) = 0.d0 - - RTheta(:,:,k) = 0.d0 - ITheta(:,:,k) = 0.d0 - - RU(:,:,k) = 0.d0 - IU(:,:,k) = 0.d0 - - return - - end subroutine get_null_boundary -!------------------------------------------------------------- -subroutine get_exact_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,T -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -RJ = 0.d0 -IJ = 0.d0 - -return - -end subroutine get_exact_null -!------------------------------------------------------------------------------------------- - subroutine get_null_boundary_c(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - - integer :: k - - do k=1,ex(3) - - beta(:,:,k) = 0.d0 - W(:,:,k) =-2.d0/R(k)**2/Rmin**2*(1.d0-R(k))**2 - - RQ(:,:,k) = 0.d0 - IQ(:,:,k) = 0.d0 - - RTheta(:,:,k) = 0.d0 - ITheta(:,:,k) = 0.d0 - - RU(:,:,k) = 0.d0 - IU(:,:,k) = 0.d0 - enddo - - return - - end subroutine get_null_boundary_c - -#else - -#if 0 -! for some trival check -#if 1 -!------------------------------------------------------------- -! Linear wave given in CQG 24S327 -!------------------------------------------------------------- -subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ - -integer :: i,j,k -real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma -double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - gr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3 - gr = dreal(Jr) - Jr = Yslm(0,2,m,gt,gp) - RJ(i,j,k) = gr*dreal(Jr) - IJ(i,j,k) = gr*dimag(Jr) - -#if 0 - RJ(i,j,k) = 0.25d0*dsqrt(5.d0/3.1415926)*(3/(1.d0+tgrho*tgrho+tgsigma*tgsigma)-1.d0) - IJ(i,j,k) = 0.d0 -#endif - enddo - enddo - enddo - -return - -end subroutine get_initial_null -#else -! for check usage -subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ - -real*8 :: thetac,thetas,sr,ss,cr,cs,srss,crcs,tcts,tcts2 -real*8 :: sr2,ss2,cr2,cs2,tc2,ts2 -integer :: i,j,k -real*8 :: ggr,tgrho,tgsigma - -real*8 :: PI - -PI = dacos(-1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - srss = sr*ss - crcs = cr*cs - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - thetac = dsqrt((1.d0-srss)/2.d0) - thetas = dsqrt((1.d0+srss)/2.d0) - tc2 = thetac*thetac - ts2 = thetas*thetas - tcts = thetac*thetas - tcts2 = tcts*tcts -! q^Aq^B@_A@_B Y20 - RJ(i,j,k) =-1.5d0*dsqrt(5.d0/PI)*sr*ss*(4.d0*cr2*cs2+cs2+cr2) - IJ(i,j,k) = 3.d0*dsqrt(5.d0/PI)*thetac*thetas*(cs2-cr2) - -! @_rho@_rho Y20 - RJ(i,j,k) = 1.5d0*dsqrt(5.d0/PI)*cs2*cs2*(-cr2*cs2+2*cr2*cr2*cs2-2*cr2*cr2-cs2+3*cr2) & - /(3*cr2*cs2*cs2*cs2-3*cr2*cr2*cr2*cs2*cs2-3*cr2*cr2*cs2*cs2*cs2+ & - cr2*cr2*cr2*cs2*cs2*cs2-3*cr2*cr2*cs2-cs2*cs2*cs2-cr2*cr2*cr2+ & - 3*cs2*cr2*cr2*cr2+6*cr2*cr2*cs2*cs2-3*cs2*cs2*cr2) - IJ(i,j,k) = 0.d0 -! q^Aq^B h_AB - RJ(i,j,k) = 0.d0 - IJ(i,j,k) = 0.d0 - enddo - enddo - enddo - -return - -end subroutine get_initial_null -#endif -#endif -!====================================================================================== -!------------------------------------------------------------- -! Linear wave given in CQG 24S327 -!------------------------------------------------------------- -subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ - -integer :: i,j,k -real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts -double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -double complex :: swtf,ff - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - gr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3 - gr = dreal(Jr) - Jr = Yslm(2,2,m,gt,gp) - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*gr*Jr*swtf**2 - RJ(i,j,k) = dreal(ff) - IJ(i,j,k) = dimag(ff) - - enddo - enddo - enddo - -return - -end subroutine get_initial_null -!============================================================================================== - -#if 0 -! for checking derivs_eth and dderivs_eth -!------------------------- - subroutine get_null_boundary(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - - double complex,dimension(ex(1),ex(2)) :: Y20,dY20,ddY20,f - integer :: i,j,k - real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma - double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - k=1 - do i=1,ex(1) - do j=1,ex(2) -! fake global coordinate is enough - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - RTheta(i,j,k) = dreal(Jr*nu*(II*dcos(nu*T)-dsin(nu*T))) - f(i,j) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& - +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 - RU(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - -! Re(r^2*Ul_,r*exp(i nu T)) of CQG 24S327, (12) indeed - Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 - RQ(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& - -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 - W(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Y20(i,j) = Yslm(0,2,m,gt,gp) - - enddo - enddo - - call derivs_eth(ex(1:2),crho,sigma,Y20,dY20,0,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call dderivs_eth(ex(1:2),crho,sigma,Y20,ddY20,0,1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k),& - dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & - bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & - dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k)) - - beta(:,:,k) = dreal(beta0*(dcos(nu*T)+II*dsin(nu*T)))*dreal(Y20) - W(:,:,k) = W(:,:,k)*dreal(Y20) - - f = dexp(-2.d0*beta(:,:,k))*(f*ddY20*RQ(:,:,k)*dconjg(dY20)+dsqrt(1.d0+abs(f*ddY20))*RQ(:,:,k)*dY20) - RQ(:,:,k) = dreal(f) - IQ(:,:,k) = dimag(f) - - f = ddY20*RTheta(:,:,k) - RTheta(:,:,k) = dreal(f) - ITheta(:,:,k) = dimag(f) - - f = dY20*RU(:,:,k) - RU(:,:,k) = dreal(f) - IU(:,:,k) = dimag(f) - - return - - end subroutine get_null_boundary -#else -!------------------------- - subroutine get_null_boundary(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - k=1 - do i=1,ex(1) - do j=1,ex(2) -! fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*nu*(II*dcos(nu*T)-dsin(nu*T))) - Jr = Yslm(2,2,m,gt,gp) - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr*swtf**2 - RTheta(i,j,k) = dreal(ff) - ITheta(i,j,k) = dimag(ff) - - rf = dreal(Yslm(0,2,m,gt,gp)) - beta(i,j,k) = rf*dreal(beta0*(dcos(nu*T)+II*dsin(nu*T))) - Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& - -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 - W(i,j,k) = rf*dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& - +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 - rf = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - Jr = Yslm(1,2,m,gt,gp) - ff = dsqrt(dble(2*(2+1)))*rf*Jr*swtf - RU(i,j,k) = dreal(ff) - IU(i,j,k) = dimag(ff) - - Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 - rf = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - Jr = Yslm(1,2,m,gt,gp) - ff = dsqrt(dble(2*(2+1)))*rf*Jr*swtf !! U_,r - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - Jr = Yslm(2,2,m,gt,gp) - Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr*swtf**2 !! J - rf = dsqrt(1.d0+abs(Jr)**2) !! K - ff = dexp(-2.d0*beta(i,j,k))*(Jr*dconjg(ff)+rf*ff) - RQ(i,j,k) = dreal(ff) - IQ(i,j,k) = dimag(ff) - - enddo - enddo - - return - - end subroutine get_null_boundary - -#endif - -#if 0 -! for checking dderivs_eth -!------------------------------------------------------------- -! Linear wave given in CQG 24S327 -!------------------------------------------------------------- -subroutine get_exact_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,T -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -double complex,dimension(ex(1),ex(2)) :: Y20,ddY20,f -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma -double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_null: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - Y20(i,j) = Yslm(0,2,m,gt,gp) - RJ(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - IJ(i,j,k) = 0.d0 - - enddo - enddo - enddo - - k=1 - call dderivs_eth(ex(1:2),crho,sigma,Y20,ddY20,0,1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k),& - dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & - bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & - dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k)) - - do k=1,ex(3) - f = ddY20*RJ(:,:,k) - RJ(:,:,k) = dreal(f) - IJ(:,:,k) = dimag(f) - enddo - -return - -end subroutine get_exact_null - -#else -!------------------------------------------------------------- -! Linear wave given in CQG 24S327 -!------------------------------------------------------------- -subroutine get_exact_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,T -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_null: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - hgr = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - Jr = Yslm(2,2,m,gt,gp) - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*hgr*Jr*swtf**2 - RJ(i,j,k) = dreal(ff) - IJ(i,j,k) = dimag(ff) - enddo - enddo - enddo - -return - -end subroutine get_exact_null - -#endif - -#if 0 -! for checking derivs_eth and dderivs_eth -!------------------------- - subroutine get_null_boundary_c(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - - double complex,dimension(ex(1),ex(2)) :: Y20,dY20,ddY20,f - integer :: i,j,k - real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma - double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - -! write(*,*) abs(II) confirms abs == cabs - - do k=1,ex(3) - do i=1,ex(1) - do j=1,ex(2) -! fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary_c: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - RTheta(i,j,k) = dreal(Jr*nu*(II*dcos(nu*T)-dsin(nu*T))) - f(i,j) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& - +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 - RU(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - -! Re(r^2*Ul_,r*exp(i nu T)) of CQG 24S327, (12) indeed - Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 - RQ(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& - -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 - W(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) - - Y20(i,j) = Yslm(0,2,m,gt,gp) - - enddo - enddo - - call derivs_eth(ex(1:2),crho,sigma,Y20,dY20,0,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call dderivs_eth(ex(1:2),crho,sigma,Y20,ddY20,0,1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k),& - dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & - bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & - dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k)) - - beta(:,:,k) = dreal(beta0*cdexp(II*nu*T))*dreal(Y20) - W(:,:,k) = W(:,:,k)*dreal(Y20) - - f = dexp(-2.d0*beta(:,:,k))*(f*ddY20*RQ(:,:,k)*dconjg(dY20)+dsqrt(1.d0+abs(f*ddY20))*RQ(:,:,k)*dY20) - RQ(:,:,k) = dreal(f) - IQ(:,:,k) = dimag(f) - - f = ddY20*RTheta(:,:,k) - RTheta(:,:,k) = dreal(f) - ITheta(:,:,k) = dimag(f) - - f = dY20*RU(:,:,k) - RU(:,:,k) = dreal(f) - IU(:,:,k) = dimag(f) - enddo - - return - - end subroutine get_null_boundary_c - -#else - -!------------------------- - subroutine get_null_boundary_c(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - -#if 0 -real*8 :: betax,KK,KKx,Wx -double complex :: CJ,DCJ,CJx,CJxx,DCJx,CU,CUx,DCU,DCUx,bDCU,bDCUx,CB,DCB,bDCB,CBx -double complex :: Cnu,Cnux,Ck,fCTheta,fCThetax,Theta_rhs - - -T=0.25d0 - i=1 - j=1 - k=1 - hgr = 1.d0 - beta(i,j,k) = dreal(beta0*cdexp(II*nu*T)) - CB = beta(i,j,k) - DCB = CB - bDCB = CB - betax = 0.d0 - Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr& - -nu*nu*C2/hgr/hgr+II*nu*C2/hgr**3+C2/2.d0/hgr**4 - W(i,j,k) = dreal(Jr*cdexp(II*nu*T)) - Jr = -(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr**2& - +2.d0*nu*nu*C2/hgr**3-3.d0*II*nu*C2/hgr**4-2.d0*C2/hgr**5 - Wx = dreal(Jr*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/hgr-C2/1.2d1/hgr**3 - CJ = dreal(Jr*cdexp(II*nu*T)) - fCTheta = dreal(Jr*II*nu*cdexp(II*nu*T)) - DCJ=CJ - KK = dsqrt(1.d0+cdabs(CJ)**2) - Jr = -C1/4.d0/hgr**2+C2/4.d0/hgr**4 - rf = dreal(Jr*cdexp(II*nu*T)) - CJx = rf*(Rmin+hgr)**2/Rmin - fCThetax = dreal(Jr*II*nu*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin - Jr = C1/2.d0/hgr**3-C2/hgr**5 - rf = dreal(Jr*cdexp(II*nu*T)) - CJxx = rf*(Rmin+hgr)**4/Rmin**2+2.d0*(Rmin+hgr)/Rmin*CJx - DCJx = CJx - KKx = dreal(CJ*dconjg(CJx))/KK - Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0/hgr& - +C1/2.d0/hgr/hgr+II*nu*C2/3.d0/hgr**3+C2/4.d0/hgr**4 - CU = dreal(Jr*cdexp(II*nu*T)) - bDCU = CU - DCU=CU - Jr = -2.d0*beta0/hgr/hgr-C1/hgr**3-II*nu*C2/hgr**4-C2/hgr**5 - rf = dreal(Jr*cdexp(II*nu*T)) - CUx = rf*(Rmin+hgr)**2/Rmin - DCUx=CUx - bDCUx=CUx - - Cnu = CJ - Cnux = CJx - Ck = 0.d0 - hgr = hgr/(Rmin+hgr) - - - call getndxs(T,crho(i),sigma(j),hgr,beta(i,j,k),KK,CU,bDCU,DCU, & - CB,DCB,W(i,j,k),CJ,DCJ,bDCB,Cnu,Ck,fCTheta,sst,Rmin) - call getdxs(T,crho(i),sigma(j),hgr,betax,KKx,CUx,DCUx,bDCUx, & - Wx,CJx,CJxx,DCJx,Cnux,fCThetax,sst,Rmin) -! write(*,*) 2.d0*hgr*(1.d0-hgr)*fCThetax-(-(hgr*(1-hgr)*DCUx+2.d0*DCU)+2.d0/hgr/Rmin*(1.d0-hgr)*DCB & -! +(1.d0-hgr)**3/Rmin*(2.d0*CJx+hgr*CJxx)-2.d0*fCTheta) -! stop - write(*,*) fCThetax-Theta_rhs(hgr,Rmin,beta(i,j,k),betax,KK,KKx,CU,CUx,DCUx,bDCU,bDCUx, & - DCU,CB,DCB,W(i,j,k),Wx,CJ,DCJ, & - CJx,CJxx,DCJx,bDCB,Cnu,Cnux,Ck,fCTheta) - stop -#endif - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*nu*II*cdexp(II*nu*T)) - Jr = Yslm(2,2,m,gt,gp)*swtf**2 - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr - RTheta(i,j,k) = dreal(ff) - ITheta(i,j,k) = dimag(ff) - - rf = dreal(Yslm(0,2,m,gt,gp)) - beta(i,j,k) = rf*dreal(beta0*cdexp(II*nu*T)) - Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& - -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 - W(i,j,k) = rf*dreal(Jr*cdexp(II*nu*T)) - - Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& - +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 - rf = dreal(Jr*cdexp(II*nu*T)) - Jr = Yslm(1,2,m,gt,gp)*swtf - ff = dsqrt(dble(2*(2+1)))*rf*Jr - RU(i,j,k) = dreal(ff) - IU(i,j,k) = dimag(ff) - - Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 - rf = dreal(Jr*cdexp(II*nu*T)) - Jr = Yslm(1,2,m,gt,gp)*swtf - ff = dsqrt(dble(2*(2+1)))*rf*Jr !! U_,r - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*cdexp(II*nu*T)) - Jr = Yslm(2,2,m,gt,gp)*swtf**2 - Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr !! J - rf = dsqrt(1.d0+cdabs(Jr)**2) !! K - ff = dexp(-2.d0*beta(i,j,k))*(Jr*dconjg(ff)+rf*ff) - RQ(i,j,k) = dreal(ff) - IQ(i,j,k) = dimag(ff) - - enddo - enddo - enddo - - return - - end subroutine get_null_boundary_c -#endif - -!========================================================== -subroutine initial_null_paramter(beta0,C1,C2,nu,m) - -implicit none - -double complex,intent(out) :: beta0,C1,C2 -integer,intent(out) :: nu,m - -nu=1 -m=0 -beta0 = dcmplx(0.d0,1.d-6) -C1 = dcmplx(3.d-6,0.d0) -C2 = dcmplx(1.d-6,0.d0) - -end subroutine initial_null_paramter - -#if 1 -subroutine get_exact_null_theta(ex,crho,sigma,R,RTheta,ITheta,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,T -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RTheta,ITheta -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_null_theta: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - hgr = dreal(Jr*nu*(-dsin(nu*T)+II*dcos(nu*T))) - Jr = Yslm(2,2,m,gt,gp) - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*hgr*Jr*swtf**2 - RTheta(i,j,k) = dreal(ff) - ITheta(i,j,k) = dimag(ff) - - enddo - enddo - enddo - -return - -end subroutine get_exact_null_theta -!------------------------------------------------------------------------------------------------ -subroutine get_exact_null_theta_x(ex,crho,sigma,R,RThetax,IThetax,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,T -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RThetax,IThetax -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 -real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_null_theta_x: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = C1/4.d0-C2/1.2d1*3*hgr**2 - Jr = -Jr/Rmin/R(k)/R(k) - hgr = dreal(Jr*nu*(-dsin(nu*T)+II*dcos(nu*T))) - Jr = Yslm(2,2,m,gt,gp) - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*hgr*Jr*swtf**2 - RThetax(i,j,k) = dreal(ff) - IThetax(i,j,k) = dimag(ff) - - enddo - enddo - enddo - -return - -end subroutine get_exact_null_theta_x -!------------------------- - subroutine get_exact_Jul(ex,crho,sigma,R,RJul,IJul, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RJul,IJul - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_Jul: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = C1/4.d0-C2/4.d0*hgr**2 - rf = dreal(Jr*nu*II*cdexp(II*nu*T)) - Jr = Yslm(2,2,m,gt,gp)*swtf**2 - ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr - RJul(i,j,k) = dreal(ff) - IJul(i,j,k) = dimag(ff) - - enddo - enddo - enddo - - return - - end subroutine get_exact_Jul -!------------------------- - subroutine get_fake_Ju(ex,crho,sigma,R,RJul,IJul, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RJul,IJul - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_fake_Ju: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*nu*II*cdexp(II*nu*T)) - ff = dcmplx(rf,0.d0) - RJul(i,j,k) = dreal(ff) - IJul(i,j,k) = dimag(ff) - - enddo - enddo - enddo - -if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then - write(*,*)"T=",T,"exp(i T)=",cdexp(II*nu*T) - write(*,*)RJul(ex(1)/2,ex(2)/2,ex(3)),RJul(ex(1)/2,ex(2)/2,ex(3)-1),R(2)-R(1) -endif - - return - - end subroutine get_fake_Ju -!------------------------- - subroutine get_exact_omegau(ex,crho,sigma,R,omegau, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: omegau - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_omegau: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*nu*II*cdexp(II*nu*T)) - Jr = Yslm(0,2,m,gt,gp) - ff = -dble(2*(2+1))/2.d0*rf*Jr - omegau(i,j,k) = dreal(ff) - - enddo - enddo - enddo - - return - - end subroutine get_exact_omegau -!------------------------- - subroutine get_exact_eth2omega(ex,crho,sigma,R,Reth2omega,Ieth2omega, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: T,Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: Reth2omega,Ieth2omega - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - -double complex :: beta0,C1,C2 -integer :: nu,m - - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - hgr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_eth2omega: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - hgr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 - rf = dreal(Jr*cdexp(II*nu*T)) - Jr = Yslm(2,2,m,gt,gp) - ff = -dble(2*(2+1))/2.d0*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr - Reth2omega(i,j,k) = dreal(ff) - Ieth2omega(i,j,k) = dimag(ff) - - enddo - enddo - enddo - - return - - end subroutine get_exact_eth2omega -#endif -#endif + + +#include "macrodef.fh" + + subroutine get_initial_nbhs_null(ex,crho,sigma,x,RJ,IJ,omega,sst,Rmin) + + implicit none +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),sst + real*8,intent(in ) :: Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::x + double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::RJ,IJ,omega + +!~~~~~~> Other variables: + real*8 :: xe + real*8,dimension(ex(1),ex(2)) :: RJe,IJe + integer :: k + + xe = x(1) + RJe = RJ(:,:,1) + IJe = IJ(:,:,1) + + do k=1,ex(3) + RJ(:,:,k) = RJe*(1.d0-x(k))*xe/(1-xe)/x(k) + IJ(:,:,k) = IJe*(1.d0-x(k))*xe/(1-xe)/x(k) + enddo + + omega = 1.d0 + + return + + end subroutine get_initial_nbhs_null +!----------------------------------- +!Eq.(10) of CQG 24, S327 (2007) +!---------------------------------- + function Zslm(s,l,m,the,phi) result(gont) + implicit none + integer,intent(in) :: s,l,m + real*8,intent(in) :: the,phi + + double complex :: Yslm,gont,II + + II=dcmplx(0.d0,1.d0) + + if(m>0)then + gont = Yslm(s,l,m,the,phi) + if(m/2*2==m)then + gont = gont+Yslm(s,l,-m,the,phi) + else + gont = gont-Yslm(s,l,-m,the,phi) + endif + gont = gont/dsqrt(2.d0) + elseif(m<0)then + gont = -Yslm(s,l,-m,the,phi) + if(m/2*2==m)then + gont = gont+Yslm(s,l,m,the,phi) + else + gont = gont-Yslm(s,l,m,the,phi) + endif + gont = II*gont/dsqrt(2.d0) + else + gont = Yslm(s,l,m,the,phi) + endif + + return + + end function Zslm + +!#define SCH + +#ifdef SCH + +subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ + +RJ = 0.d0 +IJ = 0.d0 + +return + +end subroutine get_initial_null +!------------------------- + subroutine get_null_boundary(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + + integer :: k + k=1 + + beta(:,:,k) = 0.d0 + W(:,:,k) =-2.d0/R(k)**2/Rmin**2*(1.d0-R(k))**2 + + RQ(:,:,k) = 0.d0 + IQ(:,:,k) = 0.d0 + + RTheta(:,:,k) = 0.d0 + ITheta(:,:,k) = 0.d0 + + RU(:,:,k) = 0.d0 + IU(:,:,k) = 0.d0 + + return + + end subroutine get_null_boundary +!------------------------------------------------------------- +subroutine get_exact_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,T +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +RJ = 0.d0 +IJ = 0.d0 + +return + +end subroutine get_exact_null +!------------------------------------------------------------------------------------------- + subroutine get_null_boundary_c(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + + integer :: k + + do k=1,ex(3) + + beta(:,:,k) = 0.d0 + W(:,:,k) =-2.d0/R(k)**2/Rmin**2*(1.d0-R(k))**2 + + RQ(:,:,k) = 0.d0 + IQ(:,:,k) = 0.d0 + + RTheta(:,:,k) = 0.d0 + ITheta(:,:,k) = 0.d0 + + RU(:,:,k) = 0.d0 + IU(:,:,k) = 0.d0 + enddo + + return + + end subroutine get_null_boundary_c + +#else + +#if 0 +! for some trival check +#if 1 +!------------------------------------------------------------- +! Linear wave given in CQG 24S327 +!------------------------------------------------------------- +subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ + +integer :: i,j,k +real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma +double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + gr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3 + gr = dreal(Jr) + Jr = Yslm(0,2,m,gt,gp) + RJ(i,j,k) = gr*dreal(Jr) + IJ(i,j,k) = gr*dimag(Jr) + +#if 0 + RJ(i,j,k) = 0.25d0*dsqrt(5.d0/3.1415926)*(3/(1.d0+tgrho*tgrho+tgsigma*tgsigma)-1.d0) + IJ(i,j,k) = 0.d0 +#endif + enddo + enddo + enddo + +return + +end subroutine get_initial_null +#else +! for check usage +subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ + +real*8 :: thetac,thetas,sr,ss,cr,cs,srss,crcs,tcts,tcts2 +real*8 :: sr2,ss2,cr2,cs2,tc2,ts2 +integer :: i,j,k +real*8 :: ggr,tgrho,tgsigma + +real*8 :: PI + +PI = dacos(-1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + srss = sr*ss + crcs = cr*cs + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + thetac = dsqrt((1.d0-srss)/2.d0) + thetas = dsqrt((1.d0+srss)/2.d0) + tc2 = thetac*thetac + ts2 = thetas*thetas + tcts = thetac*thetas + tcts2 = tcts*tcts +! q^Aq^B@_A@_B Y20 + RJ(i,j,k) =-1.5d0*dsqrt(5.d0/PI)*sr*ss*(4.d0*cr2*cs2+cs2+cr2) + IJ(i,j,k) = 3.d0*dsqrt(5.d0/PI)*thetac*thetas*(cs2-cr2) + +! @_rho@_rho Y20 + RJ(i,j,k) = 1.5d0*dsqrt(5.d0/PI)*cs2*cs2*(-cr2*cs2+2*cr2*cr2*cs2-2*cr2*cr2-cs2+3*cr2) & + /(3*cr2*cs2*cs2*cs2-3*cr2*cr2*cr2*cs2*cs2-3*cr2*cr2*cs2*cs2*cs2+ & + cr2*cr2*cr2*cs2*cs2*cs2-3*cr2*cr2*cs2-cs2*cs2*cs2-cr2*cr2*cr2+ & + 3*cs2*cr2*cr2*cr2+6*cr2*cr2*cs2*cs2-3*cs2*cs2*cr2) + IJ(i,j,k) = 0.d0 +! q^Aq^B h_AB + RJ(i,j,k) = 0.d0 + IJ(i,j,k) = 0.d0 + enddo + enddo + enddo + +return + +end subroutine get_initial_null +#endif +#endif +!====================================================================================== +!------------------------------------------------------------- +! Linear wave given in CQG 24S327 +!------------------------------------------------------------- +subroutine get_initial_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ + +integer :: i,j,k +real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts +double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +double complex :: swtf,ff + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + gr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3 + gr = dreal(Jr) + Jr = Yslm(2,2,m,gt,gp) + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*gr*Jr*swtf**2 + RJ(i,j,k) = dreal(ff) + IJ(i,j,k) = dimag(ff) + + enddo + enddo + enddo + +return + +end subroutine get_initial_null +!============================================================================================== + +#if 0 +! for checking derivs_eth and dderivs_eth +!------------------------- + subroutine get_null_boundary(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + + double complex,dimension(ex(1),ex(2)) :: Y20,dY20,ddY20,f + integer :: i,j,k + real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma + double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + k=1 + do i=1,ex(1) + do j=1,ex(2) +! fake global coordinate is enough + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + RTheta(i,j,k) = dreal(Jr*nu*(II*dcos(nu*T)-dsin(nu*T))) + f(i,j) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& + +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 + RU(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + +! Re(r^2*Ul_,r*exp(i nu T)) of CQG 24S327, (12) indeed + Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 + RQ(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& + -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 + W(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Y20(i,j) = Yslm(0,2,m,gt,gp) + + enddo + enddo + + call derivs_eth(ex(1:2),crho,sigma,Y20,dY20,0,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call dderivs_eth(ex(1:2),crho,sigma,Y20,ddY20,0,1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k),& + dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & + bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & + dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k)) + + beta(:,:,k) = dreal(beta0*(dcos(nu*T)+II*dsin(nu*T)))*dreal(Y20) + W(:,:,k) = W(:,:,k)*dreal(Y20) + + f = dexp(-2.d0*beta(:,:,k))*(f*ddY20*RQ(:,:,k)*dconjg(dY20)+dsqrt(1.d0+abs(f*ddY20))*RQ(:,:,k)*dY20) + RQ(:,:,k) = dreal(f) + IQ(:,:,k) = dimag(f) + + f = ddY20*RTheta(:,:,k) + RTheta(:,:,k) = dreal(f) + ITheta(:,:,k) = dimag(f) + + f = dY20*RU(:,:,k) + RU(:,:,k) = dreal(f) + IU(:,:,k) = dimag(f) + + return + + end subroutine get_null_boundary +#else +!------------------------- + subroutine get_null_boundary(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + k=1 + do i=1,ex(1) + do j=1,ex(2) +! fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*nu*(II*dcos(nu*T)-dsin(nu*T))) + Jr = Yslm(2,2,m,gt,gp) + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr*swtf**2 + RTheta(i,j,k) = dreal(ff) + ITheta(i,j,k) = dimag(ff) + + rf = dreal(Yslm(0,2,m,gt,gp)) + beta(i,j,k) = rf*dreal(beta0*(dcos(nu*T)+II*dsin(nu*T))) + Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& + -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 + W(i,j,k) = rf*dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& + +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 + rf = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + Jr = Yslm(1,2,m,gt,gp) + ff = dsqrt(dble(2*(2+1)))*rf*Jr*swtf + RU(i,j,k) = dreal(ff) + IU(i,j,k) = dimag(ff) + + Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 + rf = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + Jr = Yslm(1,2,m,gt,gp) + ff = dsqrt(dble(2*(2+1)))*rf*Jr*swtf !! U_,r + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + Jr = Yslm(2,2,m,gt,gp) + Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr*swtf**2 !! J + rf = dsqrt(1.d0+abs(Jr)**2) !! K + ff = dexp(-2.d0*beta(i,j,k))*(Jr*dconjg(ff)+rf*ff) + RQ(i,j,k) = dreal(ff) + IQ(i,j,k) = dimag(ff) + + enddo + enddo + + return + + end subroutine get_null_boundary + +#endif + +#if 0 +! for checking dderivs_eth +!------------------------------------------------------------- +! Linear wave given in CQG 24S327 +!------------------------------------------------------------- +subroutine get_exact_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,T +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +double complex,dimension(ex(1),ex(2)) :: Y20,ddY20,f +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma +double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_null: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + Y20(i,j) = Yslm(0,2,m,gt,gp) + RJ(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + IJ(i,j,k) = 0.d0 + + enddo + enddo + enddo + + k=1 + call dderivs_eth(ex(1:2),crho,sigma,Y20,ddY20,0,1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k),& + dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & + bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & + dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k)) + + do k=1,ex(3) + f = ddY20*RJ(:,:,k) + RJ(:,:,k) = dreal(f) + IJ(:,:,k) = dimag(f) + enddo + +return + +end subroutine get_exact_null + +#else +!------------------------------------------------------------- +! Linear wave given in CQG 24S327 +!------------------------------------------------------------- +subroutine get_exact_null(ex,crho,sigma,R,RJ,IJ,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,T +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RJ,IJ +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_null: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + hgr = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + Jr = Yslm(2,2,m,gt,gp) + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*hgr*Jr*swtf**2 + RJ(i,j,k) = dreal(ff) + IJ(i,j,k) = dimag(ff) + enddo + enddo + enddo + +return + +end subroutine get_exact_null + +#endif + +#if 0 +! for checking derivs_eth and dderivs_eth +!------------------------- + subroutine get_null_boundary_c(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + + double complex,dimension(ex(1),ex(2)) :: Y20,dY20,ddY20,f + integer :: i,j,k + real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma + double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + +! write(*,*) abs(II) confirms abs == cabs + + do k=1,ex(3) + do i=1,ex(1) + do j=1,ex(2) +! fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary_c: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + RTheta(i,j,k) = dreal(Jr*nu*(II*dcos(nu*T)-dsin(nu*T))) + f(i,j) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& + +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 + RU(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + +! Re(r^2*Ul_,r*exp(i nu T)) of CQG 24S327, (12) indeed + Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 + RQ(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& + -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 + W(i,j,k) = dreal(Jr*(dcos(nu*T)+II*dsin(nu*T))) + + Y20(i,j) = Yslm(0,2,m,gt,gp) + + enddo + enddo + + call derivs_eth(ex(1:2),crho,sigma,Y20,dY20,0,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call dderivs_eth(ex(1:2),crho,sigma,Y20,ddY20,0,1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k),& + dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & + bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & + dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k)) + + beta(:,:,k) = dreal(beta0*cdexp(II*nu*T))*dreal(Y20) + W(:,:,k) = W(:,:,k)*dreal(Y20) + + f = dexp(-2.d0*beta(:,:,k))*(f*ddY20*RQ(:,:,k)*dconjg(dY20)+dsqrt(1.d0+abs(f*ddY20))*RQ(:,:,k)*dY20) + RQ(:,:,k) = dreal(f) + IQ(:,:,k) = dimag(f) + + f = ddY20*RTheta(:,:,k) + RTheta(:,:,k) = dreal(f) + ITheta(:,:,k) = dimag(f) + + f = dY20*RU(:,:,k) + RU(:,:,k) = dreal(f) + IU(:,:,k) = dimag(f) + enddo + + return + + end subroutine get_null_boundary_c + +#else + +!------------------------- + subroutine get_null_boundary_c(ex,crho,sigma,R,beta,RQ,IQ,RU,IU,W,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,RQ,IQ,RU,IU + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: W,RTheta,ITheta + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + +#if 0 +real*8 :: betax,KK,KKx,Wx +double complex :: CJ,DCJ,CJx,CJxx,DCJx,CU,CUx,DCU,DCUx,bDCU,bDCUx,CB,DCB,bDCB,CBx +double complex :: Cnu,Cnux,Ck,fCTheta,fCThetax,Theta_rhs + + +T=0.25d0 + i=1 + j=1 + k=1 + hgr = 1.d0 + beta(i,j,k) = dreal(beta0*cdexp(II*nu*T)) + CB = beta(i,j,k) + DCB = CB + bDCB = CB + betax = 0.d0 + Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr& + -nu*nu*C2/hgr/hgr+II*nu*C2/hgr**3+C2/2.d0/hgr**4 + W(i,j,k) = dreal(Jr*cdexp(II*nu*T)) + Jr = -(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr**2& + +2.d0*nu*nu*C2/hgr**3-3.d0*II*nu*C2/hgr**4-2.d0*C2/hgr**5 + Wx = dreal(Jr*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/hgr-C2/1.2d1/hgr**3 + CJ = dreal(Jr*cdexp(II*nu*T)) + fCTheta = dreal(Jr*II*nu*cdexp(II*nu*T)) + DCJ=CJ + KK = dsqrt(1.d0+cdabs(CJ)**2) + Jr = -C1/4.d0/hgr**2+C2/4.d0/hgr**4 + rf = dreal(Jr*cdexp(II*nu*T)) + CJx = rf*(Rmin+hgr)**2/Rmin + fCThetax = dreal(Jr*II*nu*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin + Jr = C1/2.d0/hgr**3-C2/hgr**5 + rf = dreal(Jr*cdexp(II*nu*T)) + CJxx = rf*(Rmin+hgr)**4/Rmin**2+2.d0*(Rmin+hgr)/Rmin*CJx + DCJx = CJx + KKx = dreal(CJ*dconjg(CJx))/KK + Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0/hgr& + +C1/2.d0/hgr/hgr+II*nu*C2/3.d0/hgr**3+C2/4.d0/hgr**4 + CU = dreal(Jr*cdexp(II*nu*T)) + bDCU = CU + DCU=CU + Jr = -2.d0*beta0/hgr/hgr-C1/hgr**3-II*nu*C2/hgr**4-C2/hgr**5 + rf = dreal(Jr*cdexp(II*nu*T)) + CUx = rf*(Rmin+hgr)**2/Rmin + DCUx=CUx + bDCUx=CUx + + Cnu = CJ + Cnux = CJx + Ck = 0.d0 + hgr = hgr/(Rmin+hgr) + + + call getndxs(T,crho(i),sigma(j),hgr,beta(i,j,k),KK,CU,bDCU,DCU, & + CB,DCB,W(i,j,k),CJ,DCJ,bDCB,Cnu,Ck,fCTheta,sst,Rmin) + call getdxs(T,crho(i),sigma(j),hgr,betax,KKx,CUx,DCUx,bDCUx, & + Wx,CJx,CJxx,DCJx,Cnux,fCThetax,sst,Rmin) +! write(*,*) 2.d0*hgr*(1.d0-hgr)*fCThetax-(-(hgr*(1-hgr)*DCUx+2.d0*DCU)+2.d0/hgr/Rmin*(1.d0-hgr)*DCB & +! +(1.d0-hgr)**3/Rmin*(2.d0*CJx+hgr*CJxx)-2.d0*fCTheta) +! stop + write(*,*) fCThetax-Theta_rhs(hgr,Rmin,beta(i,j,k),betax,KK,KKx,CU,CUx,DCUx,bDCU,bDCUx, & + DCU,CB,DCB,W(i,j,k),Wx,CJ,DCJ, & + CJx,CJxx,DCJx,bDCB,Cnu,Cnux,Ck,fCTheta) + stop +#endif + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*nu*II*cdexp(II*nu*T)) + Jr = Yslm(2,2,m,gt,gp)*swtf**2 + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr + RTheta(i,j,k) = dreal(ff) + ITheta(i,j,k) = dimag(ff) + + rf = dreal(Yslm(0,2,m,gt,gp)) + beta(i,j,k) = rf*dreal(beta0*cdexp(II*nu*T)) + Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0*hgr& + -nu*nu*C2*hgr*hgr+II*nu*C2*hgr**3+C2/2.d0*hgr**4 + W(i,j,k) = rf*dreal(Jr*cdexp(II*nu*T)) + + Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0*hgr& + +C1/2.d0*hgr*hgr+II*nu*C2/3.d0*hgr**3+C2/4.d0*hgr**4 + rf = dreal(Jr*cdexp(II*nu*T)) + Jr = Yslm(1,2,m,gt,gp)*swtf + ff = dsqrt(dble(2*(2+1)))*rf*Jr + RU(i,j,k) = dreal(ff) + IU(i,j,k) = dimag(ff) + + Jr = -2.d0*beta0-C1*hgr-II*nu*C2*hgr**2-C2*hgr**3 + rf = dreal(Jr*cdexp(II*nu*T)) + Jr = Yslm(1,2,m,gt,gp)*swtf + ff = dsqrt(dble(2*(2+1)))*rf*Jr !! U_,r + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*cdexp(II*nu*T)) + Jr = Yslm(2,2,m,gt,gp)*swtf**2 + Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr !! J + rf = dsqrt(1.d0+cdabs(Jr)**2) !! K + ff = dexp(-2.d0*beta(i,j,k))*(Jr*dconjg(ff)+rf*ff) + RQ(i,j,k) = dreal(ff) + IQ(i,j,k) = dimag(ff) + + enddo + enddo + enddo + + return + + end subroutine get_null_boundary_c +#endif + +!========================================================== +subroutine initial_null_paramter(beta0,C1,C2,nu,m) + +implicit none + +double complex,intent(out) :: beta0,C1,C2 +integer,intent(out) :: nu,m + +nu=1 +m=0 +beta0 = dcmplx(0.d0,1.d-6) +C1 = dcmplx(3.d-6,0.d0) +C2 = dcmplx(1.d-6,0.d0) + +end subroutine initial_null_paramter + +#if 1 +subroutine get_exact_null_theta(ex,crho,sigma,R,RTheta,ITheta,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,T +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RTheta,ITheta +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_null_theta: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + hgr = dreal(Jr*nu*(-dsin(nu*T)+II*dcos(nu*T))) + Jr = Yslm(2,2,m,gt,gp) + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*hgr*Jr*swtf**2 + RTheta(i,j,k) = dreal(ff) + ITheta(i,j,k) = dimag(ff) + + enddo + enddo + enddo + +return + +end subroutine get_exact_null_theta +!------------------------------------------------------------------------------------------------ +subroutine get_exact_null_theta_x(ex,crho,sigma,R,RThetax,IThetax,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,T +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RThetax,IThetax +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 +real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_null_theta_x: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = C1/4.d0-C2/1.2d1*3*hgr**2 + Jr = -Jr/Rmin/R(k)/R(k) + hgr = dreal(Jr*nu*(-dsin(nu*T)+II*dcos(nu*T))) + Jr = Yslm(2,2,m,gt,gp) + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*hgr*Jr*swtf**2 + RThetax(i,j,k) = dreal(ff) + IThetax(i,j,k) = dimag(ff) + + enddo + enddo + enddo + +return + +end subroutine get_exact_null_theta_x +!------------------------- + subroutine get_exact_Jul(ex,crho,sigma,R,RJul,IJul, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RJul,IJul + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_Jul: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = C1/4.d0-C2/4.d0*hgr**2 + rf = dreal(Jr*nu*II*cdexp(II*nu*T)) + Jr = Yslm(2,2,m,gt,gp)*swtf**2 + ff = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr + RJul(i,j,k) = dreal(ff) + IJul(i,j,k) = dimag(ff) + + enddo + enddo + enddo + + return + + end subroutine get_exact_Jul +!------------------------- + subroutine get_fake_Ju(ex,crho,sigma,R,RJul,IJul, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RJul,IJul + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_fake_Ju: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*nu*II*cdexp(II*nu*T)) + ff = dcmplx(rf,0.d0) + RJul(i,j,k) = dreal(ff) + IJul(i,j,k) = dimag(ff) + + enddo + enddo + enddo + +if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then + write(*,*)"T=",T,"exp(i T)=",cdexp(II*nu*T) + write(*,*)RJul(ex(1)/2,ex(2)/2,ex(3)),RJul(ex(1)/2,ex(2)/2,ex(3)-1),R(2)-R(1) +endif + + return + + end subroutine get_fake_Ju +!------------------------- + subroutine get_exact_omegau(ex,crho,sigma,R,omegau, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: omegau + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_omegau: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*nu*II*cdexp(II*nu*T)) + Jr = Yslm(0,2,m,gt,gp) + ff = -dble(2*(2+1))/2.d0*rf*Jr + omegau(i,j,k) = dreal(ff) + + enddo + enddo + enddo + + return + + end subroutine get_exact_omegau +!------------------------- + subroutine get_exact_eth2omega(ex,crho,sigma,R,Reth2omega,Ieth2omega, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: T,Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: Reth2omega,Ieth2omega + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: quR1,quR2,quI1,quI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: qlR1,qlR2,qlI1,qlI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + +double complex :: beta0,C1,C2 +integer :: nu,m + + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + hgr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_eth2omega: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + hgr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*hgr-C2/1.2d1*hgr**3 + rf = dreal(Jr*cdexp(II*nu*T)) + Jr = Yslm(2,2,m,gt,gp) + ff = -dble(2*(2+1))/2.d0*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*rf*Jr + Reth2omega(i,j,k) = dreal(ff) + Ieth2omega(i,j,k) = dimag(ff) + + enddo + enddo + enddo + + return + + end subroutine get_exact_eth2omega +#endif +#endif diff --git a/AMSS_NCKU_source/initial_null.h b/AMSS_NCKU_source/Initial_Data_Solver/initial_null.h similarity index 97% rename from AMSS_NCKU_source/initial_null.h rename to AMSS_NCKU_source/Initial_Data_Solver/initial_null.h index 36d11fd..e632260 100644 --- a/AMSS_NCKU_source/initial_null.h +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_null.h @@ -1,100 +1,100 @@ - -#ifndef INITIAL_NULL_H -#define INITIAL_NULL_H - -#ifdef fortran1 -#define f_get_initial_nbhs_null get_initial_nbhs_null -#define f_get_initial_null get_initial_null -#define f_get_exact_null get_exact_null -#define f_get_exact_null_theta get_exact_null_theta -#define f_get_null_boundary get_null_boundary -#define f_get_null_boundary_c get_null_boundary_c -#define f_get_exact_omegau get_exact_omegau -#endif -#ifdef fortran2 -#define f_get_initial_nbhs_null GET_INITIAL_NBHS_NULL -#define f_get_initial_null GET_INITIAL_NULL -#define f_get_exact_null GET_EXACT_NULL -#define f_get_exact_null_theta GET_EXACT_NULL_THETA -#define f_get_null_boundary GET_NULL_BOUNDARY -#define f_get_null_boundary_c GET_NULL_BOUNDARY_C -#define f_get_exact_omegau GET_EXACT_OMEGAU -#endif -#ifdef fortran3 -#define f_get_initial_nbhs_null get_initial_nbhs_null_ -#define f_get_initial_null get_initial_null_ -#define f_get_exact_null get_exact_null_ -#define f_get_exact_null_theta get_exact_null_theta_ -#define f_get_null_boundary get_null_boundary_ -#define f_get_null_boundary_c get_null_boundary_c_ -#define f_get_exact_omegau get_exact_omegau_ -#endif - -extern "C" -{ - void f_get_initial_nbhs_null(int *, double *, double *, double *, - double *, double *, double *, - int &, double &); -} - -extern "C" -{ - void f_get_initial_null(int *, double *, double *, double *, - double *, double *, - int &, double &); -} - -extern "C" -{ - void f_get_null_boundary(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double &, double &, int &); -} - -extern "C" -{ - void f_get_null_boundary_c(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double &, double &, int &); -} - -extern "C" -{ - void f_get_exact_null(int *, double *, double *, double *, - double *, double *, int &, double &, double &, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *); -} - -extern "C" -{ - void f_get_exact_null_theta(int *, double *, double *, double *, - double *, double *, int &, double &, double &, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *); -} - -extern "C" -{ - void f_get_exact_omegau(int *, double *, double *, double *, - double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double &, double &, int &); -} - -#endif /* INITIAL_NULL_H */ + +#ifndef INITIAL_NULL_H +#define INITIAL_NULL_H + +#ifdef fortran1 +#define f_get_initial_nbhs_null get_initial_nbhs_null +#define f_get_initial_null get_initial_null +#define f_get_exact_null get_exact_null +#define f_get_exact_null_theta get_exact_null_theta +#define f_get_null_boundary get_null_boundary +#define f_get_null_boundary_c get_null_boundary_c +#define f_get_exact_omegau get_exact_omegau +#endif +#ifdef fortran2 +#define f_get_initial_nbhs_null GET_INITIAL_NBHS_NULL +#define f_get_initial_null GET_INITIAL_NULL +#define f_get_exact_null GET_EXACT_NULL +#define f_get_exact_null_theta GET_EXACT_NULL_THETA +#define f_get_null_boundary GET_NULL_BOUNDARY +#define f_get_null_boundary_c GET_NULL_BOUNDARY_C +#define f_get_exact_omegau GET_EXACT_OMEGAU +#endif +#ifdef fortran3 +#define f_get_initial_nbhs_null get_initial_nbhs_null_ +#define f_get_initial_null get_initial_null_ +#define f_get_exact_null get_exact_null_ +#define f_get_exact_null_theta get_exact_null_theta_ +#define f_get_null_boundary get_null_boundary_ +#define f_get_null_boundary_c get_null_boundary_c_ +#define f_get_exact_omegau get_exact_omegau_ +#endif + +extern "C" +{ + void f_get_initial_nbhs_null(int *, double *, double *, double *, + double *, double *, double *, + int &, double &); +} + +extern "C" +{ + void f_get_initial_null(int *, double *, double *, double *, + double *, double *, + int &, double &); +} + +extern "C" +{ + void f_get_null_boundary(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double &, double &, int &); +} + +extern "C" +{ + void f_get_null_boundary_c(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double &, double &, int &); +} + +extern "C" +{ + void f_get_exact_null(int *, double *, double *, double *, + double *, double *, int &, double &, double &, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *); +} + +extern "C" +{ + void f_get_exact_null_theta(int *, double *, double *, double *, + double *, double *, int &, double &, double &, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *); +} + +extern "C" +{ + void f_get_exact_omegau(int *, double *, double *, double *, + double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double &, double &, int &); +} + +#endif /* INITIAL_NULL_H */ diff --git a/AMSS_NCKU_source/initial_null2.f90 b/AMSS_NCKU_source/Initial_Data_Solver/initial_null2.f90 similarity index 96% rename from AMSS_NCKU_source/initial_null2.f90 rename to AMSS_NCKU_source/Initial_Data_Solver/initial_null2.f90 index 3489e3b..87a4f49 100644 --- a/AMSS_NCKU_source/initial_null2.f90 +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_null2.f90 @@ -1,1320 +1,1320 @@ - - -#include "macrodef.fh" - -subroutine get_RT_parameters(m0o,Pp0o,Pm0o,apo,amo,bpo,bmo,cpo,cmo,gamo) -implicit none -real*8,intent(out) :: m0o,Pp0o,Pm0o,apo,amo,bpo,bmo,cpo,cmo,gamo - -real*8,parameter::m0=1.d0,Pp0=1.d0,Pm0=1.d0,ap=1.d0,am=1.d0 -real*8,parameter::bp=0.d0,bm=0.d0,cp=0.d0,cm=0.d0 -real*8,parameter::gam=0.5d0 - -m0o = m0 -Pp0o = Pp0 -Pm0o = Pm0 -apo = ap -amo = am -bpo = bp -bmo = bm -cpo = cp -cmo = cm -gamo = gam -end subroutine get_RT_parameters -!!!--------------------------------------------------------------------------------------------- - function boostbhP(P0,gam,a,b,c,gt,gp) result(gont) - implicit none - -!~~~~~~> Input parameters: - - real*8, intent(in ):: P0,gam,a,b,c,gt,gp - - real*8::gont - - gont = dcosh(gam)+a*dsinh(gam)*dcos(gt)+dsinh(gam)*dsin(gt)*(b*dcos(gp)+c*dsin(gp)) - - gont = P0*gont - - end function boostbhP -!!!!------------------------------------------------------------------------------------------- -#if 1 -!! RT ID -subroutine get_initial_null2(ex,crho,sigma,XX,g22,g23,g33,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::XX -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g22,g23,g33 - -double precision,dimension(ex(3))::R -real*8 :: sr,ss,cr,cs -real*8 :: sr2,ss2,cr2,cs2 -integer :: i,j,k -real*8 :: ggr,tgrho,tgsigma -real*8 ::x,y,z,gr,gt,gp -real*8,dimension(ex(1),ex(2),ex(3))::P - -real*8 :: PI - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -real*8::boostbhP - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = XX*Rmin/(1-XX) - -PI = dacos(-1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - g22(i,j,k) = 1-sr2*ss2 - g22(i,j,k) = 1/g22(i,j,k)/g22(i,j,k) - - g23(i,j,k) = -sr*cr*ss*cs*g22(i,j,k) - g33(i,j,k) = cr2*g22(i,j,k) - g22(i,j,k) = cs2*g22(i,j,k) - -! we want g_AB/r^2 instead of g_AB -! g22(i,j,k) = R(k)*R(k)*g22(i,j,k) -! g23(i,j,k) = R(k)*R(k)*g23(i,j,k) -! g33(i,j,k) = R(k)*R(k)*g33(i,j,k) - -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null2: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - P(i,j,k) = 1/(1/dsqrt(boostbhP(Pp0,gam,ap,bp,cp,gt,gp))+1/dsqrt(boostbhP(Pm0,gam,am,bm,cm,gt,gp)))**2 - - enddo - enddo - enddo - - g22 = g22/P**2 - g23 = g23/P**2 - g33 = g33/P**2 - -return - -end subroutine get_initial_null2 -#else -!! fake RT for test -subroutine get_initial_null2(ex,crho,sigma,XX,g22,g23,g33,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::XX -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g22,g23,g33 - -double precision,dimension(ex(3))::R -real*8 :: sr,ss,cr,cs -real*8 :: sr2,ss2,cr2,cs2 -integer :: i,j,k -real*8 :: ggr,tgrho,tgsigma -real*8 ::x,y,z,gr,gt,gp -real*8,dimension(ex(1),ex(2),ex(3))::P - -real*8 :: PI - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -real*8::boostbhP - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = XX*Rmin/(1-XX) - -PI = dacos(-1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - g22(i,j,k) = 1-sr2*ss2 - g22(i,j,k) = 1/g22(i,j,k)/g22(i,j,k) - - g23(i,j,k) = -sr*cr*ss*cs*g22(i,j,k) - g33(i,j,k) = cr2*g22(i,j,k) - g22(i,j,k) = cs2*g22(i,j,k) - -! we want g_AB/r^2 instead of g_AB -! g22(i,j,k) = R(k)*R(k)*g22(i,j,k) -! g23(i,j,k) = R(k)*R(k)*g23(i,j,k) -! g33(i,j,k) = R(k)*R(k)*g33(i,j,k) - -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null2: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - P(i,j,k) = 1/(1/dsqrt(boostbhP(Pp0,gam,ap,bp,cp,gt,gp))+1/dsqrt(boostbhP(Pm0,gam,am,bm,cm,gt,gp)))**2 - - enddo - enddo - enddo - - g22 = P - -return - -end subroutine get_initial_null2 -#endif -!!------------------------------------------------------------------------------------------------------------ -subroutine std_covdiff(rho,sigma,fs,fr,fss,frr,frs,covf) -implicit none -! argument variables -real*8,intent(in) :: rho,sigma,fs,fr,fss,frr,frs -real*8,intent(out):: covf - -real*8 :: t1,t2,t3,t4,t5,t6,t7,t8,t11,t12,t13,t15,t16,t19,t20 -real*8 :: t27,t28,t29,t32,t33,t34,t38,t39,t51,t54,t55,t58,t59 -real*8 :: t62,t71,t72,t88,t90,t91,t92,t93,t94,t95,t97,t98,t99 -real*8 :: t100,t104,t107,t108,t109,t112,t113,t117,t118,t121,t128,t132,t133,t136,t137,t140,t141 -real*8 :: t144,t152,t153,t154,t155,t160,t166,t169,t172,t175,t178,t181,t187,t199,t204,t205,t208 -real*8 :: t209,t216,t217,t223,t226,t227,t243,t250,t256,t267,t276,t284,t287,t290,t301,t303,t306 -real*8 :: t307,t310,t313,t314,t316,t319,t323,t326,t329,t338,t346,t356,t359,t368,t371,t376,t377 -real*8 :: t380,t385,t387,t391,t394,t398,t401,t404,t407,t412,t415,t420,t427,t450,t451,t456,t459 -real*8 :: t486,t487,t511,t516,t522,t532,t537,t546,t575,t586,t591,t595,t599,t295,t298 - - t1 = cos(sigma); - t2 = t1*t1; - t3 = t2*t2; - t4 = t3*t2; - t5 = t4*fss; - t6 = 2.0*sigma; - t7 = cos(t6); - t8 = t7*t7; - t11 = cos(rho); - t12 = t11*t11; - t13 = t12*t11; - t15 = sin(rho); - t16 = fr*t15; - t19 = t12*t12; - t20 = t19*t13; - t27 = t19*t11; - t28 = t27*fr; - t29 = t15*t8; - t32 = 2.0*rho; - t33 = cos(t32); - t34 = t33*t33; - t38 = t11*fr; - t39 = t15*t3; - t51 = t19*frr; - t54 = t19*t12; - t55 = t54*frr; - t58 = -2.0*t5*t8-8.0*t2*t13*t16-64.0*t3*t20*t16+32.0*t4*t20*t16+4.0*t28*t29 & - +4.0*t28*t15*t34-4.0*t38*t39+8.0*t3*t13*t16+32.0*t4*t13*t16+8.0*t2*t27*t16 & - +4.0*t51*t2-2.0*t55*t34; - t59 = t3*fss; - t62 = t12*frr; - t71 = t19*t19; - t72 = t71*frr; - t88 = -32.0*t59*t54+2.0*t62*t3-2.0*t55*t8+64.0*t55*t4-2.0*t5*t34-32.0*t72*t2 & - +64.0*t72*t3-32.0*t72*t4-4.0*t55*t2-4.0*t51*t3-62.0*t55*t3+60.0*t3*t27*t16; - t90 = sin(t32); - t91 = sin(t6); - t92 = t90*t91; - t93 = t92*frs; - t94 = t3*t8; - t95 = t94*t34; - t97 = t3*t1; - t98 = t97*fs; - t99 = sin(sigma); - t100 = t98*t99; - t104 = t2*fss; - t107 = t54*fr; - t108 = t90*t33; - t109 = t108*t2; - t112 = t19*t8; - t113 = t112*t34; - t117 = t12*fr; - t118 = t108*t3; - t121 = t12*t3; - t128 = t19*t2; - t132 = t3*t3; - t133 = t132*fss; - t136 = t93*t95-4.0*t100-32.0*t51*t4+2.0*t104*t19+8.0*t107*t109+t93*t113-62.0*t5*t19 & - -4.0*t117*t118+2.0*t93*t121*t8+32.0*t2*t20*t16+2.0*t93*t128*t8-32.0*t133*t12; - t137 = t3*t19; - t140 = t2*t8; - t141 = t140*t34; - t144 = t8*t34; - t152 = t107*t91; - t153 = t90*t99; - t154 = t2*t1; - t155 = t153*t154; - t160 = t33*t3*t8; - t166 = frs*t19; - t169 = t19*fr; - t172 = frs*t3; - t175 = t107*t90; - t178 = -t93*t137*t8-4.0*t55*t141-2.0*t93*t128*t144+2.0*t62*t95+t93*t137*t144+16.0*t152*t155 & - +4.0*t117*t90*t160+4.0*t107*t108*t8-t92*t166*t8+8.0*t169*t118-t92*t172*t34+4.0*t175*t160; - t181 = t169*t90; - t187 = t33*t2*t8; - t199 = frs*t2; - t204 = fs*t3*t154; - t205 = t19*t99; - t208 = fs*t154; - t209 = t54*t99; - t216 = -8.0*t181*t160-4.0*t107*t118-8.0*t175*t187-t93*t137*t34+4.0*t51*t141+2.0*t93*t128*t34 & - -4.0*t51*t95+2.0*t92*t199*t12-64.0*t204*t205+32.0*t208*t209-64.0*t98*t209+32.0*t204*t209; - t217 = t99*t8; - t223 = t1*fs; - t226 = t4*fs; - t227 = t91*t7; - t243 = t12*t99; - t250 = 4.0*t98*t217+4.0*t98*t99*t34-4.0*t223*t205-4.0*t226*t227-64.0*t4*t27*t16+2.0*t93*t121*t34 & - -t92*t166*t34-2.0*t93*t121*t144+8.0*t208*t205+8.0*t98*t243+60.0*t98*t205+32.0*t204*t243; - t256 = t2*t34; - t267 = t3*t34; - t276 = -8.0*t208*t243+t92*t172+t92*t166-4.0*t51*t256-4.0*t51*t140+4.0*t51*t94+2.0*t55*t144 & - -2.0*t62*t94-2.0*t62*t267-2.0*t55*t94+4.0*t55*t140+4.0*t51*t267; - t284 = fs*t91*t33; - t287 = t243*t34; - t290 = t205*t34; - t295 = fs*t27*t15; - t298 = t92*t4; - t301 = t92*t3; - t303 = fs*t13*t15; - t306 = t208*t99; - t307 = t144*t12; - t310 = t227*t19; - t313 = t3*fs; - t314 = t313*t91; - t316 = t7*t19*t34; - t319 = 4.0*t55*t256-2.0*t55*t267+2.0*t55*t95-32.0*t137*t284-8.0*t98*t287+4.0*t98*t290 & - -8.0*t92*t2*t295-8.0*t298*t295-16.0*t301*t303-8.0*t306*t307-4.0*t226*t310-8.0*t314*t316; - t323 = t217*t12; - t326 = t227*t12; - t329 = t226*t91; - t338 = t7*t12*t34; - t346 = t2*fs; - t356 = 8.0*t208*t323+8.0*t226*t326+4.0*t329*t316+8.0*t208*t287+4.0*t226*t227*t34+8.0*t314*t338 & - -16.0*t92*t199*t54-8.0*t329*t338-4.0*t346*t310+8.0*t313*t310-8.0*t313*t326+4.0*t346*t91*t316; - t359 = t205*t8; - t368 = t153*t97; - t371 = t169*t91; - t376 = t13*fr; - t377 = t29*t2; - t380 = t376*t15; - t385 = t4*t12; - t387 = fr*t7*t90; - t391 = t15*t2*t34; - t394 = 8.0*t181*t187+4.0*t98*t359-8.0*t169*t109-8.0*t152*t153*t1-8.0*t117*t91*t368+16.0*t371*t368 & - -8.0*t152*t368+8.0*t376*t377-8.0*t380*t141-16.0*t371*t155-16.0*t385*t387+8.0*t376*t391; - t398 = t4*t54; - t401 = t3*t54; - t404 = t2*t54; - t407 = t4*t19; - t412 = t39*t8; - t415 = t28*t15; - t420 = t39*t34; - t427 = -32.0*t137*t387-16.0*t398*t387+32.0*t401*t387-16.0*t404*t387+32.0*t407*t387-8.0*t28*t377 & - -8.0*t376*t412-4.0*t415*t95+4.0*t28*t412+4.0*t38*t420+4.0*t28*t420-8.0*t28*t391; - t450 = t2*t12; - t451 = t450*t34; - t456 = -8.0*t376*t420+8.0*t415*t141+8.0*t380*t95-4.0*t28*t29*t34+4.0*t38*t412-8.0*t208*t290 & - +32.0*t92*t172*t54+32.0*t401*t284-4.0*t100*t113+4.0*t223*t290-2.0*t93*t451-16.0*t398*t284; - t459 = frs*t4; - t486 = -16.0*t92*t459*t12+32.0*t407*t284-4.0*t98*t217*t34+2.0*t55-16.0*t385*t284-16.0*t404*t284 & - -2.0*t104*t112-8.0*t208*t359-8.0*t98*t323-t92*t172*t8+4.0*t223*t359+32.0*t92*t459*t19; - t487 = t19*t34; - t511 = t140*t12; - t516 = 4.0*t59*t487+8.0*t306*t113+8.0*t100*t307-2.0*t5*t487-4.0*t223*t99*t113+16.0*t298*t303 & - -8.0*t298*fs*t11*t15+16.0*t301*t295+2.0*t104*t113+4.0*t59*t307-2.0*t93*t511-4.0*t59*t113; - t522 = t8*t12; - t532 = t144*t450; - t537 = t12*t34; - t546 = 2.0*t5*t113-4.0*t5*t307-4.0*t59*t522+2.0*t5-31.0*t92*t172*t19-2.0*t92*t199*t19+2.0*t93*t532 & - -2.0*t5*t112+4.0*t5*t537-4.0*t59*t537+2.0*t5*t144+4.0*t5*t522; - t575 = 4.0*t59*t112-2.0*t104*t487-4.0*t107*t108-4.0*t38*t15*t95-16.0*t92*t459*t54-2.0*t92*t172*t12 & - -4.0*t5*t12+4.0*t59*t12+64.0*t5*t54+64.0*t133*t19-32.0*t133*t54-4.0*t59*t19-4.0*t415; - t586 = t34*t34; - t591 = t8*t8; - t595 = 256.0*t137-32.0*t450+32.0*t451+32.0*t511-32.0*t532+1.0-2.0*t34+t586-2.0*t8+4.0*t144 & - -2.0*t8*t586+t591-2.0*t591*t34+t591*t586; - covf = -8.0*(t58+t88+t136+t178+t216+t250+t276+t319+t356+t394+t427+t456+t486+t516+t546+t575)/t595; - -return - -end subroutine std_covdiff -!!------------------------------------------------------------------------------------------------------------ -!! input g_AB and Theta_AB are divided by r^2 indeed -!! input g_00 is also divided by r^2 indeed -! the output g00 is K -#if 1 -subroutine get_gauge_g00_K(ex,crho,sigma,X,g22,g23,g33, & - Theta22,Theta23,Theta33, g00, Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::Theta22,Theta23,Theta33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = X*Rmin/(1-X) -det = g22*g33-g23*g23 -gup22 = g33/det -gup23 = -g23/det -gup33 = g22/det - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - tg22 = 1-sr2*ss2 - tg22 = 1/tg22/tg22 - - tg23 = -sr*cr*ss*cs*tg22 - tg33 = cr2*tg22 - tg22 = cs2*tg22 - -! ghat/(g/r^4) indeed - det(i,j,k) = (tg22*tg33-tg23*tg23)/det(i,j,k) - enddo - enddo - enddo - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - KK(i,j,k) = dsqrt(det(i,j,k))*(1-0.25*covf/R(k)**2) - enddo - enddo - enddo - - g00 = KK - - return - -end subroutine get_gauge_g00_K -! the input g00 is K -subroutine get_gauge_g00(ex,crho,sigma,X,g22,g23,g33, & - Theta22,Theta23,Theta33, g00, Rmin,fp) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),fp -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Theta22,Theta23,Theta33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g00 - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = X*Rmin/(1-X) -det = g22*g33-g23*g23 -gup22 = g33/det -gup23 = -g23/det -gup33 = g22/det - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - tg22 = 1-sr2*ss2 - tg22 = 1/tg22/tg22 - - tg23 = -sr*cr*ss*cs*tg22 - tg33 = cr2*tg22 - tg22 = cs2*tg22 - - Theta22(i,j,k) = tg22/6/m0 - Theta23(i,j,k) = tg23/6/m0 - Theta33(i,j,k) = tg33/6/m0 - enddo - enddo - enddo - - KK = g00 - - if(fp == 0)then - k = 1 - do i=1,ex(1) - do j=1,ex(2) - - call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - Theta22(i,j,k) = covf*Theta22(i,j,k) - Theta23(i,j,k) = covf*Theta23(i,j,k) - Theta33(i,j,k) = covf*Theta33(i,j,k) - enddo - enddo - else - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - Theta22(i,j,k) = covf*Theta22(i,j,k) - Theta23(i,j,k) = covf*Theta23(i,j,k) - Theta33(i,j,k) = covf*Theta33(i,j,k) - enddo - enddo - enddo - endif - - return - -end subroutine get_gauge_g00 -#else -subroutine get_gauge_g00_K(ex,crho,sigma,X,g22,g23,g33, & - Theta22,Theta23,Theta33, g00, Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::Theta22,Theta23,Theta33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = X*Rmin/(1-X) -! g22 is P -det = dlog(g22**2) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - KK(i,j,k) = covf - enddo - enddo - enddo - - g00 = g22**2*(1+0.5*KK) - - return - -end subroutine get_gauge_g00_K -! the input g00 is K -subroutine get_gauge_g00(ex,crho,sigma,X,g22,g23,g33, & - Theta22,Theta23,Theta33, g00, Rmin,fp) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),fp -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Theta22,Theta23,Theta33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g00 - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = X*Rmin/(1-X) - - KK = g00 - - if(fp == 0)then - k = 1 - do i=1,ex(1) - do j=1,ex(2) - - call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - Theta22(i,j,k) = covf - enddo - enddo - else - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - Theta22(i,j,k) = covf - enddo - enddo - enddo - endif - - Theta22 = -Theta22/12/m0*g22**3 - return - -end subroutine get_gauge_g00 -#endif -!!--------------------------------------------------------------------------- -subroutine get_gauge_g00_real(ex,crho,sigma,X,g22,g23,g33, & - Theta22,Theta23,Theta33, g00, Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::Theta22,Theta23,Theta33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = X*Rmin/(1-X) -det = g22*g33-g23*g23 -gup22 = g33/det -gup23 = -g23/det -gup33 = g22/det - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - tg22 = 1-sr2*ss2 - tg22 = 1/tg22/tg22 - - tg23 = -sr*cr*ss*cs*tg22 - tg33 = cr2*tg22 - tg22 = cs2*tg22 - -! ghat/(g/r^4) indeed - det(i,j,k) = (tg22*tg33-tg23*tg23)/det(i,j,k) - enddo - enddo - enddo - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - KK(i,j,k) = dsqrt(det(i,j,k))*(1-0.25*covf/R(k)**2) - - g00(i,j,k) = 2*m0/R(k)**3-KK(i,j,k)/R(k)**2 & - -(gup22(i,j,k)*Theta22(i,j,k)+2*gup23(i,j,k)*Theta23(i,j,k)+gup33(i,j,k)*Theta33(i,j,k))/2/R(k) - enddo - enddo - enddo - - return - -end subroutine get_gauge_g00_real -!!------------------------------------------------------------------------------------------------------------ -subroutine get_null_boundary2(ex,crho,sigma,X,g22,g23,g33, & - g01,p02,p03,g02,g03,Theta22,Theta23,Theta33, Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g01,p02,p03,g02,g03 -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::Theta22,Theta23,Theta33 - -#if 1 -real*8 :: fact - -!fact = X(1)/X(2)*((1-X(2))/(1-X(1))) -!fact = fact**2 -! since we used gAB/r^2 instead of gAB, so fact = 1 -fact = 1.d0 - -g22(:,:,1) = g22(:,:,2)*fact -g23(:,:,1) = g23(:,:,2)*fact -g33(:,:,1) = g33(:,:,2)*fact - -g01(:,:,1) = -1.d0 - -p02(:,:,1) = 0.d0 -p03(:,:,1) = 0.d0 -g02(:,:,1) = 0.d0 -g03(:,:,1) = 0.d0 - -! have done in get_gauge_g00 -!Theta22(:,:,1) = Theta22(:,:,2)*fact -!Theta23(:,:,1) = Theta23(:,:,2)*fact -!Theta33(:,:,1) = Theta33(:,:,2)*fact -#else -g01 = -1 -g02 = 0 -g03 = 0 -#endif -return - -end subroutine get_null_boundary2 -!!!-------------------------------------------------------------------------------------------------------------- -subroutine get_initial_null3(ex,crho,sigma,XX,g22,g23,g33,sst,Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::XX -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g22,g23,g33 - -double precision,dimension(ex(3))::R -real*8 :: sr,ss,cr,cs -real*8 :: sr2,ss2,cr2,cs2 -integer :: i,j,k -real*8 :: ggr,tgrho,tgsigma -real*8 ::x,y,z,gr,gt,gp - -real*8 :: gxx,gxy,gyy,tc,ts,PI - -double complex :: Zslm,II,Jr,ctp -double complex :: swtf,z220 - -double complex :: beta0,C1,C2,mx,my,mlx,mly -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - -R = XX*Rmin/(1-XX) - -PI = dacos(-1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - gxx = 1-sr2*ss2 - gxx = 1/gxx/gxx - - gxy = -sr*cr*ss*cs*gxx - gyy = cr2*gxx - gxx = cs2*gxx -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null2: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - z220 = Zslm(2,2,m,gt,gp)*swtf**2 - - if(sst==1 .or. sst==3 .or. sst==4)then - mx = 2*tc*ts*(ts-II*tc)/dcos(sigma(j)) - my = 2*tc*ts*(ts+II*tc)/dcos(crho(i)) - else - mx = 2*tc*ts*(ts+II*tc)/dcos(sigma(j)) - my = 2*tc*ts*(ts-II*tc)/dcos(crho(i)) - endif - mlx = gxx*mx+gxy*my - mly = gxy*mx+gyy*my - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/R(k)-C2/1.2d1/R(k)**3 - Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jr)*z220 - - ctp = Jr*mlx*mlx+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mlx - g22(i,j,k) = dreal(ctp) - ctp = Jr*mlx*mly+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mly - g23(i,j,k) = dreal(ctp) - ctp = Jr*mly*mly+dsqrt(1+abs(Jr)**2)*dconjg(mly)*mly - g33(i,j,k) = dreal(ctp) - - enddo - enddo - enddo - -return - -end subroutine get_initial_null3 -!!!-------------------------------------------------------------------------------------------------------------- -subroutine get_g00_with_t(time,ex,crho,sigma,XX,g00,Rmin,sst) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: time,Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::XX -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 - -double precision,dimension(ex(3))::R -real*8 :: sr,ss,cr,cs -real*8 :: sr2,ss2,cr2,cs2 -integer :: i,j,k -real*8 :: ggr,tgrho,tgsigma -real*8 ::x,y,z,gr,gt,gp - -real*8 :: tc,ts,PI - -double complex :: Zslm,II,Jr,Ur,Wr -double complex :: swtf,z020,z120,z220 - -double complex :: beta0,C1,C2 -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - -R = XX*Rmin/(1-XX) - -PI = dacos(-1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_g00_with_t: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - z020 = Zslm(0,2,m,gt,gp) - z120 = Zslm(1,2,m,gt,gp)*swtf - z220 = Zslm(2,2,m,gt,gp)*swtf**2 - - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/R(k)-C2/1.2d1/R(k)**3 - Ur = (-24*II*nu*beta0+3*nu*nu*C1-nu**4*C2)/36+2*beta0/R(k)+C1/2/R(k)**2+ & - II*nu*C2/3/R(k)**3+C2/4/R(k)**4 - Wr = (24*II*nu*beta0-2*nu*C1+nu**4*C2)/6+ & - (3*II*nu*C1-6*beta0-II*nu**3*C2)/3/R(k) - & - nu**2*C2/R(k)**2+II*nu*C2/R(k)**3+C2/2/R(k)**4 - - Jr = Jr*exp(II*nu*time) - Ur = Ur*exp(II*nu*time) - Wr = Wr*exp(II*nu*time) - - g00(i,j,k) = 2*(2*(2+1)*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Ur)**2* & - dreal(Jr)*dreal(z120**2*dconjg(z220))+ & - 2*(2+1)*dsqrt(1+(2-1)*2*(2+1)*(2+2)*dreal(Jr)**2*abs(z220)**2)* & - dreal(Ur)**2*abs(z120)**2)-(1/R(k)**2+dreal(z020*Wr)/R(k))* & - exp(2*dreal(z020*beta0*exp(II*nu*time))) - - enddo - enddo - enddo - -!if(sst==0 .and. crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)"time = ",time,g00(1,1,1) - -return - -end subroutine get_g00_with_t -!!------------------------------------------------------------------------------------------------------------ -subroutine get_null_boundary3(time,ex,crho,sigma,XX,g22,g23,g33, & - g01,p02,p03,g02,g03,Theta22,Theta23,Theta33, Rmin,sst) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) ::time,Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::XX -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g01,p02,p03,g02,g03 -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::Theta22,Theta23,Theta33 - -double precision,dimension(ex(3))::R -real*8 :: sr,ss,cr,cs -real*8 :: sr2,ss2,cr2,cs2 -integer :: i,j,k -real*8 :: ggr,tgrho,tgsigma -real*8 ::x,y,z,gr,gt,gp - -real*8 :: gxx,gxy,gyy,tc,ts,PI - -double complex :: Zslm,II,Jr,ctp,Jrp,Jrt,Ur,Urp,Wr -double complex :: swtf,z020,z120,z220 - -double complex :: beta0,C1,C2,mx,my,mlx,mly -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - -R = XX*Rmin/(1-XX) - -PI = dacos(-1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - gxx = 1-sr2*ss2 - gxx = 1/gxx/gxx - - gxy = -sr*cr*ss*cs*gxx - gyy = cr2*gxx - gxx = cs2*gxx -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary3: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - z020 = Zslm(0,2,m,gt,gp) - z120 = Zslm(1,2,m,gt,gp)*swtf - z220 = Zslm(2,2,m,gt,gp)*swtf**2 - - if(sst==1 .or. sst==3 .or. sst==4)then - mx = 2*tc*ts*(ts-II*tc)/dcos(sigma(j)) - my = 2*tc*ts*(ts+II*tc)/dcos(crho(i)) - else - mx = 2*tc*ts*(ts+II*tc)/dcos(sigma(j)) - my = 2*tc*ts*(ts-II*tc)/dcos(crho(i)) - endif - mlx = gxx*mx+gxy*my - mly = gxy*mx+gyy*my - - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/R(k)-C2/1.2d1/R(k)**3 -! Jrp = d Jr/d X instead of d Jr/d r - Jrp = -C1/4.d0/Rmin/XX(k)**2+C2/1.2d1*3/R(k)**2/Rmin/XX(k)**2 - Ur = (-24*II*nu*beta0+3*nu*nu*C1-nu**4*C2)/36+2*beta0/R(k)+C1/2/R(k)**2+ & - II*nu*C2/3/R(k)**3+C2/4/R(k)**4 - Urp = -2*beta0/Rmin/XX(k)**2-C1/R(k)/Rmin/XX(k)**2- & - II*nu*C2/R(k)**2/Rmin/XX(k)**2-C2/R(k)**3/Rmin/XX(k)**2 - Wr = (24*II*nu*beta0-2*nu*C1+nu**4*C2)/6+ & - (3*II*nu*C1-6*beta0-II*nu**3*C2)/3/R(k) - & - nu**2*C2/R(k)**2+II*nu*C2/R(k)**3+C2/2/R(k)**4 - - Jr = Jr*exp(II*nu*time) - Jrp = Jrp*exp(II*nu*time) - Jrt = II*nu*Jr*exp(II*nu*time) - Ur = Ur*exp(II*nu*time) - Urp = Urp*exp(II*nu*time) - Wr = Wr*exp(II*nu*time) - - Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jr)*z220 - Jrt = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jrt)*z220 - Jrp = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jrp)*z220 - - g01(i,j,k) = -dexp(2*dreal(z020*beta0*exp(II*nu*time))) -#if 1 - g02(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mlx*(z120*dconjg(z220)* & - dconjg(Jr)+dsqrt(1+abs(Jr)**2)*dconjg(z120))) - g03(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mly*(z120*dconjg(z220)* & - dconjg(Jr)+dsqrt(1+abs(Jr)**2)*dconjg(z120))) -#elif 0 - mlx = mlx/swtf - mly = mly/swtf - g02(i,j,k) = dreal(mlx) - g03(i,j,k) = dreal(mly) - !if(sst==0 .and. crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k) - !if(crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k) -#else - select case (sst) - case (0,1) - tc =-dcos(gp)/(dcos(gt)**2*dcos(gp)**2-dcos(gt)**2-dcos(gp)**2) - ts = dsin(gp)/(1-dsin(gt)**2*dcos(gp)**2) - case (2,3) - tc = 0 - ts = dcos(gp)/(dcos(gt)**2*dcos(gp)**2-dcos(gt)**2-dcos(gp)**2) - case (4,5) - tc = 0 - ts =-dsin(gp)/(1-dsin(gt)**2*dcos(gp)**2) - end select - g02(i,j,k) = gxx*tc+gxy*ts - g03(i,j,k) = gxy*tc+gyy*ts - !if(sst==0 .and. crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k) - if(crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k),sst - stop -#endif - p02(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Urp)*dreal(mlx*(z120*dconjg(Jr)+ & - dsqrt(1+abs(Jr)**2)*dconjg(z120))) & - -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mlx*(z120*dconjg(Jrp)+ & - abs(Jrp)*abs(Jr)/dsqrt(1+abs(Jr)**2)*dconjg(z120))) - p03(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Urp)*dreal(mly*(z120*dconjg(Jr)+ & - dsqrt(1+abs(Jr)**2)*dconjg(z120))) & - -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mly*(z120*dconjg(Jrp)+ & - abs(Jrp)*abs(Jr)/dsqrt(1+abs(Jr)**2)*dconjg(z120))) - - ctp = dconjg(Jr)*mlx*mlx+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mlx - g22(i,j,k) = dreal(ctp) - ctp = dconjg(Jr)*mlx*mly+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mly - g23(i,j,k) = dreal(ctp) - ctp = dconjg(Jr)*mly*mly+dsqrt(1+abs(Jr)**2)*dconjg(mly)*mly - g33(i,j,k) = dreal(ctp) - - ctp = dconjg(Jrt)*mlx*mlx+abs(Jr)*abs(Jrt)/dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mlx - Theta22(i,j,k) = dreal(ctp) - ctp = dconjg(Jrt)*mlx*mly+abs(Jr)*abs(Jrt)/dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mly - Theta23(i,j,k) = dreal(ctp) - ctp = dconjg(Jrt)*mly*mly+abs(Jr)*abs(Jrt)/dsqrt(1+abs(Jr)**2)*dconjg(mly)*mly - Theta33(i,j,k) = dreal(ctp) - - enddo - enddo - enddo - -return - -end subroutine get_null_boundary3 + + +#include "macrodef.fh" + +subroutine get_RT_parameters(m0o,Pp0o,Pm0o,apo,amo,bpo,bmo,cpo,cmo,gamo) +implicit none +real*8,intent(out) :: m0o,Pp0o,Pm0o,apo,amo,bpo,bmo,cpo,cmo,gamo + +real*8,parameter::m0=1.d0,Pp0=1.d0,Pm0=1.d0,ap=1.d0,am=1.d0 +real*8,parameter::bp=0.d0,bm=0.d0,cp=0.d0,cm=0.d0 +real*8,parameter::gam=0.5d0 + +m0o = m0 +Pp0o = Pp0 +Pm0o = Pm0 +apo = ap +amo = am +bpo = bp +bmo = bm +cpo = cp +cmo = cm +gamo = gam +end subroutine get_RT_parameters +!!!--------------------------------------------------------------------------------------------- + function boostbhP(P0,gam,a,b,c,gt,gp) result(gont) + implicit none + +!~~~~~~> Input parameters: + + real*8, intent(in ):: P0,gam,a,b,c,gt,gp + + real*8::gont + + gont = dcosh(gam)+a*dsinh(gam)*dcos(gt)+dsinh(gam)*dsin(gt)*(b*dcos(gp)+c*dsin(gp)) + + gont = P0*gont + + end function boostbhP +!!!!------------------------------------------------------------------------------------------- +#if 1 +!! RT ID +subroutine get_initial_null2(ex,crho,sigma,XX,g22,g23,g33,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::XX +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g22,g23,g33 + +double precision,dimension(ex(3))::R +real*8 :: sr,ss,cr,cs +real*8 :: sr2,ss2,cr2,cs2 +integer :: i,j,k +real*8 :: ggr,tgrho,tgsigma +real*8 ::x,y,z,gr,gt,gp +real*8,dimension(ex(1),ex(2),ex(3))::P + +real*8 :: PI + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +real*8::boostbhP + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = XX*Rmin/(1-XX) + +PI = dacos(-1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + g22(i,j,k) = 1-sr2*ss2 + g22(i,j,k) = 1/g22(i,j,k)/g22(i,j,k) + + g23(i,j,k) = -sr*cr*ss*cs*g22(i,j,k) + g33(i,j,k) = cr2*g22(i,j,k) + g22(i,j,k) = cs2*g22(i,j,k) + +! we want g_AB/r^2 instead of g_AB +! g22(i,j,k) = R(k)*R(k)*g22(i,j,k) +! g23(i,j,k) = R(k)*R(k)*g23(i,j,k) +! g33(i,j,k) = R(k)*R(k)*g33(i,j,k) + +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null2: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + P(i,j,k) = 1/(1/dsqrt(boostbhP(Pp0,gam,ap,bp,cp,gt,gp))+1/dsqrt(boostbhP(Pm0,gam,am,bm,cm,gt,gp)))**2 + + enddo + enddo + enddo + + g22 = g22/P**2 + g23 = g23/P**2 + g33 = g33/P**2 + +return + +end subroutine get_initial_null2 +#else +!! fake RT for test +subroutine get_initial_null2(ex,crho,sigma,XX,g22,g23,g33,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::XX +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g22,g23,g33 + +double precision,dimension(ex(3))::R +real*8 :: sr,ss,cr,cs +real*8 :: sr2,ss2,cr2,cs2 +integer :: i,j,k +real*8 :: ggr,tgrho,tgsigma +real*8 ::x,y,z,gr,gt,gp +real*8,dimension(ex(1),ex(2),ex(3))::P + +real*8 :: PI + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +real*8::boostbhP + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = XX*Rmin/(1-XX) + +PI = dacos(-1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + g22(i,j,k) = 1-sr2*ss2 + g22(i,j,k) = 1/g22(i,j,k)/g22(i,j,k) + + g23(i,j,k) = -sr*cr*ss*cs*g22(i,j,k) + g33(i,j,k) = cr2*g22(i,j,k) + g22(i,j,k) = cs2*g22(i,j,k) + +! we want g_AB/r^2 instead of g_AB +! g22(i,j,k) = R(k)*R(k)*g22(i,j,k) +! g23(i,j,k) = R(k)*R(k)*g23(i,j,k) +! g33(i,j,k) = R(k)*R(k)*g33(i,j,k) + +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null2: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + P(i,j,k) = 1/(1/dsqrt(boostbhP(Pp0,gam,ap,bp,cp,gt,gp))+1/dsqrt(boostbhP(Pm0,gam,am,bm,cm,gt,gp)))**2 + + enddo + enddo + enddo + + g22 = P + +return + +end subroutine get_initial_null2 +#endif +!!------------------------------------------------------------------------------------------------------------ +subroutine std_covdiff(rho,sigma,fs,fr,fss,frr,frs,covf) +implicit none +! argument variables +real*8,intent(in) :: rho,sigma,fs,fr,fss,frr,frs +real*8,intent(out):: covf + +real*8 :: t1,t2,t3,t4,t5,t6,t7,t8,t11,t12,t13,t15,t16,t19,t20 +real*8 :: t27,t28,t29,t32,t33,t34,t38,t39,t51,t54,t55,t58,t59 +real*8 :: t62,t71,t72,t88,t90,t91,t92,t93,t94,t95,t97,t98,t99 +real*8 :: t100,t104,t107,t108,t109,t112,t113,t117,t118,t121,t128,t132,t133,t136,t137,t140,t141 +real*8 :: t144,t152,t153,t154,t155,t160,t166,t169,t172,t175,t178,t181,t187,t199,t204,t205,t208 +real*8 :: t209,t216,t217,t223,t226,t227,t243,t250,t256,t267,t276,t284,t287,t290,t301,t303,t306 +real*8 :: t307,t310,t313,t314,t316,t319,t323,t326,t329,t338,t346,t356,t359,t368,t371,t376,t377 +real*8 :: t380,t385,t387,t391,t394,t398,t401,t404,t407,t412,t415,t420,t427,t450,t451,t456,t459 +real*8 :: t486,t487,t511,t516,t522,t532,t537,t546,t575,t586,t591,t595,t599,t295,t298 + + t1 = cos(sigma); + t2 = t1*t1; + t3 = t2*t2; + t4 = t3*t2; + t5 = t4*fss; + t6 = 2.0*sigma; + t7 = cos(t6); + t8 = t7*t7; + t11 = cos(rho); + t12 = t11*t11; + t13 = t12*t11; + t15 = sin(rho); + t16 = fr*t15; + t19 = t12*t12; + t20 = t19*t13; + t27 = t19*t11; + t28 = t27*fr; + t29 = t15*t8; + t32 = 2.0*rho; + t33 = cos(t32); + t34 = t33*t33; + t38 = t11*fr; + t39 = t15*t3; + t51 = t19*frr; + t54 = t19*t12; + t55 = t54*frr; + t58 = -2.0*t5*t8-8.0*t2*t13*t16-64.0*t3*t20*t16+32.0*t4*t20*t16+4.0*t28*t29 & + +4.0*t28*t15*t34-4.0*t38*t39+8.0*t3*t13*t16+32.0*t4*t13*t16+8.0*t2*t27*t16 & + +4.0*t51*t2-2.0*t55*t34; + t59 = t3*fss; + t62 = t12*frr; + t71 = t19*t19; + t72 = t71*frr; + t88 = -32.0*t59*t54+2.0*t62*t3-2.0*t55*t8+64.0*t55*t4-2.0*t5*t34-32.0*t72*t2 & + +64.0*t72*t3-32.0*t72*t4-4.0*t55*t2-4.0*t51*t3-62.0*t55*t3+60.0*t3*t27*t16; + t90 = sin(t32); + t91 = sin(t6); + t92 = t90*t91; + t93 = t92*frs; + t94 = t3*t8; + t95 = t94*t34; + t97 = t3*t1; + t98 = t97*fs; + t99 = sin(sigma); + t100 = t98*t99; + t104 = t2*fss; + t107 = t54*fr; + t108 = t90*t33; + t109 = t108*t2; + t112 = t19*t8; + t113 = t112*t34; + t117 = t12*fr; + t118 = t108*t3; + t121 = t12*t3; + t128 = t19*t2; + t132 = t3*t3; + t133 = t132*fss; + t136 = t93*t95-4.0*t100-32.0*t51*t4+2.0*t104*t19+8.0*t107*t109+t93*t113-62.0*t5*t19 & + -4.0*t117*t118+2.0*t93*t121*t8+32.0*t2*t20*t16+2.0*t93*t128*t8-32.0*t133*t12; + t137 = t3*t19; + t140 = t2*t8; + t141 = t140*t34; + t144 = t8*t34; + t152 = t107*t91; + t153 = t90*t99; + t154 = t2*t1; + t155 = t153*t154; + t160 = t33*t3*t8; + t166 = frs*t19; + t169 = t19*fr; + t172 = frs*t3; + t175 = t107*t90; + t178 = -t93*t137*t8-4.0*t55*t141-2.0*t93*t128*t144+2.0*t62*t95+t93*t137*t144+16.0*t152*t155 & + +4.0*t117*t90*t160+4.0*t107*t108*t8-t92*t166*t8+8.0*t169*t118-t92*t172*t34+4.0*t175*t160; + t181 = t169*t90; + t187 = t33*t2*t8; + t199 = frs*t2; + t204 = fs*t3*t154; + t205 = t19*t99; + t208 = fs*t154; + t209 = t54*t99; + t216 = -8.0*t181*t160-4.0*t107*t118-8.0*t175*t187-t93*t137*t34+4.0*t51*t141+2.0*t93*t128*t34 & + -4.0*t51*t95+2.0*t92*t199*t12-64.0*t204*t205+32.0*t208*t209-64.0*t98*t209+32.0*t204*t209; + t217 = t99*t8; + t223 = t1*fs; + t226 = t4*fs; + t227 = t91*t7; + t243 = t12*t99; + t250 = 4.0*t98*t217+4.0*t98*t99*t34-4.0*t223*t205-4.0*t226*t227-64.0*t4*t27*t16+2.0*t93*t121*t34 & + -t92*t166*t34-2.0*t93*t121*t144+8.0*t208*t205+8.0*t98*t243+60.0*t98*t205+32.0*t204*t243; + t256 = t2*t34; + t267 = t3*t34; + t276 = -8.0*t208*t243+t92*t172+t92*t166-4.0*t51*t256-4.0*t51*t140+4.0*t51*t94+2.0*t55*t144 & + -2.0*t62*t94-2.0*t62*t267-2.0*t55*t94+4.0*t55*t140+4.0*t51*t267; + t284 = fs*t91*t33; + t287 = t243*t34; + t290 = t205*t34; + t295 = fs*t27*t15; + t298 = t92*t4; + t301 = t92*t3; + t303 = fs*t13*t15; + t306 = t208*t99; + t307 = t144*t12; + t310 = t227*t19; + t313 = t3*fs; + t314 = t313*t91; + t316 = t7*t19*t34; + t319 = 4.0*t55*t256-2.0*t55*t267+2.0*t55*t95-32.0*t137*t284-8.0*t98*t287+4.0*t98*t290 & + -8.0*t92*t2*t295-8.0*t298*t295-16.0*t301*t303-8.0*t306*t307-4.0*t226*t310-8.0*t314*t316; + t323 = t217*t12; + t326 = t227*t12; + t329 = t226*t91; + t338 = t7*t12*t34; + t346 = t2*fs; + t356 = 8.0*t208*t323+8.0*t226*t326+4.0*t329*t316+8.0*t208*t287+4.0*t226*t227*t34+8.0*t314*t338 & + -16.0*t92*t199*t54-8.0*t329*t338-4.0*t346*t310+8.0*t313*t310-8.0*t313*t326+4.0*t346*t91*t316; + t359 = t205*t8; + t368 = t153*t97; + t371 = t169*t91; + t376 = t13*fr; + t377 = t29*t2; + t380 = t376*t15; + t385 = t4*t12; + t387 = fr*t7*t90; + t391 = t15*t2*t34; + t394 = 8.0*t181*t187+4.0*t98*t359-8.0*t169*t109-8.0*t152*t153*t1-8.0*t117*t91*t368+16.0*t371*t368 & + -8.0*t152*t368+8.0*t376*t377-8.0*t380*t141-16.0*t371*t155-16.0*t385*t387+8.0*t376*t391; + t398 = t4*t54; + t401 = t3*t54; + t404 = t2*t54; + t407 = t4*t19; + t412 = t39*t8; + t415 = t28*t15; + t420 = t39*t34; + t427 = -32.0*t137*t387-16.0*t398*t387+32.0*t401*t387-16.0*t404*t387+32.0*t407*t387-8.0*t28*t377 & + -8.0*t376*t412-4.0*t415*t95+4.0*t28*t412+4.0*t38*t420+4.0*t28*t420-8.0*t28*t391; + t450 = t2*t12; + t451 = t450*t34; + t456 = -8.0*t376*t420+8.0*t415*t141+8.0*t380*t95-4.0*t28*t29*t34+4.0*t38*t412-8.0*t208*t290 & + +32.0*t92*t172*t54+32.0*t401*t284-4.0*t100*t113+4.0*t223*t290-2.0*t93*t451-16.0*t398*t284; + t459 = frs*t4; + t486 = -16.0*t92*t459*t12+32.0*t407*t284-4.0*t98*t217*t34+2.0*t55-16.0*t385*t284-16.0*t404*t284 & + -2.0*t104*t112-8.0*t208*t359-8.0*t98*t323-t92*t172*t8+4.0*t223*t359+32.0*t92*t459*t19; + t487 = t19*t34; + t511 = t140*t12; + t516 = 4.0*t59*t487+8.0*t306*t113+8.0*t100*t307-2.0*t5*t487-4.0*t223*t99*t113+16.0*t298*t303 & + -8.0*t298*fs*t11*t15+16.0*t301*t295+2.0*t104*t113+4.0*t59*t307-2.0*t93*t511-4.0*t59*t113; + t522 = t8*t12; + t532 = t144*t450; + t537 = t12*t34; + t546 = 2.0*t5*t113-4.0*t5*t307-4.0*t59*t522+2.0*t5-31.0*t92*t172*t19-2.0*t92*t199*t19+2.0*t93*t532 & + -2.0*t5*t112+4.0*t5*t537-4.0*t59*t537+2.0*t5*t144+4.0*t5*t522; + t575 = 4.0*t59*t112-2.0*t104*t487-4.0*t107*t108-4.0*t38*t15*t95-16.0*t92*t459*t54-2.0*t92*t172*t12 & + -4.0*t5*t12+4.0*t59*t12+64.0*t5*t54+64.0*t133*t19-32.0*t133*t54-4.0*t59*t19-4.0*t415; + t586 = t34*t34; + t591 = t8*t8; + t595 = 256.0*t137-32.0*t450+32.0*t451+32.0*t511-32.0*t532+1.0-2.0*t34+t586-2.0*t8+4.0*t144 & + -2.0*t8*t586+t591-2.0*t591*t34+t591*t586; + covf = -8.0*(t58+t88+t136+t178+t216+t250+t276+t319+t356+t394+t427+t456+t486+t516+t546+t575)/t595; + +return + +end subroutine std_covdiff +!!------------------------------------------------------------------------------------------------------------ +!! input g_AB and Theta_AB are divided by r^2 indeed +!! input g_00 is also divided by r^2 indeed +! the output g00 is K +#if 1 +subroutine get_gauge_g00_K(ex,crho,sigma,X,g22,g23,g33, & + Theta22,Theta23,Theta33, g00, Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::Theta22,Theta23,Theta33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = X*Rmin/(1-X) +det = g22*g33-g23*g23 +gup22 = g33/det +gup23 = -g23/det +gup33 = g22/det + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + tg22 = 1-sr2*ss2 + tg22 = 1/tg22/tg22 + + tg23 = -sr*cr*ss*cs*tg22 + tg33 = cr2*tg22 + tg22 = cs2*tg22 + +! ghat/(g/r^4) indeed + det(i,j,k) = (tg22*tg33-tg23*tg23)/det(i,j,k) + enddo + enddo + enddo + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + KK(i,j,k) = dsqrt(det(i,j,k))*(1-0.25*covf/R(k)**2) + enddo + enddo + enddo + + g00 = KK + + return + +end subroutine get_gauge_g00_K +! the input g00 is K +subroutine get_gauge_g00(ex,crho,sigma,X,g22,g23,g33, & + Theta22,Theta23,Theta33, g00, Rmin,fp) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),fp +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Theta22,Theta23,Theta33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g00 + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = X*Rmin/(1-X) +det = g22*g33-g23*g23 +gup22 = g33/det +gup23 = -g23/det +gup33 = g22/det + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + tg22 = 1-sr2*ss2 + tg22 = 1/tg22/tg22 + + tg23 = -sr*cr*ss*cs*tg22 + tg33 = cr2*tg22 + tg22 = cs2*tg22 + + Theta22(i,j,k) = tg22/6/m0 + Theta23(i,j,k) = tg23/6/m0 + Theta33(i,j,k) = tg33/6/m0 + enddo + enddo + enddo + + KK = g00 + + if(fp == 0)then + k = 1 + do i=1,ex(1) + do j=1,ex(2) + + call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + Theta22(i,j,k) = covf*Theta22(i,j,k) + Theta23(i,j,k) = covf*Theta23(i,j,k) + Theta33(i,j,k) = covf*Theta33(i,j,k) + enddo + enddo + else + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + Theta22(i,j,k) = covf*Theta22(i,j,k) + Theta23(i,j,k) = covf*Theta23(i,j,k) + Theta33(i,j,k) = covf*Theta33(i,j,k) + enddo + enddo + enddo + endif + + return + +end subroutine get_gauge_g00 +#else +subroutine get_gauge_g00_K(ex,crho,sigma,X,g22,g23,g33, & + Theta22,Theta23,Theta33, g00, Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::Theta22,Theta23,Theta33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = X*Rmin/(1-X) +! g22 is P +det = dlog(g22**2) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + KK(i,j,k) = covf + enddo + enddo + enddo + + g00 = g22**2*(1+0.5*KK) + + return + +end subroutine get_gauge_g00_K +! the input g00 is K +subroutine get_gauge_g00(ex,crho,sigma,X,g22,g23,g33, & + Theta22,Theta23,Theta33, g00, Rmin,fp) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),fp +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Theta22,Theta23,Theta33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g00 + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = X*Rmin/(1-X) + + KK = g00 + + if(fp == 0)then + k = 1 + do i=1,ex(1) + do j=1,ex(2) + + call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + Theta22(i,j,k) = covf + enddo + enddo + else + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + Theta22(i,j,k) = covf + enddo + enddo + enddo + endif + + Theta22 = -Theta22/12/m0*g22**3 + return + +end subroutine get_gauge_g00 +#endif +!!--------------------------------------------------------------------------- +subroutine get_gauge_g00_real(ex,crho,sigma,X,g22,g23,g33, & + Theta22,Theta23,Theta33, g00, Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::Theta22,Theta23,Theta33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = X*Rmin/(1-X) +det = g22*g33-g23*g23 +gup22 = g33/det +gup23 = -g23/det +gup33 = g22/det + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + tg22 = 1-sr2*ss2 + tg22 = 1/tg22/tg22 + + tg23 = -sr*cr*ss*cs*tg22 + tg33 = cr2*tg22 + tg22 = cs2*tg22 + +! ghat/(g/r^4) indeed + det(i,j,k) = (tg22*tg33-tg23*tg23)/det(i,j,k) + enddo + enddo + enddo + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + KK(i,j,k) = dsqrt(det(i,j,k))*(1-0.25*covf/R(k)**2) + + g00(i,j,k) = 2*m0/R(k)**3-KK(i,j,k)/R(k)**2 & + -(gup22(i,j,k)*Theta22(i,j,k)+2*gup23(i,j,k)*Theta23(i,j,k)+gup33(i,j,k)*Theta33(i,j,k))/2/R(k) + enddo + enddo + enddo + + return + +end subroutine get_gauge_g00_real +!!------------------------------------------------------------------------------------------------------------ +subroutine get_null_boundary2(ex,crho,sigma,X,g22,g23,g33, & + g01,p02,p03,g02,g03,Theta22,Theta23,Theta33, Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g01,p02,p03,g02,g03 +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::Theta22,Theta23,Theta33 + +#if 1 +real*8 :: fact + +!fact = X(1)/X(2)*((1-X(2))/(1-X(1))) +!fact = fact**2 +! since we used gAB/r^2 instead of gAB, so fact = 1 +fact = 1.d0 + +g22(:,:,1) = g22(:,:,2)*fact +g23(:,:,1) = g23(:,:,2)*fact +g33(:,:,1) = g33(:,:,2)*fact + +g01(:,:,1) = -1.d0 + +p02(:,:,1) = 0.d0 +p03(:,:,1) = 0.d0 +g02(:,:,1) = 0.d0 +g03(:,:,1) = 0.d0 + +! have done in get_gauge_g00 +!Theta22(:,:,1) = Theta22(:,:,2)*fact +!Theta23(:,:,1) = Theta23(:,:,2)*fact +!Theta33(:,:,1) = Theta33(:,:,2)*fact +#else +g01 = -1 +g02 = 0 +g03 = 0 +#endif +return + +end subroutine get_null_boundary2 +!!!-------------------------------------------------------------------------------------------------------------- +subroutine get_initial_null3(ex,crho,sigma,XX,g22,g23,g33,sst,Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::XX +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g22,g23,g33 + +double precision,dimension(ex(3))::R +real*8 :: sr,ss,cr,cs +real*8 :: sr2,ss2,cr2,cs2 +integer :: i,j,k +real*8 :: ggr,tgrho,tgsigma +real*8 ::x,y,z,gr,gt,gp + +real*8 :: gxx,gxy,gyy,tc,ts,PI + +double complex :: Zslm,II,Jr,ctp +double complex :: swtf,z220 + +double complex :: beta0,C1,C2,mx,my,mlx,mly +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + +R = XX*Rmin/(1-XX) + +PI = dacos(-1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + gxx = 1-sr2*ss2 + gxx = 1/gxx/gxx + + gxy = -sr*cr*ss*cs*gxx + gyy = cr2*gxx + gxx = cs2*gxx +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null2: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + z220 = Zslm(2,2,m,gt,gp)*swtf**2 + + if(sst==1 .or. sst==3 .or. sst==4)then + mx = 2*tc*ts*(ts-II*tc)/dcos(sigma(j)) + my = 2*tc*ts*(ts+II*tc)/dcos(crho(i)) + else + mx = 2*tc*ts*(ts+II*tc)/dcos(sigma(j)) + my = 2*tc*ts*(ts-II*tc)/dcos(crho(i)) + endif + mlx = gxx*mx+gxy*my + mly = gxy*mx+gyy*my + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/R(k)-C2/1.2d1/R(k)**3 + Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jr)*z220 + + ctp = Jr*mlx*mlx+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mlx + g22(i,j,k) = dreal(ctp) + ctp = Jr*mlx*mly+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mly + g23(i,j,k) = dreal(ctp) + ctp = Jr*mly*mly+dsqrt(1+abs(Jr)**2)*dconjg(mly)*mly + g33(i,j,k) = dreal(ctp) + + enddo + enddo + enddo + +return + +end subroutine get_initial_null3 +!!!-------------------------------------------------------------------------------------------------------------- +subroutine get_g00_with_t(time,ex,crho,sigma,XX,g00,Rmin,sst) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: time,Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::XX +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::g00 + +double precision,dimension(ex(3))::R +real*8 :: sr,ss,cr,cs +real*8 :: sr2,ss2,cr2,cs2 +integer :: i,j,k +real*8 :: ggr,tgrho,tgsigma +real*8 ::x,y,z,gr,gt,gp + +real*8 :: tc,ts,PI + +double complex :: Zslm,II,Jr,Ur,Wr +double complex :: swtf,z020,z120,z220 + +double complex :: beta0,C1,C2 +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + +R = XX*Rmin/(1-XX) + +PI = dacos(-1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_g00_with_t: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + z020 = Zslm(0,2,m,gt,gp) + z120 = Zslm(1,2,m,gt,gp)*swtf + z220 = Zslm(2,2,m,gt,gp)*swtf**2 + + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/R(k)-C2/1.2d1/R(k)**3 + Ur = (-24*II*nu*beta0+3*nu*nu*C1-nu**4*C2)/36+2*beta0/R(k)+C1/2/R(k)**2+ & + II*nu*C2/3/R(k)**3+C2/4/R(k)**4 + Wr = (24*II*nu*beta0-2*nu*C1+nu**4*C2)/6+ & + (3*II*nu*C1-6*beta0-II*nu**3*C2)/3/R(k) - & + nu**2*C2/R(k)**2+II*nu*C2/R(k)**3+C2/2/R(k)**4 + + Jr = Jr*exp(II*nu*time) + Ur = Ur*exp(II*nu*time) + Wr = Wr*exp(II*nu*time) + + g00(i,j,k) = 2*(2*(2+1)*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Ur)**2* & + dreal(Jr)*dreal(z120**2*dconjg(z220))+ & + 2*(2+1)*dsqrt(1+(2-1)*2*(2+1)*(2+2)*dreal(Jr)**2*abs(z220)**2)* & + dreal(Ur)**2*abs(z120)**2)-(1/R(k)**2+dreal(z020*Wr)/R(k))* & + exp(2*dreal(z020*beta0*exp(II*nu*time))) + + enddo + enddo + enddo + +!if(sst==0 .and. crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)"time = ",time,g00(1,1,1) + +return + +end subroutine get_g00_with_t +!!------------------------------------------------------------------------------------------------------------ +subroutine get_null_boundary3(time,ex,crho,sigma,XX,g22,g23,g33, & + g01,p02,p03,g02,g03,Theta22,Theta23,Theta33, Rmin,sst) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) ::time,Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::XX +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::g01,p02,p03,g02,g03 +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::Theta22,Theta23,Theta33 + +double precision,dimension(ex(3))::R +real*8 :: sr,ss,cr,cs +real*8 :: sr2,ss2,cr2,cs2 +integer :: i,j,k +real*8 :: ggr,tgrho,tgsigma +real*8 ::x,y,z,gr,gt,gp + +real*8 :: gxx,gxy,gyy,tc,ts,PI + +double complex :: Zslm,II,Jr,ctp,Jrp,Jrt,Ur,Urp,Wr +double complex :: swtf,z020,z120,z220 + +double complex :: beta0,C1,C2,mx,my,mlx,mly +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + +R = XX*Rmin/(1-XX) + +PI = dacos(-1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + gxx = 1-sr2*ss2 + gxx = 1/gxx/gxx + + gxy = -sr*cr*ss*cs*gxx + gyy = cr2*gxx + gxx = cs2*gxx +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary3: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + z020 = Zslm(0,2,m,gt,gp) + z120 = Zslm(1,2,m,gt,gp)*swtf + z220 = Zslm(2,2,m,gt,gp)*swtf**2 + + if(sst==1 .or. sst==3 .or. sst==4)then + mx = 2*tc*ts*(ts-II*tc)/dcos(sigma(j)) + my = 2*tc*ts*(ts+II*tc)/dcos(crho(i)) + else + mx = 2*tc*ts*(ts+II*tc)/dcos(sigma(j)) + my = 2*tc*ts*(ts-II*tc)/dcos(crho(i)) + endif + mlx = gxx*mx+gxy*my + mly = gxy*mx+gyy*my + + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/R(k)-C2/1.2d1/R(k)**3 +! Jrp = d Jr/d X instead of d Jr/d r + Jrp = -C1/4.d0/Rmin/XX(k)**2+C2/1.2d1*3/R(k)**2/Rmin/XX(k)**2 + Ur = (-24*II*nu*beta0+3*nu*nu*C1-nu**4*C2)/36+2*beta0/R(k)+C1/2/R(k)**2+ & + II*nu*C2/3/R(k)**3+C2/4/R(k)**4 + Urp = -2*beta0/Rmin/XX(k)**2-C1/R(k)/Rmin/XX(k)**2- & + II*nu*C2/R(k)**2/Rmin/XX(k)**2-C2/R(k)**3/Rmin/XX(k)**2 + Wr = (24*II*nu*beta0-2*nu*C1+nu**4*C2)/6+ & + (3*II*nu*C1-6*beta0-II*nu**3*C2)/3/R(k) - & + nu**2*C2/R(k)**2+II*nu*C2/R(k)**3+C2/2/R(k)**4 + + Jr = Jr*exp(II*nu*time) + Jrp = Jrp*exp(II*nu*time) + Jrt = II*nu*Jr*exp(II*nu*time) + Ur = Ur*exp(II*nu*time) + Urp = Urp*exp(II*nu*time) + Wr = Wr*exp(II*nu*time) + + Jr = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jr)*z220 + Jrt = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jrt)*z220 + Jrp = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*dreal(Jrp)*z220 + + g01(i,j,k) = -dexp(2*dreal(z020*beta0*exp(II*nu*time))) +#if 1 + g02(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mlx*(z120*dconjg(z220)* & + dconjg(Jr)+dsqrt(1+abs(Jr)**2)*dconjg(z120))) + g03(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mly*(z120*dconjg(z220)* & + dconjg(Jr)+dsqrt(1+abs(Jr)**2)*dconjg(z120))) +#elif 0 + mlx = mlx/swtf + mly = mly/swtf + g02(i,j,k) = dreal(mlx) + g03(i,j,k) = dreal(mly) + !if(sst==0 .and. crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k) + !if(crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k) +#else + select case (sst) + case (0,1) + tc =-dcos(gp)/(dcos(gt)**2*dcos(gp)**2-dcos(gt)**2-dcos(gp)**2) + ts = dsin(gp)/(1-dsin(gt)**2*dcos(gp)**2) + case (2,3) + tc = 0 + ts = dcos(gp)/(dcos(gt)**2*dcos(gp)**2-dcos(gt)**2-dcos(gp)**2) + case (4,5) + tc = 0 + ts =-dsin(gp)/(1-dsin(gt)**2*dcos(gp)**2) + end select + g02(i,j,k) = gxx*tc+gxy*ts + g03(i,j,k) = gxy*tc+gyy*ts + !if(sst==0 .and. crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k) + if(crho(1) <-0.9 .and. sigma(1) <-0.9 .and. XX(1)<0.18182)write(*,*)g02(i,j,k),g03(i,j,k),sst + stop +#endif + p02(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Urp)*dreal(mlx*(z120*dconjg(Jr)+ & + dsqrt(1+abs(Jr)**2)*dconjg(z120))) & + -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mlx*(z120*dconjg(Jrp)+ & + abs(Jrp)*abs(Jr)/dsqrt(1+abs(Jr)**2)*dconjg(z120))) + p03(i,j,k) = -dsqrt(dble(2*(2+1)))*dreal(Urp)*dreal(mly*(z120*dconjg(Jr)+ & + dsqrt(1+abs(Jr)**2)*dconjg(z120))) & + -dsqrt(dble(2*(2+1)))*dreal(Ur)*dreal(mly*(z120*dconjg(Jrp)+ & + abs(Jrp)*abs(Jr)/dsqrt(1+abs(Jr)**2)*dconjg(z120))) + + ctp = dconjg(Jr)*mlx*mlx+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mlx + g22(i,j,k) = dreal(ctp) + ctp = dconjg(Jr)*mlx*mly+dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mly + g23(i,j,k) = dreal(ctp) + ctp = dconjg(Jr)*mly*mly+dsqrt(1+abs(Jr)**2)*dconjg(mly)*mly + g33(i,j,k) = dreal(ctp) + + ctp = dconjg(Jrt)*mlx*mlx+abs(Jr)*abs(Jrt)/dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mlx + Theta22(i,j,k) = dreal(ctp) + ctp = dconjg(Jrt)*mlx*mly+abs(Jr)*abs(Jrt)/dsqrt(1+abs(Jr)**2)*dconjg(mlx)*mly + Theta23(i,j,k) = dreal(ctp) + ctp = dconjg(Jrt)*mly*mly+abs(Jr)*abs(Jrt)/dsqrt(1+abs(Jr)**2)*dconjg(mly)*mly + Theta33(i,j,k) = dreal(ctp) + + enddo + enddo + enddo + +return + +end subroutine get_null_boundary3 diff --git a/AMSS_NCKU_source/initial_null2.h b/AMSS_NCKU_source/Initial_Data_Solver/initial_null2.h similarity index 96% rename from AMSS_NCKU_source/initial_null2.h rename to AMSS_NCKU_source/Initial_Data_Solver/initial_null2.h index 615dbff..309adc8 100644 --- a/AMSS_NCKU_source/initial_null2.h +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_null2.h @@ -1,98 +1,98 @@ - -#ifndef INITIAL_NULL2_H -#define INITIAL_NULL2_H - -#ifdef fortran1 -#define f_get_initial_null2 get_initial_null2 -#define f_get_initial_null3 get_initial_null3 -#define f_get_gauge_g00 get_gauge_g00 -#define f_get_gauge_g00_K get_gauge_g00_k -#define f_get_gauge_g00_real get_gauge_g00_real -#define f_get_null_boundary2 get_null_boundary2 -#define f_get_null_boundary3 get_null_boundary3 -#define f_get_g00_with_t get_g00_with_t -#endif -#ifdef fortran2 -#define f_get_initial_null2 GET_INITIAL_NULL2 -#define f_get_initial_null3 GET_INITIAL_NULL3 -#define f_get_gauge_g00 GET_GAUGE_G00 -#define f_get_gauge_g00_K GET_GAUGE_G00_K -#define f_get_gauge_g00_real GET_GAUGE_G00_REAL -#define f_get_null_boundary2 GET_NULL_BOUNDARY2 -#define f_get_null_boundary3 GET_NULL_BOUNDARY3 -#define f_get_g00_with_t GET_G00_WITH_T -#endif -#ifdef fortran3 -#define f_get_initial_null2 get_initial_null2_ -#define f_get_initial_null3 get_initial_null3_ -#define f_get_gauge_g00 get_gauge_g00_ -#define f_get_gauge_g00_K get_gauge_g00_k_ -#define f_get_gauge_g00_real get_gauge_g00_real_ -#define f_get_null_boundary2 get_null_boundary2_ -#define f_get_null_boundary3 get_null_boundary3_ -#define f_get_g00_with_t get_g00_with_t_ -#endif - -extern "C" -{ - void f_get_initial_null2(int *, double *, double *, double *, - double *, double *, double *, - int &, double &); -} - -extern "C" -{ - void f_get_gauge_g00(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double &, int &); -} - -extern "C" -{ - void f_get_gauge_g00_K(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double &); -} - -extern "C" -{ - void f_get_gauge_g00_real(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double &); -} - -extern "C" -{ - void f_get_null_boundary2(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, - double *, double *, double *, - double &); -} - -extern "C" -{ - void f_get_g00_with_t(double &, int *, double *, double *, double *, - double *, double &, int &); -} - -extern "C" -{ - void f_get_null_boundary3(double &, int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, - double *, double *, double *, - double &, int &); -} - -extern "C" -{ - void f_get_initial_null3(int *, double *, double *, double *, - double *, double *, double *, - int &, double &); -} - -#endif /* INITIAL_NULL2_H */ + +#ifndef INITIAL_NULL2_H +#define INITIAL_NULL2_H + +#ifdef fortran1 +#define f_get_initial_null2 get_initial_null2 +#define f_get_initial_null3 get_initial_null3 +#define f_get_gauge_g00 get_gauge_g00 +#define f_get_gauge_g00_K get_gauge_g00_k +#define f_get_gauge_g00_real get_gauge_g00_real +#define f_get_null_boundary2 get_null_boundary2 +#define f_get_null_boundary3 get_null_boundary3 +#define f_get_g00_with_t get_g00_with_t +#endif +#ifdef fortran2 +#define f_get_initial_null2 GET_INITIAL_NULL2 +#define f_get_initial_null3 GET_INITIAL_NULL3 +#define f_get_gauge_g00 GET_GAUGE_G00 +#define f_get_gauge_g00_K GET_GAUGE_G00_K +#define f_get_gauge_g00_real GET_GAUGE_G00_REAL +#define f_get_null_boundary2 GET_NULL_BOUNDARY2 +#define f_get_null_boundary3 GET_NULL_BOUNDARY3 +#define f_get_g00_with_t GET_G00_WITH_T +#endif +#ifdef fortran3 +#define f_get_initial_null2 get_initial_null2_ +#define f_get_initial_null3 get_initial_null3_ +#define f_get_gauge_g00 get_gauge_g00_ +#define f_get_gauge_g00_K get_gauge_g00_k_ +#define f_get_gauge_g00_real get_gauge_g00_real_ +#define f_get_null_boundary2 get_null_boundary2_ +#define f_get_null_boundary3 get_null_boundary3_ +#define f_get_g00_with_t get_g00_with_t_ +#endif + +extern "C" +{ + void f_get_initial_null2(int *, double *, double *, double *, + double *, double *, double *, + int &, double &); +} + +extern "C" +{ + void f_get_gauge_g00(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double &, int &); +} + +extern "C" +{ + void f_get_gauge_g00_K(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double &); +} + +extern "C" +{ + void f_get_gauge_g00_real(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double &); +} + +extern "C" +{ + void f_get_null_boundary2(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, + double *, double *, double *, + double &); +} + +extern "C" +{ + void f_get_g00_with_t(double &, int *, double *, double *, double *, + double *, double &, int &); +} + +extern "C" +{ + void f_get_null_boundary3(double &, int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, + double *, double *, double *, + double &, int &); +} + +extern "C" +{ + void f_get_initial_null3(int *, double *, double *, double *, + double *, double *, double *, + int &, double &); +} + +#endif /* INITIAL_NULL2_H */ diff --git a/AMSS_NCKU_source/initial_puncture.f90 b/AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.f90 similarity index 97% rename from AMSS_NCKU_source/initial_puncture.f90 rename to AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.f90 index bab5520..c1346e9 100644 --- a/AMSS_NCKU_source/initial_puncture.f90 +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.f90 @@ -1,2597 +1,2597 @@ - -!------------------------------------------------------------- -! kerrschild for schwarzschild -!------------------------------------------------------------- -subroutine get_initial_kerrschild(ex,XX,YY,ZZ,& - chi,trK,& - dxx,gxy,gxz,dyy,gyz,dzz,& - Axx,Axy,Axz,Ayy,Ayz,Azz,& - Gmx,Gmy,Gmz,& - Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8, intent(in ):: XX(1:ex(1)),YY(1:ex(2)),ZZ(1:ex(3)) -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::chi,trK,dxx,gxy,gxz,dyy,gyz,dzz -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Axx,Axy,Axz,Ayy,Ayz,Azz -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Gmx,Gmy,Gmz,Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz - -integer :: i,j,k -real*8 ::x,y,z -real*8,parameter :: M = 1.d0,ZEO=0.d0,mF1o3=-1.d0/3.d0 - -do i=1,ex(1) - x = XX(i) -do j=1,ex(2) - y = YY(j) -do k=1,ex(3) - z = ZZ(k) - chi(i,j,k) = ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**mF1o3 - 1.d0 - - trK(i,j,k) = 2*(sqrt(x**2+y**2+z**2)+3*M)*M/(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)& - /sqrt((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2)) - - dxx(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*z**2& - +2*x**2*M)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)/& - sqrt(x**2+y**2+z**2)**3 - 1.0 - gxy(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*y/& - sqrt(x**2+y**2+z**2)**3 - gxz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*z/& - sqrt(x**2+y**2+z**2)**3 - dyy(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)& - *z**2+2*M*y**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& - /sqrt(x**2+y**2+z**2)**3 - 1.0 - gyz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*y*z/& - sqrt(x**2+y**2+z**2)**3 - dzz(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*& - z**2+2*M*z**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& - /sqrt(x**2+y**2+z**2)**3 - 1.0 - Axx(i,j,k) = -2.D0/3.D0*M*(4*x**4+2*x**2*y**2+12*x**2*M**2+2*x**2*z**2+14*x**2*sqrt(x**2+y**2+z**2)& - *M-4*y**2*z**2-2*z**4-2*y**4-3*sqrt(x**2+y**2+z**2)*M*y**2-3*sqrt(x**2+y**2+z**2)*M*z**2)& - /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Axy(i,j,k) = -2.D0/3.D0*M*x*y*(6*x**2+12*M**2+6*z**2+6*y**2+17*sqrt(x**2+y**2+z**2)*M)/& - sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Axz(i,j,k) = -2.D0/3.D0*z*M*x*(6*x**2+12*M**2+6*z**2+6*y**2+17*M*sqrt(x**2+y**2+z**2))/& - sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Ayy(i,j,k) = 2.D0/3.D0*M*(2*x**4+3*x**2*sqrt(x**2+y**2+z**2)*M-2*x**2*y**2+4*x**2*z**2-2*y**2*z**2& - +2*z**4-4*y**4+3*sqrt(x**2+y**2+z**2)*M*z**2-14*sqrt(x**2+y**2+z**2)*M*y**2-12*M**2*y**2)& - /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Ayz(i,j,k) = -2.D0/3.D0*z*y*M*(6*x**2+6*z**2+17*sqrt(x**2+y**2+z**2)*M+12*M**2+6*y**2)/& - sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Azz(i,j,k) = 2.D0/3.D0*M*(2*x**4-2*x**2*z**2+4*x**2*y**2+3*x**2*sqrt(x**2+y**2+z**2)*M- & - 2*y**2*z**2-4*z**4+2*y**4-12*M**2*z**2-14*sqrt(x**2+y**2+z**2)*M*z**2+3*& - sqrt(x**2+y**2+z**2)*M*y**2)/sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/& - ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Gmx(i,j,k) = 8.D0/3.D0*x*M*(x**2+6*M**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2)/(sqrt(x**2+y**2+z**2) & - +2*M)**2/sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) - Gmy(i,j,k) = 8.D0/3.D0*M*y*(x**2+6*M**2+z**2+y**2+5*M*sqrt(x**2+y**2+z**2))/(sqrt(x**2+y**2+z**2)+2*M)**2/& - sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) - Gmz(i,j,k) = 8.D0/3.D0*M*z*(x**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2+6*M**2)/(sqrt(x**2+y**2+z**2)+2*M)**2/& - sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) - Lap(i,j,k) = sqrt(sqrt(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)) - 1.0 - Sfx(i,j,k) = 2/sqrt(x**2+y**2+z**2)*x*M/(sqrt(x**2+y**2+z**2)+2*M) - Sfy(i,j,k) = 2/sqrt(x**2+y**2+z**2)*M*y/(sqrt(x**2+y**2+z**2)+2*M) - Sfz(i,j,k) = 2/sqrt(x**2+y**2+z**2)*z*M/(sqrt(x**2+y**2+z**2)+2*M) - -enddo -enddo -enddo -dtSfx = ZEO -dtSfy = ZEO -dtSfz = ZEO - -return - -end subroutine get_initial_kerrschild -!for shell -subroutine get_initial_kerrschild_ss(ex,XX,YY,ZZ,& - chi,trK,& - dxx,gxy,gxz,dyy,gyz,dzz,& - Axx,Axy,Axz,Ayy,Ayz,Azz,& - Gmx,Gmy,Gmz,& - Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,dimension(ex(1),ex(2),ex(3)),intent(in ):: XX,YY,ZZ -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::chi,trK,dxx,gxy,gxz,dyy,gyz,dzz -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Axx,Axy,Axz,Ayy,Ayz,Azz -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Gmx,Gmy,Gmz,Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz - -integer :: i,j,k -real*8 ::x,y,z -real*8,parameter :: M = 1.d0,ZEO=0.d0,mF1o3=-1.d0/3.d0 - -do i=1,ex(1) -do j=1,ex(2) -do k=1,ex(3) - x = XX(i,j,k) - y = YY(i,j,k) - z = ZZ(i,j,k) - chi(i,j,k) = ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**mF1o3 - 1.d0 - - trK(i,j,k) = 2*(sqrt(x**2+y**2+z**2)+3*M)*M/(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)& - /sqrt((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2)) - - dxx(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*z**2& - +2*x**2*M)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)/& - sqrt(x**2+y**2+z**2)**3 - 1.0 - gxy(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*y/& - sqrt(x**2+y**2+z**2)**3 - gxz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*z/& - sqrt(x**2+y**2+z**2)**3 - dyy(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)& - *z**2+2*M*y**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& - /sqrt(x**2+y**2+z**2)**3 - 1.0 - gyz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*y*z/& - sqrt(x**2+y**2+z**2)**3 - dzz(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*& - z**2+2*M*z**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& - /sqrt(x**2+y**2+z**2)**3 - 1.0 - Axx(i,j,k) = -2.D0/3.D0*M*(4*x**4+2*x**2*y**2+12*x**2*M**2+2*x**2*z**2+14*x**2*sqrt(x**2+y**2+z**2)& - *M-4*y**2*z**2-2*z**4-2*y**4-3*sqrt(x**2+y**2+z**2)*M*y**2-3*sqrt(x**2+y**2+z**2)*M*z**2)& - /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Axy(i,j,k) = -2.D0/3.D0*M*x*y*(6*x**2+12*M**2+6*z**2+6*y**2+17*sqrt(x**2+y**2+z**2)*M)/& - sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Axz(i,j,k) = -2.D0/3.D0*z*M*x*(6*x**2+12*M**2+6*z**2+6*y**2+17*M*sqrt(x**2+y**2+z**2))/& - sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Ayy(i,j,k) = 2.D0/3.D0*M*(2*x**4+3*x**2*sqrt(x**2+y**2+z**2)*M-2*x**2*y**2+4*x**2*z**2-2*y**2*z**2& - +2*z**4-4*y**4+3*sqrt(x**2+y**2+z**2)*M*z**2-14*sqrt(x**2+y**2+z**2)*M*y**2-12*M**2*y**2)& - /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Ayz(i,j,k) = -2.D0/3.D0*z*y*M*(6*x**2+6*z**2+17*sqrt(x**2+y**2+z**2)*M+12*M**2+6*y**2)/& - sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& - sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Azz(i,j,k) = 2.D0/3.D0*M*(2*x**4-2*x**2*z**2+4*x**2*y**2+3*x**2*sqrt(x**2+y**2+z**2)*M- & - 2*y**2*z**2-4*z**4+2*y**4-12*M**2*z**2-14*sqrt(x**2+y**2+z**2)*M*z**2+3*& - sqrt(x**2+y**2+z**2)*M*y**2)/sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/& - ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(5.D0/6.D0) - Gmx(i,j,k) = 8.D0/3.D0*x*M*(x**2+6*M**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2)/(sqrt(x**2+y**2+z**2) & - +2*M)**2/sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) - Gmy(i,j,k) = 8.D0/3.D0*M*y*(x**2+6*M**2+z**2+y**2+5*M*sqrt(x**2+y**2+z**2))/(sqrt(x**2+y**2+z**2)+2*M)**2/& - sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) - Gmz(i,j,k) = 8.D0/3.D0*M*z*(x**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2+6*M**2)/(sqrt(x**2+y**2+z**2)+2*M)**2/& - sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) - Lap(i,j,k) = sqrt(sqrt(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)) - 1.0 - Sfx(i,j,k) = 2/sqrt(x**2+y**2+z**2)*x*M/(sqrt(x**2+y**2+z**2)+2*M) - Sfy(i,j,k) = 2/sqrt(x**2+y**2+z**2)*M*y/(sqrt(x**2+y**2+z**2)+2*M) - Sfz(i,j,k) = 2/sqrt(x**2+y**2+z**2)*z*M/(sqrt(x**2+y**2+z**2)+2*M) - -enddo -enddo -enddo -dtSfx = ZEO -dtSfy = ZEO -dtSfz = ZEO - -return - -end subroutine get_initial_kerrschild_ss -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for single black hole with small P and -!S, my own formula -! -!----------------------------------------------------------------------------------- - - subroutine get_initial_bssn3(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,M,Porg,Pmom,Spin) - - implicit none - -!------= input arguments - - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, intent(in) :: M,Porg(3),Pmom(3),Spin(3) - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k - real*8 :: Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - PP = dsqrt(Px**2 + Py**2 + Pz**2) - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) - - nx = X(i)-Porg(1) - ny = Y(j)-Porg(2) - nz = Z(k)-Porg(3) - rr = dsqrt(nx**2+ny**2+nz**2) - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - nx = nx / rr - ny = ny / rr - nz = nz / rr - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / psi **2 - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_initial_bssn3 -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for inspiral binary -! -!----------------------------------------------------------------------------------- - - subroutine get_initial_bssn6(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin) - - implicit none - -!------= input arguments - - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(2), intent(in) :: Mass - real*8, dimension(6), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k - real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 - M = Mass(2) - nx = x(i) - Porg(4) - ny = y(j) - Porg(5) - nz = z(k) - Porg(6) - Px = Pmom(4) - Py = Pmom(5) - Pz = Pmom(6) - Sx = Spin(4) - Sy = Spin(5) - Sz = Spin(6) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_initial_bssn6 -!----------------------------------------------------------------------------------- -! -!post deal the initial data after reading from file -! -!----------------------------------------------------------------------------------- - subroutine get_initial_postdeal(ex,X,Y,Z, & - chi, trK, & - dxx, gxy, gxz, dyy, gyz, dzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz) - - implicit none - -!------= input arguments -! for chi: input phi, output chi - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dtSfx,dtSfy,dtSfz - -!------= local variables - - real*8,parameter :: ZEO = 0.d0, ONE = 1.d0 - -! psi=exp(phi) - chi = dexp( chi ) -! Lap=exp(-2*phi) - Lap = ONE / ( chi * chi ) - ONE -! chi=exp(-4*phi) - chi = ONE / chi **4 - ONE - - dxx = ZEO - dyy = ZEO - dzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_initial_postdeal -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for single black hole with the given solution u by -!Ansorg -! -!----------------------------------------------------------------------------------- - - subroutine get_ansorg_single(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,M,Porg,Pmom,Spin) - - implicit none - -!------= input arguments - - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z -! in u, out chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, intent(in) :: M,Porg(3),Pmom(3),Spin(3) - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k - real*8 :: Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) - - nx = X(i)-Porg(1) - ny = Y(j)-Porg(2) - nz = Z(k)-Porg(3) - rr = dsqrt(nx**2+ny**2+nz**2) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_ansorg_single -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for inspiral binary with the given solution u by -!Ansorg -! -!----------------------------------------------------------------------------------- - - subroutine get_ansorg_binary(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin) - - implicit none - -!------= input arguments - - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z -! in u, out chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(2), intent(in) :: Mass - real*8, dimension(6), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k - real*8 :: M,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 - M = Mass(2) - nx = x(i) - Porg(4) - ny = y(j) - Porg(5) - nz = z(k) - Porg(6) - Px = Pmom(4) - Py = Pmom(5) - Pz = Pmom(6) - Sx = Spin(4) - Sy = Spin(5) - Sz = Spin(6) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_ansorg_binary - -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for black hole system with the given solution u by -!Ansorg -! -!----------------------------------------------------------------------------------- - subroutine get_ansorg_nbhs(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz, & - Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter :: TINYRR=1.d-14 - real*8,parameter :: phi0=1.d0,r0=120.d0,sigma=8.d0 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - psi = chi + psi - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_ansorg_nbhs -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for black hole system with the given solution u by -!Ansorg -! for shell part -!----------------------------------------------------------------------------------- - subroutine get_ansorg_nbhs_ss(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz, & - Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter :: TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i,j,k) - Porg(1) - ny = y(i,j,k) - Porg(2) - nz = z(i,j,k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i,j,k) - Porg(3*(bhi-1)+1) - ny = y(i,j,k) - Porg(3*(bhi-1)+2) - nz = z(i,j,k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - psi = chi + psi - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_ansorg_nbhs_ss -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n black holes -! -!----------------------------------------------------------------------------------- - - subroutine get_initial_nbhs(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_initial_nbhs -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n black holes -! -!----------------------------------------------------------------------------------- - - subroutine get_initial_nbhs_ss(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i,j,k) - Porg(1) - ny = y(i,j,k) - Porg(2) - nz = z(i,j,k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i,j,k) - Porg(3*(bhi-1)+1) - ny = y(i,j,k) - Porg(3*(bhi-1)+2) - nz = z(i,j,k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) - u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_initial_nbhs_ss -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for inspiral binary with the given solution u -! -!----------------------------------------------------------------------------------- - - subroutine get_pablo_nbhs(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z -! in u, out chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_pablo_nbhs -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n black holes with lousto's -!formula PRD 77, 024034 (2008) -! -!----------------------------------------------------------------------------------- - - subroutine get_lousto_nbhs(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4,u5 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 - u4 = -b**2*ell**5 - u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & - u5*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 - u4 = -b**2*ell**5 - u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & - u5*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_lousto_nbhs -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for black hole system coupled with scalar field -!with the given solution u by -!Ansorg -! -!----------------------------------------------------------------------------------- - subroutine get_ansorg_nbhs_escalar(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz, & - Sphi,Spi, & - Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1)), intent(in) :: X - real*8, dimension(ex(2)), intent(in) :: Y - real*8, dimension(ex(3)), intent(in) :: Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Sphi,Spi - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter :: TINYRR=1.d-14 - - real*8 :: phi0,r0,sigma,a2,l2 - - real*8 :: phi ! in Set_Rho_ADM.f90 - - call setparameters(a2,r0,phi0,sigma,l2) - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i) - Porg(1) - ny = y(j) - Porg(2) - nz = z(k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i) - Porg(3*(bhi-1)+1) - ny = y(j) - Porg(3*(bhi-1)+2) - nz = z(k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo -! scalar field - Sphi(i,j,k) = phi(x(i),y(j),z(k)) ! this function locates in 'Set_Rho_ADM.f90' - enddo - enddo - enddo - - psi = chi + psi - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - Spi = ZEO - - return - - end subroutine get_ansorg_nbhs_escalar -!----------------------------------------------------------------------------------- -! -!Set up puncture initial data for black hole system with the given solution u by -!Ansorg -! for shell part -!----------------------------------------------------------------------------------- - subroutine get_ansorg_nbhs_ss_escalar(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz, & - Sphi,Spi, & - Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Sphi,Spi - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,Sx,Sy,Sz - real*8 :: nx,ny,nz,rr,tmp - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter :: TINYRR=1.d-14 - - real*8 :: phi0,r0,sigma,a2,l2 - - real*8 :: phi ! in Set_Rho_ADM.f90 - - call setparameters(a2,r0,phi0,sigma,l2) - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i,j,k) - Porg(1) - ny = y(i,j,k) - Porg(2) - nz = z(i,j,k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = ONE + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i,j,k) - Porg(3*(bhi-1)+1) - ny = y(i,j,k) - Porg(3*(bhi-1)+2) - nz = z(i,j,k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=TINYRR - nx = nx / rr - ny = ny / rr - nz = nz / rr - - psi(i,j,k) = psi(i,j,k) + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo -! scalar field - Sphi(i,j,k) = phi(x(i,j,k),y(i,j,k),z(i,j,k)) ! this function locates in 'Set_Rho_ADM.f90' - enddo - enddo - enddo - - psi = chi + psi - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - Spi = ZEO - - return - - end subroutine get_ansorg_nbhs_ss_escalar + +!------------------------------------------------------------- +! kerrschild for schwarzschild +!------------------------------------------------------------- +subroutine get_initial_kerrschild(ex,XX,YY,ZZ,& + chi,trK,& + dxx,gxy,gxz,dyy,gyz,dzz,& + Axx,Axy,Axz,Ayy,Ayz,Azz,& + Gmx,Gmy,Gmz,& + Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8, intent(in ):: XX(1:ex(1)),YY(1:ex(2)),ZZ(1:ex(3)) +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::chi,trK,dxx,gxy,gxz,dyy,gyz,dzz +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Axx,Axy,Axz,Ayy,Ayz,Azz +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Gmx,Gmy,Gmz,Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz + +integer :: i,j,k +real*8 ::x,y,z +real*8,parameter :: M = 1.d0,ZEO=0.d0,mF1o3=-1.d0/3.d0 + +do i=1,ex(1) + x = XX(i) +do j=1,ex(2) + y = YY(j) +do k=1,ex(3) + z = ZZ(k) + chi(i,j,k) = ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**mF1o3 - 1.d0 + + trK(i,j,k) = 2*(sqrt(x**2+y**2+z**2)+3*M)*M/(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)& + /sqrt((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2)) + + dxx(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*z**2& + +2*x**2*M)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)/& + sqrt(x**2+y**2+z**2)**3 - 1.0 + gxy(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*y/& + sqrt(x**2+y**2+z**2)**3 + gxz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*z/& + sqrt(x**2+y**2+z**2)**3 + dyy(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)& + *z**2+2*M*y**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& + /sqrt(x**2+y**2+z**2)**3 - 1.0 + gyz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*y*z/& + sqrt(x**2+y**2+z**2)**3 + dzz(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*& + z**2+2*M*z**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& + /sqrt(x**2+y**2+z**2)**3 - 1.0 + Axx(i,j,k) = -2.D0/3.D0*M*(4*x**4+2*x**2*y**2+12*x**2*M**2+2*x**2*z**2+14*x**2*sqrt(x**2+y**2+z**2)& + *M-4*y**2*z**2-2*z**4-2*y**4-3*sqrt(x**2+y**2+z**2)*M*y**2-3*sqrt(x**2+y**2+z**2)*M*z**2)& + /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Axy(i,j,k) = -2.D0/3.D0*M*x*y*(6*x**2+12*M**2+6*z**2+6*y**2+17*sqrt(x**2+y**2+z**2)*M)/& + sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Axz(i,j,k) = -2.D0/3.D0*z*M*x*(6*x**2+12*M**2+6*z**2+6*y**2+17*M*sqrt(x**2+y**2+z**2))/& + sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Ayy(i,j,k) = 2.D0/3.D0*M*(2*x**4+3*x**2*sqrt(x**2+y**2+z**2)*M-2*x**2*y**2+4*x**2*z**2-2*y**2*z**2& + +2*z**4-4*y**4+3*sqrt(x**2+y**2+z**2)*M*z**2-14*sqrt(x**2+y**2+z**2)*M*y**2-12*M**2*y**2)& + /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Ayz(i,j,k) = -2.D0/3.D0*z*y*M*(6*x**2+6*z**2+17*sqrt(x**2+y**2+z**2)*M+12*M**2+6*y**2)/& + sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Azz(i,j,k) = 2.D0/3.D0*M*(2*x**4-2*x**2*z**2+4*x**2*y**2+3*x**2*sqrt(x**2+y**2+z**2)*M- & + 2*y**2*z**2-4*z**4+2*y**4-12*M**2*z**2-14*sqrt(x**2+y**2+z**2)*M*z**2+3*& + sqrt(x**2+y**2+z**2)*M*y**2)/sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/& + ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Gmx(i,j,k) = 8.D0/3.D0*x*M*(x**2+6*M**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2)/(sqrt(x**2+y**2+z**2) & + +2*M)**2/sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) + Gmy(i,j,k) = 8.D0/3.D0*M*y*(x**2+6*M**2+z**2+y**2+5*M*sqrt(x**2+y**2+z**2))/(sqrt(x**2+y**2+z**2)+2*M)**2/& + sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) + Gmz(i,j,k) = 8.D0/3.D0*M*z*(x**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2+6*M**2)/(sqrt(x**2+y**2+z**2)+2*M)**2/& + sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) + Lap(i,j,k) = sqrt(sqrt(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)) - 1.0 + Sfx(i,j,k) = 2/sqrt(x**2+y**2+z**2)*x*M/(sqrt(x**2+y**2+z**2)+2*M) + Sfy(i,j,k) = 2/sqrt(x**2+y**2+z**2)*M*y/(sqrt(x**2+y**2+z**2)+2*M) + Sfz(i,j,k) = 2/sqrt(x**2+y**2+z**2)*z*M/(sqrt(x**2+y**2+z**2)+2*M) + +enddo +enddo +enddo +dtSfx = ZEO +dtSfy = ZEO +dtSfz = ZEO + +return + +end subroutine get_initial_kerrschild +!for shell +subroutine get_initial_kerrschild_ss(ex,XX,YY,ZZ,& + chi,trK,& + dxx,gxy,gxz,dyy,gyz,dzz,& + Axx,Axy,Axz,Ayy,Ayz,Azz,& + Gmx,Gmy,Gmz,& + Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,dimension(ex(1),ex(2),ex(3)),intent(in ):: XX,YY,ZZ +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::chi,trK,dxx,gxy,gxz,dyy,gyz,dzz +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Axx,Axy,Axz,Ayy,Ayz,Azz +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::Gmx,Gmy,Gmz,Lap,Sfx,Sfy,Sfz,dtSfx,dtSfy,dtSfz + +integer :: i,j,k +real*8 ::x,y,z +real*8,parameter :: M = 1.d0,ZEO=0.d0,mF1o3=-1.d0/3.d0 + +do i=1,ex(1) +do j=1,ex(2) +do k=1,ex(3) + x = XX(i,j,k) + y = YY(i,j,k) + z = ZZ(i,j,k) + chi(i,j,k) = ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**mF1o3 - 1.d0 + + trK(i,j,k) = 2*(sqrt(x**2+y**2+z**2)+3*M)*M/(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)& + /sqrt((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2)) + + dxx(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*z**2& + +2*x**2*M)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)/& + sqrt(x**2+y**2+z**2)**3 - 1.0 + gxy(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*y/& + sqrt(x**2+y**2+z**2)**3 + gxz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*x*z/& + sqrt(x**2+y**2+z**2)**3 + dyy(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)& + *z**2+2*M*y**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& + /sqrt(x**2+y**2+z**2)**3 - 1.0 + gyz(i,j,k) = 2/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)*M*y*z/& + sqrt(x**2+y**2+z**2)**3 + dzz(i,j,k) = (sqrt(x**2+y**2+z**2)*x**2+sqrt(x**2+y**2+z**2)*y**2+sqrt(x**2+y**2+z**2)*& + z**2+2*M*z**2)/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(1.D0/3.D0)& + /sqrt(x**2+y**2+z**2)**3 - 1.0 + Axx(i,j,k) = -2.D0/3.D0*M*(4*x**4+2*x**2*y**2+12*x**2*M**2+2*x**2*z**2+14*x**2*sqrt(x**2+y**2+z**2)& + *M-4*y**2*z**2-2*z**4-2*y**4-3*sqrt(x**2+y**2+z**2)*M*y**2-3*sqrt(x**2+y**2+z**2)*M*z**2)& + /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Axy(i,j,k) = -2.D0/3.D0*M*x*y*(6*x**2+12*M**2+6*z**2+6*y**2+17*sqrt(x**2+y**2+z**2)*M)/& + sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Axz(i,j,k) = -2.D0/3.D0*z*M*x*(6*x**2+12*M**2+6*z**2+6*y**2+17*M*sqrt(x**2+y**2+z**2))/& + sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Ayy(i,j,k) = 2.D0/3.D0*M*(2*x**4+3*x**2*sqrt(x**2+y**2+z**2)*M-2*x**2*y**2+4*x**2*z**2-2*y**2*z**2& + +2*z**4-4*y**4+3*sqrt(x**2+y**2+z**2)*M*z**2-14*sqrt(x**2+y**2+z**2)*M*y**2-12*M**2*y**2)& + /sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Ayz(i,j,k) = -2.D0/3.D0*z*y*M*(6*x**2+6*z**2+17*sqrt(x**2+y**2+z**2)*M+12*M**2+6*y**2)/& + sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/((sqrt(x**2+y**2+z**2)+2*M)/& + sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Azz(i,j,k) = 2.D0/3.D0*M*(2*x**4-2*x**2*z**2+4*x**2*y**2+3*x**2*sqrt(x**2+y**2+z**2)*M- & + 2*y**2*z**2-4*z**4+2*y**4-12*M**2*z**2-14*sqrt(x**2+y**2+z**2)*M*z**2+3*& + sqrt(x**2+y**2+z**2)*M*y**2)/sqrt(x**2+y**2+z**2)**5/(sqrt(x**2+y**2+z**2)+2*M)/& + ((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(5.D0/6.D0) + Gmx(i,j,k) = 8.D0/3.D0*x*M*(x**2+6*M**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2)/(sqrt(x**2+y**2+z**2) & + +2*M)**2/sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) + Gmy(i,j,k) = 8.D0/3.D0*M*y*(x**2+6*M**2+z**2+y**2+5*M*sqrt(x**2+y**2+z**2))/(sqrt(x**2+y**2+z**2)+2*M)**2/& + sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) + Gmz(i,j,k) = 8.D0/3.D0*M*z*(x**2+z**2+5*M*sqrt(x**2+y**2+z**2)+y**2+6*M**2)/(sqrt(x**2+y**2+z**2)+2*M)**2/& + sqrt(x**2+y**2+z**2)**3/((sqrt(x**2+y**2+z**2)+2*M)/sqrt(x**2+y**2+z**2))**(2.D0/3.D0) + Lap(i,j,k) = sqrt(sqrt(x**2+y**2+z**2)/(sqrt(x**2+y**2+z**2)+2*M)) - 1.0 + Sfx(i,j,k) = 2/sqrt(x**2+y**2+z**2)*x*M/(sqrt(x**2+y**2+z**2)+2*M) + Sfy(i,j,k) = 2/sqrt(x**2+y**2+z**2)*M*y/(sqrt(x**2+y**2+z**2)+2*M) + Sfz(i,j,k) = 2/sqrt(x**2+y**2+z**2)*z*M/(sqrt(x**2+y**2+z**2)+2*M) + +enddo +enddo +enddo +dtSfx = ZEO +dtSfy = ZEO +dtSfz = ZEO + +return + +end subroutine get_initial_kerrschild_ss +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for single black hole with small P and +!S, my own formula +! +!----------------------------------------------------------------------------------- + + subroutine get_initial_bssn3(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,M,Porg,Pmom,Spin) + + implicit none + +!------= input arguments + + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, intent(in) :: M,Porg(3),Pmom(3),Spin(3) + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k + real*8 :: Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + PP = dsqrt(Px**2 + Py**2 + Pz**2) + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) + + nx = X(i)-Porg(1) + ny = Y(j)-Porg(2) + nz = Z(k)-Porg(3) + rr = dsqrt(nx**2+ny**2+nz**2) + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + nx = nx / rr + ny = ny / rr + nz = nz / rr + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / psi **2 - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_initial_bssn3 +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for inspiral binary +! +!----------------------------------------------------------------------------------- + + subroutine get_initial_bssn6(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin) + + implicit none + +!------= input arguments + + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(2), intent(in) :: Mass + real*8, dimension(6), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k + real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 + M = Mass(2) + nx = x(i) - Porg(4) + ny = y(j) - Porg(5) + nz = z(k) - Porg(6) + Px = Pmom(4) + Py = Pmom(5) + Pz = Pmom(6) + Sx = Spin(4) + Sy = Spin(5) + Sz = Spin(6) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_initial_bssn6 +!----------------------------------------------------------------------------------- +! +!post deal the initial data after reading from file +! +!----------------------------------------------------------------------------------- + subroutine get_initial_postdeal(ex,X,Y,Z, & + chi, trK, & + dxx, gxy, gxz, dyy, gyz, dzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz) + + implicit none + +!------= input arguments +! for chi: input phi, output chi + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: dtSfx,dtSfy,dtSfz + +!------= local variables + + real*8,parameter :: ZEO = 0.d0, ONE = 1.d0 + +! psi=exp(phi) + chi = dexp( chi ) +! Lap=exp(-2*phi) + Lap = ONE / ( chi * chi ) - ONE +! chi=exp(-4*phi) + chi = ONE / chi **4 - ONE + + dxx = ZEO + dyy = ZEO + dzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_initial_postdeal +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for single black hole with the given solution u by +!Ansorg +! +!----------------------------------------------------------------------------------- + + subroutine get_ansorg_single(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,M,Porg,Pmom,Spin) + + implicit none + +!------= input arguments + + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z +! in u, out chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, intent(in) :: M,Porg(3),Pmom(3),Spin(3) + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k + real*8 :: Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) + + nx = X(i)-Porg(1) + ny = Y(j)-Porg(2) + nz = Z(k)-Porg(3) + rr = dsqrt(nx**2+ny**2+nz**2) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_ansorg_single +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for inspiral binary with the given solution u by +!Ansorg +! +!----------------------------------------------------------------------------------- + + subroutine get_ansorg_binary(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin) + + implicit none + +!------= input arguments + + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z +! in u, out chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(2), intent(in) :: Mass + real*8, dimension(6), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k + real*8 :: M,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 + M = Mass(2) + nx = x(i) - Porg(4) + ny = y(j) - Porg(5) + nz = z(k) - Porg(6) + Px = Pmom(4) + Py = Pmom(5) + Pz = Pmom(6) + Sx = Spin(4) + Sy = Spin(5) + Sz = Spin(6) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_ansorg_binary + +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for black hole system with the given solution u by +!Ansorg +! +!----------------------------------------------------------------------------------- + subroutine get_ansorg_nbhs(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz, & + Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter :: TINYRR=1.d-14 + real*8,parameter :: phi0=1.d0,r0=120.d0,sigma=8.d0 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + psi = chi + psi + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_ansorg_nbhs +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for black hole system with the given solution u by +!Ansorg +! for shell part +!----------------------------------------------------------------------------------- + subroutine get_ansorg_nbhs_ss(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz, & + Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter :: TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i,j,k) - Porg(1) + ny = y(i,j,k) - Porg(2) + nz = z(i,j,k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i,j,k) - Porg(3*(bhi-1)+1) + ny = y(i,j,k) - Porg(3*(bhi-1)+2) + nz = z(i,j,k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + psi = chi + psi + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_ansorg_nbhs_ss +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n black holes +! +!----------------------------------------------------------------------------------- + + subroutine get_initial_nbhs(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_initial_nbhs +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n black holes +! +!----------------------------------------------------------------------------------- + + subroutine get_initial_nbhs_ss(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i,j,k) - Porg(1) + ny = y(i,j,k) - Porg(2) + nz = z(i,j,k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i,j,k) - Porg(3*(bhi-1)+1) + ny = y(i,j,k) - Porg(3*(bhi-1)+2) + nz = z(i,j,k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell/2.d1*(1.d0+ell+ell**2-4.d0*ell**3+2.d0*ell**4) + u4 = ell**2/1.d1*(1.d1-2.5d1*ell+2.1d1*ell**2-6.d0*ell**3) + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 6.d0*u3/M**4*SS**2*(1.d0+mus**2) + u4/M**3*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_initial_nbhs_ss +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for inspiral binary with the given solution u +! +!----------------------------------------------------------------------------------- + + subroutine get_pablo_nbhs(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z +! in u, out chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + chi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_pablo_nbhs +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n black holes with lousto's +!formula PRD 77, 024034 (2008) +! +!----------------------------------------------------------------------------------- + + subroutine get_lousto_nbhs(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4,u5 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 + u4 = -b**2*ell**5 + u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & + u5*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 + u4 = -b**2*ell**5 + u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & + u5*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_lousto_nbhs +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for black hole system coupled with scalar field +!with the given solution u by +!Ansorg +! +!----------------------------------------------------------------------------------- + subroutine get_ansorg_nbhs_escalar(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz, & + Sphi,Spi, & + Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1)), intent(in) :: X + real*8, dimension(ex(2)), intent(in) :: Y + real*8, dimension(ex(3)), intent(in) :: Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Sphi,Spi + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter :: TINYRR=1.d-14 + + real*8 :: phi0,r0,sigma,a2,l2 + + real*8 :: phi ! in Set_Rho_ADM.f90 + + call setparameters(a2,r0,phi0,sigma,l2) + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i) - Porg(1) + ny = y(j) - Porg(2) + nz = z(k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i) - Porg(3*(bhi-1)+1) + ny = y(j) - Porg(3*(bhi-1)+2) + nz = z(k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2)-X(1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo +! scalar field + Sphi(i,j,k) = phi(x(i),y(j),z(k)) ! this function locates in 'Set_Rho_ADM.f90' + enddo + enddo + enddo + + psi = chi + psi + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + Spi = ZEO + + return + + end subroutine get_ansorg_nbhs_escalar +!----------------------------------------------------------------------------------- +! +!Set up puncture initial data for black hole system with the given solution u by +!Ansorg +! for shell part +!----------------------------------------------------------------------------------- + subroutine get_ansorg_nbhs_ss_escalar(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz, & + Sphi,Spi, & + Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Sphi,Spi + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,Sx,Sy,Sz + real*8 :: nx,ny,nz,rr,tmp + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter :: TINYRR=1.d-14 + + real*8 :: phi0,r0,sigma,a2,l2 + + real*8 :: phi ! in Set_Rho_ADM.f90 + + call setparameters(a2,r0,phi0,sigma,l2) + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i,j,k) - Porg(1) + ny = y(i,j,k) - Porg(2) + nz = z(i,j,k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = ONE + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i,j,k) - Porg(3*(bhi-1)+1) + ny = y(i,j,k) - Porg(3*(bhi-1)+2) + nz = z(i,j,k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=TINYRR + nx = nx / rr + ny = ny / rr + nz = nz / rr + + psi(i,j,k) = psi(i,j,k) + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo +! scalar field + Sphi(i,j,k) = phi(x(i,j,k),y(i,j,k),z(i,j,k)) ! this function locates in 'Set_Rho_ADM.f90' + enddo + enddo + enddo + + psi = chi + psi + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + Spi = ZEO + + return + + end subroutine get_ansorg_nbhs_ss_escalar diff --git a/AMSS_NCKU_source/initial_puncture.h b/AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.h similarity index 97% rename from AMSS_NCKU_source/initial_puncture.h rename to AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.h index 90f6df0..c3fbcd2 100644 --- a/AMSS_NCKU_source/initial_puncture.h +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_puncture.h @@ -1,249 +1,249 @@ - -#ifndef GET_INITIAL_H -#define GET_INITIAL_H - -#ifdef fortran1 -#define f_get_initial_kerrschild get_initial_kerrschild -#define f_get_initial_kerrschild_ss get_initial_kerrschild_ss -#define f_get_initial_single get_initial_bssn3 -#define f_get_ansorg_single get_ansorg_single -#define f_get_initial_binary get_initial_bssn6 -#define f_get_ansorg_binary get_ansorg_binary -#define f_get_ansorg_nbhs get_ansorg_nbhs -#define f_get_ansorg_nbhs_escalar get_ansorg_nbhs_escalar -#define f_get_ansorg_nbhs_ss get_ansorg_nbhs_ss -#define f_get_ansorg_nbhs_ss_escalar get_ansorg_nbhs_ss_escalar -#define f_get_initial_postdeal get_initial_postdeal -#define f_get_initial_nbhs get_initial_nbhs -#define f_get_lousto_nbhs get_lousto_nbhs -#define f_get_pablo_nbhs get_pablo_nbhs -#define f_get_shapiro get_shapiro -#define f_get_niall_minkowski get_niall_minkowski -#endif -#ifdef fortran2 -#define f_get_initial_kerrschild GET_INITIAL_KERRSCHILD -#define f_get_initial_kerrschild_ss GET_INITIAL_KERRSCHILD_SS -#define f_get_initial_single GET_INITIAL_BSSN3 -#define f_get_ansorg_single GET_ANSORG_SINGLE -#define f_get_initial_binary GET_INITIAL_BSSN6 -#define f_get_ansorg_binary GET_ANSORG_BINARY -#define f_get_ansorg_nbhs GET_ANSORG_NBHS -#define f_get_ansorg_nbhs_escalar GET_ANSORG_NBHS_ESCALAR -#define f_get_ansorg_nbhs_ss GET_ANSORG_NBHS_SS -#define f_get_ansorg_nbhs_ss_escalar GET_ANSORG_NBHS_SS_ESCALAR -#define f_get_initial_postdeal GET_INITIAL_POSTDEAL -#define f_get_initial_nbhs GET_INITIAL_NBHS -#define f_get_lousto_nbhs GET_LOUSTO_NBHS -#define f_get_pablo_nbhs GET_PABLO_NBHS -#define f_get_shapiro GET_SHAPIRO -#define f_get_niall_minkowski GRT_NIALL_MINKOWSKI -#endif -#ifdef fortran3 -#define f_get_initial_kerrschild get_initial_kerrschild_ -#define f_get_initial_kerrschild_ss get_initial_kerrschild_ss_ -#define f_get_initial_single get_initial_bssn3_ -#define f_get_ansorg_single get_ansorg_single_ -#define f_get_initial_binary get_initial_bssn6_ -#define f_get_ansorg_binary get_ansorg_binary_ -#define f_get_ansorg_nbhs get_ansorg_nbhs_ -#define f_get_ansorg_nbhs_escalar get_ansorg_nbhs_escalar_ -#define f_get_ansorg_nbhs_ss get_ansorg_nbhs_ss_ -#define f_get_ansorg_nbhs_ss_escalar get_ansorg_nbhs_ss_escalar_ -#define f_get_initial_postdeal get_initial_postdeal_ -#define f_get_initial_nbhs get_initial_nbhs_ -#define f_get_lousto_nbhs get_lousto_nbhs_ -#define f_get_pablo_nbhs get_pablo_nbhs_ -#define f_get_shapiro get_shapiro_ -#define f_get_niall_minkowski get_niall_minkowski_ -#endif - -extern "C" -{ - void f_get_initial_kerrschild(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *); -} - -extern "C" -{ - void f_get_initial_kerrschild_ss(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *); -} - -extern "C" -{ - void f_get_initial_single(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double &, double *, double *, double *); -} - -extern "C" -{ - void f_get_initial_binary(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *); -} - -extern "C" -{ - void f_get_ansorg_single(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double &, double *, double *, double *); -} - -extern "C" -{ - void f_get_ansorg_binary(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *); -} - -extern "C" -{ - void f_get_ansorg_nbhs(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_ansorg_nbhs_ss(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_initial_postdeal(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *); -} - -extern "C" -{ - void f_get_lousto_nbhs(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_initial_nbhs(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_pablo_nbhs(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_shapiro(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_niall_minkowski(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *); -} - -extern "C" -{ - void f_get_ansorg_nbhs_escalar(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_get_ansorg_nbhs_ss_escalar(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, - double *, double *, double *, double *, int &); -} - -#endif /* GET_INITIAL_H */ + +#ifndef GET_INITIAL_H +#define GET_INITIAL_H + +#ifdef fortran1 +#define f_get_initial_kerrschild get_initial_kerrschild +#define f_get_initial_kerrschild_ss get_initial_kerrschild_ss +#define f_get_initial_single get_initial_bssn3 +#define f_get_ansorg_single get_ansorg_single +#define f_get_initial_binary get_initial_bssn6 +#define f_get_ansorg_binary get_ansorg_binary +#define f_get_ansorg_nbhs get_ansorg_nbhs +#define f_get_ansorg_nbhs_escalar get_ansorg_nbhs_escalar +#define f_get_ansorg_nbhs_ss get_ansorg_nbhs_ss +#define f_get_ansorg_nbhs_ss_escalar get_ansorg_nbhs_ss_escalar +#define f_get_initial_postdeal get_initial_postdeal +#define f_get_initial_nbhs get_initial_nbhs +#define f_get_lousto_nbhs get_lousto_nbhs +#define f_get_pablo_nbhs get_pablo_nbhs +#define f_get_shapiro get_shapiro +#define f_get_niall_minkowski get_niall_minkowski +#endif +#ifdef fortran2 +#define f_get_initial_kerrschild GET_INITIAL_KERRSCHILD +#define f_get_initial_kerrschild_ss GET_INITIAL_KERRSCHILD_SS +#define f_get_initial_single GET_INITIAL_BSSN3 +#define f_get_ansorg_single GET_ANSORG_SINGLE +#define f_get_initial_binary GET_INITIAL_BSSN6 +#define f_get_ansorg_binary GET_ANSORG_BINARY +#define f_get_ansorg_nbhs GET_ANSORG_NBHS +#define f_get_ansorg_nbhs_escalar GET_ANSORG_NBHS_ESCALAR +#define f_get_ansorg_nbhs_ss GET_ANSORG_NBHS_SS +#define f_get_ansorg_nbhs_ss_escalar GET_ANSORG_NBHS_SS_ESCALAR +#define f_get_initial_postdeal GET_INITIAL_POSTDEAL +#define f_get_initial_nbhs GET_INITIAL_NBHS +#define f_get_lousto_nbhs GET_LOUSTO_NBHS +#define f_get_pablo_nbhs GET_PABLO_NBHS +#define f_get_shapiro GET_SHAPIRO +#define f_get_niall_minkowski GRT_NIALL_MINKOWSKI +#endif +#ifdef fortran3 +#define f_get_initial_kerrschild get_initial_kerrschild_ +#define f_get_initial_kerrschild_ss get_initial_kerrschild_ss_ +#define f_get_initial_single get_initial_bssn3_ +#define f_get_ansorg_single get_ansorg_single_ +#define f_get_initial_binary get_initial_bssn6_ +#define f_get_ansorg_binary get_ansorg_binary_ +#define f_get_ansorg_nbhs get_ansorg_nbhs_ +#define f_get_ansorg_nbhs_escalar get_ansorg_nbhs_escalar_ +#define f_get_ansorg_nbhs_ss get_ansorg_nbhs_ss_ +#define f_get_ansorg_nbhs_ss_escalar get_ansorg_nbhs_ss_escalar_ +#define f_get_initial_postdeal get_initial_postdeal_ +#define f_get_initial_nbhs get_initial_nbhs_ +#define f_get_lousto_nbhs get_lousto_nbhs_ +#define f_get_pablo_nbhs get_pablo_nbhs_ +#define f_get_shapiro get_shapiro_ +#define f_get_niall_minkowski get_niall_minkowski_ +#endif + +extern "C" +{ + void f_get_initial_kerrschild(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *); +} + +extern "C" +{ + void f_get_initial_kerrschild_ss(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *); +} + +extern "C" +{ + void f_get_initial_single(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double &, double *, double *, double *); +} + +extern "C" +{ + void f_get_initial_binary(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *); +} + +extern "C" +{ + void f_get_ansorg_single(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double &, double *, double *, double *); +} + +extern "C" +{ + void f_get_ansorg_binary(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *); +} + +extern "C" +{ + void f_get_ansorg_nbhs(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_ansorg_nbhs_ss(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_initial_postdeal(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *); +} + +extern "C" +{ + void f_get_lousto_nbhs(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_initial_nbhs(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_pablo_nbhs(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_shapiro(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_niall_minkowski(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *); +} + +extern "C" +{ + void f_get_ansorg_nbhs_escalar(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_get_ansorg_nbhs_ss_escalar(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, + double *, double *, double *, double *, int &); +} + +#endif /* GET_INITIAL_H */ diff --git a/AMSS_NCKU_source/initial_scalar.f90 b/AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.f90 similarity index 95% rename from AMSS_NCKU_source/initial_scalar.f90 rename to AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.f90 index f96f0e7..a246bb9 100644 --- a/AMSS_NCKU_source/initial_scalar.f90 +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.f90 @@ -1,68 +1,68 @@ - -!----------------------------------------------------------------------------- -! -! Setting initial scalar with spherical Gauss profile centered at shell r=R0 -! with width WD and amplitude A -! -!----------------------------------------------------------------------------- - - subroutine get_initial_scalar(ex, X, Y, Z,Sphi,Spi,R0,WD,A) - implicit none - -!~~~~~~> Input parameters - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),R0,WD,A - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Sphi,Spi - -!~~~~~~> Local variables - - real*8 :: rr - integer::i,j,k - real*8, parameter :: ZEO = 0.d0,TWO=2.d0 - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - rr = dsqrt(X(i)*X(i)+Y(j)*Y(j)+Z(k)*Z(k))-R0 - Sphi(i,j,k) = A*dexp(-rr*rr/TWO/WD/WD) - enddo - enddo - enddo - - Spi = ZEO - - return - - end subroutine get_initial_scalar -! for shell - subroutine get_initial_scalar_sh(ex, X, Y, Z,Sphi,Spi,R0,WD,A) - implicit none - -!~~~~~~> Input parameters - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: R0,WD,A - real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: X, Y, Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Sphi,Spi - -!~~~~~~> Local variables - - real*8 :: rr - integer::i,j,k - real*8, parameter :: ZEO = 0.d0,TWO=2.d0 - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - rr = dsqrt(X(i,j,k)*X(i,j,k)+Y(i,j,k)*Y(i,j,k)+Z(i,j,k)*Z(i,j,k))-R0 - Sphi(i,j,k) = A*dexp(-rr*rr/TWO/WD/WD) - enddo - enddo - enddo - - Spi = ZEO - - return - - end subroutine get_initial_scalar_sh + +!----------------------------------------------------------------------------- +! +! Setting initial scalar with spherical Gauss profile centered at shell r=R0 +! with width WD and amplitude A +! +!----------------------------------------------------------------------------- + + subroutine get_initial_scalar(ex, X, Y, Z,Sphi,Spi,R0,WD,A) + implicit none + +!~~~~~~> Input parameters + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),R0,WD,A + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Sphi,Spi + +!~~~~~~> Local variables + + real*8 :: rr + integer::i,j,k + real*8, parameter :: ZEO = 0.d0,TWO=2.d0 + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + rr = dsqrt(X(i)*X(i)+Y(j)*Y(j)+Z(k)*Z(k))-R0 + Sphi(i,j,k) = A*dexp(-rr*rr/TWO/WD/WD) + enddo + enddo + enddo + + Spi = ZEO + + return + + end subroutine get_initial_scalar +! for shell + subroutine get_initial_scalar_sh(ex, X, Y, Z,Sphi,Spi,R0,WD,A) + implicit none + +!~~~~~~> Input parameters + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: R0,WD,A + real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: X, Y, Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Sphi,Spi + +!~~~~~~> Local variables + + real*8 :: rr + integer::i,j,k + real*8, parameter :: ZEO = 0.d0,TWO=2.d0 + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + rr = dsqrt(X(i,j,k)*X(i,j,k)+Y(i,j,k)*Y(i,j,k)+Z(i,j,k)*Z(i,j,k))-R0 + Sphi(i,j,k) = A*dexp(-rr*rr/TWO/WD/WD) + enddo + enddo + enddo + + Spi = ZEO + + return + + end subroutine get_initial_scalar_sh diff --git a/AMSS_NCKU_source/initial_scalar.h b/AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.h similarity index 96% rename from AMSS_NCKU_source/initial_scalar.h rename to AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.h index 96d8055..e9ed5ef 100644 --- a/AMSS_NCKU_source/initial_scalar.h +++ b/AMSS_NCKU_source/Initial_Data_Solver/initial_scalar.h @@ -1,31 +1,31 @@ - -#ifndef GET_INITIAL_SCALAR_H -#define GET_INITIAL_SCALAR_H - -#ifdef fortran1 -#define f_get_initial_scalar get_initial_scalar -#define f_get_initial_scalar_sh get_initial_scalar_sh -#endif -#ifdef fortran2 -#define f_get_initial_scalar GET_INITIAL_SCALAR -#define f_get_initial_scalar_sh GET_INITIAL_SCALAR_SH -#endif -#ifdef fortran3 -#define f_get_initial_scalar get_initial_scalar_ -#define f_get_initial_scalar_sh get_initial_scalar_sh_ -#endif - -extern "C" -{ - void f_get_initial_scalar(int *, double *, double *, double *, - double *, double *, - double &, double &, double &); -} - -extern "C" -{ - void f_get_initial_scalar_sh(int *, double *, double *, double *, - double *, double *, - double &, double &, double &); -} -#endif /* GET_INITIAL_SCALAR_H */ + +#ifndef GET_INITIAL_SCALAR_H +#define GET_INITIAL_SCALAR_H + +#ifdef fortran1 +#define f_get_initial_scalar get_initial_scalar +#define f_get_initial_scalar_sh get_initial_scalar_sh +#endif +#ifdef fortran2 +#define f_get_initial_scalar GET_INITIAL_SCALAR +#define f_get_initial_scalar_sh GET_INITIAL_SCALAR_SH +#endif +#ifdef fortran3 +#define f_get_initial_scalar get_initial_scalar_ +#define f_get_initial_scalar_sh get_initial_scalar_sh_ +#endif + +extern "C" +{ + void f_get_initial_scalar(int *, double *, double *, double *, + double *, double *, + double &, double &, double &); +} + +extern "C" +{ + void f_get_initial_scalar_sh(int *, double *, double *, double *, + double *, double *, + double &, double &, double &); +} +#endif /* GET_INITIAL_SCALAR_H */ diff --git a/AMSS_NCKU_source/kodiss.f90 b/AMSS_NCKU_source/KO_dissipation/kodiss.f90 similarity index 97% rename from AMSS_NCKU_source/kodiss.f90 rename to AMSS_NCKU_source/KO_dissipation/kodiss.f90 index a516393..b8a46f7 100644 --- a/AMSS_NCKU_source/kodiss.f90 +++ b/AMSS_NCKU_source/KO_dissipation/kodiss.f90 @@ -1,434 +1,434 @@ - - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!------------------------------------------------------------------------------------------------------------------------------ -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! (D_+D_-)^2 = -! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) -! ------------------------------------------------------ -! dx^4 -!------------------------------------------------------------------------------------------------------------------------------ -! do not add dissipation near boundary -subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) - -implicit none -! argument variables -integer,intent(in) :: Symmetry -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoA -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8,parameter :: cof = 1.6d1 ! 2^4 - real*8, parameter :: F4=4.d0,F6=6.d0 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 - - call symmetry_bd(2,ex,f,fh,SoA) - -! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) -! ------------------------------------------------------ -! dx^4 - -! note the sign (-1)^r-1, now r=2 -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) -!DIR$ UNROLL PARTIAL(4) - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i-2 >= imin .and. i+2 <= imax .and. & - j-2 >= jmin .and. j+2 <= jmax .and. & - k-2 >= kmin .and. k+2 <= kmax) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & - (fh(i-2,j,k)+fh(i+2,j,k)) & - - F4 * (fh(i-1,j,k)+fh(i+1,j,k)) & - + F6 * fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & - (fh(i,j-2,k)+fh(i,j+2,k)) & - - F4 * (fh(i,j-1,k)+fh(i,j+1,k)) & - + F6 * fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-2)+fh(i,j,k+2)) & - - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & - + F6 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis - -#elif (ghost_width == 3) -! fourth order code - -!--------------------------------------------------------------------------------------------- -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time -! Dependent Problems and Difference Methods (Wiley, New York, 1995).] -! D_+ = (f(i+1) - f(i))/h -! D_- = (f(i) - f(i-1))/h -! then we have D_+D_- = D_-D_+ -! D_+^3D_-^3 = (D_+D_-)^3 = -! f(i-3) - 6 f(i-2) + 15 f(i-1) - 20 f(i) + 15 f(i+1) - 6 f(i+2) + f(i+3) -! ----------------------------------------------------------------------------- -! dx^6 -! this is for 4th order accurate finite difference scheme -!--------------------------------------------------------------------------------------------- -subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) - -implicit none -! argument variables -integer,intent(in) :: Symmetry -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoA -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 -real*8,parameter::cof=6.4d1 ! 2^6 -integer, parameter :: NO_SYMM=0, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 - if(Symmetry == OCTANT .and. dabs(X(1)) < dX) imin = -2 - if(Symmetry == OCTANT .and. dabs(Y(1)) < dY) jmin = -2 - - call symmetry_bd(3,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i-3 >= imin .and. i+3 <= imax .and. & - j-3 >= jmin .and. j+3 <= jmax .and. & - k-3 >= kmin .and. k+3 <= kmax) then -#if 0 -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) ) -#else -! calculation order if important ? - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/cof *( ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) )/dX + & - ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) )/dY + & - ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) )/dZ ) -#endif - endif - - enddo - enddo - enddo - - return - - end subroutine kodis - -#elif (ghost_width == 4) -! sixth order code -!------------------------------------------------------------------------------------------------------------------------------ -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! (D_+D_-)^4 = -! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) -! ---------------------------------------------------------------------------------------------------------- -! dx^8 -!------------------------------------------------------------------------------------------------------------------------------ -! do not add dissipation near boundary -subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) - -implicit none -! argument variables -integer,intent(in) :: Symmetry -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoA -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8,parameter :: cof = 2.56d2 ! 2^8 - real*8, parameter :: F8=8.d0,F28=2.8d1,F56=5.6d1,F70=7.d1 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 - - call symmetry_bd(4,ex,f,fh,SoA) - -! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) -! ---------------------------------------------------------------------------------------------------------- -! dx^8 - -! note the sign (-1)^r-1, now r=4 - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i>imin+3 .and. i < imax-3 .and. & - j>jmin+3 .and. j < jmax-3 .and. & - k>kmin+3 .and. k < kmax-3) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & - (fh(i-4,j,k)+fh(i+4,j,k)) & - - F8 * (fh(i-3,j,k)+fh(i+3,j,k)) & - +F28 * (fh(i-2,j,k)+fh(i+2,j,k)) & - -F56 * (fh(i-1,j,k)+fh(i+1,j,k)) & - +F70 * fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & - (fh(i,j-4,k)+fh(i,j+4,k)) & - - F8 * (fh(i,j-3,k)+fh(i,j+3,k)) & - +F28 * (fh(i,j-2,k)+fh(i,j+2,k)) & - -F56 * (fh(i,j-1,k)+fh(i,j+1,k)) & - +F70 * fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-4)+fh(i,j,k+4)) & - - F8 * (fh(i,j,k-3)+fh(i,j,k+3)) & - +F28 * (fh(i,j,k-2)+fh(i,j,k+2)) & - -F56 * (fh(i,j,k-1)+fh(i,j,k+1)) & - +F70 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis - -#elif (ghost_width == 5) -! eighth order code -!------------------------------------------------------------------------------------------------------------------------------ -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time -! Dependent Problems and Difference Methods (Wiley, New York, 1995).] -! D_+ = (f(i+1) - f(i))/h -! D_- = (f(i) - f(i-1))/h -! then we have D_+D_- = D_-D_+ = (f(i+1) - 2f(i) + f(i-1))/h^2 -! for nth order accurate finite difference code, we need r =n/2+1 -! D_+^rD_-^r = (D_+D_-)^r -! following the tradiation of PRD 77, 024027 (BB's calibration paper, Eq.(64), -! correct some typo according to above book) : -! + eps*(-1)^(r-1)*h^(2r-1)/2^(2r)*(D_+D_-)^r -! -! -! this is for 8th order accurate finite difference scheme -! (D_+D_-)^5 = -! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) -! ------------------------------------------------------------------------------------------------------------------------------- -! dx^10 -!--------------------------------------------------------------------------------------------------------------------------------- -! do not add dissipation near boundary -subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) - -implicit none -! argument variables -integer,intent(in) :: Symmetry -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoA -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8 :: dX,dY,dZ - real*8,dimension(-4:ex(1),-4:ex(2),-4:ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8,parameter :: cof = 1.024d3 ! 2^2r = 2^10 - real*8, parameter :: F10=1.d1,F45=4.5d1,F120=1.2d2,F210=2.1d2,F252=2.52d2 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -4 - if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -4 - if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -4 - - call symmetry_bd(5,ex,f,fh,SoA) - -! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) -! ------------------------------------------------------------------------------------------------------------------------------- -! dx^10 - -! note the sign (-1)^r-1, now r=5 - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i>imin+4 .and. i < imax-4 .and. & - j>jmin+4 .and. j < jmax-4 .and. & - k>kmin+4 .and. k < kmax-4) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & - (fh(i-5,j,k)+fh(i+5,j,k)) & - - F10 * (fh(i-4,j,k)+fh(i+4,j,k)) & - + F45 * (fh(i-3,j,k)+fh(i+3,j,k)) & - - F120* (fh(i-2,j,k)+fh(i+2,j,k)) & - + F210* (fh(i-1,j,k)+fh(i+1,j,k)) & - - F252 * fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & - (fh(i,j-5,k)+fh(i,j+5,k)) & - - F10 * (fh(i,j-4,k)+fh(i,j+4,k)) & - + F45 * (fh(i,j-3,k)+fh(i,j+3,k)) & - - F120* (fh(i,j-2,k)+fh(i,j+2,k)) & - + F210* (fh(i,j-1,k)+fh(i,j+1,k)) & - - F252 * fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-5)+fh(i,j,k+5)) & - - F10 * (fh(i,j,k-4)+fh(i,j,k+4)) & - + F45 * (fh(i,j,k-3)+fh(i,j,k+3)) & - - F120* (fh(i,j,k-2)+fh(i,j,k+2)) & - + F210* (fh(i,j,k-1)+fh(i,j,k+1)) & - - F252 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis - -#endif + + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!------------------------------------------------------------------------------------------------------------------------------ +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! (D_+D_-)^2 = +! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) +! ------------------------------------------------------ +! dx^4 +!------------------------------------------------------------------------------------------------------------------------------ +! do not add dissipation near boundary +subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) + +implicit none +! argument variables +integer,intent(in) :: Symmetry +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoA +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1),-1:ex(2),-1:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8,parameter :: cof = 1.6d1 ! 2^4 + real*8, parameter :: F4=4.d0,F6=6.d0 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -1 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -1 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -1 + + call symmetry_bd(2,ex,f,fh,SoA) + +! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) +! ------------------------------------------------------ +! dx^4 + +! note the sign (-1)^r-1, now r=2 +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) +!DIR$ UNROLL PARTIAL(4) + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i-2 >= imin .and. i+2 <= imax .and. & + j-2 >= jmin .and. j+2 <= jmax .and. & + k-2 >= kmin .and. k+2 <= kmax) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & + (fh(i-2,j,k)+fh(i+2,j,k)) & + - F4 * (fh(i-1,j,k)+fh(i+1,j,k)) & + + F6 * fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & + (fh(i,j-2,k)+fh(i,j+2,k)) & + - F4 * (fh(i,j-1,k)+fh(i,j+1,k)) & + + F6 * fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-2)+fh(i,j,k+2)) & + - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & + + F6 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis + +#elif (ghost_width == 3) +! fourth order code + +!--------------------------------------------------------------------------------------------- +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time +! Dependent Problems and Difference Methods (Wiley, New York, 1995).] +! D_+ = (f(i+1) - f(i))/h +! D_- = (f(i) - f(i-1))/h +! then we have D_+D_- = D_-D_+ +! D_+^3D_-^3 = (D_+D_-)^3 = +! f(i-3) - 6 f(i-2) + 15 f(i-1) - 20 f(i) + 15 f(i+1) - 6 f(i+2) + f(i+3) +! ----------------------------------------------------------------------------- +! dx^6 +! this is for 4th order accurate finite difference scheme +!--------------------------------------------------------------------------------------------- +subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) + +implicit none +! argument variables +integer,intent(in) :: Symmetry +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoA +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8,dimension(-2:ex(1),-2:ex(2),-2:ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 +real*8,parameter::cof=6.4d1 ! 2^6 +integer, parameter :: NO_SYMM=0, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -2 + if(Symmetry == OCTANT .and. dabs(X(1)) < dX) imin = -2 + if(Symmetry == OCTANT .and. dabs(Y(1)) < dY) jmin = -2 + + call symmetry_bd(3,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i-3 >= imin .and. i+3 <= imax .and. & + j-3 >= jmin .and. j+3 <= jmax .and. & + k-3 >= kmin .and. k+3 <= kmax) then +#if 0 +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) ) +#else +! calculation order if important ? + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/cof *( ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) )/dX + & + ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) )/dY + & + ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) )/dZ ) +#endif + endif + + enddo + enddo + enddo + + return + + end subroutine kodis + +#elif (ghost_width == 4) +! sixth order code +!------------------------------------------------------------------------------------------------------------------------------ +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! (D_+D_-)^4 = +! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) +! ---------------------------------------------------------------------------------------------------------- +! dx^8 +!------------------------------------------------------------------------------------------------------------------------------ +! do not add dissipation near boundary +subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) + +implicit none +! argument variables +integer,intent(in) :: Symmetry +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoA +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1),-3:ex(2),-3:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8,parameter :: cof = 2.56d2 ! 2^8 + real*8, parameter :: F8=8.d0,F28=2.8d1,F56=5.6d1,F70=7.d1 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -3 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -3 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -3 + + call symmetry_bd(4,ex,f,fh,SoA) + +! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) +! ---------------------------------------------------------------------------------------------------------- +! dx^8 + +! note the sign (-1)^r-1, now r=4 + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i>imin+3 .and. i < imax-3 .and. & + j>jmin+3 .and. j < jmax-3 .and. & + k>kmin+3 .and. k < kmax-3) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & + (fh(i-4,j,k)+fh(i+4,j,k)) & + - F8 * (fh(i-3,j,k)+fh(i+3,j,k)) & + +F28 * (fh(i-2,j,k)+fh(i+2,j,k)) & + -F56 * (fh(i-1,j,k)+fh(i+1,j,k)) & + +F70 * fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & + (fh(i,j-4,k)+fh(i,j+4,k)) & + - F8 * (fh(i,j-3,k)+fh(i,j+3,k)) & + +F28 * (fh(i,j-2,k)+fh(i,j+2,k)) & + -F56 * (fh(i,j-1,k)+fh(i,j+1,k)) & + +F70 * fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-4)+fh(i,j,k+4)) & + - F8 * (fh(i,j,k-3)+fh(i,j,k+3)) & + +F28 * (fh(i,j,k-2)+fh(i,j,k+2)) & + -F56 * (fh(i,j,k-1)+fh(i,j,k+1)) & + +F70 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis + +#elif (ghost_width == 5) +! eighth order code +!------------------------------------------------------------------------------------------------------------------------------ +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time +! Dependent Problems and Difference Methods (Wiley, New York, 1995).] +! D_+ = (f(i+1) - f(i))/h +! D_- = (f(i) - f(i-1))/h +! then we have D_+D_- = D_-D_+ = (f(i+1) - 2f(i) + f(i-1))/h^2 +! for nth order accurate finite difference code, we need r =n/2+1 +! D_+^rD_-^r = (D_+D_-)^r +! following the tradiation of PRD 77, 024027 (BB's calibration paper, Eq.(64), +! correct some typo according to above book) : +! + eps*(-1)^(r-1)*h^(2r-1)/2^(2r)*(D_+D_-)^r +! +! +! this is for 8th order accurate finite difference scheme +! (D_+D_-)^5 = +! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) +! ------------------------------------------------------------------------------------------------------------------------------- +! dx^10 +!--------------------------------------------------------------------------------------------------------------------------------- +! do not add dissipation near boundary +subroutine kodis(ex,X,Y,Z,f,f_rhs,SoA,Symmetry,eps) + +implicit none +! argument variables +integer,intent(in) :: Symmetry +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoA +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8 :: dX,dY,dZ + real*8,dimension(-4:ex(1),-4:ex(2),-4:ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8,parameter :: cof = 1.024d3 ! 2^2r = 2^10 + real*8, parameter :: F10=1.d1,F45=4.5d1,F120=1.2d2,F210=2.1d2,F252=2.52d2 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry > NO_SYMM .and. dabs(Z(1)) < dZ) kmin = -4 + if(Symmetry > EQ_SYMM .and. dabs(X(1)) < dX) imin = -4 + if(Symmetry > EQ_SYMM .and. dabs(Y(1)) < dY) jmin = -4 + + call symmetry_bd(5,ex,f,fh,SoA) + +! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) +! ------------------------------------------------------------------------------------------------------------------------------- +! dx^10 + +! note the sign (-1)^r-1, now r=5 + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i>imin+4 .and. i < imax-4 .and. & + j>jmin+4 .and. j < jmax-4 .and. & + k>kmin+4 .and. k < kmax-4) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & + (fh(i-5,j,k)+fh(i+5,j,k)) & + - F10 * (fh(i-4,j,k)+fh(i+4,j,k)) & + + F45 * (fh(i-3,j,k)+fh(i+3,j,k)) & + - F120* (fh(i-2,j,k)+fh(i+2,j,k)) & + + F210* (fh(i-1,j,k)+fh(i+1,j,k)) & + - F252 * fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & + (fh(i,j-5,k)+fh(i,j+5,k)) & + - F10 * (fh(i,j-4,k)+fh(i,j+4,k)) & + + F45 * (fh(i,j-3,k)+fh(i,j+3,k)) & + - F120* (fh(i,j-2,k)+fh(i,j+2,k)) & + + F210* (fh(i,j-1,k)+fh(i,j+1,k)) & + - F252 * fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-5)+fh(i,j,k+5)) & + - F10 * (fh(i,j,k-4)+fh(i,j,k+4)) & + + F45 * (fh(i,j,k-3)+fh(i,j,k+3)) & + - F120* (fh(i,j,k-2)+fh(i,j,k+2)) & + + F210* (fh(i,j,k-1)+fh(i,j,k+1)) & + - F252 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis + +#endif diff --git a/AMSS_NCKU_source/kodiss.h b/AMSS_NCKU_source/KO_dissipation/kodiss.h similarity index 95% rename from AMSS_NCKU_source/kodiss.h rename to AMSS_NCKU_source/KO_dissipation/kodiss.h index 32dd5e1..6692dc5 100644 --- a/AMSS_NCKU_source/kodiss.h +++ b/AMSS_NCKU_source/KO_dissipation/kodiss.h @@ -1,42 +1,42 @@ - -#ifndef KODISS_H -#define KODISS_H - -#ifdef fortran1 -#define f_kodis_sh kodis_sh -#define f_kodis_shcr kodis_shcr -#define f_kodis_shor kodis_shor -#endif -#ifdef fortran2 -#define f_kodis_sh KODIS_SH -#define f_kodis_shcr KODIS_SHCR -#define f_kodis_shor KODIS_SHOR -#endif -#ifdef fortran3 -#define f_kodis_sh kodis_sh_ -#define f_kodis_shcr kodis_shcr_ -#define f_kodis_shor kodis_shor_ -#endif - -extern "C" -{ - void f_kodis_sh(int *, double *, double *, double *, - double *, double *, - double *, int &, double &, int &); -} - -extern "C" -{ - void f_kodis_shcr(int *, double *, double *, double *, - double *, double *, - double *, int &, double &, int &); -} - -extern "C" -{ - void f_kodis_shor(int *, double *, double *, double *, - double *, double *, - double *, int &, double &, int &); -} - -#endif /* KODISS_H */ + +#ifndef KODISS_H +#define KODISS_H + +#ifdef fortran1 +#define f_kodis_sh kodis_sh +#define f_kodis_shcr kodis_shcr +#define f_kodis_shor kodis_shor +#endif +#ifdef fortran2 +#define f_kodis_sh KODIS_SH +#define f_kodis_shcr KODIS_SHCR +#define f_kodis_shor KODIS_SHOR +#endif +#ifdef fortran3 +#define f_kodis_sh kodis_sh_ +#define f_kodis_shcr kodis_shcr_ +#define f_kodis_shor kodis_shor_ +#endif + +extern "C" +{ + void f_kodis_sh(int *, double *, double *, double *, + double *, double *, + double *, int &, double &, int &); +} + +extern "C" +{ + void f_kodis_shcr(int *, double *, double *, double *, + double *, double *, + double *, int &, double &, int &); +} + +extern "C" +{ + void f_kodis_shor(int *, double *, double *, double *, + double *, double *, + double *, int &, double &, int &); +} + +#endif /* KODISS_H */ diff --git a/AMSS_NCKU_source/kodiss_c.C b/AMSS_NCKU_source/KO_dissipation/kodiss_c.C similarity index 100% rename from AMSS_NCKU_source/kodiss_c.C rename to AMSS_NCKU_source/KO_dissipation/kodiss_c.C diff --git a/AMSS_NCKU_source/kodiss_sh.f90 b/AMSS_NCKU_source/KO_dissipation/kodiss_sh.f90 similarity index 96% rename from AMSS_NCKU_source/kodiss_sh.f90 rename to AMSS_NCKU_source/KO_dissipation/kodiss_sh.f90 index c166995..112b345 100644 --- a/AMSS_NCKU_source/kodiss_sh.f90 +++ b/AMSS_NCKU_source/KO_dissipation/kodiss_sh.f90 @@ -1,1033 +1,1033 @@ - - -#include "macrodef.fh" - -! we need only distinguish different finite difference order -! Vertex or Cell is distinguished in routine symmetry_bd which locates in -! file "fmisc.f90" - -#if (ghost_width == 2) -! second order code - -!------------------------------------------------------------------------------------------------------------------------------ -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! (D_+D_-)^2 = -! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) -! ------------------------------------------------------ -! dx^4 -!------------------------------------------------------------------------------------------------------------------------------ -! do not add dissipation near boundary -subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8, dimension(2) :: SoA - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8,parameter :: cof = 1.6d1 ! 2^4 - real*8, parameter :: F4=4.d0,F6=6.d0 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) -! ------------------------------------------------------ -! dx^4 - -! note the sign (-1)^r-1, now r=2 - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i-2 >= imin .and. i+2 <= imax .and. & - j-2 >= jmin .and. j+2 <= jmax .and. & - k-2 >= kmin .and. k+2 <= kmax) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & - (fh(i-2,j,k)+fh(i+2,j,k)) & - - F4 * (fh(i-1,j,k)+fh(i+1,j,k)) & - + F6 * fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & - (fh(i,j-2,k)+fh(i,j+2,k)) & - - F4 * (fh(i,j-1,k)+fh(i,j+1,k)) & - + F6 * fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-2)+fh(i,j,k+2)) & - - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & - + F6 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_sh - -! add dissipation near boundary for tangiential direction -subroutine kodis_sh_new(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8, dimension(2) :: SoA - real*8 :: dX,dY,dZ - real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8,parameter :: cof = 1.6d1 ! 2^4 - real*8, parameter :: F4=4.d0,F6=6.d0 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - -! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) -! ------------------------------------------------------ -! dx^4 - -! note the sign (-1)^r-1, now r=2 - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i-2 >= imin .and. i+2 <= imax)then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & - (fh(i-2,j,k)+fh(i+2,j,k)) & - - F4 * (fh(i-1,j,k)+fh(i+1,j,k)) & - + F6 * fh(i,j,k) ) - endif - if(j-2 >= jmin .and. j+2 <= jmax)then -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & - (fh(i,j-2,k)+fh(i,j+2,k)) & - - F4 * (fh(i,j-1,k)+fh(i,j+1,k)) & - + F6 * fh(i,j,k) ) - endif - if(k-2 >= kmin .and. k+2 <= kmax) then -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-2)+fh(i,j,k+2)) & - - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & - + F6 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_sh_new - - -subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8, dimension(2) :: SoA -real*8, dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8, parameter :: cof = 1.6d1 ! 2^4 -real*8, parameter :: F4=4.d0,F6=6.d0 -integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -1 - if(dabs(Y(1)) < dY) jmin = -1 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(2,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(k-2 >= kmin .and. k+2 <= kmax) then -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-2)+fh(i,j,k+2)) & - - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & - + F6 * fh(i,j,k) ) - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_shor - - -#elif (ghost_width == 3) -! fourth order code - -!--------------------------------------------------------------------------------------------- -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time -! Dependent Problems and Difference Methods (Wiley, New York, 1995).] -! D_+ = (f(i+1) - f(i))/h -! D_- = (f(i) - f(i-1))/h -! then we have D_+D_- = D_-D_+ -! D_+^3D_-^3 = (D_+D_-)^3 = -! f(i-3) - 6 f(i-2) + 15 f(i-1) - 20 f(i) + 15 f(i+1) - 6 f(i+2) + f(i+3) -! ----------------------------------------------------------------------------- -! dx^6 -! this is for 4th order accurate finite difference scheme -!--------------------------------------------------------------------------------------------- -subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8, dimension(2) :: SoA -real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 -real*8,parameter::cof=6.4d1 ! 2^6 -integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - -#if 1 - if(i-3 >= imin .and. i+3 <= imax .and. & - j-3 >= jmin .and. j+3 <= jmax .and. & - k-3 >= kmin .and. k+3 <= kmax) then -#if 0 -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) ) -#else -! calculation order if important ? - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/cof *( ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) )/dX + & - ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) )/dY + & - ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) )/dZ ) -#endif - endif -#else - if(i-3 >= imin .and. i+3 <= imax) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) ) - endif - if(j-3 >= jmin .and. j+3 <= jmax) then -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) ) - endif - if(k-3 >= kmin .and. k+3 <= kmax) then -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) ) - endif -#endif - enddo - enddo - enddo - - return - - end subroutine kodis_sh -! only on constant r sphere -subroutine kodis_shcr(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8, dimension(2) :: SoA -real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 -real*8,parameter::cof=6.4d1 ! 2^6 -integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i-3 >= imin .and. i+3 <= imax .and. & - j-3 >= jmin .and. j+3 <= jmax) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & - (fh(i-3,j,k)+fh(i+3,j,k)) - & - SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & - FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & - TWT* fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & - (fh(i,j-3,k)+fh(i,j+3,k)) - & - SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & - FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & - TWT* fh(i,j,k) ) - endif - - enddo - enddo - enddo - - return - - end subroutine kodis_shcr - -! only in r direction - -subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8, dimension(2) :: SoA -real*8, dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 -real*8,parameter::cof=6.4d1 ! 2^6 -integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -2 - if(dabs(Y(1)) < dY) jmin = -2 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(3,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(k-3 >= kmin .and. k+3 <= kmax) then -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-3)+fh(i,j,k+3)) - & - SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & - FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & - TWT* fh(i,j,k) ) - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_shor - - -#elif (ghost_width == 4) -! sixth order code -!------------------------------------------------------------------------------------------------------------------------------ -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! (D_+D_-)^4 = -! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) -! ---------------------------------------------------------------------------------------------------------- -! dx^8 -!------------------------------------------------------------------------------------------------------------------------------ -! do not add dissipation near boundary -subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8, dimension(2) :: SoA - real*8 :: dX,dY,dZ - real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8, parameter :: cof = 2.56d2 ! 2^8 - real*8, parameter :: F8=8.d0,F28=2.8d1,F56=5.6d1,F70=7.d1 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - -! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) -! ---------------------------------------------------------------------------------------------------------- -! dx^8 - -! note the sign (-1)^r-1, now r=4 - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i>imin+3 .and. i < imax-3 .and. & - j>jmin+3 .and. j < jmax-3 .and. & - k>kmin+3 .and. k < kmax-3) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & - (fh(i-4,j,k)+fh(i+4,j,k)) & - - F8 * (fh(i-3,j,k)+fh(i+3,j,k)) & - +F28 * (fh(i-2,j,k)+fh(i+2,j,k)) & - -F56 * (fh(i-1,j,k)+fh(i+1,j,k)) & - +F70 * fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & - (fh(i,j-4,k)+fh(i,j+4,k)) & - - F8 * (fh(i,j-3,k)+fh(i,j+3,k)) & - +F28 * (fh(i,j-2,k)+fh(i,j+2,k)) & - -F56 * (fh(i,j-1,k)+fh(i,j+1,k)) & - +F70 * fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-4)+fh(i,j,k+4)) & - - F8 * (fh(i,j,k-3)+fh(i,j,k+3)) & - +F28 * (fh(i,j,k-2)+fh(i,j,k+2)) & - -F56 * (fh(i,j,k-1)+fh(i,j,k+1)) & - +F70 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_sh - -! only in r direction - -subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8, dimension(2) :: SoA -real*8, dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8, parameter :: cof = 2.56d2 ! 2^8 -real*8, parameter :: F8=8.d0,F28=2.8d1,F56=5.6d1,F70=7.d1 -integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -3 - if(dabs(Y(1)) < dY) jmin = -3 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(4,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(k-4 >= kmin .and. k+4 <= kmax) then -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & - (fh(i,j,k-4)+fh(i,j,k+4)) & - - F8 * (fh(i,j,k-3)+fh(i,j,k+3)) & - +F28 * (fh(i,j,k-2)+fh(i,j,k+2)) & - -F56 * (fh(i,j,k-1)+fh(i,j,k+1)) & - +F70 * fh(i,j,k) ) - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_shor - -#elif (ghost_width == 5) -! eighth order code -!------------------------------------------------------------------------------------------------------------------------------ -!usual type Kreiss-Oliger type numerical dissipation -!We support cell center only -! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time -! Dependent Problems and Difference Methods (Wiley, New York, 1995).] -! D_+ = (f(i+1) - f(i))/h -! D_- = (f(i) - f(i-1))/h -! then we have D_+D_- = D_-D_+ = (f(i+1) - 2f(i) + f(i-1))/h^2 -! for nth order accurate finite difference code, we need r =n/2+1 -! D_+^rD_-^r = (D_+D_-)^r -! following the tradiation of PRD 77, 024027 (BB's calibration paper, Eq.(64), -! correct some typo according to above book) : -! + eps*(-1)^(r-1)*h^(2r-1)/2^(2r)*(D_+D_-)^r -! -! -! this is for 8th order accurate finite difference scheme -! (D_+D_-)^5 = -! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) -! ------------------------------------------------------------------------------------------------------------------------------- -! dx^10 -!--------------------------------------------------------------------------------------------------------------------------------- -! do not add dissipation near boundary -subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps - -!~~~~~~ other variables - - real*8, dimension(2) :: SoA - real*8 :: dX,dY,dZ - real*8,dimension(-4:ex(1)+5,-4:ex(2)+5,ex(3)) :: fh - integer :: imin,jmin,kmin,imax,jmax,kmax - integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 - real*8,parameter :: cof = 1.024d3 ! 2^2r = 2^10 - real*8, parameter :: F10=1.d1,F45=4.5d1,F120=1.2d2,F210=2.1d2,F252=2.52d2 - integer::i,j,k - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -4 - if(dabs(Y(1)) < dY) jmin = -4 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -4 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+5 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(5,ex,f,fh,SoA) - -! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) -! ------------------------------------------------------------------------------------------------------------------------------- -! dx^10 - -! note the sign (-1)^r-1, now r=5 - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(i>imin+4 .and. i < imax-4 .and. & - j>jmin+4 .and. j < jmax-4 .and. & - k>kmin+4 .and. k < kmax-4) then -! x direction - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & - (fh(i-5,j,k)+fh(i+5,j,k)) & - - F10 * (fh(i-4,j,k)+fh(i+4,j,k)) & - + F45 * (fh(i-3,j,k)+fh(i+3,j,k)) & - - F120* (fh(i-2,j,k)+fh(i+2,j,k)) & - + F210* (fh(i-1,j,k)+fh(i+1,j,k)) & - - F252 * fh(i,j,k) ) -! y direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & - (fh(i,j-5,k)+fh(i,j+5,k)) & - - F10 * (fh(i,j-4,k)+fh(i,j+4,k)) & - + F45 * (fh(i,j-3,k)+fh(i,j+3,k)) & - - F120* (fh(i,j-2,k)+fh(i,j+2,k)) & - + F210* (fh(i,j-1,k)+fh(i,j+1,k)) & - - F252 * fh(i,j,k) ) -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-5)+fh(i,j,k+5)) & - - F10 * (fh(i,j,k-4)+fh(i,j,k+4)) & - + F45 * (fh(i,j,k-3)+fh(i,j,k+3)) & - - F120* (fh(i,j,k-2)+fh(i,j,k+2)) & - + F210* (fh(i,j,k-1)+fh(i,j,k+1)) & - - F252 * fh(i,j,k) ) - - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_sh - -! only in r direction - -subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) - -implicit none -! argument variables -integer,intent(in) :: Symmetry,sst -integer,dimension(3),intent(in)::ex -real*8, dimension(1:3), intent(in) :: SoAi -double precision,intent(in),dimension(ex(1))::X -double precision,intent(in),dimension(ex(2))::Y -double precision,intent(in),dimension(ex(3))::Z -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f -double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs -real*8,intent(in) :: eps -! local variables -real*8, dimension(2) :: SoA -real*8, dimension(-4:ex(1)+5,-4:ex(2)+5,ex(3)) :: fh -integer :: imin,jmin,kmin,imax,jmax,kmax -integer :: i,j,k -real*8 :: dX,dY,dZ -real*8,parameter :: cof = 1.024d3 ! 2^2r = 2^10 -real*8, parameter :: F10=1.d1,F45=4.5d1,F120=1.2d2,F210=2.1d2,F252=2.52d2 -integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 - -!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) - - dX = X(2)-X(1) - dY = Y(2)-Y(1) - dZ = Z(2)-Z(1) - - imax = ex(1) - jmax = ex(2) - kmax = ex(3) - - imin = 1 - jmin = 1 - kmin = 1 - - if(Symmetry == OCTANT)then - if(dabs(X(1)) < dX) imin = -4 - if(dabs(Y(1)) < dY) jmin = -4 - elseif(Symmetry == EQ_SYMM)then - if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -4 - if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+5 - endif - - if(sst==0)then - SoA = SoAi(1:2) - elseif(sst==2.or.sst==3)then - SoA(1) = SoAi(2) - SoA(2) = SoAi(3) - elseif(sst==4.or.sst==5)then - SoA(1) = SoAi(1) - SoA(2) = SoAi(3) - endif - - call symmetry_stbd(5,ex,f,fh,SoA) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - - if(k-5 >= kmin .and. k+5 <= kmax) then -! z direction - - f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & - (fh(i,j,k-5)+fh(i,j,k+5)) & - - F10 * (fh(i,j,k-4)+fh(i,j,k+4)) & - + F45 * (fh(i,j,k-3)+fh(i,j,k+3)) & - - F120* (fh(i,j,k-2)+fh(i,j,k+2)) & - + F210* (fh(i,j,k-1)+fh(i,j,k+1)) & - - F252 * fh(i,j,k) ) - endif - - enddo - enddo - enddo - - return - -end subroutine kodis_shor - -#endif + + +#include "macrodef.fh" + +! we need only distinguish different finite difference order +! Vertex or Cell is distinguished in routine symmetry_bd which locates in +! file "fmisc.f90" + +#if (ghost_width == 2) +! second order code + +!------------------------------------------------------------------------------------------------------------------------------ +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! (D_+D_-)^2 = +! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) +! ------------------------------------------------------ +! dx^4 +!------------------------------------------------------------------------------------------------------------------------------ +! do not add dissipation near boundary +subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8, dimension(2) :: SoA + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8,parameter :: cof = 1.6d1 ! 2^4 + real*8, parameter :: F4=4.d0,F6=6.d0 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) +! ------------------------------------------------------ +! dx^4 + +! note the sign (-1)^r-1, now r=2 + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i-2 >= imin .and. i+2 <= imax .and. & + j-2 >= jmin .and. j+2 <= jmax .and. & + k-2 >= kmin .and. k+2 <= kmax) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & + (fh(i-2,j,k)+fh(i+2,j,k)) & + - F4 * (fh(i-1,j,k)+fh(i+1,j,k)) & + + F6 * fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & + (fh(i,j-2,k)+fh(i,j+2,k)) & + - F4 * (fh(i,j-1,k)+fh(i,j+1,k)) & + + F6 * fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-2)+fh(i,j,k+2)) & + - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & + + F6 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_sh + +! add dissipation near boundary for tangiential direction +subroutine kodis_sh_new(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8, dimension(2) :: SoA + real*8 :: dX,dY,dZ + real*8,dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8,parameter :: cof = 1.6d1 ! 2^4 + real*8, parameter :: F4=4.d0,F6=6.d0 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + +! f(i-2) - 4 f(i-1) + 6 f(i) - 4 f(i+1) + f(i+2) +! ------------------------------------------------------ +! dx^4 + +! note the sign (-1)^r-1, now r=2 + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i-2 >= imin .and. i+2 <= imax)then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & + (fh(i-2,j,k)+fh(i+2,j,k)) & + - F4 * (fh(i-1,j,k)+fh(i+1,j,k)) & + + F6 * fh(i,j,k) ) + endif + if(j-2 >= jmin .and. j+2 <= jmax)then +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & + (fh(i,j-2,k)+fh(i,j+2,k)) & + - F4 * (fh(i,j-1,k)+fh(i,j+1,k)) & + + F6 * fh(i,j,k) ) + endif + if(k-2 >= kmin .and. k+2 <= kmax) then +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-2)+fh(i,j,k+2)) & + - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & + + F6 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_sh_new + + +subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8, dimension(2) :: SoA +real*8, dimension(-1:ex(1)+2,-1:ex(2)+2,ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8, parameter :: cof = 1.6d1 ! 2^4 +real*8, parameter :: F4=4.d0,F6=6.d0 +integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -1 + if(dabs(Y(1)) < dY) jmin = -1 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -1 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+2 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(2,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(k-2 >= kmin .and. k+2 <= kmax) then +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-2)+fh(i,j,k+2)) & + - F4 * (fh(i,j,k-1)+fh(i,j,k+1)) & + + F6 * fh(i,j,k) ) + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_shor + + +#elif (ghost_width == 3) +! fourth order code + +!--------------------------------------------------------------------------------------------- +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time +! Dependent Problems and Difference Methods (Wiley, New York, 1995).] +! D_+ = (f(i+1) - f(i))/h +! D_- = (f(i) - f(i-1))/h +! then we have D_+D_- = D_-D_+ +! D_+^3D_-^3 = (D_+D_-)^3 = +! f(i-3) - 6 f(i-2) + 15 f(i-1) - 20 f(i) + 15 f(i+1) - 6 f(i+2) + f(i+3) +! ----------------------------------------------------------------------------- +! dx^6 +! this is for 4th order accurate finite difference scheme +!--------------------------------------------------------------------------------------------- +subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8, dimension(2) :: SoA +real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 +real*8,parameter::cof=6.4d1 ! 2^6 +integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + +#if 1 + if(i-3 >= imin .and. i+3 <= imax .and. & + j-3 >= jmin .and. j+3 <= jmax .and. & + k-3 >= kmin .and. k+3 <= kmax) then +#if 0 +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) ) +#else +! calculation order if important ? + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/cof *( ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) )/dX + & + ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) )/dY + & + ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) )/dZ ) +#endif + endif +#else + if(i-3 >= imin .and. i+3 <= imax) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) ) + endif + if(j-3 >= jmin .and. j+3 <= jmax) then +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) ) + endif + if(k-3 >= kmin .and. k+3 <= kmax) then +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) ) + endif +#endif + enddo + enddo + enddo + + return + + end subroutine kodis_sh +! only on constant r sphere +subroutine kodis_shcr(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8, dimension(2) :: SoA +real*8,dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 +real*8,parameter::cof=6.4d1 ! 2^6 +integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i-3 >= imin .and. i+3 <= imax .and. & + j-3 >= jmin .and. j+3 <= jmax) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & + (fh(i-3,j,k)+fh(i+3,j,k)) - & + SIX*(fh(i-2,j,k)+fh(i+2,j,k)) + & + FIT*(fh(i-1,j,k)+fh(i+1,j,k)) - & + TWT* fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & + (fh(i,j-3,k)+fh(i,j+3,k)) - & + SIX*(fh(i,j-2,k)+fh(i,j+2,k)) + & + FIT*(fh(i,j-1,k)+fh(i,j+1,k)) - & + TWT* fh(i,j,k) ) + endif + + enddo + enddo + enddo + + return + + end subroutine kodis_shcr + +! only in r direction + +subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8, dimension(2) :: SoA +real*8, dimension(-2:ex(1)+3,-2:ex(2)+3,ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8, parameter :: ONE=1.d0,SIX=6.d0,FIT=1.5d1,TWT=2.d1 +real*8,parameter::cof=6.4d1 ! 2^6 +integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -2 + if(dabs(Y(1)) < dY) jmin = -2 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -2 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+3 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(3,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(k-3 >= kmin .and. k+3 <= kmax) then +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-3)+fh(i,j,k+3)) - & + SIX*(fh(i,j,k-2)+fh(i,j,k+2)) + & + FIT*(fh(i,j,k-1)+fh(i,j,k+1)) - & + TWT* fh(i,j,k) ) + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_shor + + +#elif (ghost_width == 4) +! sixth order code +!------------------------------------------------------------------------------------------------------------------------------ +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! (D_+D_-)^4 = +! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) +! ---------------------------------------------------------------------------------------------------------- +! dx^8 +!------------------------------------------------------------------------------------------------------------------------------ +! do not add dissipation near boundary +subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8, dimension(2) :: SoA + real*8 :: dX,dY,dZ + real*8,dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8, parameter :: cof = 2.56d2 ! 2^8 + real*8, parameter :: F8=8.d0,F28=2.8d1,F56=5.6d1,F70=7.d1 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + +! f(i-4) - 8 f(i-3) + 28 f(i-2) - 56 f(i-1) + 70 f(i) - 56 f(i+1) + 28 f(i+2) - 8 f(i+3) + f(i+4) +! ---------------------------------------------------------------------------------------------------------- +! dx^8 + +! note the sign (-1)^r-1, now r=4 + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i>imin+3 .and. i < imax-3 .and. & + j>jmin+3 .and. j < jmax-3 .and. & + k>kmin+3 .and. k < kmax-3) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dX/cof * ( & + (fh(i-4,j,k)+fh(i+4,j,k)) & + - F8 * (fh(i-3,j,k)+fh(i+3,j,k)) & + +F28 * (fh(i-2,j,k)+fh(i+2,j,k)) & + -F56 * (fh(i-1,j,k)+fh(i+1,j,k)) & + +F70 * fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dY/cof * ( & + (fh(i,j-4,k)+fh(i,j+4,k)) & + - F8 * (fh(i,j-3,k)+fh(i,j+3,k)) & + +F28 * (fh(i,j-2,k)+fh(i,j+2,k)) & + -F56 * (fh(i,j-1,k)+fh(i,j+1,k)) & + +F70 * fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-4)+fh(i,j,k+4)) & + - F8 * (fh(i,j,k-3)+fh(i,j,k+3)) & + +F28 * (fh(i,j,k-2)+fh(i,j,k+2)) & + -F56 * (fh(i,j,k-1)+fh(i,j,k+1)) & + +F70 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_sh + +! only in r direction + +subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8, dimension(2) :: SoA +real*8, dimension(-3:ex(1)+4,-3:ex(2)+4,ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8, parameter :: cof = 2.56d2 ! 2^8 +real*8, parameter :: F8=8.d0,F28=2.8d1,F56=5.6d1,F70=7.d1 +integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -3 + if(dabs(Y(1)) < dY) jmin = -3 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -3 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+4 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(4,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(k-4 >= kmin .and. k+4 <= kmax) then +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) - eps/dZ/cof * ( & + (fh(i,j,k-4)+fh(i,j,k+4)) & + - F8 * (fh(i,j,k-3)+fh(i,j,k+3)) & + +F28 * (fh(i,j,k-2)+fh(i,j,k+2)) & + -F56 * (fh(i,j,k-1)+fh(i,j,k+1)) & + +F70 * fh(i,j,k) ) + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_shor + +#elif (ghost_width == 5) +! eighth order code +!------------------------------------------------------------------------------------------------------------------------------ +!usual type Kreiss-Oliger type numerical dissipation +!We support cell center only +! Note the notation D_+ and D_- [P240 of B. Gustafsson, H.-O. Kreiss, and J. Oliger, Time +! Dependent Problems and Difference Methods (Wiley, New York, 1995).] +! D_+ = (f(i+1) - f(i))/h +! D_- = (f(i) - f(i-1))/h +! then we have D_+D_- = D_-D_+ = (f(i+1) - 2f(i) + f(i-1))/h^2 +! for nth order accurate finite difference code, we need r =n/2+1 +! D_+^rD_-^r = (D_+D_-)^r +! following the tradiation of PRD 77, 024027 (BB's calibration paper, Eq.(64), +! correct some typo according to above book) : +! + eps*(-1)^(r-1)*h^(2r-1)/2^(2r)*(D_+D_-)^r +! +! +! this is for 8th order accurate finite difference scheme +! (D_+D_-)^5 = +! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) +! ------------------------------------------------------------------------------------------------------------------------------- +! dx^10 +!--------------------------------------------------------------------------------------------------------------------------------- +! do not add dissipation near boundary +subroutine kodis_sh(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps + +!~~~~~~ other variables + + real*8, dimension(2) :: SoA + real*8 :: dX,dY,dZ + real*8,dimension(-4:ex(1)+5,-4:ex(2)+5,ex(3)) :: fh + integer :: imin,jmin,kmin,imax,jmax,kmax + integer, parameter :: NO_SYMM = 0, EQ_SYMM = 1, OCTANT = 2 + real*8,parameter :: cof = 1.024d3 ! 2^2r = 2^10 + real*8, parameter :: F10=1.d1,F45=4.5d1,F120=1.2d2,F210=2.1d2,F252=2.52d2 + integer::i,j,k + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -4 + if(dabs(Y(1)) < dY) jmin = -4 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -4 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+5 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(5,ex,f,fh,SoA) + +! f(i-5) - 10 f(i-4) + 45 f(i-3) - 120 f(i-2) + 210 f(i-1) - 252 f(i) + 210 f(i+1) - 120 f(i+2) + 45 f(i+3) - 10 f(i+4) + f(i+5) +! ------------------------------------------------------------------------------------------------------------------------------- +! dx^10 + +! note the sign (-1)^r-1, now r=5 + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(i>imin+4 .and. i < imax-4 .and. & + j>jmin+4 .and. j < jmax-4 .and. & + k>kmin+4 .and. k < kmax-4) then +! x direction + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dX/cof * ( & + (fh(i-5,j,k)+fh(i+5,j,k)) & + - F10 * (fh(i-4,j,k)+fh(i+4,j,k)) & + + F45 * (fh(i-3,j,k)+fh(i+3,j,k)) & + - F120* (fh(i-2,j,k)+fh(i+2,j,k)) & + + F210* (fh(i-1,j,k)+fh(i+1,j,k)) & + - F252 * fh(i,j,k) ) +! y direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dY/cof * ( & + (fh(i,j-5,k)+fh(i,j+5,k)) & + - F10 * (fh(i,j-4,k)+fh(i,j+4,k)) & + + F45 * (fh(i,j-3,k)+fh(i,j+3,k)) & + - F120* (fh(i,j-2,k)+fh(i,j+2,k)) & + + F210* (fh(i,j-1,k)+fh(i,j+1,k)) & + - F252 * fh(i,j,k) ) +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-5)+fh(i,j,k+5)) & + - F10 * (fh(i,j,k-4)+fh(i,j,k+4)) & + + F45 * (fh(i,j,k-3)+fh(i,j,k+3)) & + - F120* (fh(i,j,k-2)+fh(i,j,k+2)) & + + F210* (fh(i,j,k-1)+fh(i,j,k+1)) & + - F252 * fh(i,j,k) ) + + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_sh + +! only in r direction + +subroutine kodis_shor(ex,X,Y,Z,f,f_rhs,SoAi,Symmetry,eps,sst) + +implicit none +! argument variables +integer,intent(in) :: Symmetry,sst +integer,dimension(3),intent(in)::ex +real*8, dimension(1:3), intent(in) :: SoAi +double precision,intent(in),dimension(ex(1))::X +double precision,intent(in),dimension(ex(2))::Y +double precision,intent(in),dimension(ex(3))::Z +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::f +double precision,intent(inout),dimension(ex(1),ex(2),ex(3))::f_rhs +real*8,intent(in) :: eps +! local variables +real*8, dimension(2) :: SoA +real*8, dimension(-4:ex(1)+5,-4:ex(2)+5,ex(3)) :: fh +integer :: imin,jmin,kmin,imax,jmax,kmax +integer :: i,j,k +real*8 :: dX,dY,dZ +real*8,parameter :: cof = 1.024d3 ! 2^2r = 2^10 +real*8, parameter :: F10=1.d1,F45=4.5d1,F120=1.2d2,F210=2.1d2,F252=2.52d2 +integer, parameter :: NO_SYMM=0, EQ_SYMM=1, OCTANT=2 + +!rhs_i = rhs_i + eps/dx/cof*(f_i-3 - 6*f_i-2 + 15*f_i-1 - 20*f_i + 15*f_i+1 - 6*f_i+2 + f_i+3) + + dX = X(2)-X(1) + dY = Y(2)-Y(1) + dZ = Z(2)-Z(1) + + imax = ex(1) + jmax = ex(2) + kmax = ex(3) + + imin = 1 + jmin = 1 + kmin = 1 + + if(Symmetry == OCTANT)then + if(dabs(X(1)) < dX) imin = -4 + if(dabs(Y(1)) < dY) jmin = -4 + elseif(Symmetry == EQ_SYMM)then + if((sst==2.or.sst==4).and.dabs(Y(1)) < dY) jmin = -4 + if((sst==3.or.sst==5).and.dabs(Y(ex(2))) < dY) jmax=ex(2)+5 + endif + + if(sst==0)then + SoA = SoAi(1:2) + elseif(sst==2.or.sst==3)then + SoA(1) = SoAi(2) + SoA(2) = SoAi(3) + elseif(sst==4.or.sst==5)then + SoA(1) = SoAi(1) + SoA(2) = SoAi(3) + endif + + call symmetry_stbd(5,ex,f,fh,SoA) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + + if(k-5 >= kmin .and. k+5 <= kmax) then +! z direction + + f_rhs(i,j,k) = f_rhs(i,j,k) + eps/dZ/cof * ( & + (fh(i,j,k-5)+fh(i,j,k+5)) & + - F10 * (fh(i,j,k-4)+fh(i,j,k+4)) & + + F45 * (fh(i,j,k-3)+fh(i,j,k+3)) & + - F120* (fh(i,j,k-2)+fh(i,j,k+2)) & + + F210* (fh(i,j,k-1)+fh(i,j,k+1)) & + - F252 * fh(i,j,k) ) + endif + + enddo + enddo + enddo + + return + +end subroutine kodis_shor + +#endif diff --git a/AMSS_NCKU_source/monitor.C b/AMSS_NCKU_source/Monitor/monitor.C similarity index 95% rename from AMSS_NCKU_source/monitor.C rename to AMSS_NCKU_source/Monitor/monitor.C index 20c718f..42f0a41 100644 --- a/AMSS_NCKU_source/monitor.C +++ b/AMSS_NCKU_source/Monitor/monitor.C @@ -1,173 +1,173 @@ - -#ifdef newc -#include -using namespace std; -#else -#include -#endif - -#include "unistd.h" - -#include "monitor.h" -#include "parameters.h" -#include "misc.h" - -monitor::monitor(const char fname[], int myrank, string head) -{ - I_Print = (myrank == 0); - - if (I_Print) - { - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - // considering checkpoint run - char filename[50]; - sprintf(filename, "%s/%s", out_dir.c_str(), fname); - int i = 1; - while ((access(filename, F_OK)) != -1) - { - sprintf(filename, "%s/%d_%s", out_dir.c_str(), i, fname); - i++; - } - - outfile.open(filename, ios::trunc); - - time_t tnow; - time(&tnow); - struct tm *loc_time; - loc_time = localtime(&tnow); - - outfile << "# File created on " << asctime(loc_time); - outfile << "#" << endl; - outfile.setf(ios::left); - outfile << head << endl; - } -} - -monitor::monitor(const char fname[], int myrank, const int out_rank, string head) -{ - I_Print = (myrank == out_rank); - - if (I_Print) - { - // considering checkpoint run - char filename[50]; - sprintf(filename, "%s/%s", out_dir.c_str(), fname); - int i = 1; - while ((access(filename, F_OK)) != -1) - { - sprintf(filename, "%s/%d_%s", out_dir.c_str(), i, fname); - i++; - } - - outfile.open(filename, ios::trunc); - - time_t tnow; - time(&tnow); - struct tm *loc_time; - loc_time = localtime(&tnow); - - outfile << "# File created on " << asctime(loc_time); - outfile << "#" << endl; - outfile.setf(ios::left); - outfile << head << endl; - } -} -monitor::~monitor() -{ - if (I_Print) - outfile.close(); -} -void monitor::writefile(double time, int NN, double *DDAT) -{ - if (I_Print) - { - outfile << setprecision(8); - outfile << setw(14) << time; - for (int countlm = 0; countlm < NN; countlm++) - { - outfile << " " << setw(15) << DDAT[countlm]; - } - outfile << endl; - flush(outfile); - } -} -void monitor::writefile(double time, int NN, double *DDAT1, double *DDAT2) -{ - if (I_Print) - { - outfile << setprecision(8); - outfile << setw(14) << time; - for (int countlm = 0; countlm < NN; countlm++) - { - outfile << " " << setw(15) << DDAT1[countlm] - << " " << setw(15) << DDAT2[countlm]; - } - outfile << endl; - flush(outfile); - } -} -void monitor::print_message(string head) -{ - if (I_Print) - { - outfile << head << endl; - flush(outfile); - } -} + +#ifdef newc +#include +using namespace std; +#else +#include +#endif + +#include "unistd.h" + +#include "monitor.h" +#include "parameters.h" +#include "misc.h" + +monitor::monitor(const char fname[], int myrank, string head) +{ + I_Print = (myrank == 0); + + if (I_Print) + { + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + // considering checkpoint run + char filename[50]; + sprintf(filename, "%s/%s", out_dir.c_str(), fname); + int i = 1; + while ((access(filename, F_OK)) != -1) + { + sprintf(filename, "%s/%d_%s", out_dir.c_str(), i, fname); + i++; + } + + outfile.open(filename, ios::trunc); + + time_t tnow; + time(&tnow); + struct tm *loc_time; + loc_time = localtime(&tnow); + + outfile << "# File created on " << asctime(loc_time); + outfile << "#" << endl; + outfile.setf(ios::left); + outfile << head << endl; + } +} + +monitor::monitor(const char fname[], int myrank, const int out_rank, string head) +{ + I_Print = (myrank == out_rank); + + if (I_Print) + { + // considering checkpoint run + char filename[50]; + sprintf(filename, "%s/%s", out_dir.c_str(), fname); + int i = 1; + while ((access(filename, F_OK)) != -1) + { + sprintf(filename, "%s/%d_%s", out_dir.c_str(), i, fname); + i++; + } + + outfile.open(filename, ios::trunc); + + time_t tnow; + time(&tnow); + struct tm *loc_time; + loc_time = localtime(&tnow); + + outfile << "# File created on " << asctime(loc_time); + outfile << "#" << endl; + outfile.setf(ios::left); + outfile << head << endl; + } +} +monitor::~monitor() +{ + if (I_Print) + outfile.close(); +} +void monitor::writefile(double time, int NN, double *DDAT) +{ + if (I_Print) + { + outfile << setprecision(8); + outfile << setw(14) << time; + for (int countlm = 0; countlm < NN; countlm++) + { + outfile << " " << setw(15) << DDAT[countlm]; + } + outfile << endl; + flush(outfile); + } +} +void monitor::writefile(double time, int NN, double *DDAT1, double *DDAT2) +{ + if (I_Print) + { + outfile << setprecision(8); + outfile << setw(14) << time; + for (int countlm = 0; countlm < NN; countlm++) + { + outfile << " " << setw(15) << DDAT1[countlm] + << " " << setw(15) << DDAT2[countlm]; + } + outfile << endl; + flush(outfile); + } +} +void monitor::print_message(string head) +{ + if (I_Print) + { + outfile << head << endl; + flush(outfile); + } +} diff --git a/AMSS_NCKU_source/monitor.h b/AMSS_NCKU_source/Monitor/monitor.h similarity index 94% rename from AMSS_NCKU_source/monitor.h rename to AMSS_NCKU_source/Monitor/monitor.h index 49692d4..fdd06d2 100644 --- a/AMSS_NCKU_source/monitor.h +++ b/AMSS_NCKU_source/Monitor/monitor.h @@ -1,45 +1,45 @@ - -#ifndef MONITOR_H -#define MONITOR_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#endif -#include - -#include - -class monitor -{ - -public: - string out_dir; - ofstream outfile; - - bool I_Print; - -public: - monitor(const char fname[], int myrank, string head); - monitor(const char fname[], int myrank, const int out_rank, string head); - - ~monitor(); - - void writefile(double time, int NN, double *DDAT); - void writefile(double time, int NN, double *DDAT1, double *DDAT2); - void print_message(string head); -}; - -#endif /* MONITOR */ + +#ifndef MONITOR_H +#define MONITOR_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#endif +#include + +#include + +class monitor +{ + +public: + string out_dir; + ofstream outfile; + + bool I_Print; + +public: + monitor(const char fname[], int myrank, string head); + monitor(const char fname[], int myrank, const int out_rank, string head); + + ~monitor(); + + void writefile(double time, int NN, double *DDAT); + void writefile(double time, int NN, double *DDAT1, double *DDAT2); + void print_message(string head); +}; + +#endif /* MONITOR */ diff --git a/AMSS_NCKU_source/NullEvol.f90 b/AMSS_NCKU_source/Null_Evolve/NullEvol.f90 similarity index 97% rename from AMSS_NCKU_source/NullEvol.f90 rename to AMSS_NCKU_source/Null_Evolve/NullEvol.f90 index 5f826b2..a9623b0 100644 --- a/AMSS_NCKU_source/NullEvol.f90 +++ b/AMSS_NCKU_source/Null_Evolve/NullEvol.f90 @@ -1,4026 +1,4026 @@ - - -#include "macrodef.fh" - -!#define OLD - -! 0: rk4, 1: Adams-Moulton - -#define RKorAM 0 - -function beta_rhs(xx,CJx,Kx) result(gont) - implicit none - double complex,intent(in) :: CJx - real*8,intent(in) :: xx,Kx - - real*8 :: gont - - gont = xx*(1.d0-xx)/8.d0*(dreal(CJx*dconjg(CJx))-Kx*Kx) - - return - -end function beta_rhs - -function Q_rhs(xx,CJ,CJx,DCJx,KK,Ck,Ckx,Cnux,KKx,CBx,Cnu,DCJ,CB,CQ) result(gont) - implicit none - double complex,intent(in) :: CJ,CJx,DCJx,Ck,Ckx,Cnux,CBx,Cnu,DCJ,CB,CQ - real*8,intent(in) :: xx,KK,KKx - - double complex :: gont - - gont = -KK*(Ckx+Cnux)+Cnu*KKx+CJ*dconjg(Ckx)+2.d0*CBx & - +dconjg(Cnu)*CJx+dconjg(CJ)*DCJx-dconjg(Ck)*CJx & - +(dconjg(Cnu)*(CJx-CJ*CJ*dconjg(CJx)) & - +DCJ*(dconjg(CJx)-dconjg(CJ*CJ)*CJx)/2.d0/KK/KK) & - -2.d0*(2.d0*CB+CQ)/xx/(1.d0-xx) - - return - -end function Q_rhs - -function U_rhs(xx,Rmin,beta,KK,CQ,CJ) result(gont) - implicit none - double complex,intent(in) :: CQ,CJ - real*8,intent(in) :: xx,Rmin,beta,KK - - double complex :: gont - -#if 1 - gont = dexp(2.d0*beta)/Rmin/xx/xx*(KK*CQ-CJ*dconjg(CQ)) -#else - gont = CQ/Rmin/xx/xx -#endif - -#if 0 - if(cdabs(gont)>1)then - write(*,*)beta,KK,CQ,CJ - stop - endif -#endif - - return - -end function U_rhs - -function W_rhs(xx,Rmin,beta,KK,DCB,CB,CJ,Cnu,Ck,W, & - CQ,bDCk,bDCnu,bDCB,bDCU,bDCUx,DCJ) result(gont) - implicit none - double complex,intent(in) :: DCB,CB,CJ,Cnu,Ck,CQ,bDCk,bDCnu,bDCB,bDCU,bDCUx,DCJ - real*8,intent(in) :: xx,Rmin,beta,KK,W - - real*8 :: Ric,gont - - Ric = dreal(2.d0*KK+bDCnu-bDCk+(DCJ*dconjg(DCJ)-Cnu*dconjg(Cnu))/4.d0/KK) - - gont = dreal(dexp(2.d0*beta)*(Ric/2.d0-KK*(bDCB+CB*dconjg(CB))+dconjg(CJ)*(bDCB+CB*CB) & - +(Cnu-Ck)*dconjg(CB))-1.d0+2.d0*Rmin*xx/(1.d0-xx)*(bDCU-W) & - +Rmin*xx*xx/2.d0*bDCUx-dexp(2.d0*beta)/4.d0* & - (KK*KK-CJ*dconjg(CJ))*(KK*dconjg(CQ)-dconjg(CJ)*CQ)*CQ) - - gont = gont/Rmin/xx/xx - - return - -end function W_rhs - -function Theta_rhs(xx,Rmin,beta,betax,KK,KKx,CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,W,Wx,CJ,DCJ,CJx,CJxx, & - DCJx,bDCB,Cnu,Cnux,Ck,Theta) result(gont) - implicit none - double complex,intent(in) :: CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,CJ,DCJ,CJx,CJxx,DCJx - double complex,intent(in) :: bDCB,Cnu,Cnux,Ck,Theta - real*8,intent(in) :: xx,Rmin,beta,betax,KK,KKx,W,Wx - - double complex :: JH,II,gont - real*8 :: V,Vx,Pu - - II = dcmplx(0.d0,1.d0) - - V = xx*Rmin/(1.d0-xx)*(1.d0+xx*Rmin/(1.d0-xx)*W) - - Vx = Rmin/(1.d0-xx)**2+2.d0*xx*Rmin*Rmin/(1.d0-xx)**3*W+xx*xx*Rmin*Rmin/(1.d0-xx)**2*Wx - - Pu = 2.d0*xx*(1.d0-xx)/KK*dreal(Theta*(dconjg(CJx)*KK-dconjg(CJ)*KKx)) - - JH = (1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(-KK*DCJ*dconjg(CB)+ & - (KK*Cnu+(KK*KK-1.d0)*DCJ-2.d0*KK*Ck)*CB+CJ* & - ((2.d0*Ck-Cnu)*dconjg(CB)-2.d0*KK*(bDCB+CB*dconjg(CB))+ & - 2.d0*dreal((Cnu-Ck)*dconjg(CB)+dconjg(CJ)*(DCB+CB*CB)))) & - +0.5d0*Rmin*xx**3*(1.d0-xx)*dexp(-2.d0*beta)* & - ((KK*CUx+CJ*dconjg(CUx))**2- & - CJ*dreal(dconjg(CUx)*(KK*CUx+CJ*dconjg(CUx)))) & - -0.5d0*(Cnu*(xx*(1.d0-xx)*CUx+2.d0*CU)+DCJ*(xx*(1.d0-xx)*dconjg(CUx)+ & - 2.d0*dconjg(CU)))+CJ*II*dimag(xx*(1.d0-xx)*bDCUx+2.d0*bDCU) & - -xx*(1.d0-xx)*CJx*dreal(bDCU) & - +xx*(1.d0-xx)*(dconjg(CU)*DCJ+CU*Cnu)*II*dimag(CJ*dconjg(CJx)) & - -xx*(1.d0-xx)*(dconjg(CU)*DCJx+CU*Cnux) & - -2.d0*xx*(1.d0-xx)*(CJ*KKx-KK*CJx)*(dreal(dconjg(CU)*Ck)+ & - II*dimag(KK*bDCU-dconjg(CJ)*DCU)) & - -8.d0*CJ*((1.d0-xx)**2/Rmin+xx*(1.d0-xx)*W)*betax - - gont = -KK*(xx*(1-xx)*DCUx+2.d0*DCU)+2.d0*(1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(DCB+CB*CB) & - -(xx*(1.d0-xx)*Wx+W)*CJ+JH+CJ*Pu-2.d0*Theta & - -(1.d0-xx)*(1.d0-xx)/xx/xx/Rmin/Rmin*V*(CJ+xx*(1.d0-xx)*CJx) & - +(1.d0-xx)*(1.d0-xx)*(1.d0-xx)/xx/Rmin/Rmin*Vx*(CJ+xx*(1.d0-xx)*CJx) & - +(1.d0-xx)**4/xx/Rmin/Rmin*V*(2.d0*CJx+xx*CJxx) -#if 0 - gont = -(xx*(1-xx)*DCUx+2.d0*DCU)+2.d0*(1.d0-xx)/xx/Rmin*DCB & - -2.d0*Theta & - +(1.d0-xx)**3/Rmin*(2.d0*CJx+xx*CJxx) -#endif - - gont = gont/2.d0/xx/(1.d0-xx) - - return - -end function Theta_rhs -!/////////////////////////////////////////////////////////////////////////////////////////////////////////////// -subroutine fake_Theta_rhs(lx,X,rhs,Theta) - implicit none - integer,intent(in) :: lx - double complex,dimension(lx),intent(in) :: Theta - double complex,dimension(lx),intent(out) :: rhs - real*8,dimension(lx),intent(in) :: X - - call cderivs_x(lx,X,Theta,rhs) - - return - -end subroutine fake_Theta_rhs -!/////////////////////////////////////////////////////////////////////////////////////////////////////////////// -! try other guy's old method -function Theta_rhs_o(xx,Rmin,beta,betax,KK,KKx,CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,W,Wx,CJ,DCJ,CJx,CJxx, & - DCJx,bDCB,Cnu,Cnux,Ck,Theta) result(gont) - implicit none - double complex,intent(in) :: CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,CJ,DCJ,CJx,CJxx,DCJx - double complex,intent(in) :: Cnu,Cnux,Ck,bDCB,Theta - real*8,intent(in) :: xx,Rmin,beta,betax,KK,KKx,W,Wx - - double complex :: JH,II,gont - real*8 :: V,Vx,Pu - - II = dcmplx(0.d0,1.d0) - - V = xx*Rmin/(1.d0-xx)*(1.d0+xx*Rmin/(1.d0-xx)*W) - - Vx = Rmin/(1.d0-xx)**2+2.d0*xx*Rmin*Rmin/(1.d0-xx)**3*W+xx*xx*Rmin*Rmin/(1.d0-xx)**2*Wx - - Pu = 2.d0*xx*(1.d0-xx)/KK*dreal(Theta*(dconjg(CJx)*KK-dconjg(CJ)*KKx)) - - JH = (1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(-KK*DCJ*dconjg(CB)+ & - (KK*Cnu+(KK*KK-1.d0)*DCJ-2.d0*KK*Ck)*CB+CJ* & - ((2.d0*Ck-Cnu)*dconjg(CB)-2.d0*KK*(bDCB+CB*dconjg(CB))+ & - 2.d0*dreal((Cnu-Ck)*dconjg(CB)+dconjg(CJ)*(DCB+CB*CB)))) & - +0.5d0*Rmin*xx**3*(1.d0-xx)*dexp(-2.d0*beta)* & - ((KK*CUx+CJ*dconjg(CUx))**2- & - CJ*dreal(dconjg(CUx)*(KK*CUx+CJ*dconjg(CUx)))) & - -0.5d0*(Cnu*(xx*(1.d0-xx)*CUx+2.d0*CU)+DCJ*(xx*(1.d0-xx)*dconjg(CUx)+ & - 2.d0*dconjg(CU)))+CJ*II*dimag(xx*(1.d0-xx)*bDCUx+2.d0*bDCU) & - -xx*(1.d0-xx)*CJx*dreal(bDCU) & - +xx*(1.d0-xx)*(dconjg(CU)*DCJ+CU*Cnu)*II*dimag(CJ*dconjg(CJx)) & - -xx*(1.d0-xx)*(dconjg(CU)*DCJx+CU*Cnux) & - -2.d0*xx*(1.d0-xx)*(CJ*KKx-KK*CJx)*(dreal(dconjg(CU)*Ck)+ & - II*dimag(KK*bDCU-dconjg(CJ)*DCU)) & - -8.d0*CJ*((1.d0-xx)**2/Rmin+xx*(1.d0-xx)*W)*betax - - gont = -KK*(xx*(1-xx)*DCUx+2.d0*DCU)+2.d0*(1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(DCB+CB*CB) & - -(xx*(1.d0-xx)*Wx+W)*CJ+JH+CJ*Pu & - -(1.d0-xx)*(1.d0-xx)/xx/xx/Rmin/Rmin*V*(CJ+xx*(1.d0-xx)*CJx) & - +(1.d0-xx)*(1.d0-xx)*(1.d0-xx)/xx/Rmin/Rmin*Vx*(CJ+xx*(1.d0-xx)*CJx) & - +(1.d0-xx)**4/xx/Rmin/Rmin*V*(2.d0*CJx+xx*CJxx) - - return - -end function Theta_rhs_o - -#if (RKorAM == 0) - -!-------------------------------------------------------------------- -! this R is indeed x -function NullEvol_Theta_o(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ - double complex :: CTheta0,CTheta,CTheta1,RHS - integer :: i,j,k,RK4 - double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx - double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB - real*8,dimension(ex(3)) :: KK,KKx,HKK,HKKx,Hbeta,betax,Hbetax,HW,Wx,HWx - double complex :: Theta_rhs_o - real*8 :: dR - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CU = dcmplx(RU,IU) - CB = dcmplx(RB,IB) - CJ = dcmplx(RJ,IJ) - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) - CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) - Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) - Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) - call cget_half_x(ex(3),CB(i,j,:),HCB) - call cget_half_x(ex(3),DCB(i,j,:),HDCB) - call cget_half_x(ex(3),bDCB(i,j,:),HbDCB) - call cget_half_x(ex(3),Cnu,HCnu) - call cderivs_x(ex(3),R,Cnu,Cnux) - call cget_half_x(ex(3),Cnux,HCnux) - call cget_half_x(ex(3),Ck,HCk) - call rget_half_x(ex(3),beta(i,j,:),Hbeta) - call rderivs_x(ex(3),R,beta(i,j,:),betax) - call rget_half_x(ex(3),betax,Hbetax) - KK = dsqrt(1.d0+RJ(i,j,:)*RJ(i,j,:)+IJ(i,j,:)*IJ(i,j,:)) - call rget_half_x(ex(3),KK,HKK) - call rderivs_x(ex(3),R,KK,KKx) - call rget_half_x(ex(3),KKx,HKKx) - call rderivs_x(ex(3),R,W,Wx) - call rget_half_x(ex(3),Wx,HWx) - call rget_half_x(ex(3),W(i,j,:),HW) - call cget_half_x(ex(3),CU(i,j,:),HCU) - call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) - call cderivs_x(ex(3),R,CU(i,j,:),CUx) - call cget_half_x(ex(3),DCUx,HDCUx) - call cget_half_x(ex(3),CUx,HCUx) - call cget_half_x(ex(3),DCU(i,j,:),HDCU) - call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) - call cget_half_x(ex(3),bDCUx,HbDCUx) - call cget_half_x(ex(3),bDCU(i,j,:),HbDCU) - call cderivs_x(ex(3),R,CJ(i,j,:),CJx) - call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) - call cget_half_x(ex(3),CJx,HCJx) - call cget_half_x(ex(3),CJxx,HCJxx) - call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) - call cget_half_x(ex(3),DCJx,HDCJx) - do k=1,ex(3)-1 - RHS = Theta_rhs_o(R(k)+dR/2.d0,Rmin,Hbeta(k),betax(k),HKK(k),KKx(k),HCU(k),CUx(k),DCUx(k),HbDCU(k),bDCUx(k), & - HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k),HCJ(k),HDCJ(k), & - CJx(k),CJxx(k),DCJx(k),HbDCB(k),HCnu(k),Cnux(k),HCk(k),CTheta0) - CTheta1 = RHS-(1-2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR)*CTheta0 - CTheta1 = CTheta1/(1+2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR) - CTheta0 = CTheta1 - - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - enddo - enddo - enddo - - gont = 0 - return - -end function NullEvol_Theta_o -!------------------------------------------------------------------------------ -! this R is indeed x -function NullEvol_beta(ex,crho,sigma,R,RJ,IJ,beta,KKx,HKKx) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KKx,HKKx -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - double complex, dimension(ex(3)):: CJ,CJx,HCJx - real*8 :: betah0,betah1,betah,rhs - integer :: i,j,k,RK4 - real*8 :: beta_rhs - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(beta)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_beta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_beta: find NaN in IJ" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_beta: find NaN in beta" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_beta: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_beta: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - betah0 = beta(i,j,1) - CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) - call cderivs_x(ex(3),R,CJ,CJx) - call cget_half_x(ex(3),CJx,HCJx) -#ifdef OLD - do k = 1,ex(3)-1 -! note our CJx(ex(3)) = (CJ(ex(3))-CJ(ex(3)-1))/dR -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - rhs = beta_rhs(R(k)+dR/2.d0,CJx(k+1),KKx(i,j,k+1)) - beta(i,j,k+1) = beta(i,j,k) + rhs*dR - enddo -#else - do k=1,ex(3)-1 - RK4 = 0 - rhs = beta_rhs(R(k),CJx(k),KKx(i,j,k)) - call rungekutta4_scalar(dR,betah0,betah,rhs,RK4) - - RK4 = 1 - betah1 = beta_rhs(R(k)+dR/2.d0,HCJx(k),HKKx(i,j,k)) - call rungekutta4_scalar(dR,betah0,betah1,rhs,RK4) - call rswap(betah,betah1) - - RK4 = 2 - betah1 = beta_rhs(R(k)+dR/2.d0,HCJx(k),HKKx(i,j,k)) - call rungekutta4_scalar(dR,betah0,betah1,rhs,RK4) - call rswap(betah,betah1) - - RK4 = 3 - betah1 = beta_rhs(R(k+1),CJx(k+1),KKx(i,j,k+1)) - call rungekutta4_scalar(dR,betah0,betah1,rhs,RK4) - call rswap(betah0,betah1) - - beta(i,j,k+1) = betah0 - enddo -! above k takes ex(3)-1 then do not need this closing step -#if 1 -! closing step - k = ex(3)-1 -! note our CJx(ex(3)) = (CJ(ex(3))-CJ(ex(3)-1))/dR -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - rhs = beta_rhs(R(k)+dR/2.d0,CJx(k+1),KKx(i,j,k+1)) - beta(i,j,k+1) = beta(i,j,k) + rhs*dR -#endif - -#endif - enddo - enddo - - gont = 0 - - return - -end function NullEvol_beta -!------------------------------------------------------------------------------ -! this R is indeed x -function NullEvol_Q(ex,crho,sigma,R,RJ,IJ,Rk,Ik,Rnu,Inu,RB,IB,RQ,IQ,KK,Hkk,KKx,HKKx, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RQ,IQ - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KK,Hkk,KKx,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rk,Ik,Rnu,Inu,RB,IB - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: xx,dR - - double complex :: CQ0,CQ,CQ1,RHS - double complex,dimension(ex(3)) :: CJx,HCJx,DCJx,HDCJx,Ck,Ckx,HCkx,Cnu,Cnux,HCnux,CB,CBx,HCBx - double complex,dimension(ex(3)) :: HCJ,HCk,HCnu,HCB,HDCJ - double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,DCJ - integer :: i,j,k,RK4 - double complex :: Q_rhs - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ) & - +sum(RK)+sum(IK)+sum(Rnu)+sum(Inu)+sum(RB)+sum(IB) & - +sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Q: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Q: find NaN in IJ" - if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_Q: find NaN in RQ" - if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_Q: find NaN in IQ" - if(sum(RK).ne.sum(RK))write(*,*)"NullEvol_Q: find NaN in RK" - if(sum(IK).ne.sum(IK))write(*,*)"NullEvol_Q: find NaN in IK" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Q: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Q: find NaN in Inu" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Q: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Q: find NaN in IB" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Q: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Q: find NaN in HKK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Q: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Q: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CJ = dcmplx(RJ,IJ) - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - do j=1,ex(2) - do i=1,ex(1) - CQ0 = dcmplx(RQ(i,j,1),IQ(i,j,1)) - call cderivs_x(ex(3),R,CJ(i,j,:),CJx) - call cget_half_x(ex(3),CJx,HCJx) - call cget_half_x(ex(3),CJ,HCJ) - call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) - call cget_half_x(ex(3),DCJx,HDCJx) - call cget_half_x(ex(3),DCJ,HDCJ) - Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) - call cderivs_x(ex(3),R,Ck,Ckx) - call cget_half_x(ex(3),Ckx,HCkx) - call cget_half_x(ex(3),Ck,HCk) - Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) - call cderivs_x(ex(3),R,Cnu,Cnux) - call cget_half_x(ex(3),Cnux,HCnux) - call cget_half_x(ex(3),Cnu,HCnu) - CB = dcmplx(RB(i,j,:),IB(i,j,:)) - call cderivs_x(ex(3),R,CB,CBx) - call cget_half_x(ex(3),CBx,HCBx) - call cget_half_x(ex(3),CB,HCB) -#ifdef OLD - do k = 1,ex(3)-1 - xx = R(k)+dR/2.d0 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - RHS = Q_rhs(xx,HCJ(k),CJx(k+1),DCJx(k+1),HKK(i,j,k),HCk(k),Ckx(k+1),Cnux(k+1),KKx(i,j,k+1),CBx(k+1),HCnu(k),HDCJ(k),HCB(k),0) - RHS = RHS+CQ0*(1.d0/dR-1.d0/xx/(1.d0-xx)) - CQ0 = RHS/(1.d0/dR+1.d0/xx/(1.d0-xx)) - RQ(i,j,k+1) = dreal(CQ0) - IQ(i,j,k+1) = dimag(CQ0) - enddo -#else - do k=1,ex(3)-2 - RK4 = 0 - RHS = Q_rhs(R(k),CJ(i,j,k),CJx(k),DCJx(k),KK(i,j,k),Ck(k),Ckx(k),Cnux(k),KKx(i,j,k),CBx(k),Cnu(k),DCJ(i,j,k),CB(k),CQ0) - call rungekutta4_cplxscalar(dR,CQ0,CQ,RHS,RK4) - - RK4 = 1 - CQ1 = Q_rhs(R(k)+dR/2.d0,HCJ(k),HCJx(k),HDCJx(k),HKK(i,j,k),HCk(k),HCkx(k),HCnux(k),HKKx(i,j,k), & - HCBx(k),HCnu(k),HDCJ(k),HCB(k),CQ) - call rungekutta4_cplxscalar(dR,CQ0,CQ1,RHS,RK4) - call cswap(CQ,CQ1) - - RK4 = 2 - CQ1 = Q_rhs(R(k)+dR/2.d0,HCJ(k),HCJx(k),HDCJx(k),HKK(i,j,k),HCk(k),HCkx(k),HCnux(k),HKKx(i,j,k), & - HCBx(k),HCnu(k),HDCJ(k),HCB(k),CQ) - call rungekutta4_cplxscalar(dR,CQ0,CQ1,RHS,RK4) - call cswap(CQ,CQ1) - - RK4 = 3 - CQ1 = Q_rhs(R(k+1),CJ(i,j,k+1),CJx(k+1),DCJx(k+1),KK(i,j,k+1),Ck(k+1),Ckx(k+1),Cnux(k+1),KKx(i,j,k+1), & - CBx(k+1),Cnu(k+1),DCJ(i,j,k+1),CB(k+1),CQ) - call rungekutta4_cplxscalar(dR,CQ0,CQ1,RHS,RK4) - call cswap(CQ0,CQ1) - - RQ(i,j,k+1) = dreal(CQ0) - IQ(i,j,k+1) = dimag(CQ0) - enddo -#if 0 - k = ex(3) - CQ0 = -2*CB(k) - RQ(i,j,k+1) = dreal(CQ0) - IQ(i,j,k+1) = dimag(CQ0) -#else -! closing step - k = ex(3)-1 - CQ0 = dcmplx(RQ(i,j,k),IQ(i,j,k)) - xx = R(k)+dR/2.d0 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - RHS = Q_rhs(xx,HCJ(k),CJx(k+1),DCJx(k+1),HKK(i,j,k), & - HCk(k),Ckx(k+1),Cnux(k+1),KKx(i,j,k+1),CBx(k+1),HCnu(k),HDCJ(k),HCB(k),dcmplx(0.d0,0.d0)) - RHS = RHS+CQ0*(1.d0/dR-1.d0/xx/(1.d0-xx)) - CQ0 = RHS/(1.d0/dR+1.d0/xx/(1.d0-xx)) - RQ(i,j,k+1) = dreal(CQ0) - IQ(i,j,k+1) = dimag(CQ0) -#endif - -#endif - enddo - enddo - - gont = 0 - return - -end function NullEvol_Q -!-------------------------------------------------------------------- -! this R is indeed x -function NullEvol_U(ex,crho,sigma,R,RJ,IJ,RQ,IQ,KK,HKK,beta,RU,IU, & - Rmin) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RQ,IQ,beta,KK,HKK - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU - real*8,intent(in) :: Rmin -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - double complex :: CU0,CU,CU1,RHS - integer :: i,j,k,RK4 - double complex,dimension(ex(3)) :: CJ,CQ,HCJ,HCQ - real*8,dimension(ex(3)) :: Hbeta - double complex :: U_rhs - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ)+sum(beta)+sum(RU)+sum(IU)+sum(KK)+sum(HKK) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_U: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_U: find NaN in IJ" - if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_U: find NaN in RQ" - if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_U: find NaN in IQ" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_U: find NaN in beta" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_U: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_U: find NaN in IU" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_U: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_U: find NaN in HKK" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - CU0 = dcmplx(RU(i,j,1),IU(i,j,1)) - CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) - CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) - call cget_half_x(ex(3),CJ,HCJ) - call cget_half_x(ex(3),CQ,HCQ) - call rget_half_x(ex(3),beta(i,j,:),Hbeta) -#ifdef OLD - do k = 1,ex(3)-1 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - RHS = U_rhs(R(k)+dR/2,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) - CU0 = CU0+RHS*dR - RU(i,j,k+1) = dreal(CU0) - IU(i,j,k+1) = dimag(CU0) - enddo -#else - - do k=1,ex(3)-2 - - RK4 = 0 - RHS = U_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),CQ(k),CJ(k)) - call rungekutta4_cplxscalar(dR,CU0,CU,RHS,RK4) - - RK4 = 1 - CU1 = U_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) - call rungekutta4_cplxscalar(dR,CU0,CU1,RHS,RK4) - call cswap(CU,CU1) - - RK4 = 2 - CU1 = U_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) - call rungekutta4_cplxscalar(dR,CU0,CU1,RHS,RK4) - call cswap(CU,CU1) - - RK4 = 3 - CU1 = U_rhs(R(k+1),Rmin,beta(i,j,k+1),KK(i,j,k+1),CQ(k+1),CJ(k+1)) - call rungekutta4_cplxscalar(dR,CU0,CU1,RHS,RK4) - call cswap(CU0,CU1) - - RU(i,j,k+1) = dreal(CU0) - IU(i,j,k+1) = dimag(CU0) - - enddo -! above k takes ex(3)-1 then do not need closing step -#if 1 -! closing step - k = ex(3)-1 - CU0 = dcmplx(RU(i,j,k),IU(i,j,k)) -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - RHS = U_rhs(R(k)+dR/2,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) - CU0 = CU0+RHS*dR - RU(i,j,k+1) = dreal(CU0) - IU(i,j,k+1) = dimag(CU0) -#endif - -#endif - enddo - enddo - - gont = 0 - return - -end function NullEvol_U -!---------------------------------------------------------------------------------------- -! this R is indeed x -function NullEvol_W(ex,crho,sigma,R,RJ,IJ,RB,IB,Rnu,Inu,Rk,Ik, & - RU,IU,RQ,IQ,W,beta,KK,HKK,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: W - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,RB,IB - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RU,IU,RQ,IQ,beta,KK,HKK - real*8,intent(in ) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - real*8, dimension(ex(3)) :: Hbeta - double complex, dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU - double complex, dimension(ex(1),ex(2),ex(3)) :: CB,DCB,bDCB,CJ,DCJ,Cnu,bDCnu,Ck,bDCk - double complex, dimension(ex(3)) :: HCB,HDCB,HbDCB,HCJ,HDCJ,HCnu,HbDCnu,HCk,HbDCk - double complex, dimension(ex(3)) :: HbDCU,bDCUx,HbDCUx,CQ,HCQ - real*8 :: Wh0,Wh1,Wh,rhs - integer :: i,j,k,RK4 - real*8 :: xx,W_rhs - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(beta)+sum(RB)+sum(IB)+sum(Rnu)+sum(Inu) & - +sum(Rk)+sum(Ik)+sum(W)+sum(RU)+sum(IU)+sum(RQ)+sum(IQ)& - +sum(KK)+sum(HKK) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_W: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_W: find NaN in IJ" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_W: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_W: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_W: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_W: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_W: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_W: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_W: find NaN in Ik" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_W: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_W: find NaN in IU" - if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_W: find NaN in RQ" - if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_W: find NaN in IQ" - if(sum(W).ne.sum(W))write(*,*)"NullEvol_W: find NaN in W" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_W: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_W: find NaN in HKK" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CB = dcmplx(RB,IB) - CU = dcmplx(RU,IU) - Ck = dcmplx(Rk,Ik) - Cnu = dcmplx(Rnu,Inu) - CJ = dcmplx(RJ,IJ) - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,Ck(:,:,k),bDCk(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,Cnu(:,:,k),bDCnu(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) - Wh0 = W(i,j,1) - call rget_half_x(ex(3),beta(i,j,:),Hbeta) - call cderivs_x(ex(3),R,bDCU,bDCUx) - call cget_half_x(ex(3),bDCUx,HbDCUx) - call cget_half_x(ex(3),bDCU,HbDCU) - call cget_half_x(ex(3),DCJ,HDCJ) - call cget_half_x(ex(3),DCB,HDCB) - call cget_half_x(ex(3),bDCB,HbDCB) - call cget_half_x(ex(3),CB,HCB) - call cget_half_x(ex(3),CJ,HCJ) - call cget_half_x(ex(3),Cnu,HCnu) - call cget_half_x(ex(3),Ck,HCk) - CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) - call cget_half_x(ex(3),CQ,HCQ) - call cget_half_x(ex(3),bDCk,HbDCk) - call cget_half_x(ex(3),bDCnu,HbDCnu) -#ifdef OLD - do k = 1,ex(3)-1 - xx = R(k)+dR/2 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - rhs = W_rhs(xx,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),0, & - HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),bDCUx(k+1),HDCJ(k)) - rhs = rhs+Wh0*(1.d0/dR-1.d0/xx/(1.d0-xx)) - W(i,j,k+1) = rhs/(1.d0/dR+1.d0/xx/(1.d0-xx)) - enddo -#else - do k=1,ex(3)-2 - RK4 = 0 - rhs = W_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),DCB(i,j,k),CB(i,j,k),CJ(i,j,k),Cnu(i,j,k),Ck(i,j,k),Wh0, & - CQ(k),bDCk(i,j,k),bDCnu(i,j,k),bDCB(i,j,k),bDCU(i,j,k),bDCUx(k),DCJ(i,j,k)) - call rungekutta4_scalar(dR,Wh0,Wh,rhs,RK4) - - RK4 = 1 - Wh1 = W_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),Wh, & - HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),HbDCUx(k),HDCJ(k)) - call rungekutta4_scalar(dR,Wh0,Wh1,rhs,RK4) - call rswap(Wh,Wh1) - - RK4 = 2 - Wh1 = W_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),Wh, & - HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),HbDCUx(k),HDCJ(k)) - call rungekutta4_scalar(dR,Wh0,Wh1,rhs,RK4) - call rswap(Wh,Wh1) - - RK4 = 3 - Wh1 = W_rhs(R(k+1),Rmin,beta(i,j,k+1),KK(i,j,k+1),DCB(i,j,k+1),CB(i,j,k+1),CJ(i,j,k+1),Cnu(i,j,k+1),Ck(i,j,k+1),Wh, & - CQ(k+1),bDCk(i,j,k+1),bDCnu(i,j,k+1),bDCB(i,j,k+1),bDCU(i,j,k+1),bDCUx(k+1),DCJ(i,j,k+1)) - call rungekutta4_scalar(dR,Wh0,Wh1,rhs,RK4) - call rswap(Wh0,Wh1) - - W(i,j,k+1) = Wh0 - enddo -#if 0 - k = ex(3) - W(i,j,k) = dreal(bDCU(i,j,k)) -#else -! closing step - k = ex(3)-1 - Wh0 = W(i,j,k) - xx = R(k)+dR/2 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR - rhs = W_rhs(xx,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),0.d0, & - HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),bDCUx(k+1),HDCJ(k)) - rhs = rhs+Wh0*(1.d0/dR-1.d0/xx/(1.d0-xx)) - W(i,j,k+1) = rhs/(1.d0/dR+1.d0/xx/(1.d0-xx)) -#endif - -#endif - enddo - enddo - - gont = 0 - return - -end function NullEvol_W -!----------------------------------------------------------------------------------------------- -! given exact Theta_x -! this R is indeed x -function NullEvol_Theta_givenx(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,T,sst) result(gont) - implicit none - integer,intent(in ):: ex(1:3),sst - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin,T - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI -! gont = 0: success; gont = 1: something wrong - integer::gont - - real*8,dimension(ex(3))::HR - real*8,dimension(ex(1),ex(2),ex(3)) :: RThetax,IThetax,HRThetax,HIThetax - double complex,dimension(ex(3)) :: fRHS,HfRHS - real*8 :: xx,dR - integer :: i,j,k,RK4 - double complex :: CTheta0,CTheta,CTheta1,RHS - integer,parameter :: ks=1 - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & - sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - HR = R+dR/2 - - call get_exact_null_theta_x(ex,crho,sigma,R,RThetax,IThetax,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) - call get_exact_null_theta_x(ex,crho,sigma,HR,HRThetax,HIThetax,sst,Rmin,T, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) - do j=1,ex(2) - do i=1,ex(1) - CTheta0 = dcmplx(RTheta(i,j,ks),ITheta(i,j,ks)) - fRHS = dcmplx(RThetax(i,j,:),IThetax(i,j,:)) - HfRHS = dcmplx(HRThetax(i,j,:),HIThetax(i,j,:)) - ! call cget_half_x(ex(3),fRHS,HfRHS) - - do k=ks,ex(3)-1 - RK4 = 0 - RHS = fRHS(k) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) - - RK4 = 1 - CTheta1 = HfRHS(k) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 2 - CTheta1 = HfRHS(k) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 3 - CTheta1 = fRHS(k+1) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta0,CTheta1) - - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - enddo - -#if 0 -! closing step - k = ex(3)-1 - RHS = fRHS(k) - CTheta0 = dcmplx(RTheta(i,j,k),ITheta(i,j,k))+RHS*dR - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) -#endif - - enddo - enddo - - gont = 0 - return - -end function NullEvol_Theta_givenx -!----------------------------------------------------------------------------------------------- -#if 1 -! real evolve -! for eth_x, eth first, _x later -! this R is indeed x -function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ - double complex :: CTheta0,CTheta,CTheta1,RHS - integer :: i,j,k,RK4 - double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx - double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB - real*8,dimension(ex(3)) :: Hbeta,betax,Hbetax,HW,Wx,HWx - double complex :: Theta_rhs,Theta_rhs_o - real*8 :: xx,dR - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & - sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CU = dcmplx(RU,IU) - CB = dcmplx(RB,IB) - CJ = dcmplx(RJ,IJ) - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) - CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) - Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) - Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) - call cget_half_x(ex(3),CB(i,j,:),HCB) - call cget_half_x(ex(3),DCB(i,j,:),HDCB) - call cget_half_x(ex(3),bDCB(i,j,:),HbDCB) - call cget_half_x(ex(3),Cnu,HCnu) - call cderivs_x(ex(3),R,Cnu,Cnux) - call cget_half_x(ex(3),Cnux,HCnux) - call cget_half_x(ex(3),Ck,HCk) - call rget_half_x(ex(3),beta(i,j,:),Hbeta) - call rderivs_x(ex(3),R,beta(i,j,:),betax) - call rget_half_x(ex(3),betax,Hbetax) - call rderivs_x(ex(3),R,W,Wx) - call rget_half_x(ex(3),Wx,HWx) - call rget_half_x(ex(3),W(i,j,:),HW) - call cget_half_x(ex(3),CU(i,j,:),HCU) - call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) - call cderivs_x(ex(3),R,CU(i,j,:),CUx) - call cget_half_x(ex(3),DCUx,HDCUx) - call cget_half_x(ex(3),CUx,HCUx) - call cget_half_x(ex(3),DCU(i,j,:),HDCU) - call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) - call cget_half_x(ex(3),bDCUx,HbDCUx) - call cget_half_x(ex(3),bDCU(i,j,:),HbDCU) - call cderivs_x(ex(3),R,CJ(i,j,:),CJx) - call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) - call cget_half_x(ex(3),CJx,HCJx) - call cget_half_x(ex(3),CJxx,HCJxx) - call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) - call cget_half_x(ex(3),DCJx,HDCJx) -! old type code: PRD 54, 6153, Eq.(32) etc. -#if 0 -! start up part - k = 1 - RHS = Theta_rhs_o(R(k)+dR/2.d0,Rmin,Hbeta(k),betax(k),HKK(i,j,k),KKx(i,j,k),HCU(k),CUx(k),DCUx(k),HbDCU(k),bDCUx(k), & - HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k),HCJ(k),HDCJ(k), & - CJx(k),CJxx(k),DCJx(k),HbDCB(k),HCnu(k),Cnux(k),HCk(k),CTheta0) - CTheta1 = RHS-(1-2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR)*CTheta0 - CTheta0 = CTheta1/(1+2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR) - - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - - do k=1,ex(3)-2 - RHS = Theta_rhs_o(R(k+1),Rmin,beta(i,j,k+1),betax(k+1),KK(i,j,k+1),KKx(i,j,k+1),CU(i,j,k+1),CUx(k+1),DCUx(k+1),bDCU(i,j,k+1),bDCUx(k+1), & - DCU(i,j,k+1),CB(i,j,k+1),DCB(i,j,k+1),W(i,j,k+1),Wx(k+1),CJ(i,j,k+1),DCJ(i,j,k+1), & - CJx(k+1),CJxx(k+1),DCJx(k+1),bDCB(i,j,k+1),Cnu(k+1),Cnux(k+1),Ck(k+1),CTheta0) - CTheta1 = RHS-(1-R(k+1)*(1.d0-R(k+1))/dR)*(dcmplx(RTheta(i,j,k),ITheta(i,j,k))) - CTheta0 = CTheta1/(1+R(k+1)*(1.d0-R(k+1))/dR) - - RTheta(i,j,k+2) = dreal(CTheta0) - ITheta(i,j,k+2) = dimag(CTheta0) - enddo -#endif - -#ifdef OLD - do k = 1,ex(3)-1 - xx = R(k)+dR/2 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR -! note our fxx(ex(3)) = (f(ex(3))-2.d0*f(ex(3)-1)+f(ex(3)-2))/dR - RHS = Theta_rhs(xx,Rmin,Hbeta(k),betax(k+1),HKK(i,j,k),KKx(i,j,k+1),HCU(k),CUx(k+1),DCUx(k+1),HbDCU(k),bDCUx(k+1), & - HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k+1),HCJ(k),HDCJ(k), & - CJx(k+1),CJxx(k+1),DCJx(k+1),HbDCB(k),HCnu(k),Cnux(k+1),HCk(k),0) - RHS = RHS+CTheta0*(1.d0/dR-0.5d0/xx/(1.d0-xx)) - CTheta0 = RHS/(1.d0/dR+0.5d0/xx/(1.d0-xx)) - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - enddo -#else - do k=1,ex(3)-2 - RK4 = 0 - RHS = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(k),KK(i,j,k),KKx(i,j,k),CU(i,j,k),CUx(k),DCUx(k),bDCU(i,j,k),bDCUx(k), & - DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(k),CJ(i,j,k),DCJ(i,j,k), & - CJx(k),CJxx(k),DCJx(k),bDCB(i,j,k),Cnu(k),Cnux(k),Ck(k),CTheta0) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) - - RK4 = 1 - CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),Hbetax(k),HKK(i,j,k),HKKx(i,j,k), & - HCU(k),HCUx(k),HDCUx(k),HbDCU(k),HbDCUx(k), & - HDCU(k),HCB(k),HDCB(k),HW(k),HWx(k),HCJ(k),HDCJ(k), & - HCJx(k),HCJxx(k),HDCJx(k),HbDCB(k),HCnu(k),HCnux(k),HCk(k),CTheta) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 2 - CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),Hbetax(k),HKK(i,j,k),HKKx(i,j,k), & - HCU(k),HCUx(k),HDCUx(k),HbDCU(k),HbDCUx(k), & - HDCU(k),HCB(k),HDCB(k),HW(k),HWx(k),HCJ(k),HDCJ(k), & - HCJx(k),HCJxx(k),HDCJx(k),HbDCB(k),HCnu(k),HCnux(k),HCk(k),CTheta) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 3 - CTheta1 = Theta_rhs(R(k+1),Rmin,beta(i,j,k+1),betax(k+1),KK(i,j,k+1),KKx(i,j,k+1), & - CU(i,j,k+1),CUx(k+1),DCUx(k+1),bDCU(i,j,k+1),bDCUx(k+1), & - DCU(i,j,k+1),CB(i,j,k+1),DCB(i,j,k+1),W(i,j,k+1),Wx(k+1),CJ(i,j,k+1),DCJ(i,j,k+1), & - CJx(k+1),CJxx(k+1),DCJx(k+1),bDCB(i,j,k+1),Cnu(k+1),Cnux(k+1),Ck(k+1),CTheta) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta0,CTheta1) - - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - enddo -#if 0 - k = ex(3) - CTheta0 = -KK(i,j,k)*DCU(i,j,k)-(CU(i,j,k)*Cnu(k)+dconjg(CU(i,j,k))*DCJ(i,j,k))/2 & - +CJ(i,j,k)*(bDCU(i,j,k)-dconjg(bDCU(i,j,k)))/2 - W(i,j,k)*CJ(i,j,k)/2 - - RTheta(i,j,k) = dreal(CTheta0) - ITheta(i,j,k) = dimag(CTheta0) -#else -! closing step - k = ex(3)-1 - CTheta0 = dcmplx(RTheta(i,j,k),ITheta(i,j,k)) - xx = R(k)+dR/2 -! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 -! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR -! note our fxx(ex(3)) = (f(ex(3))-2.d0*f(ex(3)-1)+f(ex(3)-2))/dR - RHS = Theta_rhs(xx,Rmin,Hbeta(k),betax(k+1),HKK(i,j,k),KKx(i,j,k+1),HCU(k),CUx(k+1),DCUx(k+1),HbDCU(k),bDCUx(k+1), & - HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k+1),HCJ(k),HDCJ(k), & - CJx(k+1),CJxx(k+1),DCJx(k+1),HbDCB(k),HCnu(k),Cnux(k+1),HCk(k),dcmplx(0.d0,0.d0)) - RHS = RHS+CTheta0*(1.d0/dR-0.5d0/xx/(1.d0-xx)) - CTheta0 = RHS/(1.d0/dR+0.5d0/xx/(1.d0-xx)) - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) -#endif - -#endif - enddo - enddo - - gont = 0 - return - -end function NullEvol_Theta -!-------------------------------------------------------------------- -! check with fake_Theta_rhs -#elif 0 -! this R is indeed x -function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ - double complex :: CTheta0,CTheta,CTheta1,RHS - integer :: i,j,k,RK4 - integer,parameter :: ks=1 - double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx - double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB - real*8,dimension(ex(3)) :: Hbeta,betax,Hbetax,HW,Wx,HWx - double complex :: Theta_rhs,Theta_rhs_o - real*8 :: xx,dR - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & - sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CU = dcmplx(RU,IU) - CB = dcmplx(RB,IB) - CJ = dcmplx(RJ,IJ) - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) - CTheta0 = dcmplx(RTheta(i,j,ks),ITheta(i,j,ks)) - Cnu = dcmplx(RTheta(i,j,:),ITheta(i,j,:)) - call fake_Theta_rhs(ex(3),R,Ck,Cnu) - call cget_half_x(ex(3),Ck,HCk) - - do k=ks,ex(3)-1 - RK4 = 0 - RHS = Ck(k) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) - - RK4 = 1 - CTheta1 = HCk(k) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 2 - CTheta1 = HCk(k) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 3 - CTheta1 = Ck(k+1) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta0,CTheta1) - - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - enddo - - enddo - enddo - - gont = 0 - return - -end function NullEvol_Theta - -#else -! for eth_x, _x first, eth second -! this R is indeed x -function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ - double complex :: CTheta0,CTheta,CTheta1,RHS - integer :: i,j,k,RK4 - double complex,dimension(ex(1),ex(2),ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx - double complex,dimension(ex(1),ex(2),ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB - real*8,dimension(ex(1),ex(2),ex(3)) :: Hbeta,betax,Hbetax,HW,Wx,HWx - double complex :: Theta_rhs - real*8 :: xx,dR - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & - sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" - if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CU = dcmplx(RU,IU) - CB = dcmplx(RB,IB) - CJ = dcmplx(RJ,IJ) - Cnu = dcmplx(Rnu,Inu) - Ck = dcmplx(Rk,Ik) - - do j=1,ex(2) - do i=1,ex(1) - call cderivs_x(ex(3),R,Cnu(i,j,:),Cnux(i,j,:)) - call rderivs_x(ex(3),R,beta(i,j,:),betax(i,j,:)) - call rderivs_x(ex(3),R,W(i,j,:),Wx(i,j,:)) - call cderivs_x(ex(3),R,CU(i,j,:),CUx(i,j,:)) - call cderivs_x(ex(3),R,CJ(i,j,:),CJx(i,j,:)) - call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx(i,j,:)) - enddo - enddo - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CUx(:,:,k),DCUx(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CUx(:,:,k),bDCUx(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJx(:,:,k),DCJx(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) - call cget_half_x(ex(3),CB(i,j,:),HCB(i,j,:)) - call cget_half_x(ex(3),DCB(i,j,:),HDCB(i,j,:)) - call cget_half_x(ex(3),bDCB(i,j,:),HbDCB(i,j,:)) - call cget_half_x(ex(3),Cnu(i,j,:),HCnu(i,j,:)) - call cget_half_x(ex(3),Cnux(i,j,:),HCnux(i,j,:)) - call cget_half_x(ex(3),Ck(i,j,:),HCk(i,j,:)) - call rget_half_x(ex(3),beta(i,j,:),Hbeta(i,j,:)) - call rget_half_x(ex(3),betax(i,j,:),Hbetax(i,j,:)) - call rget_half_x(ex(3),Wx(i,j,:),HWx(i,j,:)) - call rget_half_x(ex(3),W(i,j,:),HW(i,j,:)) - call cget_half_x(ex(3),CU(i,j,:),HCU(i,j,:)) - call cget_half_x(ex(3),DCUx(i,j,:),HDCUx(i,j,:)) - call cget_half_x(ex(3),CUx(i,j,:),HCUx(i,j,:)) - call cget_half_x(ex(3),DCU(i,j,:),HDCU(i,j,:)) - call cget_half_x(ex(3),bDCUx(i,j,:),HbDCUx(i,j,:)) - call cget_half_x(ex(3),bDCU(i,j,:),HbDCU(i,j,:)) - call cget_half_x(ex(3),CJx(i,j,:),HCJx(i,j,:)) - call cget_half_x(ex(3),CJxx(i,j,:),HCJxx(i,j,:)) - call cget_half_x(ex(3),DCJx(i,j,:),HDCJx(i,j,:)) - enddo - enddo - - do j=1,ex(2) - do i=1,ex(1) - CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) - - do k=1,ex(3)-2 - RK4 = 0 - RHS = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(i,j,k),KK(i,j,k),KKx(i,j,k),CU(i,j,k),CUx(i,j,k),DCUx(i,j,k),bDCU(i,j,k),bDCUx(i,j,k), & - DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(i,j,k),CJ(i,j,k),DCJ(i,j,k), & - CJx(i,j,k),CJxx(i,j,k),DCJx(i,j,k),bDCB(i,j,k),Cnu(i,j,k),Cnux(i,j,k),Ck(i,j,k),CTheta0) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) - - RK4 = 1 - CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(i,j,k),Hbetax(i,j,k),HKK(i,j,k),HKKx(i,j,k), & - HCU(i,j,k),HCUx(i,j,k),HDCUx(i,j,k),HbDCU(i,j,k),HbDCUx(i,j,k), & - HDCU(i,j,k),HCB(i,j,k),HDCB(i,j,k),HW(i,j,k),HWx(i,j,k),HCJ(i,j,k),HDCJ(i,j,k), & - HCJx(i,j,k),HCJxx(i,j,k),HDCJx(i,j,k),HbDCB(i,j,k),HCnu(i,j,k),HCnux(i,j,k),HCk(i,j,k),CTheta) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 2 - CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(i,j,k),Hbetax(i,j,k),HKK(i,j,k),HKKx(i,j,k), & - HCU(i,j,k),HCUx(i,j,k),HDCUx(i,j,k),HbDCU(i,j,k),HbDCUx(i,j,k), & - HDCU(i,j,k),HCB(i,j,k),HDCB(i,j,k),HW(i,j,k),HWx(i,j,k),HCJ(i,j,k),HDCJ(i,j,k), & - HCJx(i,j,k),HCJxx(i,j,k),HDCJx(i,j,k),HbDCB(i,j,k),HCnu(i,j,k),HCnux(i,j,k),HCk(i,j,k),CTheta) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta,CTheta1) - - RK4 = 3 - CTheta1 = Theta_rhs(R(k+1),Rmin,beta(i,j,k+1),betax(i,j,k+1),KK(i,j,k+1), & - KKx(i,j,k+1),CU(i,j,k+1),CUx(i,j,k+1),DCUx(i,j,k+1),bDCU(i,j,k+1),bDCUx(i,j,k+1), & - DCU(i,j,k+1),CB(i,j,k+1),DCB(i,j,k+1),W(i,j,k+1),Wx(i,j,k+1),CJ(i,j,k+1),DCJ(i,j,k+1), & - CJx(i,j,k+1),CJxx(i,j,k+1),DCJx(i,j,k+1),bDCB(i,j,k+1),Cnu(i,j,k+1),Cnux(i,j,k+1),Ck(i,j,k+1),CTheta) - call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) - call cswap(CTheta0,CTheta1) - - RTheta(i,j,k+1) = dreal(CTheta0) - ITheta(i,j,k+1) = dimag(CTheta0) - enddo - - k = ex(3) - CTheta0 = -KK(i,j,k)*DCU(i,j,k)-(CU(i,j,k)*Cnu(i,j,k)+dconjg(CU(i,j,k))*DCJ(i,j,k))/2 & - +CJ(i,j,k)*(bDCU(i,j,k)-dconjg(bDCU(i,j,k)))/2 - W(i,j,k)*CJ(i,j,k)/2 - - RTheta(i,j,k) = dreal(CTheta0) - ITheta(i,j,k) = dimag(CTheta0) - - enddo - enddo - - gont = 0 - return - -end function NullEvol_Theta -#endif - -#elif (RKorAM == 1) -!------------------------------------------------------------------------------ -! this R is indeed x -function NullEvol_beta(ex,crho,sigma,R,RJ,IJ,beta,KKx,HKKx) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KKx,HKKx -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR,beta_rhs - - double complex, dimension(ex(3)):: CJ,CJx - real*8, dimension(ex(3)) :: rhs - integer :: i,j,k - - real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 - real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(beta)+sum(KKx)+sum(HKKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_beta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_beta: find NaN in IJ" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_beta: find NaN in beta" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_beta: find NaN in KKx" - if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_beta: find NaN in HKKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) -#if 0 - call cderivs_sw_x(ex(3),R,CJ,CJx) -#else - call cderivs_x(ex(3),R,CJ,CJx) -#endif - - do k=1,ex(3) - rhs(k) = beta_rhs(R(k),CJx(k),KKx(i,j,k)) - enddo - - k = 1 - beta(i,j,k+1) = beta(i,j,k) + (rhs(k+1)+rhs(k))*dR/2 - - k = 2 - beta(i,j,k+1) = beta(i,j,k) + (F5o12*rhs(k+1) + F2o3*rhs(k) - F1o12*rhs(k-1))*dR - - do k=3,ex(3)-1 - beta(i,j,k+1) = beta(i,j,k) + (F3o8*rhs(k+1) + F19o24*rhs(k) - F5o24*rhs(k-1) + F1o24*rhs(k-2))*dR - enddo - - enddo - enddo - - gont = 0 - - return - -end function NullEvol_beta -!------------------------------------------------------------------------------ -! this R is indeed x -function NullEvol_Q(ex,crho,sigma,R,RJ,IJ,Rk,Ik,Rnu,Inu,RB,IB,RQ,IQ,KK,Hkk,KKx,HKKx, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RQ,IQ - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KK,KKx,HKK,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rk,Ik,Rnu,Inu,RB,IB - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: xx,dR - - double complex,dimension(ex(3)) :: CQ,RHS - real*8, dimension(ex(3)) :: gunc - double complex,dimension(ex(3)) :: CJx,DCJx,Ck,Ckx,Cnu,Cnux,CB,CBx - double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,DCJ - integer :: i,j,k - double complex :: ZEO,Q_rhs - - real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 - real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ) & - +sum(RK)+sum(IK)+sum(Rnu)+sum(Inu)+sum(RB)+sum(IB) & - +sum(KK)+sum(KKx) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Q: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Q: find NaN in IJ" - if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_Q: find NaN in RQ" - if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_Q: find NaN in IQ" - if(sum(RK).ne.sum(RK))write(*,*)"NullEvol_Q: find NaN in RK" - if(sum(IK).ne.sum(IK))write(*,*)"NullEvol_Q: find NaN in IK" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Q: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Q: find NaN in Inu" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Q: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Q: find NaN in IB" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Q: find NaN in KK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Q: find NaN in KKx" - gont = 1 - return - endif - - dR = R(2) - R(1) - ZEO = dcmplx(0.d0,0.d0) - - CJ = dcmplx(RJ,IJ) - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - do j=1,ex(2) - do i=1,ex(1) - - CQ(1) = dcmplx(RQ(i,j,1),IQ(i,j,1)) - Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) - Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) - CB = dcmplx(RB(i,j,:),IB(i,j,:)) -#if 0 - call cderivs_sw_x(ex(3),R,CJ(i,j,:),CJx) - call cderivs_sw_x(ex(3),R,DCJ(i,j,:),DCJx) - call cderivs_sw_x(ex(3),R,Ck,Ckx) - call cderivs_sw_x(ex(3),R,Cnu,Cnux) - call cderivs_sw_x(ex(3),R,CB,CBx) -#else - call cderivs_x(ex(3),R,CJ(i,j,:),CJx) - call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) - call cderivs_x(ex(3),R,Ck,Ckx) - call cderivs_x(ex(3),R,Cnu,Cnux) - call cderivs_x(ex(3),R,CB,CBx) -#endif - - do k = 1,ex(3) - RHS(k) = Q_rhs(R(k),CJ(i,j,k),CJx(k),DCJx(k),KK(i,j,k),Ck(k),Ckx(k),Cnux(k),KKx(i,j,k),CBx(k),Cnu(k),DCJ(i,j,k),CB(k),ZEO) - gunc(k) = -2/R(k)/(1-R(k)) - enddo - - k = 1 - CQ(k+1) = CQ(k) + (RHS(k+1)+RHS(k)+CQ(k)*gunc(k))*dR/2 - CQ(k+1) = CQ(k+1)/(1-0.5*dR*gunc(k+1)) - - k = 2 - CQ(k+1) = CQ(k) + (F5o12*RHS(k+1) + F2o3*(RHS(k)+CQ(k)*gunc(k)) - F1o12*(RHS(k-1)+CQ(k-1)*gunc(k-1)))*dR - CQ(k+1) = CQ(k+1)/(1-F5o12*dR*gunc(k+1)) - - do k=3,ex(3)-2 - CQ(k+1) = CQ(k) + (F3o8*RHS(k+1) + F19o24*(RHS(k)+CQ(k)*gunc(k)) - F5o24*(RHS(k-1)+CQ(k-1)*gunc(k-1)) & - + F1o24*(RHS(k-2)+CQ(k-2)*gunc(k-2)))*dR - CQ(k+1) = CQ(k+1)/(1-F3o8*dR*gunc(k+1)) - enddo - - k = ex(3) - CQ(k) = -2*CB(k) - - RQ(i,j,:) = dreal(CQ) - IQ(i,j,:) = dimag(CQ) - - enddo - enddo - - gont = 0 - - return - -end function NullEvol_Q -!-------------------------------------------------------------------- -! this R is indeed x -function NullEvol_U(ex,crho,sigma,R,RJ,IJ,RQ,IQ,KK,HKK,beta,RU,IU, & - Rmin) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RQ,IQ,beta,KK,HKK - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU - real*8,intent(in) :: Rmin -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - double complex,dimension(ex(3)) :: CU0,RHS - integer :: i,j,k - double complex :: U_rhs - double complex,dimension(ex(3)) :: CJ,CQ - - real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 - real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ)+sum(beta)+sum(RU)+sum(IU)+sum(KK) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_U: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_U: find NaN in IJ" - if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_U: find NaN in RQ" - if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_U: find NaN in IQ" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_U: find NaN in beta" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_U: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_U: find NaN in IU" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_U: find NaN in KK" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - CU0(1) = dcmplx(RU(i,j,1),IU(i,j,1)) - CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) - CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) - - do k = 1,ex(3) - RHS(k) = U_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),CQ(k),CJ(k)) - enddo - - k = 1 - CU0(k+1) = CU0(k) + (RHS(k+1)+RHS(k))*dR/2 - - k = 2 - CU0(k+1) = CU0(k) + (F5o12*RHS(k+1) + F2o3*RHS(k) - F1o12*RHS(k-1))*dR - - do k=3,ex(3)-1 - CU0(k+1) = CU0(k) + (F3o8*RHS(k+1) + F19o24*RHS(k) - F5o24*RHS(k-1) & - + F1o24*RHS(k-2))*dR - enddo - - RU(i,j,:) = dreal(CU0) - IU(i,j,:) = dimag(CU0) - - enddo - enddo - - gont = 0 - return - -end function NullEvol_U -!---------------------------------------------------------------------------------------- -! this R is indeed x -function NullEvol_W(ex,crho,sigma,R,RJ,IJ,RB,IB,Rnu,Inu,Rk,Ik, & - RU,IU,RQ,IQ,W,beta,KK,HKK,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: W - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,RB,IB - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RU,IU,RQ,IQ,beta,KK,HKK - real*8,intent(in ) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - double complex, dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU - double complex, dimension(ex(1),ex(2),ex(3)) :: CB,DCB,bDCB,CJ,DCJ,Cnu,bDCnu,Ck,bDCk - double complex, dimension(ex(3)) :: bDCUx,CQ - integer :: i,j,k - real*8, dimension(ex(3)) :: rhs,gunc - real*8 :: zeo,W_rhs - - real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 - real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(beta)+sum(RB)+sum(IB)+sum(Rnu)+sum(Inu) & - +sum(Rk)+sum(Ik)+sum(W)+sum(RU)+sum(IU)+sum(RQ)+sum(IQ)& - +sum(KK) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_W: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_W: find NaN in IJ" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_W: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_W: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_W: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_W: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_W: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_W: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_W: find NaN in Ik" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_W: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_W: find NaN in IU" - if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_W: find NaN in RQ" - if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_W: find NaN in IQ" - if(sum(W).ne.sum(W))write(*,*)"NullEvol_W: find NaN in W" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_W: find NaN in KK" - gont = 1 - return - endif - - dR = R(2) - R(1) - zeo = 0.d0 - - CB = dcmplx(RB,IB) - CU = dcmplx(RU,IU) - Ck = dcmplx(Rk,Ik) - Cnu = dcmplx(Rnu,Inu) - CJ = dcmplx(RJ,IJ) - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,Ck(:,:,k),bDCk(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,Cnu(:,:,k),bDCnu(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) -#if 0 - call cderivs_sw_x(ex(3),R,bDCU,bDCUx) -#else - call cderivs_x(ex(3),R,bDCU,bDCUx) -#endif - - CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) - - do k = 1,ex(3) - rhs(k) = W_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),DCB(i,j,k),CB(i,j,k),CJ(i,j,k),Cnu(i,j,k),Ck(i,j,k),zeo, & - CQ(k),bDCk(i,j,k),bDCnu(i,j,k),bDCB(i,j,k),bDCU(i,j,k),bDCUx(k),DCJ(i,j,k)) - gunc(k) = -2/R(k)/(1-R(k)) - enddo - - k = 1 - W(i,j,k+1) = W(i,j,k) + (rhs(k+1)+rhs(k)+W(i,j,k)*gunc(k))*dR/2 - W(i,j,k+1) = W(i,j,k+1)/(1-0.5*dR*gunc(k+1)) - - k = 2 - W(i,j,k+1) = W(i,j,k) + (F5o12*rhs(k+1) + F2o3*(rhs(k)+W(i,j,k)*gunc(k)) - F1o12*(rhs(k-1)+W(i,j,k-1)*gunc(k-1)))*dR - W(i,j,k+1) = W(i,j,k+1)/(1-F5o12*dR*gunc(k+1)) - - do k=3,ex(3)-2 - W(i,j,k+1) = W(i,j,k) + (F3o8*rhs(k+1) + F19o24*(rhs(k)+W(i,j,k)*gunc(k)) - F5o24*(rhs(k-1)+W(i,j,k-1)*gunc(k-1)) & - + F1o24*(rhs(k-2)+W(i,j,k-2)*gunc(k-2)))*dR - W(i,j,k+1) = W(i,j,k+1)/(1-F3o8*dR*gunc(k+1)) - enddo - - k = ex(3) - W(i,j,k) = dreal(bDCU(i,j,k)) - - enddo - enddo - - gont = 0 - return - -end function NullEvol_W -!-------------------------------------------------------------------- -! this R is indeed x -function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,KKx,HKK,HKKx - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ - double complex,dimension(ex(3)) :: CTheta0,RHS - integer :: i,j,k,RK4 - double complex,dimension(ex(3)) :: Cnu,Ck,CUx,DCUx,bDCUx - double complex,dimension(ex(3)) :: Cnux,CJx,CJxx,DCJx - real*8,dimension(ex(3)) :: betax,Wx,gunc - double complex :: Theta_rhs,ZEO - real*8 :: dR - - real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 - real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & - sum(KK)+sum(KKx)+sum(W) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" - if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" - if(sum(W).ne.sum(W))write(*,*)"NullEvol_Theta: find NaN in W" - gont = 1 - return - endif - - dR = R(2) - R(1) - ZEO = dcmplx(0.d0,0.d0) - - CU = dcmplx(RU,IU) - CB = dcmplx(RB,IB) - CJ = dcmplx(RJ,IJ) - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=1,ex(2) - do i=1,ex(1) - CTheta0(1) = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) - Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) - Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) -#if 0 - call cderivs_sw_x(ex(3),R,Cnu,Cnux) - call rderivs_sw_x(ex(3),R,beta(i,j,:),betax) - call rderivs_sw_x(ex(3),R,W,Wx) - call cderivs_sw_x(ex(3),R,DCU(i,j,:),DCUx) - call cderivs_sw_x(ex(3),R,CU(i,j,:),CUx) - call cderivs_sw_x(ex(3),R,bDCU(i,j,:),bDCUx) - call cderivs_sw_x(ex(3),R,CJ(i,j,:),CJx) - call cdderivs_sw_x(ex(3),R,CJ(i,j,:),CJxx) - call cderivs_sw_x(ex(3),R,DCJ(i,j,:),DCJx) -#else - call cderivs_x(ex(3),R,Cnu,Cnux) - call rderivs_x(ex(3),R,beta(i,j,:),betax) - call rderivs_x(ex(3),R,W,Wx) - call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) - call cderivs_x(ex(3),R,CU(i,j,:),CUx) - call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) - call cderivs_x(ex(3),R,CJ(i,j,:),CJx) - call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) - call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) -#endif - do k = 1,ex(3) - rhs(k) = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(k),KK(i,j,k),KKx(i,j,k),CU(i,j,k),CUx(k),DCUx(k),bDCU(i,j,k),bDCUx(k), & - DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(k),CJ(i,j,k),DCJ(i,j,k), & - CJx(k),CJxx(k),DCJx(k),bDCB(i,j,k),Cnu(k),Cnux(k),Ck(k),ZEO) - gunc(k) = -1/R(k)/(1-R(k)) - enddo - - k = 1 - CTheta0(k+1) = CTheta0(k) + (RHS(k+1)+RHS(k)+CTheta0(k)*gunc(k))*dR/2 - CTheta0(k+1) = CTheta0(k+1)/(1-0.5*dR*gunc(k+1)) - - k = 2 - CTheta0(k+1) = CTheta0(k) + (F5o12*RHS(k+1) + F2o3*(RHS(k)+CTheta0(k)*gunc(k)) - F1o12*(RHS(k-1)+CTheta0(k-1)*gunc(k-1)))*dR - CTheta0(k+1) = CTheta0(k+1)/(1-F5o12*dR*gunc(k+1)) - - do k=3,ex(3)-2 - CTheta0(k+1) = CTheta0(k) + (F3o8*RHS(k+1) + F19o24*(RHS(k)+CTheta0(k)*gunc(k)) - F5o24*(RHS(k-1)+CTheta0(k-1)*gunc(k-1)) & - + F1o24*(RHS(k-2)+CTheta0(k-2)*gunc(k-2)))*dR - CTheta0(k+1) = CTheta0(k+1)/(1-F3o8*dR*gunc(k+1)) - enddo - - k = ex(3) - CTheta0(k) = -KK(i,j,k)*DCU(i,j,k)-(CU(i,j,k)*Cnu(k)+dconjg(CU(i,j,k))*DCJ(i,j,k))/2 & - +CJ(i,j,k)*(bDCU(i,j,k)-dconjg(bDCU(i,j,k)))/2 - W(i,j,k)*CJ(i,j,k)/2 - - RTheta(i,j,:) = dreal(CTheta0) - ITheta(i,j,:) = dimag(CTheta0) - enddo - enddo - - gont = 0 - return - -end function NullEvol_Theta - -#else -#error "not recognized RKorAM" -#endif - -!===================================================================================================================================== -! basic tool routines - subroutine rswap(r1,r2) - - implicit none - -!~~~~~~% Input parameters: - - real*8,intent(inout) :: r1,r2 - - real*8 :: r - - r = r1 - r1= r2 - r2= r - - return - - end subroutine rswap -!---- - subroutine cswap(r1,r2) - - implicit none - -!~~~~~~% Input parameters: - - double complex,intent(inout) :: r1,r2 - - double complex :: r - - r = r1 - r1= r2 - r2= r - - return - - end subroutine cswap - -! center type finite difference -!==================================================================================== -!---- - subroutine rderivs_x(lx,X,f,fx) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx - real*8,intent(in),dimension(lx) :: X - real*8,intent(in),dimension(lx) :: f - real*8,intent(out),dimension(lx) :: fx - - real*8 :: dX - - dX = X(2)-X(1) - -#ifdef OLD - fx(1:lx-1) = (f(2:lx)-f(1:lx-1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#else - -#if (ghost_width == 2) - fx(2:lx-1) = (f(3:lx)-f(1:lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#elif (ghost_width == 3) - fx(3:lx-2) = (f(1:lx-4)-8.d0*f(2:lx-3)+8.d0*f(4:lx-1)-f(5:lx))/1.2d1/dX - fx(2) = (f(3)-f(1))/2.d0/dX - fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -! fx(1) =-(2.5d1*f(1)-4.8d1*f(2)+3.6d1*f(3)-1.6d1*f(4)+3.d0*f(5))/1.2d1/dX -! fx(2) =-(3.d0*f(1)+1.d1*f(2)-1.8d1*f(3)+6.d0*f(4)-f(5))/1.2d1/dX -#elif (ghost_width == 4) - fx(4:lx-3) = (-f(1:lx-6)+9.d0*f(2:lx-5)-4.5d1*f(3:lx-4)+4.5d1*f(5:lx-2)-9.d0*f(6:lx-1)+f(7:lx))/6.d1/dX - fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX - fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX - fx(2) = (f(3)-f(1))/2.d0/dX - fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#elif (ghost_width == 5) - fx(5:lx-4) = (3.d0*f(1:lx-8)-3.2d1*f(2:lx-7)+1.68d2*f(3:lx-6)-6.72d2*f(4:lx-5)+ & - 6.72d2*f(6:lx-3)-1.68d2*f(7:lx-2)+3.2d1*f(8:lx-1)-3.d0*f(9:lx))/8.4d2/dX - fx(4) = (-f(1)+9.d0*f(2)-4.5d1*f(3)+4.5d1*f(5)-9.d0*f(6)+f(7))/6.d1/dX - fx(lx-3) = (-f(lx-6)+9.d0*f(lx-5)-4.5d1*f(lx-4)+4.5d1*f(lx-2)-9.d0*f(lx-1)+f(lx))/6.d1/dX - fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX - fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX - fx(2) = (f(3)-f(1))/2.d0/dX - fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#endif - -#endif - return - - end subroutine rderivs_x -!---- - subroutine rderivs_x_point(lx,X,f,fx,k) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx,k - real*8,intent(in),dimension(lx) :: X - real*8,intent(in),dimension(lx) :: f - real*8,intent(out) :: fx - - real*8 :: dX - - dX = X(2)-X(1) - -#ifdef OLD - if(k .eq. lx)then - fx = (f(lx)-f(lx-1))/dX - else - fx = (f(k+1)-f(k))/dX - endif -#else - -#if (ghost_width == 2) - if(k .gt. 1 .and. k .lt. lx) then - fx = (f(k+1)-f(k-1))/2.d0/dX - elseif(k.eq.1) then - fx = (f(2)-f(1))/dX - elseif(k.eq.lx) then - fx = (f(lx)-f(lx-1))/dX - endif -#elif (ghost_width == 3) - if(k .gt. 2 .and. k .lt. lx-1) then - fx = (f(k-2)-8.d0*f(k-1)+8.d0*f(k+1)-f(k+2))/1.2d1/dX - elseif(k.eq.1) then - fx = (f(2)-f(1))/dX - elseif(k.eq.lx) then - fx = (f(lx)-f(lx-1))/dX - elseif(k.eq.2) then - fx = (f(3)-f(1))/2.d0/dX - elseif(k.eq.lx-1) then - fx = (f(lx)-f(lx-2))/2.d0/dX - endif -#elif (ghost_width == 4) - if(k .gt. 3 .and. k .lt. lx-2) then - fx = (-f(k-3)+9.d0*f(k-2)-4.5d1*f(k-1)+4.5d1*f(k+1)-9.d0*f(k+2)+f(k+3))/6.d1/dX - elseif(k.eq.1) then - fx = (f(2)-f(1))/dX - elseif(k.eq.lx) then - fx = (f(lx)-f(lx-1))/dX - elseif(k.eq.2) then - fx = (f(3)-f(1))/2.d0/dX - elseif(k.eq.lx-1) then - fx = (f(lx)-f(lx-2))/2.d0/dX - elseif(k.eq.3) then - fx = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX - elseif(k.eq.lx-2) then - fx = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX - endif -#elif (ghost_width == 5) - if(k .gt. 4 .and. k .lt. lx-3) then - fx = (3.d0*f(k-4)-3.2d1*f(k-3)+1.68d2*f(k-2)-6.72d2*f(k-1)+ & - 6.72d2*f(k+1)-1.68d2*f(k+2)+3.2d1*f(k+3)-3.d0*f(k+4))/8.4d2/dX - elseif(k.eq.1) then - fx = (f(2)-f(1))/dX - elseif(k.eq.lx) then - fx = (f(lx)-f(lx-1))/dX - elseif(k.eq.2) then - fx = (f(3)-f(1))/2.d0/dX - elseif(k.eq.lx-1) then - fx = (f(lx)-f(lx-2))/2.d0/dX - elseif(k.eq.3) then - fx = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX - elseif(k.eq.lx-2) then - fx = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX - elseif(k.eq.4) then - fx = (-f(1)+9.d0*f(2)-4.5d1*f(3)+4.5d1*f(5)-9.d0*f(6)+f(7))/6.d1/dX - elseif(k.eq.lx-3) then - fx = (-f(lx-6)+9.d0*f(lx-5)-4.5d1*f(lx-4)+4.5d1*f(lx-2)-9.d0*f(lx-1)+f(lx))/6.d1/dX - endif -#endif - -#endif - return - - end subroutine rderivs_x_point -!---- - subroutine cderivs_x(lx,X,f,fx) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx - real*8,intent(in),dimension(lx) :: X - double complex,intent(in),dimension(lx) :: f - double complex,intent(out),dimension(lx) :: fx - - real*8 :: dX - - dX = X(2)-X(1) - -#ifdef OLD - fx(1:lx-1) = (f(2:lx)-f(1:lx-1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#else - -#if (ghost_width == 2) - fx(2:lx-1) = (f(3:lx)-f(1:lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#elif (ghost_width == 3) - fx(3:lx-2) = (f(1:lx-4)-8.d0*f(2:lx-3)+8.d0*f(4:lx-1)-f(5:lx))/1.2d1/dX - fx(2) = (f(3)-f(1))/2.d0/dX - fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -! fx(1) =-(2.5d1*f(1)-4.8d1*f(2)+3.6d1*f(3)-1.6d1*f(4)+3.d0*f(5))/1.2d1/dX -! fx(2) =-(3.d0*f(1)+1.d1*f(2)-1.8d1*f(3)+6.d0*f(4)-f(5))/1.2d1/dX -#elif (ghost_width == 4) - fx(4:lx-3) = (-f(1:lx-6)+9.d0*f(2:lx-5)-4.5d1*f(3:lx-4)+4.5d1*f(5:lx-2)-9.d0*f(6:lx-1)+f(7:lx))/6.d1/dX - fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX - fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX - fx(2) = (f(3)-f(1))/2.d0/dX - fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#elif (ghost_width == 5) - fx(5:lx-4) = (3.d0*f(1:lx-8)-3.2d1*f(2:lx-7)+1.68d2*f(3:lx-6)-6.72d2*f(4:lx-5)+ & - 6.72d2*f(6:lx-3)-1.68d2*f(7:lx-2)+3.2d1*f(8:lx-1)-3.d0*f(9:lx))/8.4d2/dX - fx(4) = (-f(1)+9.d0*f(2)-4.5d1*f(3)+4.5d1*f(5)-9.d0*f(6)+f(7))/6.d1/dX - fx(lx-3) = (-f(lx-6)+9.d0*f(lx-5)-4.5d1*f(lx-4)+4.5d1*f(lx-2)-9.d0*f(lx-1)+f(lx))/6.d1/dX - fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX - fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX - fx(2) = (f(3)-f(1))/2.d0/dX - fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX - fx(1) = (f(2)-f(1))/dX - fx(lx) = (f(lx)-f(lx-1))/dX -#endif - -#endif - - return - - end subroutine cderivs_x -!---- - subroutine cdderivs_x(lx,X,f,fxx) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx - real*8,intent(in),dimension(lx) :: X - double complex,intent(in),dimension(lx) :: f - double complex,intent(out),dimension(lx) :: fxx - - real*8 :: dX - - dX = X(2)-X(1) - dX = dX*dX - -#ifdef OLD - fxx(1:lx-2) = (f(3:lx)-2.0*f(2:lx-1)+f(1:lx-2))/dX - fxx(lx-1) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX - fxx(lx ) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX -#else - -#if (ghost_width == 2) - fxx(2:lx-1) = (f(3:lx)-2.d0*f(2:lx-1)+f(1:lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#elif (ghost_width == 3) - fxx(3:lx-2) = (-f(1:lx-4)+1.6d1*f(2:lx-3)-3.d1*f(3:lx-2)+1.6d1*f(4:lx-1)-f(5:lx))/1.2d1/dX - fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#elif (ghost_width == 4) - fxx(4:lx-3) = (2.d0*f(1:lx-6)-2.7d1*f(2:lx-5)+2.7d2*f(3:lx-4)-4.9d2*f(4:lx-3) & - +2.7d2*f(5:lx-2)-2.7d1*f(6:lx-1)+2.d0*f(7:lx))/1.8d2/dX - fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX - fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX - fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#elif (ghost_width == 5) - fxx(5:lx-4) = (-9.d0*f(1:lx-8)+1.28d2*f(2:lx-7)-1.008d3*f(3:lx-6)+8.064d3*f(4:lx-5)-1.435d4*f(5:lx-4) & - +8.064d3*f(6:lx-3)-1.008d3*f(7:lx-2)+1.28d2*f(8:lx-1)-9.d0*f(9:lx))/5.04d3/dX - fxx(4) = (2.d0*f(1)-2.7d1*f(2)+2.7d2*f(3)-4.9d2*f(4) & - +2.7d2*f(5)-2.7d1*f(6)+2.d0*f(7))/1.8d2/dX - fxx(lx-3) = (2.d0*f(lx-6)-2.7d1*f(lx-5)+2.7d2*f(lx-4)-4.9d2*f(lx-3) & - +2.7d2*f(lx-2)-2.7d1*f(lx-1)+2.d0*f(lx))/1.8d2/dX - fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX - fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX - fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#endif - -#endif - - return - - end subroutine cdderivs_x -!---- - subroutine rdderivs_x(lx,X,f,fxx) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx - real*8,intent(in),dimension(lx) :: X - real*8,intent(in),dimension(lx) :: f - real*8,intent(out),dimension(lx) :: fxx - - real*8 :: dX - - dX = X(2)-X(1) - dX = dX*dX - -#ifdef OLD - fxx(1:lx-2) = (f(3:lx)-2.0*f(2:lx-1)+f(1:lx-2))/dX - fxx(lx-1) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX - fxx(lx ) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX -#else - -#if (ghost_width == 2) - fxx(2:lx-1) = (f(3:lx)-2.d0*f(2:lx-1)+f(1:lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#elif (ghost_width == 3) - fxx(3:lx-2) = (-f(1:lx-4)+1.6d1*f(2:lx-3)-3.d1*f(3:lx-2)+1.6d1*f(4:lx-1)-f(5:lx))/1.2d1/dX - fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#elif (ghost_width == 4) - fxx(4:lx-3) = (2.d0*f(1:lx-6)-2.7d1*f(2:lx-5)+2.7d2*f(3:lx-4)-4.9d2*f(4:lx-3) & - +2.7d2*f(5:lx-2)-2.7d1*f(6:lx-1)+2.d0*f(7:lx))/1.8d2/dX - fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX - fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX - fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#elif (ghost_width == 5) - fxx(5:lx-4) = (-9.d0*f(1:lx-8)+1.28d2*f(2:lx-7)-1.008d3*f(3:lx-6)+8.064d3*f(4:lx-5)-1.435d4*f(5:lx-4) & - +8.064d3*f(6:lx-3)-1.008d3*f(7:lx-2)+1.28d2*f(8:lx-1)-9.d0*f(9:lx))/5.04d3/dX - fxx(4) = (2.d0*f(1)-2.7d1*f(2)+2.7d2*f(3)-4.9d2*f(4) & - +2.7d2*f(5)-2.7d1*f(6)+2.d0*f(7))/1.8d2/dX - fxx(lx-3) = (2.d0*f(lx-6)-2.7d1*f(lx-5)+2.7d2*f(lx-4)-4.9d2*f(lx-3) & - +2.7d2*f(lx-2)-2.7d1*f(lx-1)+2.d0*f(lx))/1.8d2/dX - fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX - fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX - fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX - fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX -#endif - -#endif - - return - - end subroutine rdderivs_x -!---- - subroutine rdderivs_x_point(lx,X,f,fxx,k) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx,k - real*8,intent(in),dimension(lx) :: X - real*8,intent(in),dimension(lx) :: f - real*8,intent(out) :: fxx - - real*8 :: dX - - dX = X(2)-X(1) - dX = dX*dX - -#ifdef OLD - if(k.lt.lx-1) then - fxx = (f(k+2)-2.0*f(k+1)+f(k))/dX - elseif(k.eq.lx-1) then - fxx = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX - elseif(k.eq.lx) then - fxx = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX - endif -#else - -#if (ghost_width == 2) - if(k.gt.1 .and. k.lt.lx) then - fxx = (f(k+1)-2.d0*f(k)+f(k-1))/dX - elseif(k.eq.1) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - endif -#elif (ghost_width == 3) - if(k.gt.2 .and. k.lt.lx-1) then - fxx = (-f(k-2)+1.6d1*f(k-1)-3.d1*f(k)+1.6d1*f(k+1)-f(k+2))/1.2d1/dX - elseif(k.eq.1) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - elseif(k.eq.2) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx-1) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - endif -#elif (ghost_width == 4) - if(k.gt.3 .and. k.lt.lx-2)then - fxx = (2.d0*f(k-3)-2.7d1*f(k-2)+2.7d2*f(k-1)-4.9d2*f(k) & - +2.7d2*f(k+1)-2.7d1*f(k+2)+2.d0*f(k+3))/1.8d2/dX - elseif(k.eq.1) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - elseif(k.eq.2) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx-1) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - elseif(k.eq.3) then - fxx = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX - elseif(k.eq.lx-2) then - fxx = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX - endif -#elif (ghost_width == 5) - if(k.gt.4 .and. k.lt.lx-3) then - fxx = (-9.d0*f(k-4)+1.28d2*f(k-3)-1.008d3*f(k-2)+8.064d3*f(k-1)-1.435d4*f(k) & - +8.064d3*f(k+1)-1.008d3*f(k+2)+1.28d2*f(k+3)-9.d0*f(k+4))/5.04d3/dX - elseif(k.eq.1) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - elseif(k.eq.2) then - fxx = (f(3)-2.d0*f(2)+f(1))/dX - elseif(k.eq.lx-1) then - fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX - elseif(k.eq.3) then - fxx = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX - elseif(k.eq.lx-2) then - fxx = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX - elseif(k.eq.4) then - fxx = (2.d0*f(1)-2.7d1*f(2)+2.7d2*f(3)-4.9d2*f(4) & - +2.7d2*f(5)-2.7d1*f(6)+2.d0*f(7))/1.8d2/dX - elseif(k.eq.lx-3) then - fxx = (2.d0*f(lx-6)-2.7d1*f(lx-5)+2.7d2*f(lx-4)-4.9d2*f(lx-3) & - +2.7d2*f(lx-2)-2.7d1*f(lx-1)+2.d0*f(lx))/1.8d2/dX - endif -#endif - -#endif - - return - - end subroutine rdderivs_x_point -!---- - subroutine rdderivs_xy_point(lx,ly,X,Y,f,fxy,i,j) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: lx,ly,i,j - real*8,intent(in),dimension(lx) :: X - real*8,intent(in),dimension(ly) :: Y - real*8,intent(in),dimension(lx,ly) :: f - real*8,intent(out) :: fxy - - real*8 :: dX,dY - - dX = X(2)-X(1) - dY = Y(2)-Y(1) -!! we only consider inner points -#if (ghost_width == 2) - if(i>1 .and. j>1.and.i2 .and. j>2.and.i3 .and. j>3.and.i4 .and. j>4.and.ieps) write(*,*) f - -return - -end subroutine check_daxiao -subroutine check_factor(T,crho,sigma,R,sst,Rmin) -implicit none -integer,intent(in) :: sst -real*8,intent(in) :: T,crho,sigma,R,Rmin - -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff - - hgr = R*Rmin/(1.d0-R) - tgrho = dtan(crho) - tgsigma = dtan(sigma) - tc = dsqrt((1.d0-dsin(crho)*dsin(sigma))/2.d0) - ts = dsqrt((1.d0+dsin(crho)*dsin(sigma))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - write(*,*) dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,0,gt,gp)*swtf**2 - - return - - end subroutine check_factor - -subroutine getdxs(T,crho,sigma,R,betax,KKx,CUx,DCUx,bDCUx,Wx,CJx,CJxx,DCJx,Cnux,CThetax,sst,Rmin) -implicit none -integer,intent(in) :: sst -real*8,intent(in) :: T,crho,sigma,R,Rmin -real*8,intent(out) :: betax,KKx,Wx -double complex,intent(out) :: CUx,DCUx,bDCUx,CJx,CJxx,DCJx,Cnux,CThetax - -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff -double complex :: beta0,C1,C2 -integer :: nu,m - - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - hgr = R*Rmin/(1.d0-R) - tgrho = dtan(crho) - tgsigma = dtan(sigma) - tc = dsqrt((1.d0-dsin(crho)*dsin(sigma))/2.d0) - ts = dsqrt((1.d0+dsin(crho)*dsin(sigma))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - betax = 0.d0 - - Jr = -(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr**2& - +2.d0*nu*nu*C2/hgr**3-3.d0*II*nu*C2/hgr**4-2.d0*C2/hgr**5 - Wx = dreal(Yslm(0,2,m,gt,gp))*dreal(Jr*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin -! Wx = dreal(Jr*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin - KKx = 0.d0 - - Jr = -2.d0*beta0/hgr/hgr-C1/hgr**3-II*nu*C2/hgr**4-C2/hgr**5 - rf = dreal(Jr*cdexp(II*nu*T)) - CUx = dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*rf*(Rmin+hgr)**2/Rmin -! CUx = rf*(Rmin+hgr)**2/Rmin - DCUx = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**2/Rmin -! DCUx = rf*(Rmin+hgr)**2/Rmin - bDCUx =-dble(2*(2+1))*Yslm(0,2,m,gt,gp)*rf*(Rmin+hgr)**2/Rmin -! bDCUx = rf*(Rmin+hgr)**2/Rmin - - Jr = -C1/4.d0/hgr**2+C2/4.d0/hgr**4 - rf = dreal(Jr*cdexp(II*nu*T)) - CJx = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**2/Rmin -! CJx = rf*(Rmin+hgr)**2/Rmin - Cnux =-dble((2-1)*(2+2))*dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*rf*(Rmin+hgr)**2/Rmin -! Cnux = rf*(Rmin+hgr)**2/Rmin - DCJx = 0.d0 - rf = dreal(Jr*II*nu*cdexp(II*nu*T)) - CThetax = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**2/Rmin -! CThetax = rf*(Rmin+hgr)**2/Rmin - Jr = C1/2.d0/hgr**3-C2/hgr**5 - rf = dreal(Jr*cdexp(II*nu*T)) - CJxx = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**4/Rmin**2+2.d0*(Rmin+hgr)/Rmin*CJx -! CJxx = rf*(Rmin+hgr)**4/Rmin**2+2.d0*(Rmin+hgr)/Rmin*CJx - -#if 0 - DCUx = DCUx*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 - CJx = CJx*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 - CJxx = CJxx*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 - CThetax = CThetax*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 -#endif - return - - end subroutine getdxs - -subroutine getndxs(T,crho,sigma,R,beta,KK,CU,bDCU,DCU,CB,DCB,W,CJ,DCJ,bDCB,Cnu,Ck,CTheta,sst,Rmin) -implicit none -integer,intent(in) :: sst -real*8,intent(in) :: T,crho,sigma,R,Rmin -real*8,intent(out) :: beta,KK,W -double complex,intent(out) :: CU,bDCU,DCU,CB,DCB,CJ,DCJ,bDCB,Cnu,Ck,CTheta - -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: Yslm,II,Jr,swtf,ff -double complex :: beta0,C1,C2 -integer :: nu,m - - call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - hgr = R*Rmin/(1.d0-R) - tgrho = dtan(crho) - tgsigma = dtan(sigma) - tc = dsqrt((1.d0-dsin(crho)*dsin(sigma))/2.d0) - ts = dsqrt((1.d0+dsin(crho)*dsin(sigma))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - beta = dreal(Yslm(0,2,m,gt,gp))*dreal(beta0*cdexp(II*nu*T)) -! beta = dreal(beta0*cdexp(II*nu*T)) - CB = dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*dreal(beta0*cdexp(II*nu*T)) -! CB = dreal(beta0*cdexp(II*nu*T)) - DCB = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*dreal(beta0*cdexp(II*nu*T)) -! DCB = dreal(beta0*cdexp(II*nu*T)) - bDCB =-dble(2*(2+1))*Yslm(0,2,m,gt,gp)*dreal(beta0*cdexp(II*nu*T)) -! bDCB = dreal(beta0*cdexp(II*nu*T)) - - Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr& - -nu*nu*C2/hgr/hgr+II*nu*C2/hgr**3+C2/2.d0/hgr**4 - W = dreal(Yslm(0,2,m,gt,gp))*dreal(Jr*cdexp(II*nu*T)) -! W = dreal(Jr*cdexp(II*nu*T)) - - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/hgr-C2/1.2d1/hgr**3 - rf = dreal(Jr*cdexp(II*nu*T)) - CJ = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf -! CJ = rf - DCJ = 0.d0 - Cnu =-dsqrt(dble((2+2)*(2-2+1)*(2-1)*2*(2+1)*(2+2)))*Yslm(1,2,m,gt,gp)*swtf*rf -! Cnu = rf - KK = dsqrt(1.d0+cdabs(CJ)**2) - Ck = 0.d0 - rf = dreal(Jr*II*nu*cdexp(II*nu*T)) - CTheta = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf -! CTheta = rf - - Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0/hgr& - +C1/2.d0/hgr/hgr+II*nu*C2/3.d0/hgr**3+C2/4.d0/hgr**4 - rf = dreal(Jr*cdexp(II*nu*T)) - CU = dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*rf -! CU = rf - DCU = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf -! DCU = rf - bDCU =-dble(2*(2+1))*Yslm(0,2,m,gt,gp)*rf -! bDCU = rf - -#if 0 - DCU = DCU*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 - DCB = DCB*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 - CTheta = CTheta*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 -#endif - return - - end subroutine getndxs -!-------------------------------------------------------------------- -! this R is indeed x -function Eq_Theta_2(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & - Rnu,Inu,Rk,Ik,RTheta,ITheta,W,Rmin, & - qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI, & - T,sst) result(gont) - implicit none - integer,intent(in ):: ex(1:3),sst - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,W - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta - real*8,intent(in) :: Rmin,T - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ - double complex :: CTheta0,CTheta,CTheta1,RHS - integer :: i,j,k,RK4 - double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx - double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB - double complex,dimension(ex(3)) :: fCTheta,CThetax - real*8,dimension(ex(3)) :: KK,KKx,HKK,HKKx,Hbeta,betax,Hbetax,HW,Wx,HWx - double complex :: Theta_rhs,Theta_rhs_o - real*8 :: dR - -!!! sanity check - dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & - sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) - if(dR.ne.dR) then - if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" - if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" - if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" - if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" - if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" - if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" - if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" - if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" - if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" - if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" - if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" - gont = 1 - return - endif - - dR = R(2) - R(1) - - CU = dcmplx(RU,IU) - CB = dcmplx(RB,IB) - CJ = dcmplx(RJ,IJ) - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - - do j=ghost_width+1,ex(2)-ghost_width - do i=ghost_width+1,ex(1)-ghost_width - CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) - fCTheta = dcmplx(RTheta(i,j,:),ITheta(i,j,:)) - call cderivs_x(ex(3),R,fCTheta,CThetax) - Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) - Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) - call cget_half_x(ex(3),CB(i,j,:),HCB) - call cget_half_x(ex(3),DCB(i,j,:),HDCB) - call cget_half_x(ex(3),bDCB(i,j,:),HbDCB) - call cget_half_x(ex(3),Cnu,HCnu) - call cderivs_x(ex(3),R,Cnu,Cnux) - call cget_half_x(ex(3),Cnux,HCnux) - call cget_half_x(ex(3),Ck,HCk) - call rget_half_x(ex(3),beta(i,j,:),Hbeta) - call rderivs_x(ex(3),R,beta(i,j,:),betax) - call rget_half_x(ex(3),betax,Hbetax) - KK = dsqrt(1.d0+RJ(i,j,:)*RJ(i,j,:)+IJ(i,j,:)*IJ(i,j,:)) - call rget_half_x(ex(3),KK,HKK) - call rderivs_x(ex(3),R,KK,KKx) - call rget_half_x(ex(3),KKx,HKKx) - call rderivs_x(ex(3),R,W,Wx) - call rget_half_x(ex(3),Wx,HWx) - call rget_half_x(ex(3),W(i,j,:),HW) - call cget_half_x(ex(3),CU(i,j,:),HCU) - call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) - call cderivs_x(ex(3),R,CU(i,j,:),CUx) - call cget_half_x(ex(3),DCUx,HDCUx) - call cget_half_x(ex(3),CUx,HCUx) - call cget_half_x(ex(3),DCU(i,j,:),HDCU) - call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) - call cget_half_x(ex(3),bDCUx,HbDCUx) - call cget_half_x(ex(3),bDCU(i,j,:),HbDCU) - call cderivs_x(ex(3),R,CJ(i,j,:),CJx) - call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) - call cget_half_x(ex(3),CJx,HCJx) - call cget_half_x(ex(3),CJxx,HCJxx) - call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) - call cget_half_x(ex(3),DCJx,HDCJx) - - RTheta(i,j,1) = 0.d0 - ITheta(i,j,1) = 0.d0 - do k=1,ex(3)-1 -! call getndxs(T,crho(i),sigma(j),R(k),beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k), & -! CB(i,j,k),DCB(i,j,k),W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k),sst,Rmin) -! call getdxs(T,crho(i),sigma(j),R(k),betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k), & -! Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k),sst,Rmin) - RHS = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(k),KK(k),KKx(k),CU(i,j,k),CUx(k),DCUx(k),bDCU(i,j,k),bDCUx(k), & - DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(k),CJ(i,j,k),DCJ(i,j,k), & - CJx(k),CJxx(k),DCJx(k),bDCB(i,j,k),Cnu(k),Cnux(k),Ck(k),fCTheta(k)) - RHS = RHS - CThetax(k) -#if 0 - if(cdabs(RHS)>1.d-9)then -#if 0 - write(*,*)beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k),CB(i,j,k),DCB(i,j,k) - write(*,*)W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k) - call getndxs(T,crho(i),sigma(j),R(k),beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k), & - CB(i,j,k),DCB(i,j,k),W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k),sst,Rmin) - write(*,*)"VS" - write(*,*)beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k),CB(i,j,k),DCB(i,j,k) - write(*,*)W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k) -#endif - write(*,*)betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k) - write(*,*)Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k) - call getdxs(T,crho(i),sigma(j),R(k),betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k), & - Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k),sst,Rmin) - write(*,*)"VS" - write(*,*)betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k) - write(*,*)Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k) -! write(*,*)RHS -! call check_factor(T,crho(i),sigma(j),R(k),sst,Rmin) - stop - endif -#endif - RTheta(i,j,k+1) = dreal(RHS) - ITheta(i,j,k+1) = dimag(RHS) - enddo - enddo - enddo - - gont = 0 - return - -end function Eq_Theta_2 + + +#include "macrodef.fh" + +!#define OLD + +! 0: rk4, 1: Adams-Moulton + +#define RKorAM 0 + +function beta_rhs(xx,CJx,Kx) result(gont) + implicit none + double complex,intent(in) :: CJx + real*8,intent(in) :: xx,Kx + + real*8 :: gont + + gont = xx*(1.d0-xx)/8.d0*(dreal(CJx*dconjg(CJx))-Kx*Kx) + + return + +end function beta_rhs + +function Q_rhs(xx,CJ,CJx,DCJx,KK,Ck,Ckx,Cnux,KKx,CBx,Cnu,DCJ,CB,CQ) result(gont) + implicit none + double complex,intent(in) :: CJ,CJx,DCJx,Ck,Ckx,Cnux,CBx,Cnu,DCJ,CB,CQ + real*8,intent(in) :: xx,KK,KKx + + double complex :: gont + + gont = -KK*(Ckx+Cnux)+Cnu*KKx+CJ*dconjg(Ckx)+2.d0*CBx & + +dconjg(Cnu)*CJx+dconjg(CJ)*DCJx-dconjg(Ck)*CJx & + +(dconjg(Cnu)*(CJx-CJ*CJ*dconjg(CJx)) & + +DCJ*(dconjg(CJx)-dconjg(CJ*CJ)*CJx)/2.d0/KK/KK) & + -2.d0*(2.d0*CB+CQ)/xx/(1.d0-xx) + + return + +end function Q_rhs + +function U_rhs(xx,Rmin,beta,KK,CQ,CJ) result(gont) + implicit none + double complex,intent(in) :: CQ,CJ + real*8,intent(in) :: xx,Rmin,beta,KK + + double complex :: gont + +#if 1 + gont = dexp(2.d0*beta)/Rmin/xx/xx*(KK*CQ-CJ*dconjg(CQ)) +#else + gont = CQ/Rmin/xx/xx +#endif + +#if 0 + if(cdabs(gont)>1)then + write(*,*)beta,KK,CQ,CJ + stop + endif +#endif + + return + +end function U_rhs + +function W_rhs(xx,Rmin,beta,KK,DCB,CB,CJ,Cnu,Ck,W, & + CQ,bDCk,bDCnu,bDCB,bDCU,bDCUx,DCJ) result(gont) + implicit none + double complex,intent(in) :: DCB,CB,CJ,Cnu,Ck,CQ,bDCk,bDCnu,bDCB,bDCU,bDCUx,DCJ + real*8,intent(in) :: xx,Rmin,beta,KK,W + + real*8 :: Ric,gont + + Ric = dreal(2.d0*KK+bDCnu-bDCk+(DCJ*dconjg(DCJ)-Cnu*dconjg(Cnu))/4.d0/KK) + + gont = dreal(dexp(2.d0*beta)*(Ric/2.d0-KK*(bDCB+CB*dconjg(CB))+dconjg(CJ)*(bDCB+CB*CB) & + +(Cnu-Ck)*dconjg(CB))-1.d0+2.d0*Rmin*xx/(1.d0-xx)*(bDCU-W) & + +Rmin*xx*xx/2.d0*bDCUx-dexp(2.d0*beta)/4.d0* & + (KK*KK-CJ*dconjg(CJ))*(KK*dconjg(CQ)-dconjg(CJ)*CQ)*CQ) + + gont = gont/Rmin/xx/xx + + return + +end function W_rhs + +function Theta_rhs(xx,Rmin,beta,betax,KK,KKx,CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,W,Wx,CJ,DCJ,CJx,CJxx, & + DCJx,bDCB,Cnu,Cnux,Ck,Theta) result(gont) + implicit none + double complex,intent(in) :: CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,CJ,DCJ,CJx,CJxx,DCJx + double complex,intent(in) :: bDCB,Cnu,Cnux,Ck,Theta + real*8,intent(in) :: xx,Rmin,beta,betax,KK,KKx,W,Wx + + double complex :: JH,II,gont + real*8 :: V,Vx,Pu + + II = dcmplx(0.d0,1.d0) + + V = xx*Rmin/(1.d0-xx)*(1.d0+xx*Rmin/(1.d0-xx)*W) + + Vx = Rmin/(1.d0-xx)**2+2.d0*xx*Rmin*Rmin/(1.d0-xx)**3*W+xx*xx*Rmin*Rmin/(1.d0-xx)**2*Wx + + Pu = 2.d0*xx*(1.d0-xx)/KK*dreal(Theta*(dconjg(CJx)*KK-dconjg(CJ)*KKx)) + + JH = (1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(-KK*DCJ*dconjg(CB)+ & + (KK*Cnu+(KK*KK-1.d0)*DCJ-2.d0*KK*Ck)*CB+CJ* & + ((2.d0*Ck-Cnu)*dconjg(CB)-2.d0*KK*(bDCB+CB*dconjg(CB))+ & + 2.d0*dreal((Cnu-Ck)*dconjg(CB)+dconjg(CJ)*(DCB+CB*CB)))) & + +0.5d0*Rmin*xx**3*(1.d0-xx)*dexp(-2.d0*beta)* & + ((KK*CUx+CJ*dconjg(CUx))**2- & + CJ*dreal(dconjg(CUx)*(KK*CUx+CJ*dconjg(CUx)))) & + -0.5d0*(Cnu*(xx*(1.d0-xx)*CUx+2.d0*CU)+DCJ*(xx*(1.d0-xx)*dconjg(CUx)+ & + 2.d0*dconjg(CU)))+CJ*II*dimag(xx*(1.d0-xx)*bDCUx+2.d0*bDCU) & + -xx*(1.d0-xx)*CJx*dreal(bDCU) & + +xx*(1.d0-xx)*(dconjg(CU)*DCJ+CU*Cnu)*II*dimag(CJ*dconjg(CJx)) & + -xx*(1.d0-xx)*(dconjg(CU)*DCJx+CU*Cnux) & + -2.d0*xx*(1.d0-xx)*(CJ*KKx-KK*CJx)*(dreal(dconjg(CU)*Ck)+ & + II*dimag(KK*bDCU-dconjg(CJ)*DCU)) & + -8.d0*CJ*((1.d0-xx)**2/Rmin+xx*(1.d0-xx)*W)*betax + + gont = -KK*(xx*(1-xx)*DCUx+2.d0*DCU)+2.d0*(1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(DCB+CB*CB) & + -(xx*(1.d0-xx)*Wx+W)*CJ+JH+CJ*Pu-2.d0*Theta & + -(1.d0-xx)*(1.d0-xx)/xx/xx/Rmin/Rmin*V*(CJ+xx*(1.d0-xx)*CJx) & + +(1.d0-xx)*(1.d0-xx)*(1.d0-xx)/xx/Rmin/Rmin*Vx*(CJ+xx*(1.d0-xx)*CJx) & + +(1.d0-xx)**4/xx/Rmin/Rmin*V*(2.d0*CJx+xx*CJxx) +#if 0 + gont = -(xx*(1-xx)*DCUx+2.d0*DCU)+2.d0*(1.d0-xx)/xx/Rmin*DCB & + -2.d0*Theta & + +(1.d0-xx)**3/Rmin*(2.d0*CJx+xx*CJxx) +#endif + + gont = gont/2.d0/xx/(1.d0-xx) + + return + +end function Theta_rhs +!/////////////////////////////////////////////////////////////////////////////////////////////////////////////// +subroutine fake_Theta_rhs(lx,X,rhs,Theta) + implicit none + integer,intent(in) :: lx + double complex,dimension(lx),intent(in) :: Theta + double complex,dimension(lx),intent(out) :: rhs + real*8,dimension(lx),intent(in) :: X + + call cderivs_x(lx,X,Theta,rhs) + + return + +end subroutine fake_Theta_rhs +!/////////////////////////////////////////////////////////////////////////////////////////////////////////////// +! try other guy's old method +function Theta_rhs_o(xx,Rmin,beta,betax,KK,KKx,CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,W,Wx,CJ,DCJ,CJx,CJxx, & + DCJx,bDCB,Cnu,Cnux,Ck,Theta) result(gont) + implicit none + double complex,intent(in) :: CU,CUx,DCUx,bDCU,bDCUx,DCU,CB,DCB,CJ,DCJ,CJx,CJxx,DCJx + double complex,intent(in) :: Cnu,Cnux,Ck,bDCB,Theta + real*8,intent(in) :: xx,Rmin,beta,betax,KK,KKx,W,Wx + + double complex :: JH,II,gont + real*8 :: V,Vx,Pu + + II = dcmplx(0.d0,1.d0) + + V = xx*Rmin/(1.d0-xx)*(1.d0+xx*Rmin/(1.d0-xx)*W) + + Vx = Rmin/(1.d0-xx)**2+2.d0*xx*Rmin*Rmin/(1.d0-xx)**3*W+xx*xx*Rmin*Rmin/(1.d0-xx)**2*Wx + + Pu = 2.d0*xx*(1.d0-xx)/KK*dreal(Theta*(dconjg(CJx)*KK-dconjg(CJ)*KKx)) + + JH = (1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(-KK*DCJ*dconjg(CB)+ & + (KK*Cnu+(KK*KK-1.d0)*DCJ-2.d0*KK*Ck)*CB+CJ* & + ((2.d0*Ck-Cnu)*dconjg(CB)-2.d0*KK*(bDCB+CB*dconjg(CB))+ & + 2.d0*dreal((Cnu-Ck)*dconjg(CB)+dconjg(CJ)*(DCB+CB*CB)))) & + +0.5d0*Rmin*xx**3*(1.d0-xx)*dexp(-2.d0*beta)* & + ((KK*CUx+CJ*dconjg(CUx))**2- & + CJ*dreal(dconjg(CUx)*(KK*CUx+CJ*dconjg(CUx)))) & + -0.5d0*(Cnu*(xx*(1.d0-xx)*CUx+2.d0*CU)+DCJ*(xx*(1.d0-xx)*dconjg(CUx)+ & + 2.d0*dconjg(CU)))+CJ*II*dimag(xx*(1.d0-xx)*bDCUx+2.d0*bDCU) & + -xx*(1.d0-xx)*CJx*dreal(bDCU) & + +xx*(1.d0-xx)*(dconjg(CU)*DCJ+CU*Cnu)*II*dimag(CJ*dconjg(CJx)) & + -xx*(1.d0-xx)*(dconjg(CU)*DCJx+CU*Cnux) & + -2.d0*xx*(1.d0-xx)*(CJ*KKx-KK*CJx)*(dreal(dconjg(CU)*Ck)+ & + II*dimag(KK*bDCU-dconjg(CJ)*DCU)) & + -8.d0*CJ*((1.d0-xx)**2/Rmin+xx*(1.d0-xx)*W)*betax + + gont = -KK*(xx*(1-xx)*DCUx+2.d0*DCU)+2.d0*(1.d0-xx)/xx/Rmin*dexp(2.d0*beta)*(DCB+CB*CB) & + -(xx*(1.d0-xx)*Wx+W)*CJ+JH+CJ*Pu & + -(1.d0-xx)*(1.d0-xx)/xx/xx/Rmin/Rmin*V*(CJ+xx*(1.d0-xx)*CJx) & + +(1.d0-xx)*(1.d0-xx)*(1.d0-xx)/xx/Rmin/Rmin*Vx*(CJ+xx*(1.d0-xx)*CJx) & + +(1.d0-xx)**4/xx/Rmin/Rmin*V*(2.d0*CJx+xx*CJxx) + + return + +end function Theta_rhs_o + +#if (RKorAM == 0) + +!-------------------------------------------------------------------- +! this R is indeed x +function NullEvol_Theta_o(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ + double complex :: CTheta0,CTheta,CTheta1,RHS + integer :: i,j,k,RK4 + double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx + double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB + real*8,dimension(ex(3)) :: KK,KKx,HKK,HKKx,Hbeta,betax,Hbetax,HW,Wx,HWx + double complex :: Theta_rhs_o + real*8 :: dR + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CU = dcmplx(RU,IU) + CB = dcmplx(RB,IB) + CJ = dcmplx(RJ,IJ) + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) + CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) + Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) + Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) + call cget_half_x(ex(3),CB(i,j,:),HCB) + call cget_half_x(ex(3),DCB(i,j,:),HDCB) + call cget_half_x(ex(3),bDCB(i,j,:),HbDCB) + call cget_half_x(ex(3),Cnu,HCnu) + call cderivs_x(ex(3),R,Cnu,Cnux) + call cget_half_x(ex(3),Cnux,HCnux) + call cget_half_x(ex(3),Ck,HCk) + call rget_half_x(ex(3),beta(i,j,:),Hbeta) + call rderivs_x(ex(3),R,beta(i,j,:),betax) + call rget_half_x(ex(3),betax,Hbetax) + KK = dsqrt(1.d0+RJ(i,j,:)*RJ(i,j,:)+IJ(i,j,:)*IJ(i,j,:)) + call rget_half_x(ex(3),KK,HKK) + call rderivs_x(ex(3),R,KK,KKx) + call rget_half_x(ex(3),KKx,HKKx) + call rderivs_x(ex(3),R,W,Wx) + call rget_half_x(ex(3),Wx,HWx) + call rget_half_x(ex(3),W(i,j,:),HW) + call cget_half_x(ex(3),CU(i,j,:),HCU) + call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) + call cderivs_x(ex(3),R,CU(i,j,:),CUx) + call cget_half_x(ex(3),DCUx,HDCUx) + call cget_half_x(ex(3),CUx,HCUx) + call cget_half_x(ex(3),DCU(i,j,:),HDCU) + call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) + call cget_half_x(ex(3),bDCUx,HbDCUx) + call cget_half_x(ex(3),bDCU(i,j,:),HbDCU) + call cderivs_x(ex(3),R,CJ(i,j,:),CJx) + call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) + call cget_half_x(ex(3),CJx,HCJx) + call cget_half_x(ex(3),CJxx,HCJxx) + call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) + call cget_half_x(ex(3),DCJx,HDCJx) + do k=1,ex(3)-1 + RHS = Theta_rhs_o(R(k)+dR/2.d0,Rmin,Hbeta(k),betax(k),HKK(k),KKx(k),HCU(k),CUx(k),DCUx(k),HbDCU(k),bDCUx(k), & + HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k),HCJ(k),HDCJ(k), & + CJx(k),CJxx(k),DCJx(k),HbDCB(k),HCnu(k),Cnux(k),HCk(k),CTheta0) + CTheta1 = RHS-(1-2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR)*CTheta0 + CTheta1 = CTheta1/(1+2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR) + CTheta0 = CTheta1 + + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + enddo + enddo + enddo + + gont = 0 + return + +end function NullEvol_Theta_o +!------------------------------------------------------------------------------ +! this R is indeed x +function NullEvol_beta(ex,crho,sigma,R,RJ,IJ,beta,KKx,HKKx) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KKx,HKKx +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + double complex, dimension(ex(3)):: CJ,CJx,HCJx + real*8 :: betah0,betah1,betah,rhs + integer :: i,j,k,RK4 + real*8 :: beta_rhs + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(beta)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_beta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_beta: find NaN in IJ" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_beta: find NaN in beta" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_beta: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_beta: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + betah0 = beta(i,j,1) + CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) + call cderivs_x(ex(3),R,CJ,CJx) + call cget_half_x(ex(3),CJx,HCJx) +#ifdef OLD + do k = 1,ex(3)-1 +! note our CJx(ex(3)) = (CJ(ex(3))-CJ(ex(3)-1))/dR +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + rhs = beta_rhs(R(k)+dR/2.d0,CJx(k+1),KKx(i,j,k+1)) + beta(i,j,k+1) = beta(i,j,k) + rhs*dR + enddo +#else + do k=1,ex(3)-1 + RK4 = 0 + rhs = beta_rhs(R(k),CJx(k),KKx(i,j,k)) + call rungekutta4_scalar(dR,betah0,betah,rhs,RK4) + + RK4 = 1 + betah1 = beta_rhs(R(k)+dR/2.d0,HCJx(k),HKKx(i,j,k)) + call rungekutta4_scalar(dR,betah0,betah1,rhs,RK4) + call rswap(betah,betah1) + + RK4 = 2 + betah1 = beta_rhs(R(k)+dR/2.d0,HCJx(k),HKKx(i,j,k)) + call rungekutta4_scalar(dR,betah0,betah1,rhs,RK4) + call rswap(betah,betah1) + + RK4 = 3 + betah1 = beta_rhs(R(k+1),CJx(k+1),KKx(i,j,k+1)) + call rungekutta4_scalar(dR,betah0,betah1,rhs,RK4) + call rswap(betah0,betah1) + + beta(i,j,k+1) = betah0 + enddo +! above k takes ex(3)-1 then do not need this closing step +#if 1 +! closing step + k = ex(3)-1 +! note our CJx(ex(3)) = (CJ(ex(3))-CJ(ex(3)-1))/dR +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + rhs = beta_rhs(R(k)+dR/2.d0,CJx(k+1),KKx(i,j,k+1)) + beta(i,j,k+1) = beta(i,j,k) + rhs*dR +#endif + +#endif + enddo + enddo + + gont = 0 + + return + +end function NullEvol_beta +!------------------------------------------------------------------------------ +! this R is indeed x +function NullEvol_Q(ex,crho,sigma,R,RJ,IJ,Rk,Ik,Rnu,Inu,RB,IB,RQ,IQ,KK,Hkk,KKx,HKKx, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RQ,IQ + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KK,Hkk,KKx,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rk,Ik,Rnu,Inu,RB,IB + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: xx,dR + + double complex :: CQ0,CQ,CQ1,RHS + double complex,dimension(ex(3)) :: CJx,HCJx,DCJx,HDCJx,Ck,Ckx,HCkx,Cnu,Cnux,HCnux,CB,CBx,HCBx + double complex,dimension(ex(3)) :: HCJ,HCk,HCnu,HCB,HDCJ + double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,DCJ + integer :: i,j,k,RK4 + double complex :: Q_rhs + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ) & + +sum(RK)+sum(IK)+sum(Rnu)+sum(Inu)+sum(RB)+sum(IB) & + +sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Q: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Q: find NaN in IJ" + if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_Q: find NaN in RQ" + if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_Q: find NaN in IQ" + if(sum(RK).ne.sum(RK))write(*,*)"NullEvol_Q: find NaN in RK" + if(sum(IK).ne.sum(IK))write(*,*)"NullEvol_Q: find NaN in IK" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Q: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Q: find NaN in Inu" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Q: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Q: find NaN in IB" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Q: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Q: find NaN in HKK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Q: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Q: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CJ = dcmplx(RJ,IJ) + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + do j=1,ex(2) + do i=1,ex(1) + CQ0 = dcmplx(RQ(i,j,1),IQ(i,j,1)) + call cderivs_x(ex(3),R,CJ(i,j,:),CJx) + call cget_half_x(ex(3),CJx,HCJx) + call cget_half_x(ex(3),CJ,HCJ) + call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) + call cget_half_x(ex(3),DCJx,HDCJx) + call cget_half_x(ex(3),DCJ,HDCJ) + Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) + call cderivs_x(ex(3),R,Ck,Ckx) + call cget_half_x(ex(3),Ckx,HCkx) + call cget_half_x(ex(3),Ck,HCk) + Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) + call cderivs_x(ex(3),R,Cnu,Cnux) + call cget_half_x(ex(3),Cnux,HCnux) + call cget_half_x(ex(3),Cnu,HCnu) + CB = dcmplx(RB(i,j,:),IB(i,j,:)) + call cderivs_x(ex(3),R,CB,CBx) + call cget_half_x(ex(3),CBx,HCBx) + call cget_half_x(ex(3),CB,HCB) +#ifdef OLD + do k = 1,ex(3)-1 + xx = R(k)+dR/2.d0 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + RHS = Q_rhs(xx,HCJ(k),CJx(k+1),DCJx(k+1),HKK(i,j,k),HCk(k),Ckx(k+1),Cnux(k+1),KKx(i,j,k+1),CBx(k+1),HCnu(k),HDCJ(k),HCB(k),0) + RHS = RHS+CQ0*(1.d0/dR-1.d0/xx/(1.d0-xx)) + CQ0 = RHS/(1.d0/dR+1.d0/xx/(1.d0-xx)) + RQ(i,j,k+1) = dreal(CQ0) + IQ(i,j,k+1) = dimag(CQ0) + enddo +#else + do k=1,ex(3)-2 + RK4 = 0 + RHS = Q_rhs(R(k),CJ(i,j,k),CJx(k),DCJx(k),KK(i,j,k),Ck(k),Ckx(k),Cnux(k),KKx(i,j,k),CBx(k),Cnu(k),DCJ(i,j,k),CB(k),CQ0) + call rungekutta4_cplxscalar(dR,CQ0,CQ,RHS,RK4) + + RK4 = 1 + CQ1 = Q_rhs(R(k)+dR/2.d0,HCJ(k),HCJx(k),HDCJx(k),HKK(i,j,k),HCk(k),HCkx(k),HCnux(k),HKKx(i,j,k), & + HCBx(k),HCnu(k),HDCJ(k),HCB(k),CQ) + call rungekutta4_cplxscalar(dR,CQ0,CQ1,RHS,RK4) + call cswap(CQ,CQ1) + + RK4 = 2 + CQ1 = Q_rhs(R(k)+dR/2.d0,HCJ(k),HCJx(k),HDCJx(k),HKK(i,j,k),HCk(k),HCkx(k),HCnux(k),HKKx(i,j,k), & + HCBx(k),HCnu(k),HDCJ(k),HCB(k),CQ) + call rungekutta4_cplxscalar(dR,CQ0,CQ1,RHS,RK4) + call cswap(CQ,CQ1) + + RK4 = 3 + CQ1 = Q_rhs(R(k+1),CJ(i,j,k+1),CJx(k+1),DCJx(k+1),KK(i,j,k+1),Ck(k+1),Ckx(k+1),Cnux(k+1),KKx(i,j,k+1), & + CBx(k+1),Cnu(k+1),DCJ(i,j,k+1),CB(k+1),CQ) + call rungekutta4_cplxscalar(dR,CQ0,CQ1,RHS,RK4) + call cswap(CQ0,CQ1) + + RQ(i,j,k+1) = dreal(CQ0) + IQ(i,j,k+1) = dimag(CQ0) + enddo +#if 0 + k = ex(3) + CQ0 = -2*CB(k) + RQ(i,j,k+1) = dreal(CQ0) + IQ(i,j,k+1) = dimag(CQ0) +#else +! closing step + k = ex(3)-1 + CQ0 = dcmplx(RQ(i,j,k),IQ(i,j,k)) + xx = R(k)+dR/2.d0 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + RHS = Q_rhs(xx,HCJ(k),CJx(k+1),DCJx(k+1),HKK(i,j,k), & + HCk(k),Ckx(k+1),Cnux(k+1),KKx(i,j,k+1),CBx(k+1),HCnu(k),HDCJ(k),HCB(k),dcmplx(0.d0,0.d0)) + RHS = RHS+CQ0*(1.d0/dR-1.d0/xx/(1.d0-xx)) + CQ0 = RHS/(1.d0/dR+1.d0/xx/(1.d0-xx)) + RQ(i,j,k+1) = dreal(CQ0) + IQ(i,j,k+1) = dimag(CQ0) +#endif + +#endif + enddo + enddo + + gont = 0 + return + +end function NullEvol_Q +!-------------------------------------------------------------------- +! this R is indeed x +function NullEvol_U(ex,crho,sigma,R,RJ,IJ,RQ,IQ,KK,HKK,beta,RU,IU, & + Rmin) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RQ,IQ,beta,KK,HKK + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU + real*8,intent(in) :: Rmin +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + double complex :: CU0,CU,CU1,RHS + integer :: i,j,k,RK4 + double complex,dimension(ex(3)) :: CJ,CQ,HCJ,HCQ + real*8,dimension(ex(3)) :: Hbeta + double complex :: U_rhs + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ)+sum(beta)+sum(RU)+sum(IU)+sum(KK)+sum(HKK) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_U: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_U: find NaN in IJ" + if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_U: find NaN in RQ" + if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_U: find NaN in IQ" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_U: find NaN in beta" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_U: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_U: find NaN in IU" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_U: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_U: find NaN in HKK" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + CU0 = dcmplx(RU(i,j,1),IU(i,j,1)) + CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) + CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) + call cget_half_x(ex(3),CJ,HCJ) + call cget_half_x(ex(3),CQ,HCQ) + call rget_half_x(ex(3),beta(i,j,:),Hbeta) +#ifdef OLD + do k = 1,ex(3)-1 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + RHS = U_rhs(R(k)+dR/2,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) + CU0 = CU0+RHS*dR + RU(i,j,k+1) = dreal(CU0) + IU(i,j,k+1) = dimag(CU0) + enddo +#else + + do k=1,ex(3)-2 + + RK4 = 0 + RHS = U_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),CQ(k),CJ(k)) + call rungekutta4_cplxscalar(dR,CU0,CU,RHS,RK4) + + RK4 = 1 + CU1 = U_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) + call rungekutta4_cplxscalar(dR,CU0,CU1,RHS,RK4) + call cswap(CU,CU1) + + RK4 = 2 + CU1 = U_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) + call rungekutta4_cplxscalar(dR,CU0,CU1,RHS,RK4) + call cswap(CU,CU1) + + RK4 = 3 + CU1 = U_rhs(R(k+1),Rmin,beta(i,j,k+1),KK(i,j,k+1),CQ(k+1),CJ(k+1)) + call rungekutta4_cplxscalar(dR,CU0,CU1,RHS,RK4) + call cswap(CU0,CU1) + + RU(i,j,k+1) = dreal(CU0) + IU(i,j,k+1) = dimag(CU0) + + enddo +! above k takes ex(3)-1 then do not need closing step +#if 1 +! closing step + k = ex(3)-1 + CU0 = dcmplx(RU(i,j,k),IU(i,j,k)) +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + RHS = U_rhs(R(k)+dR/2,Rmin,Hbeta(k),HKK(i,j,k),HCQ(k),HCJ(k)) + CU0 = CU0+RHS*dR + RU(i,j,k+1) = dreal(CU0) + IU(i,j,k+1) = dimag(CU0) +#endif + +#endif + enddo + enddo + + gont = 0 + return + +end function NullEvol_U +!---------------------------------------------------------------------------------------- +! this R is indeed x +function NullEvol_W(ex,crho,sigma,R,RJ,IJ,RB,IB,Rnu,Inu,Rk,Ik, & + RU,IU,RQ,IQ,W,beta,KK,HKK,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: W + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,RB,IB + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RU,IU,RQ,IQ,beta,KK,HKK + real*8,intent(in ) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + real*8, dimension(ex(3)) :: Hbeta + double complex, dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU + double complex, dimension(ex(1),ex(2),ex(3)) :: CB,DCB,bDCB,CJ,DCJ,Cnu,bDCnu,Ck,bDCk + double complex, dimension(ex(3)) :: HCB,HDCB,HbDCB,HCJ,HDCJ,HCnu,HbDCnu,HCk,HbDCk + double complex, dimension(ex(3)) :: HbDCU,bDCUx,HbDCUx,CQ,HCQ + real*8 :: Wh0,Wh1,Wh,rhs + integer :: i,j,k,RK4 + real*8 :: xx,W_rhs + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(beta)+sum(RB)+sum(IB)+sum(Rnu)+sum(Inu) & + +sum(Rk)+sum(Ik)+sum(W)+sum(RU)+sum(IU)+sum(RQ)+sum(IQ)& + +sum(KK)+sum(HKK) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_W: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_W: find NaN in IJ" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_W: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_W: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_W: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_W: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_W: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_W: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_W: find NaN in Ik" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_W: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_W: find NaN in IU" + if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_W: find NaN in RQ" + if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_W: find NaN in IQ" + if(sum(W).ne.sum(W))write(*,*)"NullEvol_W: find NaN in W" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_W: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_W: find NaN in HKK" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CB = dcmplx(RB,IB) + CU = dcmplx(RU,IU) + Ck = dcmplx(Rk,Ik) + Cnu = dcmplx(Rnu,Inu) + CJ = dcmplx(RJ,IJ) + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,Ck(:,:,k),bDCk(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,Cnu(:,:,k),bDCnu(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) + Wh0 = W(i,j,1) + call rget_half_x(ex(3),beta(i,j,:),Hbeta) + call cderivs_x(ex(3),R,bDCU,bDCUx) + call cget_half_x(ex(3),bDCUx,HbDCUx) + call cget_half_x(ex(3),bDCU,HbDCU) + call cget_half_x(ex(3),DCJ,HDCJ) + call cget_half_x(ex(3),DCB,HDCB) + call cget_half_x(ex(3),bDCB,HbDCB) + call cget_half_x(ex(3),CB,HCB) + call cget_half_x(ex(3),CJ,HCJ) + call cget_half_x(ex(3),Cnu,HCnu) + call cget_half_x(ex(3),Ck,HCk) + CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) + call cget_half_x(ex(3),CQ,HCQ) + call cget_half_x(ex(3),bDCk,HbDCk) + call cget_half_x(ex(3),bDCnu,HbDCnu) +#ifdef OLD + do k = 1,ex(3)-1 + xx = R(k)+dR/2 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + rhs = W_rhs(xx,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),0, & + HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),bDCUx(k+1),HDCJ(k)) + rhs = rhs+Wh0*(1.d0/dR-1.d0/xx/(1.d0-xx)) + W(i,j,k+1) = rhs/(1.d0/dR+1.d0/xx/(1.d0-xx)) + enddo +#else + do k=1,ex(3)-2 + RK4 = 0 + rhs = W_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),DCB(i,j,k),CB(i,j,k),CJ(i,j,k),Cnu(i,j,k),Ck(i,j,k),Wh0, & + CQ(k),bDCk(i,j,k),bDCnu(i,j,k),bDCB(i,j,k),bDCU(i,j,k),bDCUx(k),DCJ(i,j,k)) + call rungekutta4_scalar(dR,Wh0,Wh,rhs,RK4) + + RK4 = 1 + Wh1 = W_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),Wh, & + HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),HbDCUx(k),HDCJ(k)) + call rungekutta4_scalar(dR,Wh0,Wh1,rhs,RK4) + call rswap(Wh,Wh1) + + RK4 = 2 + Wh1 = W_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),Wh, & + HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),HbDCUx(k),HDCJ(k)) + call rungekutta4_scalar(dR,Wh0,Wh1,rhs,RK4) + call rswap(Wh,Wh1) + + RK4 = 3 + Wh1 = W_rhs(R(k+1),Rmin,beta(i,j,k+1),KK(i,j,k+1),DCB(i,j,k+1),CB(i,j,k+1),CJ(i,j,k+1),Cnu(i,j,k+1),Ck(i,j,k+1),Wh, & + CQ(k+1),bDCk(i,j,k+1),bDCnu(i,j,k+1),bDCB(i,j,k+1),bDCU(i,j,k+1),bDCUx(k+1),DCJ(i,j,k+1)) + call rungekutta4_scalar(dR,Wh0,Wh1,rhs,RK4) + call rswap(Wh0,Wh1) + + W(i,j,k+1) = Wh0 + enddo +#if 0 + k = ex(3) + W(i,j,k) = dreal(bDCU(i,j,k)) +#else +! closing step + k = ex(3)-1 + Wh0 = W(i,j,k) + xx = R(k)+dR/2 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR + rhs = W_rhs(xx,Rmin,Hbeta(k),HKK(i,j,k),HDCB(k),HCB(k),HCJ(k),HCnu(k),HCk(k),0.d0, & + HCQ(k),HbDCk(k),HbDCnu(k),HbDCB(k),HbDCU(k),bDCUx(k+1),HDCJ(k)) + rhs = rhs+Wh0*(1.d0/dR-1.d0/xx/(1.d0-xx)) + W(i,j,k+1) = rhs/(1.d0/dR+1.d0/xx/(1.d0-xx)) +#endif + +#endif + enddo + enddo + + gont = 0 + return + +end function NullEvol_W +!----------------------------------------------------------------------------------------------- +! given exact Theta_x +! this R is indeed x +function NullEvol_Theta_givenx(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,T,sst) result(gont) + implicit none + integer,intent(in ):: ex(1:3),sst + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin,T + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dquR1,dquR2,dquI1,dquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8,intent(in),dimension(ex(1),ex(2),ex(3)) :: dgR,dgI,bdgR,bdgI +! gont = 0: success; gont = 1: something wrong + integer::gont + + real*8,dimension(ex(3))::HR + real*8,dimension(ex(1),ex(2),ex(3)) :: RThetax,IThetax,HRThetax,HIThetax + double complex,dimension(ex(3)) :: fRHS,HfRHS + real*8 :: xx,dR + integer :: i,j,k,RK4 + double complex :: CTheta0,CTheta,CTheta1,RHS + integer,parameter :: ks=1 + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & + sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + HR = R+dR/2 + + call get_exact_null_theta_x(ex,crho,sigma,R,RThetax,IThetax,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) + call get_exact_null_theta_x(ex,crho,sigma,HR,HRThetax,HIThetax,sst,Rmin,T, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) + do j=1,ex(2) + do i=1,ex(1) + CTheta0 = dcmplx(RTheta(i,j,ks),ITheta(i,j,ks)) + fRHS = dcmplx(RThetax(i,j,:),IThetax(i,j,:)) + HfRHS = dcmplx(HRThetax(i,j,:),HIThetax(i,j,:)) + ! call cget_half_x(ex(3),fRHS,HfRHS) + + do k=ks,ex(3)-1 + RK4 = 0 + RHS = fRHS(k) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) + + RK4 = 1 + CTheta1 = HfRHS(k) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 2 + CTheta1 = HfRHS(k) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 3 + CTheta1 = fRHS(k+1) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta0,CTheta1) + + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + enddo + +#if 0 +! closing step + k = ex(3)-1 + RHS = fRHS(k) + CTheta0 = dcmplx(RTheta(i,j,k),ITheta(i,j,k))+RHS*dR + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) +#endif + + enddo + enddo + + gont = 0 + return + +end function NullEvol_Theta_givenx +!----------------------------------------------------------------------------------------------- +#if 1 +! real evolve +! for eth_x, eth first, _x later +! this R is indeed x +function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ + double complex :: CTheta0,CTheta,CTheta1,RHS + integer :: i,j,k,RK4 + double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx + double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB + real*8,dimension(ex(3)) :: Hbeta,betax,Hbetax,HW,Wx,HWx + double complex :: Theta_rhs,Theta_rhs_o + real*8 :: xx,dR + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & + sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CU = dcmplx(RU,IU) + CB = dcmplx(RB,IB) + CJ = dcmplx(RJ,IJ) + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) + CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) + Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) + Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) + call cget_half_x(ex(3),CB(i,j,:),HCB) + call cget_half_x(ex(3),DCB(i,j,:),HDCB) + call cget_half_x(ex(3),bDCB(i,j,:),HbDCB) + call cget_half_x(ex(3),Cnu,HCnu) + call cderivs_x(ex(3),R,Cnu,Cnux) + call cget_half_x(ex(3),Cnux,HCnux) + call cget_half_x(ex(3),Ck,HCk) + call rget_half_x(ex(3),beta(i,j,:),Hbeta) + call rderivs_x(ex(3),R,beta(i,j,:),betax) + call rget_half_x(ex(3),betax,Hbetax) + call rderivs_x(ex(3),R,W,Wx) + call rget_half_x(ex(3),Wx,HWx) + call rget_half_x(ex(3),W(i,j,:),HW) + call cget_half_x(ex(3),CU(i,j,:),HCU) + call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) + call cderivs_x(ex(3),R,CU(i,j,:),CUx) + call cget_half_x(ex(3),DCUx,HDCUx) + call cget_half_x(ex(3),CUx,HCUx) + call cget_half_x(ex(3),DCU(i,j,:),HDCU) + call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) + call cget_half_x(ex(3),bDCUx,HbDCUx) + call cget_half_x(ex(3),bDCU(i,j,:),HbDCU) + call cderivs_x(ex(3),R,CJ(i,j,:),CJx) + call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) + call cget_half_x(ex(3),CJx,HCJx) + call cget_half_x(ex(3),CJxx,HCJxx) + call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) + call cget_half_x(ex(3),DCJx,HDCJx) +! old type code: PRD 54, 6153, Eq.(32) etc. +#if 0 +! start up part + k = 1 + RHS = Theta_rhs_o(R(k)+dR/2.d0,Rmin,Hbeta(k),betax(k),HKK(i,j,k),KKx(i,j,k),HCU(k),CUx(k),DCUx(k),HbDCU(k),bDCUx(k), & + HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k),HCJ(k),HDCJ(k), & + CJx(k),CJxx(k),DCJx(k),HbDCB(k),HCnu(k),Cnux(k),HCk(k),CTheta0) + CTheta1 = RHS-(1-2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR)*CTheta0 + CTheta0 = CTheta1/(1+2.d0*(R(k)+dR/2.d0)*(1.d0-R(k)-dR/2.d0)/dR) + + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + + do k=1,ex(3)-2 + RHS = Theta_rhs_o(R(k+1),Rmin,beta(i,j,k+1),betax(k+1),KK(i,j,k+1),KKx(i,j,k+1),CU(i,j,k+1),CUx(k+1),DCUx(k+1),bDCU(i,j,k+1),bDCUx(k+1), & + DCU(i,j,k+1),CB(i,j,k+1),DCB(i,j,k+1),W(i,j,k+1),Wx(k+1),CJ(i,j,k+1),DCJ(i,j,k+1), & + CJx(k+1),CJxx(k+1),DCJx(k+1),bDCB(i,j,k+1),Cnu(k+1),Cnux(k+1),Ck(k+1),CTheta0) + CTheta1 = RHS-(1-R(k+1)*(1.d0-R(k+1))/dR)*(dcmplx(RTheta(i,j,k),ITheta(i,j,k))) + CTheta0 = CTheta1/(1+R(k+1)*(1.d0-R(k+1))/dR) + + RTheta(i,j,k+2) = dreal(CTheta0) + ITheta(i,j,k+2) = dimag(CTheta0) + enddo +#endif + +#ifdef OLD + do k = 1,ex(3)-1 + xx = R(k)+dR/2 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR +! note our fxx(ex(3)) = (f(ex(3))-2.d0*f(ex(3)-1)+f(ex(3)-2))/dR + RHS = Theta_rhs(xx,Rmin,Hbeta(k),betax(k+1),HKK(i,j,k),KKx(i,j,k+1),HCU(k),CUx(k+1),DCUx(k+1),HbDCU(k),bDCUx(k+1), & + HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k+1),HCJ(k),HDCJ(k), & + CJx(k+1),CJxx(k+1),DCJx(k+1),HbDCB(k),HCnu(k),Cnux(k+1),HCk(k),0) + RHS = RHS+CTheta0*(1.d0/dR-0.5d0/xx/(1.d0-xx)) + CTheta0 = RHS/(1.d0/dR+0.5d0/xx/(1.d0-xx)) + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + enddo +#else + do k=1,ex(3)-2 + RK4 = 0 + RHS = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(k),KK(i,j,k),KKx(i,j,k),CU(i,j,k),CUx(k),DCUx(k),bDCU(i,j,k),bDCUx(k), & + DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(k),CJ(i,j,k),DCJ(i,j,k), & + CJx(k),CJxx(k),DCJx(k),bDCB(i,j,k),Cnu(k),Cnux(k),Ck(k),CTheta0) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) + + RK4 = 1 + CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),Hbetax(k),HKK(i,j,k),HKKx(i,j,k), & + HCU(k),HCUx(k),HDCUx(k),HbDCU(k),HbDCUx(k), & + HDCU(k),HCB(k),HDCB(k),HW(k),HWx(k),HCJ(k),HDCJ(k), & + HCJx(k),HCJxx(k),HDCJx(k),HbDCB(k),HCnu(k),HCnux(k),HCk(k),CTheta) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 2 + CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(k),Hbetax(k),HKK(i,j,k),HKKx(i,j,k), & + HCU(k),HCUx(k),HDCUx(k),HbDCU(k),HbDCUx(k), & + HDCU(k),HCB(k),HDCB(k),HW(k),HWx(k),HCJ(k),HDCJ(k), & + HCJx(k),HCJxx(k),HDCJx(k),HbDCB(k),HCnu(k),HCnux(k),HCk(k),CTheta) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 3 + CTheta1 = Theta_rhs(R(k+1),Rmin,beta(i,j,k+1),betax(k+1),KK(i,j,k+1),KKx(i,j,k+1), & + CU(i,j,k+1),CUx(k+1),DCUx(k+1),bDCU(i,j,k+1),bDCUx(k+1), & + DCU(i,j,k+1),CB(i,j,k+1),DCB(i,j,k+1),W(i,j,k+1),Wx(k+1),CJ(i,j,k+1),DCJ(i,j,k+1), & + CJx(k+1),CJxx(k+1),DCJx(k+1),bDCB(i,j,k+1),Cnu(k+1),Cnux(k+1),Ck(k+1),CTheta) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta0,CTheta1) + + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + enddo +#if 0 + k = ex(3) + CTheta0 = -KK(i,j,k)*DCU(i,j,k)-(CU(i,j,k)*Cnu(k)+dconjg(CU(i,j,k))*DCJ(i,j,k))/2 & + +CJ(i,j,k)*(bDCU(i,j,k)-dconjg(bDCU(i,j,k)))/2 - W(i,j,k)*CJ(i,j,k)/2 + + RTheta(i,j,k) = dreal(CTheta0) + ITheta(i,j,k) = dimag(CTheta0) +#else +! closing step + k = ex(3)-1 + CTheta0 = dcmplx(RTheta(i,j,k),ITheta(i,j,k)) + xx = R(k)+dR/2 +! note our HCJ(ex(3)-1) = (CJ(ex(3))+CJ(ex(3)-1))/2 +! note our KKx(ex(3)) = (KK(ex(3))-KK(ex(3)-1))/dR +! note our fxx(ex(3)) = (f(ex(3))-2.d0*f(ex(3)-1)+f(ex(3)-2))/dR + RHS = Theta_rhs(xx,Rmin,Hbeta(k),betax(k+1),HKK(i,j,k),KKx(i,j,k+1),HCU(k),CUx(k+1),DCUx(k+1),HbDCU(k),bDCUx(k+1), & + HDCU(k),HCB(k),HDCB(k),HW(k),Wx(k+1),HCJ(k),HDCJ(k), & + CJx(k+1),CJxx(k+1),DCJx(k+1),HbDCB(k),HCnu(k),Cnux(k+1),HCk(k),dcmplx(0.d0,0.d0)) + RHS = RHS+CTheta0*(1.d0/dR-0.5d0/xx/(1.d0-xx)) + CTheta0 = RHS/(1.d0/dR+0.5d0/xx/(1.d0-xx)) + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) +#endif + +#endif + enddo + enddo + + gont = 0 + return + +end function NullEvol_Theta +!-------------------------------------------------------------------- +! check with fake_Theta_rhs +#elif 0 +! this R is indeed x +function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ + double complex :: CTheta0,CTheta,CTheta1,RHS + integer :: i,j,k,RK4 + integer,parameter :: ks=1 + double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx + double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB + real*8,dimension(ex(3)) :: Hbeta,betax,Hbetax,HW,Wx,HWx + double complex :: Theta_rhs,Theta_rhs_o + real*8 :: xx,dR + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & + sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CU = dcmplx(RU,IU) + CB = dcmplx(RB,IB) + CJ = dcmplx(RJ,IJ) + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) + CTheta0 = dcmplx(RTheta(i,j,ks),ITheta(i,j,ks)) + Cnu = dcmplx(RTheta(i,j,:),ITheta(i,j,:)) + call fake_Theta_rhs(ex(3),R,Ck,Cnu) + call cget_half_x(ex(3),Ck,HCk) + + do k=ks,ex(3)-1 + RK4 = 0 + RHS = Ck(k) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) + + RK4 = 1 + CTheta1 = HCk(k) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 2 + CTheta1 = HCk(k) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 3 + CTheta1 = Ck(k+1) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta0,CTheta1) + + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + enddo + + enddo + enddo + + gont = 0 + return + +end function NullEvol_Theta + +#else +! for eth_x, _x first, eth second +! this R is indeed x +function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,HKK,KKx,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ + double complex :: CTheta0,CTheta,CTheta1,RHS + integer :: i,j,k,RK4 + double complex,dimension(ex(1),ex(2),ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx + double complex,dimension(ex(1),ex(2),ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB + real*8,dimension(ex(1),ex(2),ex(3)) :: Hbeta,betax,Hbetax,HW,Wx,HWx + double complex :: Theta_rhs + real*8 :: xx,dR + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & + sum(KK)+sum(HKK)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" + if(sum(HKK).ne.sum(HKK))write(*,*)"NullEvol_Theta: find NaN in HKK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_Theta: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CU = dcmplx(RU,IU) + CB = dcmplx(RB,IB) + CJ = dcmplx(RJ,IJ) + Cnu = dcmplx(Rnu,Inu) + Ck = dcmplx(Rk,Ik) + + do j=1,ex(2) + do i=1,ex(1) + call cderivs_x(ex(3),R,Cnu(i,j,:),Cnux(i,j,:)) + call rderivs_x(ex(3),R,beta(i,j,:),betax(i,j,:)) + call rderivs_x(ex(3),R,W(i,j,:),Wx(i,j,:)) + call cderivs_x(ex(3),R,CU(i,j,:),CUx(i,j,:)) + call cderivs_x(ex(3),R,CJ(i,j,:),CJx(i,j,:)) + call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx(i,j,:)) + enddo + enddo + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CUx(:,:,k),DCUx(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CUx(:,:,k),bDCUx(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJx(:,:,k),DCJx(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) + call cget_half_x(ex(3),CB(i,j,:),HCB(i,j,:)) + call cget_half_x(ex(3),DCB(i,j,:),HDCB(i,j,:)) + call cget_half_x(ex(3),bDCB(i,j,:),HbDCB(i,j,:)) + call cget_half_x(ex(3),Cnu(i,j,:),HCnu(i,j,:)) + call cget_half_x(ex(3),Cnux(i,j,:),HCnux(i,j,:)) + call cget_half_x(ex(3),Ck(i,j,:),HCk(i,j,:)) + call rget_half_x(ex(3),beta(i,j,:),Hbeta(i,j,:)) + call rget_half_x(ex(3),betax(i,j,:),Hbetax(i,j,:)) + call rget_half_x(ex(3),Wx(i,j,:),HWx(i,j,:)) + call rget_half_x(ex(3),W(i,j,:),HW(i,j,:)) + call cget_half_x(ex(3),CU(i,j,:),HCU(i,j,:)) + call cget_half_x(ex(3),DCUx(i,j,:),HDCUx(i,j,:)) + call cget_half_x(ex(3),CUx(i,j,:),HCUx(i,j,:)) + call cget_half_x(ex(3),DCU(i,j,:),HDCU(i,j,:)) + call cget_half_x(ex(3),bDCUx(i,j,:),HbDCUx(i,j,:)) + call cget_half_x(ex(3),bDCU(i,j,:),HbDCU(i,j,:)) + call cget_half_x(ex(3),CJx(i,j,:),HCJx(i,j,:)) + call cget_half_x(ex(3),CJxx(i,j,:),HCJxx(i,j,:)) + call cget_half_x(ex(3),DCJx(i,j,:),HDCJx(i,j,:)) + enddo + enddo + + do j=1,ex(2) + do i=1,ex(1) + CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) + + do k=1,ex(3)-2 + RK4 = 0 + RHS = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(i,j,k),KK(i,j,k),KKx(i,j,k),CU(i,j,k),CUx(i,j,k),DCUx(i,j,k),bDCU(i,j,k),bDCUx(i,j,k), & + DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(i,j,k),CJ(i,j,k),DCJ(i,j,k), & + CJx(i,j,k),CJxx(i,j,k),DCJx(i,j,k),bDCB(i,j,k),Cnu(i,j,k),Cnux(i,j,k),Ck(i,j,k),CTheta0) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta,RHS,RK4) + + RK4 = 1 + CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(i,j,k),Hbetax(i,j,k),HKK(i,j,k),HKKx(i,j,k), & + HCU(i,j,k),HCUx(i,j,k),HDCUx(i,j,k),HbDCU(i,j,k),HbDCUx(i,j,k), & + HDCU(i,j,k),HCB(i,j,k),HDCB(i,j,k),HW(i,j,k),HWx(i,j,k),HCJ(i,j,k),HDCJ(i,j,k), & + HCJx(i,j,k),HCJxx(i,j,k),HDCJx(i,j,k),HbDCB(i,j,k),HCnu(i,j,k),HCnux(i,j,k),HCk(i,j,k),CTheta) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 2 + CTheta1 = Theta_rhs(R(k)+dR/2.d0,Rmin,Hbeta(i,j,k),Hbetax(i,j,k),HKK(i,j,k),HKKx(i,j,k), & + HCU(i,j,k),HCUx(i,j,k),HDCUx(i,j,k),HbDCU(i,j,k),HbDCUx(i,j,k), & + HDCU(i,j,k),HCB(i,j,k),HDCB(i,j,k),HW(i,j,k),HWx(i,j,k),HCJ(i,j,k),HDCJ(i,j,k), & + HCJx(i,j,k),HCJxx(i,j,k),HDCJx(i,j,k),HbDCB(i,j,k),HCnu(i,j,k),HCnux(i,j,k),HCk(i,j,k),CTheta) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta,CTheta1) + + RK4 = 3 + CTheta1 = Theta_rhs(R(k+1),Rmin,beta(i,j,k+1),betax(i,j,k+1),KK(i,j,k+1), & + KKx(i,j,k+1),CU(i,j,k+1),CUx(i,j,k+1),DCUx(i,j,k+1),bDCU(i,j,k+1),bDCUx(i,j,k+1), & + DCU(i,j,k+1),CB(i,j,k+1),DCB(i,j,k+1),W(i,j,k+1),Wx(i,j,k+1),CJ(i,j,k+1),DCJ(i,j,k+1), & + CJx(i,j,k+1),CJxx(i,j,k+1),DCJx(i,j,k+1),bDCB(i,j,k+1),Cnu(i,j,k+1),Cnux(i,j,k+1),Ck(i,j,k+1),CTheta) + call rungekutta4_cplxscalar(dR,CTheta0,CTheta1,RHS,RK4) + call cswap(CTheta0,CTheta1) + + RTheta(i,j,k+1) = dreal(CTheta0) + ITheta(i,j,k+1) = dimag(CTheta0) + enddo + + k = ex(3) + CTheta0 = -KK(i,j,k)*DCU(i,j,k)-(CU(i,j,k)*Cnu(i,j,k)+dconjg(CU(i,j,k))*DCJ(i,j,k))/2 & + +CJ(i,j,k)*(bDCU(i,j,k)-dconjg(bDCU(i,j,k)))/2 - W(i,j,k)*CJ(i,j,k)/2 + + RTheta(i,j,k) = dreal(CTheta0) + ITheta(i,j,k) = dimag(CTheta0) + + enddo + enddo + + gont = 0 + return + +end function NullEvol_Theta +#endif + +#elif (RKorAM == 1) +!------------------------------------------------------------------------------ +! this R is indeed x +function NullEvol_beta(ex,crho,sigma,R,RJ,IJ,beta,KKx,HKKx) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KKx,HKKx +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR,beta_rhs + + double complex, dimension(ex(3)):: CJ,CJx + real*8, dimension(ex(3)) :: rhs + integer :: i,j,k + + real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 + real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(beta)+sum(KKx)+sum(HKKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_beta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_beta: find NaN in IJ" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_beta: find NaN in beta" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_beta: find NaN in KKx" + if(sum(HKKx).ne.sum(HKKx))write(*,*)"NullEvol_beta: find NaN in HKKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) +#if 0 + call cderivs_sw_x(ex(3),R,CJ,CJx) +#else + call cderivs_x(ex(3),R,CJ,CJx) +#endif + + do k=1,ex(3) + rhs(k) = beta_rhs(R(k),CJx(k),KKx(i,j,k)) + enddo + + k = 1 + beta(i,j,k+1) = beta(i,j,k) + (rhs(k+1)+rhs(k))*dR/2 + + k = 2 + beta(i,j,k+1) = beta(i,j,k) + (F5o12*rhs(k+1) + F2o3*rhs(k) - F1o12*rhs(k-1))*dR + + do k=3,ex(3)-1 + beta(i,j,k+1) = beta(i,j,k) + (F3o8*rhs(k+1) + F19o24*rhs(k) - F5o24*rhs(k-1) + F1o24*rhs(k-2))*dR + enddo + + enddo + enddo + + gont = 0 + + return + +end function NullEvol_beta +!------------------------------------------------------------------------------ +! this R is indeed x +function NullEvol_Q(ex,crho,sigma,R,RJ,IJ,Rk,Ik,Rnu,Inu,RB,IB,RQ,IQ,KK,Hkk,KKx,HKKx, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RQ,IQ + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,KK,KKx,HKK,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rk,Ik,Rnu,Inu,RB,IB + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: xx,dR + + double complex,dimension(ex(3)) :: CQ,RHS + real*8, dimension(ex(3)) :: gunc + double complex,dimension(ex(3)) :: CJx,DCJx,Ck,Ckx,Cnu,Cnux,CB,CBx + double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,DCJ + integer :: i,j,k + double complex :: ZEO,Q_rhs + + real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 + real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ) & + +sum(RK)+sum(IK)+sum(Rnu)+sum(Inu)+sum(RB)+sum(IB) & + +sum(KK)+sum(KKx) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Q: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Q: find NaN in IJ" + if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_Q: find NaN in RQ" + if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_Q: find NaN in IQ" + if(sum(RK).ne.sum(RK))write(*,*)"NullEvol_Q: find NaN in RK" + if(sum(IK).ne.sum(IK))write(*,*)"NullEvol_Q: find NaN in IK" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Q: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Q: find NaN in Inu" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Q: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Q: find NaN in IB" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Q: find NaN in KK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Q: find NaN in KKx" + gont = 1 + return + endif + + dR = R(2) - R(1) + ZEO = dcmplx(0.d0,0.d0) + + CJ = dcmplx(RJ,IJ) + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + do j=1,ex(2) + do i=1,ex(1) + + CQ(1) = dcmplx(RQ(i,j,1),IQ(i,j,1)) + Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) + Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) + CB = dcmplx(RB(i,j,:),IB(i,j,:)) +#if 0 + call cderivs_sw_x(ex(3),R,CJ(i,j,:),CJx) + call cderivs_sw_x(ex(3),R,DCJ(i,j,:),DCJx) + call cderivs_sw_x(ex(3),R,Ck,Ckx) + call cderivs_sw_x(ex(3),R,Cnu,Cnux) + call cderivs_sw_x(ex(3),R,CB,CBx) +#else + call cderivs_x(ex(3),R,CJ(i,j,:),CJx) + call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) + call cderivs_x(ex(3),R,Ck,Ckx) + call cderivs_x(ex(3),R,Cnu,Cnux) + call cderivs_x(ex(3),R,CB,CBx) +#endif + + do k = 1,ex(3) + RHS(k) = Q_rhs(R(k),CJ(i,j,k),CJx(k),DCJx(k),KK(i,j,k),Ck(k),Ckx(k),Cnux(k),KKx(i,j,k),CBx(k),Cnu(k),DCJ(i,j,k),CB(k),ZEO) + gunc(k) = -2/R(k)/(1-R(k)) + enddo + + k = 1 + CQ(k+1) = CQ(k) + (RHS(k+1)+RHS(k)+CQ(k)*gunc(k))*dR/2 + CQ(k+1) = CQ(k+1)/(1-0.5*dR*gunc(k+1)) + + k = 2 + CQ(k+1) = CQ(k) + (F5o12*RHS(k+1) + F2o3*(RHS(k)+CQ(k)*gunc(k)) - F1o12*(RHS(k-1)+CQ(k-1)*gunc(k-1)))*dR + CQ(k+1) = CQ(k+1)/(1-F5o12*dR*gunc(k+1)) + + do k=3,ex(3)-2 + CQ(k+1) = CQ(k) + (F3o8*RHS(k+1) + F19o24*(RHS(k)+CQ(k)*gunc(k)) - F5o24*(RHS(k-1)+CQ(k-1)*gunc(k-1)) & + + F1o24*(RHS(k-2)+CQ(k-2)*gunc(k-2)))*dR + CQ(k+1) = CQ(k+1)/(1-F3o8*dR*gunc(k+1)) + enddo + + k = ex(3) + CQ(k) = -2*CB(k) + + RQ(i,j,:) = dreal(CQ) + IQ(i,j,:) = dimag(CQ) + + enddo + enddo + + gont = 0 + + return + +end function NullEvol_Q +!-------------------------------------------------------------------- +! this R is indeed x +function NullEvol_U(ex,crho,sigma,R,RJ,IJ,RQ,IQ,KK,HKK,beta,RU,IU, & + Rmin) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RQ,IQ,beta,KK,HKK + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU + real*8,intent(in) :: Rmin +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + double complex,dimension(ex(3)) :: CU0,RHS + integer :: i,j,k + double complex :: U_rhs + double complex,dimension(ex(3)) :: CJ,CQ + + real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 + real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RQ)+sum(IQ)+sum(beta)+sum(RU)+sum(IU)+sum(KK) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_U: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_U: find NaN in IJ" + if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_U: find NaN in RQ" + if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_U: find NaN in IQ" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_U: find NaN in beta" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_U: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_U: find NaN in IU" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_U: find NaN in KK" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + CU0(1) = dcmplx(RU(i,j,1),IU(i,j,1)) + CJ = dcmplx(RJ(i,j,:),IJ(i,j,:)) + CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) + + do k = 1,ex(3) + RHS(k) = U_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),CQ(k),CJ(k)) + enddo + + k = 1 + CU0(k+1) = CU0(k) + (RHS(k+1)+RHS(k))*dR/2 + + k = 2 + CU0(k+1) = CU0(k) + (F5o12*RHS(k+1) + F2o3*RHS(k) - F1o12*RHS(k-1))*dR + + do k=3,ex(3)-1 + CU0(k+1) = CU0(k) + (F3o8*RHS(k+1) + F19o24*RHS(k) - F5o24*RHS(k-1) & + + F1o24*RHS(k-2))*dR + enddo + + RU(i,j,:) = dreal(CU0) + IU(i,j,:) = dimag(CU0) + + enddo + enddo + + gont = 0 + return + +end function NullEvol_U +!---------------------------------------------------------------------------------------- +! this R is indeed x +function NullEvol_W(ex,crho,sigma,R,RJ,IJ,RB,IB,Rnu,Inu,Rk,Ik, & + RU,IU,RQ,IQ,W,beta,KK,HKK,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: W + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RJ,IJ,RB,IB + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RU,IU,RQ,IQ,beta,KK,HKK + real*8,intent(in ) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + double complex, dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU + double complex, dimension(ex(1),ex(2),ex(3)) :: CB,DCB,bDCB,CJ,DCJ,Cnu,bDCnu,Ck,bDCk + double complex, dimension(ex(3)) :: bDCUx,CQ + integer :: i,j,k + real*8, dimension(ex(3)) :: rhs,gunc + real*8 :: zeo,W_rhs + + real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 + real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(beta)+sum(RB)+sum(IB)+sum(Rnu)+sum(Inu) & + +sum(Rk)+sum(Ik)+sum(W)+sum(RU)+sum(IU)+sum(RQ)+sum(IQ)& + +sum(KK) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_W: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_W: find NaN in IJ" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_W: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_W: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_W: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_W: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_W: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_W: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_W: find NaN in Ik" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_W: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_W: find NaN in IU" + if(sum(RQ).ne.sum(RQ))write(*,*)"NullEvol_W: find NaN in RQ" + if(sum(IQ).ne.sum(IQ))write(*,*)"NullEvol_W: find NaN in IQ" + if(sum(W).ne.sum(W))write(*,*)"NullEvol_W: find NaN in W" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_W: find NaN in KK" + gont = 1 + return + endif + + dR = R(2) - R(1) + zeo = 0.d0 + + CB = dcmplx(RB,IB) + CU = dcmplx(RU,IU) + Ck = dcmplx(Rk,Ik) + Cnu = dcmplx(Rnu,Inu) + CJ = dcmplx(RJ,IJ) + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,Ck(:,:,k),bDCk(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,Cnu(:,:,k),bDCnu(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) +#if 0 + call cderivs_sw_x(ex(3),R,bDCU,bDCUx) +#else + call cderivs_x(ex(3),R,bDCU,bDCUx) +#endif + + CQ = dcmplx(RQ(i,j,:),IQ(i,j,:)) + + do k = 1,ex(3) + rhs(k) = W_rhs(R(k),Rmin,beta(i,j,k),KK(i,j,k),DCB(i,j,k),CB(i,j,k),CJ(i,j,k),Cnu(i,j,k),Ck(i,j,k),zeo, & + CQ(k),bDCk(i,j,k),bDCnu(i,j,k),bDCB(i,j,k),bDCU(i,j,k),bDCUx(k),DCJ(i,j,k)) + gunc(k) = -2/R(k)/(1-R(k)) + enddo + + k = 1 + W(i,j,k+1) = W(i,j,k) + (rhs(k+1)+rhs(k)+W(i,j,k)*gunc(k))*dR/2 + W(i,j,k+1) = W(i,j,k+1)/(1-0.5*dR*gunc(k+1)) + + k = 2 + W(i,j,k+1) = W(i,j,k) + (F5o12*rhs(k+1) + F2o3*(rhs(k)+W(i,j,k)*gunc(k)) - F1o12*(rhs(k-1)+W(i,j,k-1)*gunc(k-1)))*dR + W(i,j,k+1) = W(i,j,k+1)/(1-F5o12*dR*gunc(k+1)) + + do k=3,ex(3)-2 + W(i,j,k+1) = W(i,j,k) + (F3o8*rhs(k+1) + F19o24*(rhs(k)+W(i,j,k)*gunc(k)) - F5o24*(rhs(k-1)+W(i,j,k-1)*gunc(k-1)) & + + F1o24*(rhs(k-2)+W(i,j,k-2)*gunc(k-2)))*dR + W(i,j,k+1) = W(i,j,k+1)/(1-F3o8*dR*gunc(k+1)) + enddo + + k = ex(3) + W(i,j,k) = dreal(bDCU(i,j,k)) + + enddo + enddo + + gont = 0 + return + +end function NullEvol_W +!-------------------------------------------------------------------- +! this R is indeed x +function NullEvol_Theta(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,KK,HKK,KKx,HKKx,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: beta,W,KK,KKx,HKK,HKKx + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ + double complex,dimension(ex(3)) :: CTheta0,RHS + integer :: i,j,k,RK4 + double complex,dimension(ex(3)) :: Cnu,Ck,CUx,DCUx,bDCUx + double complex,dimension(ex(3)) :: Cnux,CJx,CJxx,DCJx + real*8,dimension(ex(3)) :: betax,Wx,gunc + double complex :: Theta_rhs,ZEO + real*8 :: dR + + real*8,parameter :: F5o12=2.d0/1.2d1,F2o3=2.d0/3.d0,F1o12=1.d0/1.2d1 + real*8,parameter :: F3o8=3.d0/8.d0,F19o24=1.9d1/2.4d1,F5o24=5.d0/2.4d1,F1o24=1.d0/2.4d1 + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + & + sum(KK)+sum(KKx)+sum(W) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + if(sum(KK).ne.sum(KK))write(*,*)"NullEvol_Theta: find NaN in KK" + if(sum(KKx).ne.sum(KKx))write(*,*)"NullEvol_Theta: find NaN in KKx" + if(sum(W).ne.sum(W))write(*,*)"NullEvol_Theta: find NaN in W" + gont = 1 + return + endif + + dR = R(2) - R(1) + ZEO = dcmplx(0.d0,0.d0) + + CU = dcmplx(RU,IU) + CB = dcmplx(RB,IB) + CJ = dcmplx(RJ,IJ) + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=1,ex(2) + do i=1,ex(1) + CTheta0(1) = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) + Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) + Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) +#if 0 + call cderivs_sw_x(ex(3),R,Cnu,Cnux) + call rderivs_sw_x(ex(3),R,beta(i,j,:),betax) + call rderivs_sw_x(ex(3),R,W,Wx) + call cderivs_sw_x(ex(3),R,DCU(i,j,:),DCUx) + call cderivs_sw_x(ex(3),R,CU(i,j,:),CUx) + call cderivs_sw_x(ex(3),R,bDCU(i,j,:),bDCUx) + call cderivs_sw_x(ex(3),R,CJ(i,j,:),CJx) + call cdderivs_sw_x(ex(3),R,CJ(i,j,:),CJxx) + call cderivs_sw_x(ex(3),R,DCJ(i,j,:),DCJx) +#else + call cderivs_x(ex(3),R,Cnu,Cnux) + call rderivs_x(ex(3),R,beta(i,j,:),betax) + call rderivs_x(ex(3),R,W,Wx) + call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) + call cderivs_x(ex(3),R,CU(i,j,:),CUx) + call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) + call cderivs_x(ex(3),R,CJ(i,j,:),CJx) + call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) + call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) +#endif + do k = 1,ex(3) + rhs(k) = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(k),KK(i,j,k),KKx(i,j,k),CU(i,j,k),CUx(k),DCUx(k),bDCU(i,j,k),bDCUx(k), & + DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(k),CJ(i,j,k),DCJ(i,j,k), & + CJx(k),CJxx(k),DCJx(k),bDCB(i,j,k),Cnu(k),Cnux(k),Ck(k),ZEO) + gunc(k) = -1/R(k)/(1-R(k)) + enddo + + k = 1 + CTheta0(k+1) = CTheta0(k) + (RHS(k+1)+RHS(k)+CTheta0(k)*gunc(k))*dR/2 + CTheta0(k+1) = CTheta0(k+1)/(1-0.5*dR*gunc(k+1)) + + k = 2 + CTheta0(k+1) = CTheta0(k) + (F5o12*RHS(k+1) + F2o3*(RHS(k)+CTheta0(k)*gunc(k)) - F1o12*(RHS(k-1)+CTheta0(k-1)*gunc(k-1)))*dR + CTheta0(k+1) = CTheta0(k+1)/(1-F5o12*dR*gunc(k+1)) + + do k=3,ex(3)-2 + CTheta0(k+1) = CTheta0(k) + (F3o8*RHS(k+1) + F19o24*(RHS(k)+CTheta0(k)*gunc(k)) - F5o24*(RHS(k-1)+CTheta0(k-1)*gunc(k-1)) & + + F1o24*(RHS(k-2)+CTheta0(k-2)*gunc(k-2)))*dR + CTheta0(k+1) = CTheta0(k+1)/(1-F3o8*dR*gunc(k+1)) + enddo + + k = ex(3) + CTheta0(k) = -KK(i,j,k)*DCU(i,j,k)-(CU(i,j,k)*Cnu(k)+dconjg(CU(i,j,k))*DCJ(i,j,k))/2 & + +CJ(i,j,k)*(bDCU(i,j,k)-dconjg(bDCU(i,j,k)))/2 - W(i,j,k)*CJ(i,j,k)/2 + + RTheta(i,j,:) = dreal(CTheta0) + ITheta(i,j,:) = dimag(CTheta0) + enddo + enddo + + gont = 0 + return + +end function NullEvol_Theta + +#else +#error "not recognized RKorAM" +#endif + +!===================================================================================================================================== +! basic tool routines + subroutine rswap(r1,r2) + + implicit none + +!~~~~~~% Input parameters: + + real*8,intent(inout) :: r1,r2 + + real*8 :: r + + r = r1 + r1= r2 + r2= r + + return + + end subroutine rswap +!---- + subroutine cswap(r1,r2) + + implicit none + +!~~~~~~% Input parameters: + + double complex,intent(inout) :: r1,r2 + + double complex :: r + + r = r1 + r1= r2 + r2= r + + return + + end subroutine cswap + +! center type finite difference +!==================================================================================== +!---- + subroutine rderivs_x(lx,X,f,fx) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx + real*8,intent(in),dimension(lx) :: X + real*8,intent(in),dimension(lx) :: f + real*8,intent(out),dimension(lx) :: fx + + real*8 :: dX + + dX = X(2)-X(1) + +#ifdef OLD + fx(1:lx-1) = (f(2:lx)-f(1:lx-1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#else + +#if (ghost_width == 2) + fx(2:lx-1) = (f(3:lx)-f(1:lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#elif (ghost_width == 3) + fx(3:lx-2) = (f(1:lx-4)-8.d0*f(2:lx-3)+8.d0*f(4:lx-1)-f(5:lx))/1.2d1/dX + fx(2) = (f(3)-f(1))/2.d0/dX + fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +! fx(1) =-(2.5d1*f(1)-4.8d1*f(2)+3.6d1*f(3)-1.6d1*f(4)+3.d0*f(5))/1.2d1/dX +! fx(2) =-(3.d0*f(1)+1.d1*f(2)-1.8d1*f(3)+6.d0*f(4)-f(5))/1.2d1/dX +#elif (ghost_width == 4) + fx(4:lx-3) = (-f(1:lx-6)+9.d0*f(2:lx-5)-4.5d1*f(3:lx-4)+4.5d1*f(5:lx-2)-9.d0*f(6:lx-1)+f(7:lx))/6.d1/dX + fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX + fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX + fx(2) = (f(3)-f(1))/2.d0/dX + fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#elif (ghost_width == 5) + fx(5:lx-4) = (3.d0*f(1:lx-8)-3.2d1*f(2:lx-7)+1.68d2*f(3:lx-6)-6.72d2*f(4:lx-5)+ & + 6.72d2*f(6:lx-3)-1.68d2*f(7:lx-2)+3.2d1*f(8:lx-1)-3.d0*f(9:lx))/8.4d2/dX + fx(4) = (-f(1)+9.d0*f(2)-4.5d1*f(3)+4.5d1*f(5)-9.d0*f(6)+f(7))/6.d1/dX + fx(lx-3) = (-f(lx-6)+9.d0*f(lx-5)-4.5d1*f(lx-4)+4.5d1*f(lx-2)-9.d0*f(lx-1)+f(lx))/6.d1/dX + fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX + fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX + fx(2) = (f(3)-f(1))/2.d0/dX + fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#endif + +#endif + return + + end subroutine rderivs_x +!---- + subroutine rderivs_x_point(lx,X,f,fx,k) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx,k + real*8,intent(in),dimension(lx) :: X + real*8,intent(in),dimension(lx) :: f + real*8,intent(out) :: fx + + real*8 :: dX + + dX = X(2)-X(1) + +#ifdef OLD + if(k .eq. lx)then + fx = (f(lx)-f(lx-1))/dX + else + fx = (f(k+1)-f(k))/dX + endif +#else + +#if (ghost_width == 2) + if(k .gt. 1 .and. k .lt. lx) then + fx = (f(k+1)-f(k-1))/2.d0/dX + elseif(k.eq.1) then + fx = (f(2)-f(1))/dX + elseif(k.eq.lx) then + fx = (f(lx)-f(lx-1))/dX + endif +#elif (ghost_width == 3) + if(k .gt. 2 .and. k .lt. lx-1) then + fx = (f(k-2)-8.d0*f(k-1)+8.d0*f(k+1)-f(k+2))/1.2d1/dX + elseif(k.eq.1) then + fx = (f(2)-f(1))/dX + elseif(k.eq.lx) then + fx = (f(lx)-f(lx-1))/dX + elseif(k.eq.2) then + fx = (f(3)-f(1))/2.d0/dX + elseif(k.eq.lx-1) then + fx = (f(lx)-f(lx-2))/2.d0/dX + endif +#elif (ghost_width == 4) + if(k .gt. 3 .and. k .lt. lx-2) then + fx = (-f(k-3)+9.d0*f(k-2)-4.5d1*f(k-1)+4.5d1*f(k+1)-9.d0*f(k+2)+f(k+3))/6.d1/dX + elseif(k.eq.1) then + fx = (f(2)-f(1))/dX + elseif(k.eq.lx) then + fx = (f(lx)-f(lx-1))/dX + elseif(k.eq.2) then + fx = (f(3)-f(1))/2.d0/dX + elseif(k.eq.lx-1) then + fx = (f(lx)-f(lx-2))/2.d0/dX + elseif(k.eq.3) then + fx = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX + elseif(k.eq.lx-2) then + fx = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX + endif +#elif (ghost_width == 5) + if(k .gt. 4 .and. k .lt. lx-3) then + fx = (3.d0*f(k-4)-3.2d1*f(k-3)+1.68d2*f(k-2)-6.72d2*f(k-1)+ & + 6.72d2*f(k+1)-1.68d2*f(k+2)+3.2d1*f(k+3)-3.d0*f(k+4))/8.4d2/dX + elseif(k.eq.1) then + fx = (f(2)-f(1))/dX + elseif(k.eq.lx) then + fx = (f(lx)-f(lx-1))/dX + elseif(k.eq.2) then + fx = (f(3)-f(1))/2.d0/dX + elseif(k.eq.lx-1) then + fx = (f(lx)-f(lx-2))/2.d0/dX + elseif(k.eq.3) then + fx = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX + elseif(k.eq.lx-2) then + fx = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX + elseif(k.eq.4) then + fx = (-f(1)+9.d0*f(2)-4.5d1*f(3)+4.5d1*f(5)-9.d0*f(6)+f(7))/6.d1/dX + elseif(k.eq.lx-3) then + fx = (-f(lx-6)+9.d0*f(lx-5)-4.5d1*f(lx-4)+4.5d1*f(lx-2)-9.d0*f(lx-1)+f(lx))/6.d1/dX + endif +#endif + +#endif + return + + end subroutine rderivs_x_point +!---- + subroutine cderivs_x(lx,X,f,fx) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx + real*8,intent(in),dimension(lx) :: X + double complex,intent(in),dimension(lx) :: f + double complex,intent(out),dimension(lx) :: fx + + real*8 :: dX + + dX = X(2)-X(1) + +#ifdef OLD + fx(1:lx-1) = (f(2:lx)-f(1:lx-1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#else + +#if (ghost_width == 2) + fx(2:lx-1) = (f(3:lx)-f(1:lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#elif (ghost_width == 3) + fx(3:lx-2) = (f(1:lx-4)-8.d0*f(2:lx-3)+8.d0*f(4:lx-1)-f(5:lx))/1.2d1/dX + fx(2) = (f(3)-f(1))/2.d0/dX + fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +! fx(1) =-(2.5d1*f(1)-4.8d1*f(2)+3.6d1*f(3)-1.6d1*f(4)+3.d0*f(5))/1.2d1/dX +! fx(2) =-(3.d0*f(1)+1.d1*f(2)-1.8d1*f(3)+6.d0*f(4)-f(5))/1.2d1/dX +#elif (ghost_width == 4) + fx(4:lx-3) = (-f(1:lx-6)+9.d0*f(2:lx-5)-4.5d1*f(3:lx-4)+4.5d1*f(5:lx-2)-9.d0*f(6:lx-1)+f(7:lx))/6.d1/dX + fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX + fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX + fx(2) = (f(3)-f(1))/2.d0/dX + fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#elif (ghost_width == 5) + fx(5:lx-4) = (3.d0*f(1:lx-8)-3.2d1*f(2:lx-7)+1.68d2*f(3:lx-6)-6.72d2*f(4:lx-5)+ & + 6.72d2*f(6:lx-3)-1.68d2*f(7:lx-2)+3.2d1*f(8:lx-1)-3.d0*f(9:lx))/8.4d2/dX + fx(4) = (-f(1)+9.d0*f(2)-4.5d1*f(3)+4.5d1*f(5)-9.d0*f(6)+f(7))/6.d1/dX + fx(lx-3) = (-f(lx-6)+9.d0*f(lx-5)-4.5d1*f(lx-4)+4.5d1*f(lx-2)-9.d0*f(lx-1)+f(lx))/6.d1/dX + fx(3) = (f(1)-8.d0*f(2)+8.d0*f(4)-f(5))/1.2d1/dX + fx(lx-2) = (f(lx-4)-8.d0*f(lx-3)+8.d0*f(lx-1)-f(lx))/1.2d1/dX + fx(2) = (f(3)-f(1))/2.d0/dX + fx(lx-1) = (f(lx)-f(lx-2))/2.d0/dX + fx(1) = (f(2)-f(1))/dX + fx(lx) = (f(lx)-f(lx-1))/dX +#endif + +#endif + + return + + end subroutine cderivs_x +!---- + subroutine cdderivs_x(lx,X,f,fxx) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx + real*8,intent(in),dimension(lx) :: X + double complex,intent(in),dimension(lx) :: f + double complex,intent(out),dimension(lx) :: fxx + + real*8 :: dX + + dX = X(2)-X(1) + dX = dX*dX + +#ifdef OLD + fxx(1:lx-2) = (f(3:lx)-2.0*f(2:lx-1)+f(1:lx-2))/dX + fxx(lx-1) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX + fxx(lx ) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX +#else + +#if (ghost_width == 2) + fxx(2:lx-1) = (f(3:lx)-2.d0*f(2:lx-1)+f(1:lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#elif (ghost_width == 3) + fxx(3:lx-2) = (-f(1:lx-4)+1.6d1*f(2:lx-3)-3.d1*f(3:lx-2)+1.6d1*f(4:lx-1)-f(5:lx))/1.2d1/dX + fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#elif (ghost_width == 4) + fxx(4:lx-3) = (2.d0*f(1:lx-6)-2.7d1*f(2:lx-5)+2.7d2*f(3:lx-4)-4.9d2*f(4:lx-3) & + +2.7d2*f(5:lx-2)-2.7d1*f(6:lx-1)+2.d0*f(7:lx))/1.8d2/dX + fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX + fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX + fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#elif (ghost_width == 5) + fxx(5:lx-4) = (-9.d0*f(1:lx-8)+1.28d2*f(2:lx-7)-1.008d3*f(3:lx-6)+8.064d3*f(4:lx-5)-1.435d4*f(5:lx-4) & + +8.064d3*f(6:lx-3)-1.008d3*f(7:lx-2)+1.28d2*f(8:lx-1)-9.d0*f(9:lx))/5.04d3/dX + fxx(4) = (2.d0*f(1)-2.7d1*f(2)+2.7d2*f(3)-4.9d2*f(4) & + +2.7d2*f(5)-2.7d1*f(6)+2.d0*f(7))/1.8d2/dX + fxx(lx-3) = (2.d0*f(lx-6)-2.7d1*f(lx-5)+2.7d2*f(lx-4)-4.9d2*f(lx-3) & + +2.7d2*f(lx-2)-2.7d1*f(lx-1)+2.d0*f(lx))/1.8d2/dX + fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX + fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX + fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#endif + +#endif + + return + + end subroutine cdderivs_x +!---- + subroutine rdderivs_x(lx,X,f,fxx) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx + real*8,intent(in),dimension(lx) :: X + real*8,intent(in),dimension(lx) :: f + real*8,intent(out),dimension(lx) :: fxx + + real*8 :: dX + + dX = X(2)-X(1) + dX = dX*dX + +#ifdef OLD + fxx(1:lx-2) = (f(3:lx)-2.0*f(2:lx-1)+f(1:lx-2))/dX + fxx(lx-1) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX + fxx(lx ) = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX +#else + +#if (ghost_width == 2) + fxx(2:lx-1) = (f(3:lx)-2.d0*f(2:lx-1)+f(1:lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#elif (ghost_width == 3) + fxx(3:lx-2) = (-f(1:lx-4)+1.6d1*f(2:lx-3)-3.d1*f(3:lx-2)+1.6d1*f(4:lx-1)-f(5:lx))/1.2d1/dX + fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#elif (ghost_width == 4) + fxx(4:lx-3) = (2.d0*f(1:lx-6)-2.7d1*f(2:lx-5)+2.7d2*f(3:lx-4)-4.9d2*f(4:lx-3) & + +2.7d2*f(5:lx-2)-2.7d1*f(6:lx-1)+2.d0*f(7:lx))/1.8d2/dX + fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX + fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX + fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#elif (ghost_width == 5) + fxx(5:lx-4) = (-9.d0*f(1:lx-8)+1.28d2*f(2:lx-7)-1.008d3*f(3:lx-6)+8.064d3*f(4:lx-5)-1.435d4*f(5:lx-4) & + +8.064d3*f(6:lx-3)-1.008d3*f(7:lx-2)+1.28d2*f(8:lx-1)-9.d0*f(9:lx))/5.04d3/dX + fxx(4) = (2.d0*f(1)-2.7d1*f(2)+2.7d2*f(3)-4.9d2*f(4) & + +2.7d2*f(5)-2.7d1*f(6)+2.d0*f(7))/1.8d2/dX + fxx(lx-3) = (2.d0*f(lx-6)-2.7d1*f(lx-5)+2.7d2*f(lx-4)-4.9d2*f(lx-3) & + +2.7d2*f(lx-2)-2.7d1*f(lx-1)+2.d0*f(lx))/1.8d2/dX + fxx(3) = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX + fxx(lx-2) = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX + fxx(2) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx-1) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + fxx(1) = (f(3)-2.d0*f(2)+f(1))/dX + fxx(lx) = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX +#endif + +#endif + + return + + end subroutine rdderivs_x +!---- + subroutine rdderivs_x_point(lx,X,f,fxx,k) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx,k + real*8,intent(in),dimension(lx) :: X + real*8,intent(in),dimension(lx) :: f + real*8,intent(out) :: fxx + + real*8 :: dX + + dX = X(2)-X(1) + dX = dX*dX + +#ifdef OLD + if(k.lt.lx-1) then + fxx = (f(k+2)-2.0*f(k+1)+f(k))/dX + elseif(k.eq.lx-1) then + fxx = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX + elseif(k.eq.lx) then + fxx = (f(lx)-2.0*f(lx-1)+f(lx-2))/dX + endif +#else + +#if (ghost_width == 2) + if(k.gt.1 .and. k.lt.lx) then + fxx = (f(k+1)-2.d0*f(k)+f(k-1))/dX + elseif(k.eq.1) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + endif +#elif (ghost_width == 3) + if(k.gt.2 .and. k.lt.lx-1) then + fxx = (-f(k-2)+1.6d1*f(k-1)-3.d1*f(k)+1.6d1*f(k+1)-f(k+2))/1.2d1/dX + elseif(k.eq.1) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + elseif(k.eq.2) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx-1) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + endif +#elif (ghost_width == 4) + if(k.gt.3 .and. k.lt.lx-2)then + fxx = (2.d0*f(k-3)-2.7d1*f(k-2)+2.7d2*f(k-1)-4.9d2*f(k) & + +2.7d2*f(k+1)-2.7d1*f(k+2)+2.d0*f(k+3))/1.8d2/dX + elseif(k.eq.1) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + elseif(k.eq.2) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx-1) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + elseif(k.eq.3) then + fxx = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX + elseif(k.eq.lx-2) then + fxx = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX + endif +#elif (ghost_width == 5) + if(k.gt.4 .and. k.lt.lx-3) then + fxx = (-9.d0*f(k-4)+1.28d2*f(k-3)-1.008d3*f(k-2)+8.064d3*f(k-1)-1.435d4*f(k) & + +8.064d3*f(k+1)-1.008d3*f(k+2)+1.28d2*f(k+3)-9.d0*f(k+4))/5.04d3/dX + elseif(k.eq.1) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + elseif(k.eq.2) then + fxx = (f(3)-2.d0*f(2)+f(1))/dX + elseif(k.eq.lx-1) then + fxx = (f(lx)-2.d0*f(lx-1)+f(lx-2))/dX + elseif(k.eq.3) then + fxx = (-f(1)+1.6d1*f(2)-3.d1*f(3)+1.6d1*f(4)-f(5))/1.2d1/dX + elseif(k.eq.lx-2) then + fxx = (-f(lx-4)+1.6d1*f(lx-3)-3.d1*f(lx-2)+1.6d1*f(lx-1)-f(lx))/1.2d1/dX + elseif(k.eq.4) then + fxx = (2.d0*f(1)-2.7d1*f(2)+2.7d2*f(3)-4.9d2*f(4) & + +2.7d2*f(5)-2.7d1*f(6)+2.d0*f(7))/1.8d2/dX + elseif(k.eq.lx-3) then + fxx = (2.d0*f(lx-6)-2.7d1*f(lx-5)+2.7d2*f(lx-4)-4.9d2*f(lx-3) & + +2.7d2*f(lx-2)-2.7d1*f(lx-1)+2.d0*f(lx))/1.8d2/dX + endif +#endif + +#endif + + return + + end subroutine rdderivs_x_point +!---- + subroutine rdderivs_xy_point(lx,ly,X,Y,f,fxy,i,j) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: lx,ly,i,j + real*8,intent(in),dimension(lx) :: X + real*8,intent(in),dimension(ly) :: Y + real*8,intent(in),dimension(lx,ly) :: f + real*8,intent(out) :: fxy + + real*8 :: dX,dY + + dX = X(2)-X(1) + dY = Y(2)-Y(1) +!! we only consider inner points +#if (ghost_width == 2) + if(i>1 .and. j>1.and.i2 .and. j>2.and.i3 .and. j>3.and.i4 .and. j>4.and.ieps) write(*,*) f + +return + +end subroutine check_daxiao +subroutine check_factor(T,crho,sigma,R,sst,Rmin) +implicit none +integer,intent(in) :: sst +real*8,intent(in) :: T,crho,sigma,R,Rmin + +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff + + hgr = R*Rmin/(1.d0-R) + tgrho = dtan(crho) + tgsigma = dtan(sigma) + tc = dsqrt((1.d0-dsin(crho)*dsin(sigma))/2.d0) + ts = dsqrt((1.d0+dsin(crho)*dsin(sigma))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + write(*,*) dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,0,gt,gp)*swtf**2 + + return + + end subroutine check_factor + +subroutine getdxs(T,crho,sigma,R,betax,KKx,CUx,DCUx,bDCUx,Wx,CJx,CJxx,DCJx,Cnux,CThetax,sst,Rmin) +implicit none +integer,intent(in) :: sst +real*8,intent(in) :: T,crho,sigma,R,Rmin +real*8,intent(out) :: betax,KKx,Wx +double complex,intent(out) :: CUx,DCUx,bDCUx,CJx,CJxx,DCJx,Cnux,CThetax + +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff +double complex :: beta0,C1,C2 +integer :: nu,m + + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + hgr = R*Rmin/(1.d0-R) + tgrho = dtan(crho) + tgsigma = dtan(sigma) + tc = dsqrt((1.d0-dsin(crho)*dsin(sigma))/2.d0) + ts = dsqrt((1.d0+dsin(crho)*dsin(sigma))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + betax = 0.d0 + + Jr = -(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr**2& + +2.d0*nu*nu*C2/hgr**3-3.d0*II*nu*C2/hgr**4-2.d0*C2/hgr**5 + Wx = dreal(Yslm(0,2,m,gt,gp))*dreal(Jr*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin +! Wx = dreal(Jr*cdexp(II*nu*T))*(Rmin+hgr)**2/Rmin + KKx = 0.d0 + + Jr = -2.d0*beta0/hgr/hgr-C1/hgr**3-II*nu*C2/hgr**4-C2/hgr**5 + rf = dreal(Jr*cdexp(II*nu*T)) + CUx = dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*rf*(Rmin+hgr)**2/Rmin +! CUx = rf*(Rmin+hgr)**2/Rmin + DCUx = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**2/Rmin +! DCUx = rf*(Rmin+hgr)**2/Rmin + bDCUx =-dble(2*(2+1))*Yslm(0,2,m,gt,gp)*rf*(Rmin+hgr)**2/Rmin +! bDCUx = rf*(Rmin+hgr)**2/Rmin + + Jr = -C1/4.d0/hgr**2+C2/4.d0/hgr**4 + rf = dreal(Jr*cdexp(II*nu*T)) + CJx = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**2/Rmin +! CJx = rf*(Rmin+hgr)**2/Rmin + Cnux =-dble((2-1)*(2+2))*dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*rf*(Rmin+hgr)**2/Rmin +! Cnux = rf*(Rmin+hgr)**2/Rmin + DCJx = 0.d0 + rf = dreal(Jr*II*nu*cdexp(II*nu*T)) + CThetax = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**2/Rmin +! CThetax = rf*(Rmin+hgr)**2/Rmin + Jr = C1/2.d0/hgr**3-C2/hgr**5 + rf = dreal(Jr*cdexp(II*nu*T)) + CJxx = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf*(Rmin+hgr)**4/Rmin**2+2.d0*(Rmin+hgr)/Rmin*CJx +! CJxx = rf*(Rmin+hgr)**4/Rmin**2+2.d0*(Rmin+hgr)/Rmin*CJx + +#if 0 + DCUx = DCUx*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 + CJx = CJx*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 + CJxx = CJxx*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 + CThetax = CThetax*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 +#endif + return + + end subroutine getdxs + +subroutine getndxs(T,crho,sigma,R,beta,KK,CU,bDCU,DCU,CB,DCB,W,CJ,DCJ,bDCB,Cnu,Ck,CTheta,sst,Rmin) +implicit none +integer,intent(in) :: sst +real*8,intent(in) :: T,crho,sigma,R,Rmin +real*8,intent(out) :: beta,KK,W +double complex,intent(out) :: CU,bDCU,DCU,CB,DCB,CJ,DCJ,bDCB,Cnu,Ck,CTheta + +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: Yslm,II,Jr,swtf,ff +double complex :: beta0,C1,C2 +integer :: nu,m + + call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + hgr = R*Rmin/(1.d0-R) + tgrho = dtan(crho) + tgsigma = dtan(sigma) + tc = dsqrt((1.d0-dsin(crho)*dsin(sigma))/2.d0) + ts = dsqrt((1.d0+dsin(crho)*dsin(sigma))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + beta = dreal(Yslm(0,2,m,gt,gp))*dreal(beta0*cdexp(II*nu*T)) +! beta = dreal(beta0*cdexp(II*nu*T)) + CB = dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*dreal(beta0*cdexp(II*nu*T)) +! CB = dreal(beta0*cdexp(II*nu*T)) + DCB = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*dreal(beta0*cdexp(II*nu*T)) +! DCB = dreal(beta0*cdexp(II*nu*T)) + bDCB =-dble(2*(2+1))*Yslm(0,2,m,gt,gp)*dreal(beta0*cdexp(II*nu*T)) +! bDCB = dreal(beta0*cdexp(II*nu*T)) + + Jr = (2.4d1*II*nu*beta0-3.d0*nu*nu*C1+nu**4*C2)/6.d0+(3.d0*II*nu*C1-6.d0*beta0-II*nu**3*C2)/3.d0/hgr& + -nu*nu*C2/hgr/hgr+II*nu*C2/hgr**3+C2/2.d0/hgr**4 + W = dreal(Yslm(0,2,m,gt,gp))*dreal(Jr*cdexp(II*nu*T)) +! W = dreal(Jr*cdexp(II*nu*T)) + + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0/hgr-C2/1.2d1/hgr**3 + rf = dreal(Jr*cdexp(II*nu*T)) + CJ = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf +! CJ = rf + DCJ = 0.d0 + Cnu =-dsqrt(dble((2+2)*(2-2+1)*(2-1)*2*(2+1)*(2+2)))*Yslm(1,2,m,gt,gp)*swtf*rf +! Cnu = rf + KK = dsqrt(1.d0+cdabs(CJ)**2) + Ck = 0.d0 + rf = dreal(Jr*II*nu*cdexp(II*nu*T)) + CTheta = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf +! CTheta = rf + + Jr = (-2.4d1*II*nu*beta0+3.d0*nu*nu*C1-nu**4*C2)/36.d0+2.d0*beta0/hgr& + +C1/2.d0/hgr/hgr+II*nu*C2/3.d0/hgr**3+C2/4.d0/hgr**4 + rf = dreal(Jr*cdexp(II*nu*T)) + CU = dsqrt(dble(2*(2+1)))*Yslm(1,2,m,gt,gp)*swtf*rf +! CU = rf + DCU = dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2*rf +! DCU = rf + bDCU =-dble(2*(2+1))*Yslm(0,2,m,gt,gp)*rf +! bDCU = rf + +#if 0 + DCU = DCU*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 + DCB = DCB*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 + CTheta = CTheta*dsqrt(dble((2-1)*2*(2+1)*(2+2)))*Yslm(2,2,m,gt,gp)*swtf**2 +#endif + return + + end subroutine getndxs +!-------------------------------------------------------------------- +! this R is indeed x +function Eq_Theta_2(ex,crho,sigma,R,RJ,IJ,RU,IU,beta,RB,IB, & + Rnu,Inu,Rk,Ik,RTheta,ITheta,W,Rmin, & + qlR1,qlR2,qlI1,qlI2,quR1,quR2,quI1,quI2,gR,gI, & + T,sst) result(gont) + implicit none + integer,intent(in ):: ex(1:3),sst + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: beta,W + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RJ,IJ,RU,IU,RB,IB,Rnu,Inu,Rk,Ik + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: RTheta,ITheta + real*8,intent(in) :: Rmin,T + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex,dimension(ex(1),ex(2),ex(3)) :: CU,DCU,bDCU,CB,DCB,bDCB,CJ,DCJ + double complex :: CTheta0,CTheta,CTheta1,RHS + integer :: i,j,k,RK4 + double complex,dimension(ex(3)) :: Cnu,Ck,HCnu,HCk,HCU,HDCU,CUx,HCUx,DCUx,HDCUx,HbDCU,bDCUx,HbDCUx + double complex,dimension(ex(3)) :: Cnux,HCnux,HCJ,HDCJ,CJx,HCJx,CJxx,HCJxx,DCJx,HDCJx,HCB,HDCB,HbDCB + double complex,dimension(ex(3)) :: fCTheta,CThetax + real*8,dimension(ex(3)) :: KK,KKx,HKK,HKKx,Hbeta,betax,Hbetax,HW,Wx,HWx + double complex :: Theta_rhs,Theta_rhs_o + real*8 :: dR + +!!! sanity check + dR = sum(RJ)+sum(IJ)+sum(RU)+sum(IU)+sum(beta)+sum(RB)+sum(IB) + & + sum(Rnu)+sum(Inu)+sum(Rk)+sum(Ik)+sum(RTheta)+sum(ITheta) + if(dR.ne.dR) then + if(sum(RJ).ne.sum(RJ))write(*,*)"NullEvol_Theta: find NaN in RJ" + if(sum(IJ).ne.sum(IJ))write(*,*)"NullEvol_Theta: find NaN in IJ" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_Theta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_Theta: find NaN in IU" + if(sum(beta).ne.sum(beta))write(*,*)"NullEvol_Theta: find NaN in beta" + if(sum(RB).ne.sum(RB))write(*,*)"NullEvol_Theta: find NaN in RB" + if(sum(IB).ne.sum(IB))write(*,*)"NullEvol_Theta: find NaN in IB" + if(sum(Rnu).ne.sum(Rnu))write(*,*)"NullEvol_Theta: find NaN in Rnu" + if(sum(Inu).ne.sum(Inu))write(*,*)"NullEvol_Theta: find NaN in Inu" + if(sum(Rk).ne.sum(Rk))write(*,*)"NullEvol_Theta: find NaN in Rk" + if(sum(Ik).ne.sum(Ik))write(*,*)"NullEvol_Theta: find NaN in Ik" + if(sum(RTheta).ne.sum(RTheta))write(*,*)"NullEvol_Theta: find NaN in RTheta" + if(sum(ITheta).ne.sum(ITheta))write(*,*)"NullEvol_Theta: find NaN in ITheta" + gont = 1 + return + endif + + dR = R(2) - R(1) + + CU = dcmplx(RU,IU) + CB = dcmplx(RB,IB) + CJ = dcmplx(RJ,IJ) + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),DCU(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CU(:,:,k),bDCU(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),DCB(:,:,k),1,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CB(:,:,k),bDCB(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,CJ(:,:,k),DCJ(:,:,k),2,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + + do j=ghost_width+1,ex(2)-ghost_width + do i=ghost_width+1,ex(1)-ghost_width + CTheta0 = dcmplx(RTheta(i,j,1),ITheta(i,j,1)) + fCTheta = dcmplx(RTheta(i,j,:),ITheta(i,j,:)) + call cderivs_x(ex(3),R,fCTheta,CThetax) + Cnu = dcmplx(Rnu(i,j,:),Inu(i,j,:)) + Ck = dcmplx(Rk(i,j,:),Ik(i,j,:)) + call cget_half_x(ex(3),CB(i,j,:),HCB) + call cget_half_x(ex(3),DCB(i,j,:),HDCB) + call cget_half_x(ex(3),bDCB(i,j,:),HbDCB) + call cget_half_x(ex(3),Cnu,HCnu) + call cderivs_x(ex(3),R,Cnu,Cnux) + call cget_half_x(ex(3),Cnux,HCnux) + call cget_half_x(ex(3),Ck,HCk) + call rget_half_x(ex(3),beta(i,j,:),Hbeta) + call rderivs_x(ex(3),R,beta(i,j,:),betax) + call rget_half_x(ex(3),betax,Hbetax) + KK = dsqrt(1.d0+RJ(i,j,:)*RJ(i,j,:)+IJ(i,j,:)*IJ(i,j,:)) + call rget_half_x(ex(3),KK,HKK) + call rderivs_x(ex(3),R,KK,KKx) + call rget_half_x(ex(3),KKx,HKKx) + call rderivs_x(ex(3),R,W,Wx) + call rget_half_x(ex(3),Wx,HWx) + call rget_half_x(ex(3),W(i,j,:),HW) + call cget_half_x(ex(3),CU(i,j,:),HCU) + call cderivs_x(ex(3),R,DCU(i,j,:),DCUx) + call cderivs_x(ex(3),R,CU(i,j,:),CUx) + call cget_half_x(ex(3),DCUx,HDCUx) + call cget_half_x(ex(3),CUx,HCUx) + call cget_half_x(ex(3),DCU(i,j,:),HDCU) + call cderivs_x(ex(3),R,bDCU(i,j,:),bDCUx) + call cget_half_x(ex(3),bDCUx,HbDCUx) + call cget_half_x(ex(3),bDCU(i,j,:),HbDCU) + call cderivs_x(ex(3),R,CJ(i,j,:),CJx) + call cdderivs_x(ex(3),R,CJ(i,j,:),CJxx) + call cget_half_x(ex(3),CJx,HCJx) + call cget_half_x(ex(3),CJxx,HCJxx) + call cderivs_x(ex(3),R,DCJ(i,j,:),DCJx) + call cget_half_x(ex(3),DCJx,HDCJx) + + RTheta(i,j,1) = 0.d0 + ITheta(i,j,1) = 0.d0 + do k=1,ex(3)-1 +! call getndxs(T,crho(i),sigma(j),R(k),beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k), & +! CB(i,j,k),DCB(i,j,k),W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k),sst,Rmin) +! call getdxs(T,crho(i),sigma(j),R(k),betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k), & +! Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k),sst,Rmin) + RHS = Theta_rhs(R(k),Rmin,beta(i,j,k),betax(k),KK(k),KKx(k),CU(i,j,k),CUx(k),DCUx(k),bDCU(i,j,k),bDCUx(k), & + DCU(i,j,k),CB(i,j,k),DCB(i,j,k),W(i,j,k),Wx(k),CJ(i,j,k),DCJ(i,j,k), & + CJx(k),CJxx(k),DCJx(k),bDCB(i,j,k),Cnu(k),Cnux(k),Ck(k),fCTheta(k)) + RHS = RHS - CThetax(k) +#if 0 + if(cdabs(RHS)>1.d-9)then +#if 0 + write(*,*)beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k),CB(i,j,k),DCB(i,j,k) + write(*,*)W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k) + call getndxs(T,crho(i),sigma(j),R(k),beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k), & + CB(i,j,k),DCB(i,j,k),W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k),sst,Rmin) + write(*,*)"VS" + write(*,*)beta(i,j,k),KK(k),CU(i,j,k),bDCU(i,j,k),DCU(i,j,k),CB(i,j,k),DCB(i,j,k) + write(*,*)W(i,j,k),CJ(i,j,k),DCJ(i,j,k),bDCB(i,j,k),Cnu(k),Ck(k),fCTheta(k) +#endif + write(*,*)betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k) + write(*,*)Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k) + call getdxs(T,crho(i),sigma(j),R(k),betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k), & + Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k),sst,Rmin) + write(*,*)"VS" + write(*,*)betax(k),KKx(k),CUx(k),DCUx(k),bDCUx(k) + write(*,*)Wx(k),CJx(k),CJxx(k),DCJx(k),Cnux(k),CThetax(k) +! write(*,*)RHS +! call check_factor(T,crho(i),sigma(j),R(k),sst,Rmin) + stop + endif +#endif + RTheta(i,j,k+1) = dreal(RHS) + ITheta(i,j,k+1) = dimag(RHS) + enddo + enddo + enddo + + gont = 0 + return + +end function Eq_Theta_2 diff --git a/AMSS_NCKU_source/NullEvol.h b/AMSS_NCKU_source/Null_Evolve/NullEvol.h similarity index 97% rename from AMSS_NCKU_source/NullEvol.h rename to AMSS_NCKU_source/Null_Evolve/NullEvol.h index 65a799d..7ece59b 100644 --- a/AMSS_NCKU_source/NullEvol.h +++ b/AMSS_NCKU_source/Null_Evolve/NullEvol.h @@ -1,225 +1,225 @@ - -#ifndef NULLEVOL_H -#define NULLEVOL_H - -#ifdef fortran1 -#define f_setup_dyad setup_dyad -#define f_eth_derivs eth_derivs -#define f_eth_dderivs eth_dderivs -#define f_fill_symmetric_boundarybuffer fill_symmetric_boundarybuffer -#define f_fill_symmetric_boundarybuffer2 fill_symmetric_boundarybuffer2 -#define f_calculate_K calculate_k -#define f_NullEvol_beta nullevol_beta -#define f_NullEvol_Q nullevol_q -#define f_NullEvol_U nullevol_u -#define f_NullEvol_W nullevol_w -#define f_NullEvol_Theta nullevol_theta -#define f_NullEvol_Theta_givenx nullevol_theta_givenx -#define f_Eq_Theta eq_theta -#define f_Eq_Theta_2 eq_theta_2 -#define f_NullEvol_g01 nullevol_g01 -#define f_NullEvol_pg0A nullevol_pg0a -#define f_NullEvol_Theta2 nullevol_theta2 -#define f_NullEvol_Thetag00 nullevol_thetag00 -#endif -#ifdef fortran2 -#define f_setup_dyad SETUP_DYAD -#define f_eth_derivs ETH_DERIVS -#define f_eth_dderivs ETH_DDERIVS -#define f_fill_symmetric_boundarybuffer FILL_SYMMETRIC_BOUNDARYBUFFER -#define f_fill_symmetric_boundarybuffer2 FILL_SYMMETRIC_BOUNDARYBUFFER2 -#define f_calculate_K CALCULATE_K -#define f_NullEvol_beta NULLEVOL_BETA -#define f_NullEvol_Q NULLEVOL_Q -#define f_NullEvol_U NULLEVOL_U -#define f_NullEvol_W NULLEVOL_W -#define f_NullEvol_Theta NULLEVOL_THETA -#define f_NullEvol_Theta_givenx NULLEVOL_THETA_GIVENX -#define f_Eq_Theta EQ_THETA -#define f_Eq_Theta_2 EQ_THETA_2 -#define f_NullEvol_g01 NULLEVOL_G01 -#define f_NullEvol_pg0A NULLEVOL_PG0A -#define f_NullEvol_Theta2 NULLEVOL_THETA2 -#define f_NullEvol_Thetag00 NULLEVOL_THETAG00 -#endif -#ifdef fortran3 -#define f_setup_dyad setup_dyad_ -#define f_eth_derivs eth_derivs_ -#define f_eth_dderivs eth_dderivs_ -#define f_fill_symmetric_boundarybuffer fill_symmetric_boundarybuffer_ -#define f_fill_symmetric_boundarybuffer2 fill_symmetric_boundarybuffer2_ -#define f_calculate_K calculate_k_ -#define f_NullEvol_beta nullevol_beta_ -#define f_NullEvol_Q nullevol_q_ -#define f_NullEvol_U nullevol_u_ -#define f_NullEvol_W nullevol_w_ -#define f_NullEvol_Theta nullevol_theta_ -#define f_NullEvol_Theta_givenx nullevol_theta_givenx_ -#define f_Eq_Theta eq_theta_ -#define f_Eq_Theta_2 eq_theta_2_ -#define f_NullEvol_g01 nullevol_g01_ -#define f_NullEvol_pg0A nullevol_pg0a_ -#define f_NullEvol_Theta2 nullevol_theta2_ -#define f_NullEvol_Thetag00 nullevol_thetag00_ -#endif - -extern "C" -{ - void f_setup_dyad(int *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - int &, double &); -} - -extern "C" -{ - void f_eth_derivs(int *, double *, double *, - double *, double *, - double *, double *, - int &, int &, - double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_eth_dderivs(int *, double *, double *, - double *, double *, - double *, double *, - int &, int &, int &, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *); -} - -extern "C" -{ - void f_fill_symmetric_boundarybuffer(int *, double *, double *, double *, - double &, double &, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, int &, int &, int &); -} - -extern "C" -{ - void f_fill_symmetric_boundarybuffer2(int *, double *, double *, double *, - double &, double &, - double *, int &, int &, double *); -} - -extern "C" -{ - void f_calculate_K(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *); -} - -extern "C" -{ - int f_NullEvol_beta(int *, double *, double *, double *, - double *, double *, double *, double *, double *); -} - -extern "C" -{ - int f_NullEvol_Q(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - int f_NullEvol_U(int *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double &); -} - -extern "C" -{ - int f_NullEvol_W(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, double &, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - int f_NullEvol_Theta(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double &, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - int f_NullEvol_Theta_givenx(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double &, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double &, int &); -} - -extern "C" -{ - int f_Eq_Theta(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double &, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - int f_Eq_Theta_2(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double &, - double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, - double &, int &); -} - -extern "C" -{ - int f_NullEvol_g01(int *, double *, double *, double *, - double *, double *, double *, double *, - double &); -} - -extern "C" -{ - int f_NullEvol_pg0A(int *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double &); -} - -extern "C" -{ - int f_NullEvol_Theta2(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double &); -} - -extern "C" -{ - int f_NullEvol_Thetag00(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double &); -} -#endif /* NULLEVOL_H */ + +#ifndef NULLEVOL_H +#define NULLEVOL_H + +#ifdef fortran1 +#define f_setup_dyad setup_dyad +#define f_eth_derivs eth_derivs +#define f_eth_dderivs eth_dderivs +#define f_fill_symmetric_boundarybuffer fill_symmetric_boundarybuffer +#define f_fill_symmetric_boundarybuffer2 fill_symmetric_boundarybuffer2 +#define f_calculate_K calculate_k +#define f_NullEvol_beta nullevol_beta +#define f_NullEvol_Q nullevol_q +#define f_NullEvol_U nullevol_u +#define f_NullEvol_W nullevol_w +#define f_NullEvol_Theta nullevol_theta +#define f_NullEvol_Theta_givenx nullevol_theta_givenx +#define f_Eq_Theta eq_theta +#define f_Eq_Theta_2 eq_theta_2 +#define f_NullEvol_g01 nullevol_g01 +#define f_NullEvol_pg0A nullevol_pg0a +#define f_NullEvol_Theta2 nullevol_theta2 +#define f_NullEvol_Thetag00 nullevol_thetag00 +#endif +#ifdef fortran2 +#define f_setup_dyad SETUP_DYAD +#define f_eth_derivs ETH_DERIVS +#define f_eth_dderivs ETH_DDERIVS +#define f_fill_symmetric_boundarybuffer FILL_SYMMETRIC_BOUNDARYBUFFER +#define f_fill_symmetric_boundarybuffer2 FILL_SYMMETRIC_BOUNDARYBUFFER2 +#define f_calculate_K CALCULATE_K +#define f_NullEvol_beta NULLEVOL_BETA +#define f_NullEvol_Q NULLEVOL_Q +#define f_NullEvol_U NULLEVOL_U +#define f_NullEvol_W NULLEVOL_W +#define f_NullEvol_Theta NULLEVOL_THETA +#define f_NullEvol_Theta_givenx NULLEVOL_THETA_GIVENX +#define f_Eq_Theta EQ_THETA +#define f_Eq_Theta_2 EQ_THETA_2 +#define f_NullEvol_g01 NULLEVOL_G01 +#define f_NullEvol_pg0A NULLEVOL_PG0A +#define f_NullEvol_Theta2 NULLEVOL_THETA2 +#define f_NullEvol_Thetag00 NULLEVOL_THETAG00 +#endif +#ifdef fortran3 +#define f_setup_dyad setup_dyad_ +#define f_eth_derivs eth_derivs_ +#define f_eth_dderivs eth_dderivs_ +#define f_fill_symmetric_boundarybuffer fill_symmetric_boundarybuffer_ +#define f_fill_symmetric_boundarybuffer2 fill_symmetric_boundarybuffer2_ +#define f_calculate_K calculate_k_ +#define f_NullEvol_beta nullevol_beta_ +#define f_NullEvol_Q nullevol_q_ +#define f_NullEvol_U nullevol_u_ +#define f_NullEvol_W nullevol_w_ +#define f_NullEvol_Theta nullevol_theta_ +#define f_NullEvol_Theta_givenx nullevol_theta_givenx_ +#define f_Eq_Theta eq_theta_ +#define f_Eq_Theta_2 eq_theta_2_ +#define f_NullEvol_g01 nullevol_g01_ +#define f_NullEvol_pg0A nullevol_pg0a_ +#define f_NullEvol_Theta2 nullevol_theta2_ +#define f_NullEvol_Thetag00 nullevol_thetag00_ +#endif + +extern "C" +{ + void f_setup_dyad(int *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + int &, double &); +} + +extern "C" +{ + void f_eth_derivs(int *, double *, double *, + double *, double *, + double *, double *, + int &, int &, + double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_eth_dderivs(int *, double *, double *, + double *, double *, + double *, double *, + int &, int &, int &, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *); +} + +extern "C" +{ + void f_fill_symmetric_boundarybuffer(int *, double *, double *, double *, + double &, double &, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, int &, int &, int &); +} + +extern "C" +{ + void f_fill_symmetric_boundarybuffer2(int *, double *, double *, double *, + double &, double &, + double *, int &, int &, double *); +} + +extern "C" +{ + void f_calculate_K(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *); +} + +extern "C" +{ + int f_NullEvol_beta(int *, double *, double *, double *, + double *, double *, double *, double *, double *); +} + +extern "C" +{ + int f_NullEvol_Q(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + int f_NullEvol_U(int *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double &); +} + +extern "C" +{ + int f_NullEvol_W(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, double &, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + int f_NullEvol_Theta(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double &, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + int f_NullEvol_Theta_givenx(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double &, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double &, int &); +} + +extern "C" +{ + int f_Eq_Theta(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double &, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + int f_Eq_Theta_2(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double &, + double *, double *, double *, double *, double *, double *, double *, double *, double *, double *, + double &, int &); +} + +extern "C" +{ + int f_NullEvol_g01(int *, double *, double *, double *, + double *, double *, double *, double *, + double &); +} + +extern "C" +{ + int f_NullEvol_pg0A(int *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double &); +} + +extern "C" +{ + int f_NullEvol_Theta2(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double &); +} + +extern "C" +{ + int f_NullEvol_Thetag00(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double &); +} +#endif /* NULLEVOL_H */ diff --git a/AMSS_NCKU_source/NullEvol2.f90 b/AMSS_NCKU_source/Null_Evolve/NullEvol2.f90 similarity index 97% rename from AMSS_NCKU_source/NullEvol2.f90 rename to AMSS_NCKU_source/Null_Evolve/NullEvol2.f90 index 8cd8cb8..eb5b015 100644 --- a/AMSS_NCKU_source/NullEvol2.f90 +++ b/AMSS_NCKU_source/Null_Evolve/NullEvol2.f90 @@ -1,4449 +1,4449 @@ - - -#include "macrodef.fh" - -!--------------------------------------------------------------------------------- -! fill symmetric boundary buffer points -!--------------------------------------------------------------------------------- -subroutine fill_symmetric_boundarybuffer2(ex,crho,sigma,R,drho,dsigma, & - var,Symmetry,sst,AoS) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in),dimension(3) :: ex - integer,intent(in) :: Symmetry,sst - real*8,dimension(3) :: AoS - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8,intent(in) :: drho,dsigma - real*8,intent(inout),dimension(ex(1),ex(2),ex(3)) :: var - - integer :: i,j,k,t - - select case (Symmetry) - case (0) - return - case (1) - if((sst==2.or.sst==4).and.dabs(sigma(1)+ghost_width*dsigma) < dsigma/2.d0)then - do k=1,ex(3) - do j=1,ghost_width - do i=1,ex(1) -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+2-j -#endif -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+1-j -#endif - var(i,j,k) = AoS(2)*var(i,t,k) - enddo - enddo - enddo - endif - if((sst==3.or.sst==5).and.dabs(sigma(ex(2))-ghost_width*dsigma) < dsigma/2.d0)then - do k=1,ex(3) - do j=ex(2)-ghost_width+1,ex(2) - do i=1,ex(1) - t = ex(2)-j+1 -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - t = ex(2)-2*ghost_width-1+t -#endif -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - t = ex(2)-2*ghost_width+t -#endif - var(i,j,k) = AoS(2)*var(i,t,k) - enddo - enddo - enddo - endif - case (2) - if(dabs(crho(1)+ghost_width*drho) < drho/2.d0)then - if(dabs(sigma(1)+ghost_width*dsigma) < dsigma/2.d0)then - do k=1,ex(3) - do j=1,ghost_width - do i=ghost_width+1,ex(1) -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+2-j -#endif -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+1-j -#endif - var(i,j,k) = AoS(2)*var(i,t,k) - enddo - enddo - enddo - endif - do k=1,ex(3) - do j=1,ex(2) - do i=1,ghost_width -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+2-i -#endif -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+1-i -#endif - var(i,j,k) = AoS(1)*var(t,j,k) - enddo - enddo - enddo - else - if(dabs(sigma(1)+ghost_width*dsigma) < dsigma/2.d0)then - do k=1,ex(3) - do j=1,ghost_width - do i=1,ex(1) -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+2-j -#endif -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - t = 2*ghost_width+1-j -#endif - var(i,j,k) = AoS(2)*var(i,t,k) - enddo - enddo - enddo - endif - endif - end select - - return - - end subroutine fill_symmetric_boundarybuffer2 -!--------------------------------------------------------------------------------- -!!!! using r^2g_AB instead of g_AB -!!!! using r^2g_0A instead of g_0A -!!!! using r^2g_00 instead of g_00 -!!!! using x in the metric form directly instead of r -!--------------------------------------------------------------------------------- -! this R is indeed x -function NullEvol_g01(ex,crho,sigma,R, & - g22,g23,g33,g01,Rmin) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in ):: Rmin - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: g01 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g22,g23,g33 -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - real*8, dimension(ex(3)):: dg22,dg23,dg33,ddg22,ddg23,ddg33 - real*8, dimension(ex(3)):: Hg22,Hg23,Hg33 - real*8, dimension(ex(3)):: Hdg22,Hdg23,Hdg33,Hddg22,Hddg23,Hddg33 - real*8 :: g010,g011,g01h,rhs - integer :: i,j,k,RK4 - -!!! sanity check - dR = sum(g22)+sum(g23)+sum(g33)+sum(g01) - if(dR.ne.dR) then - if(sum(g22).ne.sum(g22))write(*,*)"NullEvol_g01: find NaN in g22" - if(sum(g23).ne.sum(g23))write(*,*)"NullEvol_g01: find NaN in g23" - if(sum(g33).ne.sum(g33))write(*,*)"NullEvol_g01: find NaN in g33" - if(sum(g01).ne.sum(g01))write(*,*)"NullEvol_g01: find NaN in g01" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - g010 = g01(i,j,1) - - call rderivs_x(ex(3),R,g22(i,j,:),dg22) - call rderivs_x(ex(3),R,g23(i,j,:),dg23) - call rderivs_x(ex(3),R,g33(i,j,:),dg33) - call rdderivs_x(ex(3),R,g22(i,j,:),ddg22) - call rdderivs_x(ex(3),R,g23(i,j,:),ddg23) - call rdderivs_x(ex(3),R,g33(i,j,:),ddg33) - - call rget_half_x(ex(3),g22(i,j,:),Hg22) - call rget_half_x(ex(3),g23(i,j,:),Hg23) - call rget_half_x(ex(3),g33(i,j,:),Hg33) - - call rget_half_x(ex(3),dg22,Hdg22) - call rget_half_x(ex(3),dg23,Hdg23) - call rget_half_x(ex(3),dg33,Hdg33) - - call rget_half_x(ex(3),ddg22,Hddg22) - call rget_half_x(ex(3),ddg23,Hddg23) - call rget_half_x(ex(3),ddg33,Hddg33) - - do k=1,ex(3)-2 - RK4 = 0 - call get_g01_rhs(R(k),g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & - dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k),rhs) - call rungekutta4_scalar(dR,g010,g01h,rhs,RK4) - - RK4 = 1 - call get_g01_rhs(R(k)+dR/2,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & - Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),g01h,g011) - call rungekutta4_scalar(dR,g010,g011,rhs,RK4) - call rswap(g01h,g011) - - RK4 = 2 - call get_g01_rhs(R(k)+dR/2,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & - Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),g01h,g011) - call rungekutta4_scalar(dR,g010,g011,rhs,RK4) - call rswap(g01h,g011) - - RK4 = 3 - call get_g01_rhs(R(k+1),g22(i,j,k+1),g23(i,j,k+1),g33(i,j,k+1),dg22(k+1),dg23(k+1), & - dg33(k+1),ddg22(k+1),ddg23(k+1),ddg33(k+1),g01h,g011) - call rungekutta4_scalar(dR,g010,g011,rhs,RK4) - call rswap(g010,g011) - - g01(i,j,k+1) = g010 - enddo -! closing step - k = ex(3)-1 - call get_g01_rhs(R(k),g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & - dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k),rhs) - g01(i,j,k+1) = g01(i,j,k) + rhs*dR - - enddo - enddo - - gont = 0 - - return - -end function NullEvol_g01 -!------------------------------------------------------------------------------ -! this R is indeed x -function NullEvol_pg0a(ex,crho,sigma,R, & - g22,g23,g33,g01,p02,p03,g02,g03,Rmin) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in ):: Rmin - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: p02,p03,g02,g03 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g22,g23,g33,g01 -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - real*8, dimension(ex(3)) :: Hg01 - real*8, dimension(ex(3)) :: Hg22,Hg23,Hg33 - - real*8, dimension(ex(3)) :: dg01,dg02,dg03 - real*8, dimension(ex(3)) :: dgx01,dgx22,dgx23,dgx33 - real*8, dimension(ex(3)) :: dgy01,dgy22,dgy23,dgy33 - real*8, dimension(ex(3)) :: ddgxr01,ddgxr22,ddgxr23,ddgxr33 - real*8, dimension(ex(3)) :: ddgyr01,ddgyr22,ddgyr23,ddgyr33 - real*8, dimension(ex(3)) :: dg22,dg23,dg33,ddg22,ddg23,ddg33 - real*8, dimension(ex(3)) :: Hdg01,Hdg02,Hdg03 - real*8, dimension(ex(3)) :: Hdgx01,Hdgx22,Hdgx23,Hdgx33 - real*8, dimension(ex(3)) :: Hdgy01,Hdgy22,Hdgy23,Hdgy33 - real*8, dimension(ex(3)) :: Hddgxr01,Hddgxr22,Hddgxr23,Hddgxr33 - real*8, dimension(ex(3)) :: Hddgyr01,Hddgyr22,Hddgyr23,Hddgyr33 - real*8, dimension(ex(3)) :: Hdg22,Hdg23,Hdg33,Hddg22,Hddg23,Hddg33 - - real*8 :: p020,p021,p02h,p02_rhs - real*8 :: p030,p031,p03h,p03_rhs - real*8 :: g020,g021,g02h,g02_rhs - real*8 :: g030,g031,g03h,g03_rhs - integer :: i,j,k,RK4 - -!!! sanity check - dR = sum(g22)+sum(g23)+sum(g33)+sum(g01) & - +sum(p02)+sum(p03)+sum(g02)+sum(g03) - if(dR.ne.dR) then - if(sum(g22).ne.sum(g22))write(*,*)"NullEvol_pg0a: find NaN in g22" - if(sum(g23).ne.sum(g23))write(*,*)"NullEvol_pg0a: find NaN in g23" - if(sum(g33).ne.sum(g33))write(*,*)"NullEvol_pg0a: find NaN in g33" - if(sum(g01).ne.sum(g01))write(*,*)"NullEvol_pg0a: find NaN in g01" - if(sum(p02).ne.sum(p02))write(*,*)"NullEvol_pg0a: find NaN in p02" - if(sum(p03).ne.sum(p03))write(*,*)"NullEvol_pg0a: find NaN in p03" - if(sum(g02).ne.sum(g02))write(*,*)"NullEvol_pg0a: find NaN in g02" - if(sum(g03).ne.sum(g03))write(*,*)"NullEvol_pg0a: find NaN in g03" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - - call rderivs_x(ex(3),R,g01(i,j,:),dg01) - dg02 = p02(i,j,:) - dg03 = p03(i,j,:) - call rderivs_x(ex(3),R,g22(i,j,:),dg22) - call rderivs_x(ex(3),R,g23(i,j,:),dg23) - call rderivs_x(ex(3),R,g33(i,j,:),dg33) - call rdderivs_x(ex(3),R,g22(i,j,:),ddg22) - call rdderivs_x(ex(3),R,g23(i,j,:),ddg23) - call rdderivs_x(ex(3),R,g33(i,j,:),ddg33) - - do k=1,ex(3) - call rderivs_x_point(ex(1),crho,g01(:,j,k),dgx01(k),i) - call rderivs_x_point(ex(1),crho,g22(:,j,k),dgx22(k),i) - call rderivs_x_point(ex(1),crho,g23(:,j,k),dgx23(k),i) - call rderivs_x_point(ex(1),crho,g33(:,j,k),dgx33(k),i) - - call rderivs_x_point(ex(2),sigma,g01(i,:,k),dgy01(k),j) - call rderivs_x_point(ex(2),sigma,g22(i,:,k),dgy22(k),j) - call rderivs_x_point(ex(2),sigma,g23(i,:,k),dgy23(k),j) - call rderivs_x_point(ex(2),sigma,g33(i,:,k),dgy33(k),j) - - call rdderivs_xy_point(ex(1),ex(3),crho,R,g01(:,j,:),ddgxr01(k),i,k) - call rdderivs_xy_point(ex(1),ex(3),crho,R,g22(:,j,:),ddgxr22(k),i,k) - call rdderivs_xy_point(ex(1),ex(3),crho,R,g23(:,j,:),ddgxr23(k),i,k) - call rdderivs_xy_point(ex(1),ex(3),crho,R,g33(:,j,:),ddgxr33(k),i,k) - - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g01(i,:,:),ddgyr01(k),j,k) - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g22(i,:,:),ddgyr22(k),j,k) - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g23(i,:,:),ddgyr23(k),j,k) - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g33(i,:,:),ddgyr33(k),j,k) - enddo - - call rget_half_x(ex(3),g01(i,j,:),Hg01) - call rget_half_x(ex(3),g22(i,j,:),Hg22) - call rget_half_x(ex(3),g23(i,j,:),Hg23) - call rget_half_x(ex(3),g33(i,j,:),Hg33) - - call rget_half_x(ex(3),dg01,Hdg01) - call rget_half_x(ex(3),dg02,Hdg02) - call rget_half_x(ex(3),dg03,Hdg03) - - call rget_half_x(ex(3),dgx01,Hdgx01) - call rget_half_x(ex(3),dgy01,Hdgy01) - - call rget_half_x(ex(3),dgx22,Hdgx22) - call rget_half_x(ex(3),dgx23,Hdgx23) - call rget_half_x(ex(3),dgx33,Hdgx33) - call rget_half_x(ex(3),dgy22,Hdgy22) - call rget_half_x(ex(3),dgy23,Hdgy23) - call rget_half_x(ex(3),dgy33,Hdgy33) - - call rget_half_x(ex(3),ddgxr01,Hddgxr01) - call rget_half_x(ex(3),ddgyr01,Hddgyr01) - - call rget_half_x(ex(3),ddgxr22,Hddgxr22) - call rget_half_x(ex(3),ddgxr23,Hddgxr23) - call rget_half_x(ex(3),ddgxr33,Hddgxr33) - call rget_half_x(ex(3),ddgyr22,Hddgyr22) - call rget_half_x(ex(3),ddgyr23,Hddgyr23) - call rget_half_x(ex(3),ddgyr33,Hddgyr33) - - call rget_half_x(ex(3),dg22,Hdg22) - call rget_half_x(ex(3),dg23,Hdg23) - call rget_half_x(ex(3),dg33,Hdg33) - call rget_half_x(ex(3),ddg22,Hddg22) - call rget_half_x(ex(3),ddg23,Hddg23) - call rget_half_x(ex(3),ddg33,Hddg33) - -#if 0 - g020 = g02(i,j,1) - g030 = g03(i,j,1) - p020 = p02(i,j,1) - p030 = p03(i,j,1) - - do k=1,ex(3)-2 - RK4 = 0 - call pg0a_rhs(Rmin,R(k),p020,p030,g020,g030,g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & - dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & - dg01(k),dg02(k),dg03(k), & - dgx01(k),dgx22(k),dgx23(k),dgx33(k), & - dgy01(k),dgy22(k),dgy23(k),dgy33(k), & - ddgxr01(k),ddgxr22(k),ddgxr23(k),ddgxr33(k), & - ddgyr01(k),ddgyr22(k),ddgyr23(k),ddgyr33(k), & - g02_rhs,g03_rhs,p02_rhs,p03_rhs) - call rungekutta4_scalar(dR,g020,g02h,g02_rhs,RK4) - call rungekutta4_scalar(dR,g030,g03h,g03_rhs,RK4) - call rungekutta4_scalar(dR,p020,p02h,p02_rhs,RK4) - call rungekutta4_scalar(dR,p030,p03h,p03_rhs,RK4) - - RK4 = 1 - call pg0a_rhs(Rmin,R(k)+dR/2,p02h,p03h,g02h,g03h,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & - Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & - Hdg01(k),Hdg02(k),Hdg03(k), & - Hdgx01(k),Hdgx22(k),Hdgx23(k),Hdgx33(k), & - Hdgy01(k),Hdgy22(k),Hdgy23(k),Hdgy33(k), & - Hddgxr01(k),Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & - Hddgyr01(k),Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & - g021,g031,p021,p031) - call rungekutta4_scalar(dR,g020,g021,g02_rhs,RK4) - call rungekutta4_scalar(dR,g030,g031,g03_rhs,RK4) - call rungekutta4_scalar(dR,p020,p021,p02_rhs,RK4) - call rungekutta4_scalar(dR,p030,p031,p03_rhs,RK4) - call rswap(g02h,g021) - call rswap(g03h,g031) - call rswap(p02h,p021) - call rswap(p03h,p031) - - RK4 = 2 - call pg0a_rhs(Rmin,R(k)+dR/2,p02h,p03h,g02h,g03h,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & - Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & - Hdg01(k),Hdg02(k),Hdg03(k), & - Hdgx01(k),Hdgx22(k),Hdgx23(k),Hdgx33(k), & - Hdgy01(k),Hdgy22(k),Hdgy23(k),Hdgy33(k), & - Hddgxr01(k),Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & - Hddgyr01(k),Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & - g021,g031,p021,p031) - call rungekutta4_scalar(dR,g020,g021,g02_rhs,RK4) - call rungekutta4_scalar(dR,g030,g031,g03_rhs,RK4) - call rungekutta4_scalar(dR,p020,p021,p02_rhs,RK4) - call rungekutta4_scalar(dR,p030,p031,p03_rhs,RK4) - call rswap(g02h,g021) - call rswap(g03h,g031) - call rswap(p02h,p021) - call rswap(p03h,p031) - - RK4 = 3 - call pg0a_rhs(Rmin,R(k+1),p02h,p03h,g02h,g03h,Hg22(k+1),Hg23(k+1),Hg33(k+1),Hdg22(k+1),Hdg23(k+1), & - Hdg33(k+1),Hddg22(k+1),Hddg23(k+1),Hddg33(k+1),Hg01(k+1), & - Hdg01(k+1),Hdg02(k+1),Hdg03(k+1), & - Hdgx01(k+1),Hdgx22(k+1),Hdgx23(k+1),Hdgx33(k+1), & - Hdgy01(k+1),Hdgy22(k+1),Hdgy23(k+1),Hdgy33(k+1), & - Hddgxr01(k+1),Hddgxr22(k+1),Hddgxr23(k+1),Hddgxr33(k+1), & - Hddgyr01(k+1),Hddgyr22(k+1),Hddgyr23(k+1),Hddgyr33(k+1), & - g021,g031,p021,p031) - call rungekutta4_scalar(dR,g020,g021,g02_rhs,RK4) - call rungekutta4_scalar(dR,g030,g031,g03_rhs,RK4) - call rungekutta4_scalar(dR,p020,p021,p02_rhs,RK4) - call rungekutta4_scalar(dR,p030,p031,p03_rhs,RK4) - call rswap(g020,g021) - call rswap(g030,g031) - call rswap(p020,p021) - call rswap(p030,p031) - - g02(i,j,k+1) = g020 - g03(i,j,k+1) = g030 - p02(i,j,k+1) = p020 - p03(i,j,k+1) = p030 - - enddo - k=ex(3)-1 -! closing step - call pg0a_rhs(Rmin,R(k),p020,p030,g020,g030,g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & - dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & - dg01(k),dg02(k),dg03(k), & - dgx01(k),dgx22(k),dgx23(k),dgx33(k), & - dgy01(k),dgy22(k),dgy23(k),dgy33(k), & - ddgxr01(k),ddgxr22(k),ddgxr23(k),ddgxr33(k), & - ddgyr01(k),ddgyr22(k),ddgyr23(k),ddgyr33(k), & - g02_rhs,g03_rhs,p02_rhs,p03_rhs) - g02(i,j,k+1) = g02(i,j,k) + g02_rhs*dR - g03(i,j,k+1) = g03(i,j,k) + g03_rhs*dR - p02(i,j,k+1) = p02(i,j,k) + p02_rhs*dR - p03(i,j,k+1) = p03(i,j,k) + p03_rhs*dR -#endif - - enddo - enddo - - gont = 0 - - return - -end function NullEvol_pg0a -!------------------------------------------------------------------------------ -! this R is indeed x -function NullEvol_Theta2(ex,crho,sigma,R, & - g22,g23,g33,g00,g01,g02,g03,p02,p03, & - Theta22,Theta23,Theta33,Rmin) result(gont) - implicit none - integer,intent(in ):: ex(1:3) - real*8,intent(in ):: Rmin - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g00 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g02,g03,p02,p03 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g22,g23,g33,g01 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Theta22,Theta23,Theta33 -! gont = 0: success; gont = 1: something wrong - integer::gont - real*8 :: dR - - real*8,dimension(ex(3)) :: dg22,dg23,dg33,ddg22,ddg23,ddg33 - real*8,dimension(ex(3)) :: dg00,dg01,dg02,dg03 - real*8,dimension(ex(3)) :: dgx01,dgx02,dgx03 - real*8,dimension(ex(3)) :: dgy01,dgy02,dgy03 - real*8,dimension(ex(3)) :: dgx22,dgx23,dgx33 - real*8,dimension(ex(3)) :: dgy22,dgy23,dgy33 - real*8,dimension(ex(3)) :: ddgxx01,ddgxx33,ddgyy01,ddgyy22,ddgxy23 - real*8,dimension(ex(3)) :: ddgxy01,ddgxr02,ddgxr03,ddgyr02,ddgyr03 - real*8,dimension(ex(3)) :: ddgxr22,ddgxr23,ddgxr33,ddgyr22,ddgyr23,ddgyr33 - - real*8,dimension(ex(3)) :: Hdg22,Hdg23,Hdg33,Hddg22,Hddg23,Hddg33 - real*8,dimension(ex(3)) :: Hdg00,Hdg01,Hdg02,Hdg03 - real*8,dimension(ex(3)) :: Hdgx01,Hdgx02,Hdgx03 - real*8,dimension(ex(3)) :: Hdgy01,Hdgy02,Hdgy03 - real*8,dimension(ex(3)) :: Hdgx22,Hdgx23,Hdgx33 - real*8,dimension(ex(3)) :: Hdgy22,Hdgy23,Hdgy33 - real*8,dimension(ex(3)) :: Hddgxx01,Hddgxx33,Hddgyy01,Hddgyy22,Hddgxy23 - real*8,dimension(ex(3)) :: Hddgxy01,Hddgxr02,Hddgxr03,Hddgyr02,Hddgyr03 - real*8,dimension(ex(3)) :: Hddgxr22,Hddgxr23,Hddgxr33,Hddgyr22,Hddgyr23,Hddgyr33 - - real*8,dimension(ex(3)) :: Hg00,Hg01,Hg02,Hg03,Hg22,Hg23,Hg33 - real*8,dimension(ex(3)) :: HTheta22,HTheta23,HTheta33 - - real*8 :: Theta220,Theta221,Theta22h,Theta22_rhs - real*8 :: Theta230,Theta231,Theta23h,Theta23_rhs - real*8 :: Theta330,Theta331,Theta33h,Theta33_rhs - integer :: i,j,k,RK4 - -!!! sanity check - dR = sum(g22)+sum(g23)+sum(g33)+sum(g01) & - +sum(g00)+sum(g02)+sum(g03) & - +sum(Theta22)+sum(Theta23)+sum(Theta33) - if(dR.ne.dR) then - if(sum(g22).ne.sum(g22))write(*,*)"NullEvol_Theta: find NaN in g22" - if(sum(g23).ne.sum(g23))write(*,*)"NullEvol_Theta: find NaN in g23" - if(sum(g33).ne.sum(g33))write(*,*)"NullEvol_Theta: find NaN in g33" - if(sum(g01).ne.sum(g01))write(*,*)"NullEvol_Theta: find NaN in g01" - if(sum(g00).ne.sum(g00))write(*,*)"NullEvol_Theta: find NaN in g00" - if(sum(g02).ne.sum(g02))write(*,*)"NullEvol_Theta: find NaN in g02" - if(sum(g03).ne.sum(g03))write(*,*)"NullEvol_Theta: find NaN in g03" - if(sum(Theta22).ne.sum(Theta22))write(*,*)"NullEvol_Theta: find NaN in Theta22" - if(sum(Theta23).ne.sum(Theta23))write(*,*)"NullEvol_Theta: find NaN in Theta23" - if(sum(Theta33).ne.sum(Theta33))write(*,*)"NullEvol_Theta: find NaN in Theta33" - gont = 1 - return - endif - - dR = R(2) - R(1) - - do j=1,ex(2) - do i=1,ex(1) - call rderivs_x(ex(3),R,g00(i,j,:),dg00) - call rderivs_x(ex(3),R,g01(i,j,:),dg01) - dg02 = p02(i,j,:) - dg03 = p03(i,j,:) - - call rderivs_x(ex(3),R,g22(i,j,:),dg22) - call rderivs_x(ex(3),R,g23(i,j,:),dg23) - call rderivs_x(ex(3),R,g33(i,j,:),dg33) - call rdderivs_x(ex(3),R,g22(i,j,:),ddg22) - call rdderivs_x(ex(3),R,g23(i,j,:),ddg23) - call rdderivs_x(ex(3),R,g33(i,j,:),ddg33) - - do k=1,ex(3) - call rderivs_x_point(ex(1),crho,g01(:,j,k),dgx01(k),i) - call rderivs_x_point(ex(1),crho,g02(:,j,k),dgx02(k),i) - call rderivs_x_point(ex(1),crho,g03(:,j,k),dgx03(k),i) - - call rderivs_x_point(ex(2),sigma,g01(i,:,k),dgy01(k),j) - call rderivs_x_point(ex(2),sigma,g02(i,:,k),dgy02(k),j) - call rderivs_x_point(ex(2),sigma,g03(i,:,k),dgy03(k),j) - - call rderivs_x_point(ex(1),crho,g22(:,j,k),dgx22(k),i) - call rderivs_x_point(ex(1),crho,g23(:,j,k),dgx23(k),i) - call rderivs_x_point(ex(1),crho,g33(:,j,k),dgx33(k),i) - - call rderivs_x_point(ex(2),sigma,g22(i,:,k),dgy22(k),j) - call rderivs_x_point(ex(2),sigma,g23(i,:,k),dgy23(k),j) - call rderivs_x_point(ex(2),sigma,g33(i,:,k),dgy33(k),j) - - call rdderivs_x_point(ex(1),crho,g01(:,j,k),ddgxx01(k),i) - call rdderivs_x_point(ex(1),crho,g33(:,j,k),ddgxx33(k),i) - - call rdderivs_x_point(ex(2),sigma,g01(i,:,k),ddgyy01(k),j) - call rdderivs_x_point(ex(2),sigma,g22(i,:,k),ddgyy22(k),j) - - call rderivs_x_point(ex(1),crho,p02(:,j,k),ddgxr02(k),i) - call rderivs_x_point(ex(1),crho,p03(:,j,k),ddgxr03(k),i) - - call rderivs_x_point(ex(2),sigma,p02(i,:,k),ddgyr02(k),j) - call rderivs_x_point(ex(2),sigma,p03(i,:,k),ddgyr03(k),j) - - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,g01(:,:,k),ddgxy01(k),i,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,g23(:,:,k),ddgxy23(k),i,j) - - call rdderivs_xy_point(ex(1),ex(3),crho,R,g22(:,j,:),ddgxr22(k),i,k) - call rdderivs_xy_point(ex(1),ex(3),crho,R,g23(:,j,:),ddgxr23(k),i,k) - call rdderivs_xy_point(ex(1),ex(3),crho,R,g33(:,j,:),ddgxr33(k),i,k) - - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g22(i,:,:),ddgyr22(k),j,k) - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g23(i,:,:),ddgyr23(k),j,k) - call rdderivs_xy_point(ex(2),ex(3),sigma,R,g33(i,:,:),ddgyr33(k),j,k) - enddo - - call rget_half_x(ex(3),g00(i,j,:),Hg00) - call rget_half_x(ex(3),g01(i,j,:),Hg01) - call rget_half_x(ex(3),g02(i,j,:),Hg02) - call rget_half_x(ex(3),g03(i,j,:),Hg03) - call rget_half_x(ex(3),g22(i,j,:),Hg22) - call rget_half_x(ex(3),g23(i,j,:),Hg23) - call rget_half_x(ex(3),g33(i,j,:),Hg33) - call rget_half_x(ex(3),Theta22(i,j,:),HTheta22) - call rget_half_x(ex(3),Theta23(i,j,:),HTheta23) - call rget_half_x(ex(3),Theta33(i,j,:),HTheta33) - - call rget_half_x(ex(3),dg22,Hdg22) - call rget_half_x(ex(3),dg23,Hdg23) - call rget_half_x(ex(3),dg33,Hdg33) - call rget_half_x(ex(3),ddg22,Hddg22) - call rget_half_x(ex(3),ddg23,Hddg23) - call rget_half_x(ex(3),ddg33,Hddg33) - call rget_half_x(ex(3),dg00,Hdg00) - call rget_half_x(ex(3),dg01,Hdg01) - call rget_half_x(ex(3),dg02,Hdg02) - call rget_half_x(ex(3),dg03,Hdg03) - call rget_half_x(ex(3),dgx01,Hdgx01) - call rget_half_x(ex(3),dgx02,Hdgx02) - call rget_half_x(ex(3),dgx03,Hdgx03) - call rget_half_x(ex(3),dgy01,Hdgy01) - call rget_half_x(ex(3),dgy02,Hdgy02) - call rget_half_x(ex(3),dgy03,Hdgy03) - call rget_half_x(ex(3),dgx22,Hdgx22) - call rget_half_x(ex(3),dgx23,Hdgx23) - call rget_half_x(ex(3),dgx33,Hdgx33) - call rget_half_x(ex(3),dgy22,Hdgy22) - call rget_half_x(ex(3),dgy23,Hdgy23) - call rget_half_x(ex(3),dgy33,Hdgy33) - call rget_half_x(ex(3),ddgxx01,Hddgxx01) - call rget_half_x(ex(3),ddgxx33,Hddgxx33) - call rget_half_x(ex(3),ddgyy01,Hddgyy01) - call rget_half_x(ex(3),ddgyy22,Hddgyy22) - call rget_half_x(ex(3),ddgxy23,Hddgxy23) - call rget_half_x(ex(3),ddgxy01,Hddgxy01) - call rget_half_x(ex(3),ddgxr02,Hddgxr02) - call rget_half_x(ex(3),ddgxr03,Hddgxr03) - call rget_half_x(ex(3),ddgyr02,Hddgyr02) - call rget_half_x(ex(3),ddgyr03,Hddgyr03) - call rget_half_x(ex(3),ddgxr22,Hddgxr22) - call rget_half_x(ex(3),ddgxr23,Hddgxr23) - call rget_half_x(ex(3),ddgxr33,Hddgxr33) - call rget_half_x(ex(3),ddgyr22,Hddgyr22) - call rget_half_x(ex(3),ddgyr23,Hddgyr23) - call rget_half_x(ex(3),ddgyr33,Hddgyr33) - -#if 0 - Theta220 = Theta22(i,j,1) - Theta230 = Theta23(i,j,1) - Theta330 = Theta33(i,j,1) - - do k=1,ex(3)-2 - RK4 = 0 - call Theta_rhs2(Rmin,R(k),g00(i,j,k),g02(i,j,k),g03(i,j,k),g22(i,j,k),g23(i,j,k),g33(i,j,k), & - dg22(k),dg23(k),dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & - Theta220,Theta230,Theta330, & - dg01(k),dg02(k),dg03(k), & - dgx01(k),dgx02(k),dgx03(k), & - dgy01(k),dgy02(k),dgy03(k), & - dgx22(k),dgx23(k),dgx33(k), & - dgy22(k),dgy23(k),dgy33(k), & - dg00(k), & - ddgxx01(k), & - ddgxx33(k), & - ddgyy01(k), & - ddgyy22(k), & - ddgxy23(k), & - ddgxy01(k), & - ddgxr02(k),ddgxr03(k), & - ddgyr02(k),ddgyr03(k), & - ddgxr22(k),ddgxr23(k),ddgxr33(k), & - ddgyr22(k),ddgyr23(k),ddgyr33(k), & - Theta22_rhs,Theta23_rhs,Theta33_rhs) - call rungekutta4_scalar(dR,Theta220,Theta22h,Theta22_rhs,RK4) - call rungekutta4_scalar(dR,Theta230,Theta23h,Theta23_rhs,RK4) - call rungekutta4_scalar(dR,Theta330,Theta33h,Theta33_rhs,RK4) - - RK4 = 1 - - call Theta_rhs2(Rmin,R(k)+dR/2,Hg00(k),Hg02(k),Hg03(k),Hg22(k),Hg23(k),Hg33(k), & - Hdg22(k),Hdg23(k),Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & - Theta22h,Theta23h,Theta33h, & - Hdg01(k),Hdg02(k),Hdg03(k), & - Hdgx01(k),Hdgx02(k),Hdgx03(k), & - Hdgy01(k),Hdgy02(k),Hdgy03(k), & - Hdgx22(k),Hdgx23(k),Hdgx33(k), & - Hdgy22(k),Hdgy23(k),Hdgy33(k), & - Hdg00(k), & - Hddgxx01(k), & - Hddgxx33(k), & - Hddgyy01(k), & - Hddgyy22(k), & - Hddgxy23(k), & - Hddgxy01(k), & - Hddgxr02(k),Hddgxr03(k), & - Hddgyr02(k),Hddgyr03(k), & - Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & - Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & - Theta221,Theta231,Theta331) - - call rungekutta4_scalar(dR,Theta220,Theta221,Theta22_rhs,RK4) - call rungekutta4_scalar(dR,Theta230,Theta231,Theta23_rhs,RK4) - call rungekutta4_scalar(dR,Theta330,Theta331,Theta33_rhs,RK4) - call rswap(Theta22h,Theta221) - call rswap(Theta23h,Theta231) - call rswap(Theta33h,Theta331) - - RK4 = 2 - call Theta_rhs2(Rmin,R(k)+dR/2,Hg00(k),Hg02(k),Hg03(k),Hg22(k),Hg23(k),Hg33(k), & - Hdg22(k),Hdg23(k),Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & - Theta22h,Theta23h,Theta33h, & - Hdg01(k),Hdg02(k),Hdg03(k), & - Hdgx01(k),Hdgx02(k),Hdgx03(k), & - Hdgy01(k),Hdgy02(k),Hdgy03(k), & - Hdgx22(k),Hdgx23(k),Hdgx33(k), & - Hdgy22(k),Hdgy23(k),Hdgy33(k), & - Hdg00(k), & - Hddgxx01(k), & - Hddgxx33(k), & - Hddgyy01(k), & - Hddgyy22(k), & - Hddgxy23(k), & - Hddgxy01(k), & - Hddgxr02(k),Hddgxr03(k), & - Hddgyr02(k),Hddgyr03(k), & - Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & - Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & - Theta221,Theta231,Theta331) - - call rungekutta4_scalar(dR,Theta220,Theta221,Theta22_rhs,RK4) - call rungekutta4_scalar(dR,Theta230,Theta231,Theta23_rhs,RK4) - call rungekutta4_scalar(dR,Theta330,Theta331,Theta33_rhs,RK4) - call rswap(Theta22h,Theta221) - call rswap(Theta23h,Theta231) - call rswap(Theta33h,Theta331) - - RK4 = 3 - call Theta_rhs2(Rmin,R(k+1),g00(i,j,k+1),g02(i,j,k+1),g03(i,j,k+1),g22(i,j,k+1),g23(i,j,k+1),g33(i,j,k+1), & - dg22(k+1),dg23(k+1),dg33(k+1),ddg22(k+1),ddg23(k+1),ddg33(k+1),g01(i,j,k+1), & - Theta22h,Theta23h,Theta33h, & - dg01(k+1),dg02(k+1),dg03(k+1), & - dgx01(k+1),dgx02(k+1),dgx03(k+1), & - dgy01(k+1),dgy02(k+1),dgy03(k+1), & - dgx22(k+1),dgx23(k+1),dgx33(k+1), & - dgy22(k+1),dgy23(k+1),dgy33(k+1), & - dg00(k+1), & - ddgxx01(k+1), & - ddgxx33(k+1), & - ddgyy01(k+1), & - ddgyy22(k+1), & - ddgxy23(k+1), & - ddgxy01(k+1), & - ddgxr02(k+1),ddgxr03(k+1), & - ddgyr02(k+1),ddgyr03(k+1), & - ddgxr22(k+1),ddgxr23(k+1),ddgxr33(k+1), & - ddgyr22(k+1),ddgyr23(k+1),ddgyr33(k+1), & - Theta221,Theta231,Theta331) - - call rungekutta4_scalar(dR,Theta220,Theta221,Theta22_rhs,RK4) - call rungekutta4_scalar(dR,Theta230,Theta231,Theta23_rhs,RK4) - call rungekutta4_scalar(dR,Theta330,Theta331,Theta33_rhs,RK4) - call rswap(Theta220,Theta221) - call rswap(Theta230,Theta231) - call rswap(Theta330,Theta331) - - Theta22(i,j,k+1) = Theta220 - Theta23(i,j,k+1) = Theta230 - Theta33(i,j,k+1) = Theta330 - enddo - - k=ex(3)-1 -! closing step - - call Theta_rhs2(Rmin,R(k),g00(i,j,k),g02(i,j,k),g03(i,j,k),g22(i,j,k),g23(i,j,k),g33(i,j,k), & - dg22(k),dg23(k),dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & - Theta22(i,j,k),Theta23(i,j,k),Theta33(i,j,k), & - dg01(k),dg02(k),dg03(k), & - dgx01(k),dgx02(k),dgx03(k), & - dgy01(k),dgy02(k),dgy03(k), & - dgx22(k),dgx23(k),dgx33(k), & - dgy22(k),dgy23(k),dgy33(k), & - dg00(k), & - ddgxx01(k), & - ddgxx33(k), & - ddgyy01(k), & - ddgyy22(k), & - ddgxy23(k), & - ddgxy01(k), & - ddgxr02(k),ddgxr03(k), & - ddgyr02(k),ddgyr03(k), & - ddgxr22(k),ddgxr23(k),ddgxr33(k), & - ddgyr22(k),ddgyr23(k),ddgyr33(k), & - Theta22_rhs,Theta23_rhs,Theta33_rhs) - - Theta22(i,j,k+1) = Theta22(i,j,k) + Theta22_rhs*dR - Theta23(i,j,k+1) = Theta23(i,j,k) + Theta23_rhs*dR - Theta33(i,j,k+1) = Theta33(i,j,k) + Theta33_rhs*dR - -#endif - enddo - enddo - - gont = 0 - - return - -end function NullEvol_Theta2 -!--------------------------------------------------------------------------------- -subroutine Theta_rhs2(Rmin,r,g00,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01, & - Theta22,Theta23,Theta33, & - dg01,dg02,dg03, & - dgx01,dgx02,dgx03, & - dgy01,dgy02,dgy03, & - dgx22,dgx23,dgx33, & - dgy22,dgy23,dgy33, & - dg00, & - ddgxx01, & - ddgxx33, & - ddgyy01, & - ddgyy22, & - ddgxy23, & - ddgxy01, & - ddgxr02,ddgxr03, & - ddgyr02,ddgyr03, & - ddgxr22,ddgxr23,ddgxr33, & - ddgyr22,ddgyr23,ddgyr33, & - Theta22_rhs,Theta23_rhs,Theta33_rhs) - - implicit none - -!~~~~~~% Input parameters: - real*8,intent(in) :: Rmin,r,g00,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01 - real*8,intent(in) :: Theta22,Theta23,Theta33,dg01,dg02,dg03 - real*8,intent(in) :: dgx01,dgx02,dgx03,dgx22,dgx23,dgx33 - real*8,intent(in) :: dgy01,dgy02,dgy03,dgy22,dgy23,dgy33 - real*8,intent(in) :: dg00 - real*8,intent(out) :: Theta22_rhs,Theta23_rhs,Theta33_rhs - real*8,intent(in) :: ddgxx01 - real*8,intent(in) :: ddgxx33 - real*8,intent(in) :: ddgyy01 - real*8,intent(in) :: ddgyy22 - real*8,intent(in) :: ddgxy23 - real*8,intent(in) :: ddgxy01 - real*8,intent(in) :: ddgxr02,ddgxr03 - real*8,intent(in) :: ddgyr02,ddgyr03 - real*8,intent(in) :: ddgxr22,ddgxr23,ddgxr33,ddgyr22,ddgyr23,ddgyr33 - - real*8 :: t1; - real*8 :: t100; - real*8 :: t1001; - real*8 :: t1009; - real*8 :: t1010; - real*8 :: t1011; - real*8 :: t1015; - real*8 :: t1019; - real*8 :: t1023; - real*8 :: t1037; - real*8 :: t104; - real*8 :: t1041; - real*8 :: t1042; - real*8 :: t1049; - real*8 :: t1065; - real*8 :: t1070; - real*8 :: t1090; - real*8 :: t1094; - real*8 :: t1099; - real*8 :: t11; - real*8 :: t111; - real*8 :: t1113; - real*8 :: t112; - real*8 :: t1123; - real*8 :: t1126; - real*8 :: t1130; - real*8 :: t1134; - real*8 :: t1160; - real*8 :: t1173; - real*8 :: t1174; - real*8 :: t1180; - real*8 :: t12; - real*8 :: t1207; - real*8 :: t1211; - real*8 :: t1218; - real*8 :: t1222; - real*8 :: t1223; - real*8 :: t1226; - real*8 :: t1227; - real*8 :: t1230; - real*8 :: t1231; - real*8 :: t1234; - real*8 :: t1240; - real*8 :: t1242; - real*8 :: t1245; - real*8 :: t1248; - real*8 :: t125; - real*8 :: t1250; - real*8 :: t1254; - real*8 :: t1265; - real*8 :: t1272; - real*8 :: t1277; - real*8 :: t1281; - real*8 :: t1282; - real*8 :: t1287; - real*8 :: t1296; - real*8 :: t13; - real*8 :: t1301; - real*8 :: t1308; - real*8 :: t1311; - real*8 :: t1325; - real*8 :: t1326; - real*8 :: t1330; - real*8 :: t1334; - real*8 :: t1335; - real*8 :: t1338; - real*8 :: t1348; - real*8 :: t1351; - real*8 :: t1354; - real*8 :: t1386; - real*8 :: t1398; - real*8 :: t1411; - real*8 :: t142; - real*8 :: t1426; - real*8 :: t143; - real*8 :: t1432; - real*8 :: t1437; - real*8 :: t144; - real*8 :: t1441; - real*8 :: t1449; - real*8 :: t1475; - real*8 :: t148; - real*8 :: t1483; - real*8 :: t1496; - real*8 :: t1506; - real*8 :: t152; - real*8 :: t1522; - real*8 :: t1523; - real*8 :: t1526; - real*8 :: t1529; - real*8 :: t1532; - real*8 :: t1535; - real*8 :: t1536; - real*8 :: t1539; - real*8 :: t1540; - real*8 :: t1543; - real*8 :: t1547; - real*8 :: t1556; - real*8 :: t1592; - real*8 :: t1598; - real*8 :: t1601; - real*8 :: t1604; - real*8 :: t162; - real*8 :: t1629; - real*8 :: t1636; - real*8 :: t1641; - real*8 :: t1646; - real*8 :: t1647; - real*8 :: t1652; - real*8 :: t1653; - real*8 :: t1654; - real*8 :: t1668; - real*8 :: t1673; - real*8 :: t1674; - real*8 :: t1678; - real*8 :: t1682; - real*8 :: t1686; - real*8 :: t1691; - real*8 :: t1694; - real*8 :: t1695; - real*8 :: t1697; - real*8 :: t17; - real*8 :: t170; - real*8 :: t1700; - real*8 :: t1701; - real*8 :: t1703; - real*8 :: t1706; - real*8 :: t1707; - real*8 :: t1710; - real*8 :: t1711; - real*8 :: t1712; - real*8 :: t1716; - real*8 :: t1717; - real*8 :: t1718; - real*8 :: t1720; - real*8 :: t1727; - real*8 :: t1728; - real*8 :: t1731; - real*8 :: t1733; - real*8 :: t1737; - real*8 :: t1740; - real*8 :: t1744; - real*8 :: t1747; - real*8 :: t1760; - real*8 :: t1764; - real*8 :: t1768; - real*8 :: t177; - real*8 :: t1787; - real*8 :: t18; - real*8 :: t1813; - real*8 :: t1817; - real*8 :: t1820; - real*8 :: t1822; - real*8 :: t1825; - real*8 :: t1828; - real*8 :: t1833; - real*8 :: t1847; - real*8 :: t185; - real*8 :: t1873; - real*8 :: t1876; - real*8 :: t1882; - real*8 :: t1884; - real*8 :: t1887; - real*8 :: t1891; - real*8 :: t1896; - real*8 :: t1897; - real*8 :: t19; - real*8 :: t1901; - real*8 :: t1904; - real*8 :: t1906; - real*8 :: t1909; - real*8 :: t1910; - real*8 :: t1914; - real*8 :: t192; - real*8 :: t1932; - real*8 :: t1934; - real*8 :: t1935; - real*8 :: t1936; - real*8 :: t1939; - real*8 :: t1942; - real*8 :: t1943; - real*8 :: t1946; - real*8 :: t1949; - real*8 :: t197; - real*8 :: t1973; - real*8 :: t198; - real*8 :: t1982; - real*8 :: t199; - real*8 :: t1995; - real*8 :: t1998; - real*8 :: t20; - real*8 :: t201; - real*8 :: t202; - real*8 :: t2035; - real*8 :: t205; - real*8 :: t207; - real*8 :: t211; - real*8 :: t22; - real*8 :: t234; - real*8 :: t249; - real*8 :: t25; - real*8 :: t265; - real*8 :: t266; - real*8 :: t267; - real*8 :: t27; - real*8 :: t270; - real*8 :: t273; - real*8 :: t274; - real*8 :: t277; - real*8 :: t278; - real*8 :: t279; - real*8 :: t285; - real*8 :: t3; - real*8 :: t301; - real*8 :: t304; - real*8 :: t305; - real*8 :: t306; - real*8 :: t31; - real*8 :: t315; - real*8 :: t320; - real*8 :: t321; - real*8 :: t325; - real*8 :: t326; - real*8 :: t327; - real*8 :: t329; - real*8 :: t333; - real*8 :: t336; - real*8 :: t337; - real*8 :: t338; - real*8 :: t339; - real*8 :: t341; - real*8 :: t348; - real*8 :: t35; - real*8 :: t355; - real*8 :: t364; - real*8 :: t365; - real*8 :: t366; - real*8 :: t367; - real*8 :: t368; - real*8 :: t371; - real*8 :: t372; - real*8 :: t373; - real*8 :: t377; - real*8 :: t378; - real*8 :: t382; - real*8 :: t385; - real*8 :: t386; - real*8 :: t387; - real*8 :: t388; - real*8 :: t39; - real*8 :: t392; - real*8 :: t393; - real*8 :: t397; - real*8 :: t4; - real*8 :: t401; - real*8 :: t402; - real*8 :: t406; - real*8 :: t407; - real*8 :: t408; - real*8 :: t411; - real*8 :: t412; - real*8 :: t415; - real*8 :: t416; - real*8 :: t417; - real*8 :: t42; - real*8 :: t420; - real*8 :: t421; - real*8 :: t422; - real*8 :: t426; - real*8 :: t427; - real*8 :: t43; - real*8 :: t430; - real*8 :: t431; - real*8 :: t432; - real*8 :: t435; - real*8 :: t436; - real*8 :: t437; - real*8 :: t440; - real*8 :: t441; - real*8 :: t444; - real*8 :: t448; - real*8 :: t449; - real*8 :: t453; - real*8 :: t454; - real*8 :: t455; - real*8 :: t458; - real*8 :: t461; - real*8 :: t462; - real*8 :: t465; - real*8 :: t466; - real*8 :: t469; - real*8 :: t470; - real*8 :: t473; - real*8 :: t474; - real*8 :: t477; - real*8 :: t479; - real*8 :: t48; - real*8 :: t480; - real*8 :: t483; - real*8 :: t484; - real*8 :: t487; - real*8 :: t488; - real*8 :: t491; - real*8 :: t495; - real*8 :: t496; - real*8 :: t5; - real*8 :: t500; - real*8 :: t501; - real*8 :: t504; - real*8 :: t505; - real*8 :: t508; - real*8 :: t509; - real*8 :: t510; - real*8 :: t516; - real*8 :: t519; - real*8 :: t52; - real*8 :: t522; - real*8 :: t523; - real*8 :: t524; - real*8 :: t525; - real*8 :: t528; - real*8 :: t529; - real*8 :: t532; - real*8 :: t535; - real*8 :: t541; - real*8 :: t549; - real*8 :: t55; - real*8 :: t552; - real*8 :: t553; - real*8 :: t56; - real*8 :: t561; - real*8 :: t564; - real*8 :: t569; - real*8 :: t57; - real*8 :: t572; - real*8 :: t575; - real*8 :: t576; - real*8 :: t577; - real*8 :: t579; - real*8 :: t582; - real*8 :: t586; - real*8 :: t589; - real*8 :: t590; - real*8 :: t591; - real*8 :: t594; - real*8 :: t595; - real*8 :: t6; - real*8 :: t605; - real*8 :: t61; - real*8 :: t610; - real*8 :: t611; - real*8 :: t618; - real*8 :: t622; - real*8 :: t623; - real*8 :: t624; - real*8 :: t627; - real*8 :: t631; - real*8 :: t634; - real*8 :: t638; - real*8 :: t639; - real*8 :: t640; - real*8 :: t643; - real*8 :: t644; - real*8 :: t645; - real*8 :: t648; - real*8 :: t649; - real*8 :: t658; - real*8 :: t659; - real*8 :: t660; - real*8 :: t663; - real*8 :: t664; - real*8 :: t668; - real*8 :: t671; - real*8 :: t686; - real*8 :: t7; - real*8 :: t70; - real*8 :: t706; - real*8 :: t710; - real*8 :: t713; - real*8 :: t717; - real*8 :: t723; - real*8 :: t725; - real*8 :: t728; - real*8 :: t731; - real*8 :: t733; - real*8 :: t738; - real*8 :: t741; - real*8 :: t742; - real*8 :: t746; - real*8 :: t749; - real*8 :: t750; - real*8 :: t751; - real*8 :: t754; - real*8 :: t755; - real*8 :: t758; - real*8 :: t77; - real*8 :: t775; - real*8 :: t780; - real*8 :: t782; - real*8 :: t783; - real*8 :: t786; - real*8 :: t787; - real*8 :: t788; - real*8 :: t792; - real*8 :: t796; - real*8 :: t799; - real*8 :: t800; - real*8 :: t804; - real*8 :: t811; - real*8 :: t812; - real*8 :: t822; - real*8 :: t831; - real*8 :: t832; - real*8 :: t835; - real*8 :: t836; - real*8 :: t837; - real*8 :: t84; - real*8 :: t850; - real*8 :: t855; - real*8 :: t856; - real*8 :: t857; - real*8 :: t860; - real*8 :: t862; - real*8 :: t865; - real*8 :: t871; - real*8 :: t876; - real*8 :: t88; - real*8 :: t880; - real*8 :: t884; - real*8 :: t888; - real*8 :: t889; - real*8 :: t892; - real*8 :: t895; - real*8 :: t898; - real*8 :: t901; - real*8 :: t904; - real*8 :: t92; - real*8 :: t922; - real*8 :: t925; - real*8 :: t928; - real*8 :: t929; - real*8 :: t93; - real*8 :: t932; - real*8 :: t935; - real*8 :: t938; - real*8 :: t956; - real*8 :: t959; - real*8 :: t960; - real*8 :: t963; - real*8 :: t970; - real*8 :: t975; - real*8 :: t979; - real*8 :: t980; - real*8 :: t983; - real*8 :: t985; - real*8 :: t991; - real*8 :: t996; - - real*8 :: t10; - real*8 :: t1006; - real*8 :: t1007; - real*8 :: t1012; - real*8 :: t1030; - real*8 :: t1039; - real*8 :: t1044; - real*8 :: t1067; - real*8 :: t1084; - real*8 :: t1092; - real*8 :: t1100; - real*8 :: t1112; - real*8 :: t1117; - real*8 :: t1121; - real*8 :: t1122; - real*8 :: t1127; - real*8 :: t1131; - real*8 :: t1133; - real*8 :: t1138; - real*8 :: t1141; - real*8 :: t1142; - real*8 :: t1143; - real*8 :: t1144; - real*8 :: t1148; - real*8 :: t1166; - real*8 :: t1177; - real*8 :: t1181; - real*8 :: t1191; - real*8 :: t120; - real*8 :: t1203; - real*8 :: t1204; - real*8 :: t121; - real*8 :: t1212; - real*8 :: t1235; - real*8 :: t1239; - real*8 :: t124; - real*8 :: t1249; - real*8 :: t1252; - real*8 :: t1253; - real*8 :: t1256; - real*8 :: t128; - real*8 :: t1289; - real*8 :: t129; - real*8 :: t1291; - real*8 :: t1293; - real*8 :: t130; - real*8 :: t131; - real*8 :: t1313; - real*8 :: t1314; - real*8 :: t1317; - real*8 :: t132; - real*8 :: t1320; - real*8 :: t1322; - real*8 :: t133; - real*8 :: t1331; - real*8 :: t1332; - real*8 :: t1342; - real*8 :: t1355; - real*8 :: t1357; - real*8 :: t1359; - real*8 :: t136; - real*8 :: t1362; - real*8 :: t1366; - real*8 :: t137; - real*8 :: t1374; - real*8 :: t1379; - real*8 :: t138; - real*8 :: t1380; - real*8 :: t1381; - real*8 :: t1384; - real*8 :: t1385; - real*8 :: t1388; - real*8 :: t139; - real*8 :: t1391; - real*8 :: t1392; - real*8 :: t140; - real*8 :: t1405; - real*8 :: t1406; - real*8 :: t1409; - real*8 :: t1410; - real*8 :: t1413; - real*8 :: t1416; - real*8 :: t1417; - real*8 :: t1419; - real*8 :: t1421; - real*8 :: t1428; - real*8 :: t1434; - real*8 :: t1440; - real*8 :: t1444; - real*8 :: t145; - real*8 :: t1450; - real*8 :: t1454; - real*8 :: t1457; - real*8 :: t1473; - real*8 :: t1476; - real*8 :: t1488; - real*8 :: t1490; - real*8 :: t1501; - real*8 :: t1505; - real*8 :: t1510; - real*8 :: t1516; - real*8 :: t1577; - real*8 :: t1612; - real*8 :: t1615; - real*8 :: t1619; - real*8 :: t1624; - real*8 :: t1625; - real*8 :: t163; - real*8 :: t1634; - real*8 :: t1640; - real*8 :: t1644; - real*8 :: t1648; - real*8 :: t1651; - real*8 :: t1655; - real*8 :: t1660; - real*8 :: t1663; - real*8 :: t1664; - real*8 :: t168; - real*8 :: t1689; - real*8 :: t169; - real*8 :: t1690; - real*8 :: t1693; - real*8 :: t1696; - real*8 :: t1708; - real*8 :: t171; - real*8 :: t1724; - real*8 :: t174; - real*8 :: t1741; - real*8 :: t175; - real*8 :: t1752; - real*8 :: t176; - real*8 :: t1775; - real*8 :: t1783; - real*8 :: t1788; - real*8 :: t1791; - real*8 :: t1795; - real*8 :: t181; - real*8 :: t1823; - real*8 :: t1824; - real*8 :: t183; - real*8 :: t1836; - real*8 :: t1842; - real*8 :: t1852; - real*8 :: t1856; - real*8 :: t1859; - real*8 :: t186; - real*8 :: t1863; - real*8 :: t187; - real*8 :: t1875; - real*8 :: t1878; - real*8 :: t1883; - real*8 :: t189; - real*8 :: t1890; - real*8 :: t191; - real*8 :: t1918; - real*8 :: t1921; - real*8 :: t1927; - real*8 :: t1931; - real*8 :: t194; - real*8 :: t1952; - real*8 :: t196; - real*8 :: t1970; - real*8 :: t200; - real*8 :: t2003; - real*8 :: t2004; - real*8 :: t2008; - real*8 :: t2017; - real*8 :: t2024; - real*8 :: t2032; - real*8 :: t204; - real*8 :: t206; - real*8 :: t2065; - real*8 :: t208; - real*8 :: t2085; - real*8 :: t209; - real*8 :: t2091; - real*8 :: t2093; - real*8 :: t21; - real*8 :: t212; - real*8 :: t2122; - real*8 :: t213; - real*8 :: t2133; - real*8 :: t2138; - real*8 :: t214; - real*8 :: t215; - real*8 :: t2166; - real*8 :: t219; - real*8 :: t2192; - real*8 :: t2201; - real*8 :: t222; - real*8 :: t226; - real*8 :: t23; - real*8 :: t233; - real*8 :: t236; - real*8 :: t237; - real*8 :: t238; - real*8 :: t239; - real*8 :: t24; - real*8 :: t247; - real*8 :: t248; - real*8 :: t251; - real*8 :: t252; - real*8 :: t255; - real*8 :: t258; - real*8 :: t259; - real*8 :: t268; - real*8 :: t28; - real*8 :: t282; - real*8 :: t283; - real*8 :: t287; - real*8 :: t29; - real*8 :: t290; - real*8 :: t293; - real*8 :: t296; - real*8 :: t297; - real*8 :: t298; - real*8 :: t302; - real*8 :: t310; - real*8 :: t311; - real*8 :: t316; - real*8 :: t317; - real*8 :: t32; - real*8 :: t322; - real*8 :: t323; - real*8 :: t324; - real*8 :: t33; - real*8 :: t330; - real*8 :: t34; - real*8 :: t344; - real*8 :: t376; - real*8 :: t384; - real*8 :: t389; - real*8 :: t394; - real*8 :: t399; - real*8 :: t40; - real*8 :: t404; - real*8 :: t41; - real*8 :: t419; - real*8 :: t438; - real*8 :: t439; - real*8 :: t443; - real*8 :: t445; - real*8 :: t450; - real*8 :: t451; - real*8 :: t459; - real*8 :: t46; - real*8 :: t460; - real*8 :: t463; - real*8 :: t464; - real*8 :: t47; - real*8 :: t478; - real*8 :: t482; - real*8 :: t49; - real*8 :: t492; - real*8 :: t50; - real*8 :: t503; - real*8 :: t507; - real*8 :: t511; - real*8 :: t514; - real*8 :: t515; - real*8 :: t517; - real*8 :: t518; - real*8 :: t520; - real*8 :: t533; - real*8 :: t537; - real*8 :: t538; - real*8 :: t54; - real*8 :: t544; - real*8 :: t545; - real*8 :: t548; - real*8 :: t551; - real*8 :: t555; - real*8 :: t556; - real*8 :: t560; - real*8 :: t563; - real*8 :: t566; - real*8 :: t574; - real*8 :: t59; - real*8 :: t597; - real*8 :: t599; - real*8 :: t600; - real*8 :: t603; - real*8 :: t606; - real*8 :: t609; - real*8 :: t614; - real*8 :: t616; - real*8 :: t617; - real*8 :: t620; - real*8 :: t621; - real*8 :: t625; - real*8 :: t63; - real*8 :: t64; - real*8 :: t646; - real*8 :: t655; - real*8 :: t662; - real*8 :: t667; - real*8 :: t672; - real*8 :: t676; - real*8 :: t677; - real*8 :: t68; - real*8 :: t680; - real*8 :: t683; - real*8 :: t696; - real*8 :: t72; - real*8 :: t739; - real*8 :: t740; - real*8 :: t743; - real*8 :: t744; - real*8 :: t745; - real*8 :: t748; - real*8 :: t752; - real*8 :: t756; - real*8 :: t76; - real*8 :: t766; - real*8 :: t769; - real*8 :: t770; - real*8 :: t771; - real*8 :: t774; - real*8 :: t778; - real*8 :: t785; - real*8 :: t789; - real*8 :: t793; - real*8 :: t798; - real*8 :: t8; - real*8 :: t801; - real*8 :: t803; - real*8 :: t806; - real*8 :: t808; - real*8 :: t813; - real*8 :: t816; - real*8 :: t817; - real*8 :: t818; - real*8 :: t823; - real*8 :: t824; - real*8 :: t838; - real*8 :: t842; - real*8 :: t843; - real*8 :: t844; - real*8 :: t849; - real*8 :: t868; - real*8 :: t873; - real*8 :: t874; - real*8 :: t877; - real*8 :: t878; - real*8 :: t881; - real*8 :: t882; - real*8 :: t885; - real*8 :: t89; - real*8 :: t9; - real*8 :: t900; - real*8 :: t902; - real*8 :: t913; - real*8 :: t915; - real*8 :: t919; - real*8 :: t921; - real*8 :: t923; - real*8 :: t941; - real*8 :: t944; - real*8 :: t946; - real*8 :: t949; - real*8 :: t953; - real*8 :: t958; - real*8 :: t96; - real*8 :: t968; - real*8 :: t969; - real*8 :: t973; - real*8 :: t978; - real*8 :: t990; - real*8 :: t995; - real*8 :: t998; - - real*8 :: t1004; - real*8 :: t1005; - real*8 :: t1008; - real*8 :: t1020; - real*8 :: t103; - real*8 :: t105; - real*8 :: t1051; - real*8 :: t1057; - real*8 :: t1064; - real*8 :: t107; - real*8 :: t1072; - real*8 :: t1077; - real*8 :: t108; - real*8 :: t1086; - real*8 :: t1111; - real*8 :: t1115; - real*8 :: t1119; - real*8 :: t1125; - real*8 :: t1128; - real*8 :: t113; - real*8 :: t1136; - real*8 :: t1139; - real*8 :: t1146; - real*8 :: t1149; - real*8 :: t1151; - real*8 :: t1154; - real*8 :: t1158; - real*8 :: t1164; - real*8 :: t1168; - real*8 :: t117; - real*8 :: t1175; - real*8 :: t1185; - real*8 :: t1186; - real*8 :: t1208; - real*8 :: t1216; - real*8 :: t1232; - real*8 :: t1276; - real*8 :: t1284; - real*8 :: t1286; - real*8 :: t1290; - real*8 :: t1295; - real*8 :: t1298; - real*8 :: t1299; - real*8 :: t1302; - real*8 :: t1305; - real*8 :: t1309; - real*8 :: t1323; - real*8 :: t1324; - real*8 :: t1328; - real*8 :: t1333; - real*8 :: t1336; - real*8 :: t1337; - real*8 :: t1340; - real*8 :: t1341; - real*8 :: t1344; - real*8 :: t1365; - real*8 :: t1382; - real*8 :: t1389; - real*8 :: t1390; - real*8 :: t1393; - real*8 :: t1396; - real*8 :: t1397; - real*8 :: t14; - real*8 :: t1400; - real*8 :: t1401; - real*8 :: t1404; - real*8 :: t1408; - real*8 :: t1412; - real*8 :: t1415; - real*8 :: t1418; - real*8 :: t1424; - real*8 :: t1427; - real*8 :: t1430; - real*8 :: t1436; - real*8 :: t1439; - real*8 :: t1442; - real*8 :: t1445; - real*8 :: t1448; - real*8 :: t1453; - real*8 :: t1456; - real*8 :: t1471; - real*8 :: t1477; - real*8 :: t1481; - real*8 :: t1485; - real*8 :: t1487; - real*8 :: t1493; - real*8 :: t15; - real*8 :: t1500; - real*8 :: t1504; - real*8 :: t1507; - real*8 :: t1509; - real*8 :: t151; - real*8 :: t1513; - real*8 :: t1517; - real*8 :: t1521; - real*8 :: t1527; - real*8 :: t1541; - real*8 :: t1550; - real*8 :: t1553; - real*8 :: t1557; - real*8 :: t1558; - real*8 :: t1578; - real*8 :: t1579; - real*8 :: t158; - real*8 :: t1582; - real*8 :: t1583; - real*8 :: t1587; - real*8 :: t1595; - real*8 :: t1600; - real*8 :: t1603; - real*8 :: t1608; - real*8 :: t161; - real*8 :: t1620; - real*8 :: t1626; - real*8 :: t165; - real*8 :: t1656; - real*8 :: t1661; - real*8 :: t1662; - real*8 :: t1665; - real*8 :: t1666; - real*8 :: t1677; - real*8 :: t1681; - real*8 :: t1685; - real*8 :: t1692; - real*8 :: t1721; - real*8 :: t1722; - real*8 :: t1726; - real*8 :: t173; - real*8 :: t1730; - real*8 :: t1743; - real*8 :: t1745; - real*8 :: t1756; - real*8 :: t1761; - real*8 :: t1780; - real*8 :: t1807; - real*8 :: t1812; - real*8 :: t1845; - real*8 :: t1846; - real*8 :: t1854; - real*8 :: t1855; - real*8 :: t1860; - real*8 :: t1864; - real*8 :: t1869; - real*8 :: t188; - real*8 :: t1888; - real*8 :: t1894; - real*8 :: t1944; - real*8 :: t195; - real*8 :: t1956; - real*8 :: t1988; - real*8 :: t1997; - real*8 :: t2038; - real*8 :: t225; - real*8 :: t227; - real*8 :: t228; - real*8 :: t230; - real*8 :: t235; - real*8 :: t240; - real*8 :: t241; - real*8 :: t243; - real*8 :: t246; - real*8 :: t250; - real*8 :: t253; - real*8 :: t254; - real*8 :: t256; - real*8 :: t257; - real*8 :: t260; - real*8 :: t261; - real*8 :: t262; - real*8 :: t263; - real*8 :: t276; - real*8 :: t280; - real*8 :: t284; - real*8 :: t288; - real*8 :: t291; - real*8 :: t292; - real*8 :: t294; - real*8 :: t295; - real*8 :: t299; - real*8 :: t307; - real*8 :: t308; - real*8 :: t312; - real*8 :: t314; - real*8 :: t319; - real*8 :: t328; - real*8 :: t331; - real*8 :: t334; - real*8 :: t345; - real*8 :: t347; - real*8 :: t349; - real*8 :: t352; - real*8 :: t353; - real*8 :: t356; - real*8 :: t357; - real*8 :: t358; - real*8 :: t36; - real*8 :: t363; - real*8 :: t369; - real*8 :: t381; - real*8 :: t403; - real*8 :: t405; - real*8 :: t409; - real*8 :: t410; - real*8 :: t428; - real*8 :: t433; - real*8 :: t442; - real*8 :: t45; - real*8 :: t456; - real*8 :: t481; - real*8 :: t539; - real*8 :: t540; - real*8 :: t570; - real*8 :: t58; - real*8 :: t613; - real*8 :: t615; - real*8 :: t619; - real*8 :: t629; - real*8 :: t630; - real*8 :: t633; - real*8 :: t656; - real*8 :: t669; - real*8 :: t682; - real*8 :: t685; - real*8 :: t732; - real*8 :: t737; - real*8 :: t747; - real*8 :: t764; - real*8 :: t765; - real*8 :: t772; - real*8 :: t776; - real*8 :: t78; - real*8 :: t781; - real*8 :: t79; - real*8 :: t790; - real*8 :: t807; - real*8 :: t809; - real*8 :: t819; - real*8 :: t820; - real*8 :: t821; - real*8 :: t825; - real*8 :: t826; - real*8 :: t829; - real*8 :: t83; - real*8 :: t830; - real*8 :: t833; - real*8 :: t851; - real*8 :: t853; - real*8 :: t859; - real*8 :: t864; - real*8 :: t869; - real*8 :: t87; - real*8 :: t872; - real*8 :: t875; - real*8 :: t883; - real*8 :: t886; - real*8 :: t887; - real*8 :: t891; - real*8 :: t896; - real*8 :: t910; - real*8 :: t911; - real*8 :: t924; - real*8 :: t937; - real*8 :: t940; - real*8 :: t95; - real*8 :: t952; - real*8 :: t961; - real*8 :: t971; - real*8 :: t981; - real*8 :: t988; - real*8 :: t994; - real*8 :: t997; - real*8 :: t999; - - t1 = g01*g01; - t3 = g22*g22; - t4 = g01*t3; - t5 = g33*g33; - t6 = dgx01*dgx01; - t7 = t5*t6; - t11 = g01*g22; - t12 = g23*g23; - t13 = g33*t12; - t17 = t12*t12; - t18 = t1*t17; - t19 = r*r; - t20 = t19*t19; - t22 = ddgxr02*t20*Rmin; - t25 = t19*r; - t27 = ddgxr02*t25*Rmin; - t31 = ddgxr02*t19*Rmin; - t35 = Theta22*t19*Rmin; - t39 = dgx02*t19*Rmin; - t42 = t1*t3; - t43 = t5*ddgxx01; - t48 = Theta22*r*Rmin; - t52 = dgx02*r*Rmin; - t55 = t1*g01; - t56 = t3*t55; - t57 = dgy33*dgx23; - t61 = dgy33*dgy22; - t70 = g33*ddgxy23; - t77 = g33*ddgyy22; - t84 = g33*ddgxx33; - t88 = -4.0*t4*t7*r-4.0*t11*t13*t6+4.0*t18*t22-8.0*t18*t27+4.0*t18*t31+4.0*t18*t35 & - -8.0*t18*t39-4.0*t42*t43*t19-4.0*t18*t48+8.0*t18*t52-2.0*t56*t57*t19 & - +t56*t61*t19+4.0*t56*t57*r-2.0*t56*t61*r+4.0*t56*t70*t19-8.0*t56*t70*r & - -2.0*t56*t77*t19+4.0*t56*t77*r-2.0*t56*t84*t19; - t92 = g22*t55; - t93 = t12*ddgxy23; - t100 = t12*ddgyy22; - t104 = t12*ddgxx33; - t111 = dgy22*dgy22; - t112 = g33*t111; - t125 = g23*dgx33; - t142 = t12*g23; - t143 = t1*t142; - t144 = dgx01*dgx23; - t148 = dgx01*dgy22; - t152 = dgy01*dgx22; - t162 = 4.0*t56*t84*r-4.0*t92*t93*t19+8.0*t92*t93*r-4.0*t92*t100*r+2.0*t92*t104*t19 & - -4.0*t92*t104*r+t92*t112*t19-2.0*t92*t112*r+t92*g33*dgx33*dgx22-2.0*t92*g33*dgy23*dgx22 & - -t92*t125*dgy22+t92*g23*dgy33*dgx22-2.0*t92*t125*dgx23+4.0*t92*g23*dgx23*dgy23 & - -2.0*t92*g23*dgy23*dgy22+4.0*t143*t144*t19-2.0*t143*t148*t19+2.0*t143*t152*t19+8.0*t42*t43*r-8.0*t143*t144*r; - t170 = g33*dgy01; - t177 = t1*g22; - t185 = t12*dgy01; - t192 = t1*g33; - t197 = g01*t17; - t198 = dg02*dg02; - t199 = t20*t19; - t201 = Rmin*Rmin; - t202 = t198*t199*t201; - t205 = t20*r; - t207 = t198*t205*t201; - t211 = t198*t20*t201; - t234 = 4.0*t143*t148*r-4.0*t143*t152*r+4.0*t42*t170*dgx23-2.0*t42*t170*dgy22 & - +2.0*t177*t5*dgx01*dgx22+8.0*t177*t13*ddgxx01-4.0*t177*t185*dgx23+2.0*t177*t185*dgy22 & - -2.0*t192*t12*dgx01*dgx22-2.0*t197*t202+4.0*t197*t207-2.0*t197*t211+2.0*t4*t7*t19 & - +2.0*t92*t100*t19-4.0*t18*ddgxx01*t19+8.0*t18*ddgxx01*r & - -4.0*t42*t43+4.0*t143*t144-2.0*t143*t148+2.0*t143*t152; - t249 = dgx33*dgx33; - t265 = t201*t20; - t266 = t265*t11; - t267 = g03*dg33; - t270 = t267*dg22*g23*g02; - t273 = t201*t199; - t274 = t273*t11; - t277 = g33*g23; - t278 = t11*t277; - t279 = g02*dg02; - t285 = g02*dg22; - t301 = 2.0*t197*t6*t19-4.0*t197*t6*r+2.0*t4*t7+4.0*t56*t70-2.0*t56*t77-2.0*t56*t84+t56*t249*t19 & - -2.0*t56*t249*r-2.0*t56*t57+t56*t61-4.0*t92*t93+2.0*t92*t100+2.0*t92*t104+t92*t112-2.0*t266*t270 & - -2.0*t274*t270-4.0*t278*t279*dg23*t199*t201+4.0*t278*t285*dg03*t199*t201 & - +8.0*t278*t279*dg23*t205*t201-8.0*t278*t285*dg03*t205*t201; - t304 = g02*g03; - t305 = dg22*t20; - t306 = t305*t201; - t315 = dg03*t20; - t320 = dg22*t25; - t321 = t320*t201; - t325 = t205*t201; - t326 = t325*t11; - t327 = g00*dg23; - t329 = t277*t327*dg22; - t333 = t277*t304*ddg22; - t336 = g22*g33; - t337 = t325*t336; - t338 = g23*g02; - t339 = g03*dg01; - t341 = t338*t339*dg22; - t348 = t265*t336; - t355 = t273*t336; - t364 = t273*g22; - t365 = g02*g02; - t366 = t5*t365; - t367 = dg01*dg22; - t368 = t366*t367; - t371 = g03*g03; - t372 = t12*t371; - t373 = t372*t367; - t377 = t12*t365; - t378 = t377*t367; - t382 = t304*t367; - t385 = -20.0*t278*t304*t306-4.0*t278*t279*dg23*t20*t201+4.0*t278*t285*t315*t201+12.0*t278*t304*t321 & - -4.0*t326*t329-8.0*t326*t333+8.0*t337*t341+2.0*t266*t329+4.0*t266*t333-4.0*t348*t341+2.0*t274*t329+4.0*t274*t333 & - -4.0*t355*t341+8.0*t326*t277*t304*dg22+4.0*t326*t270+2.0*t364*t368-2.0*t364*t373-2.0*t273*g33*t378+4.0*t273*t142*t382; - t386 = t177*g33; - t387 = t12*dgx02; - t388 = r*Rmin; - t392 = g23*dgx01; - t393 = dgx23*t19; - t397 = dgy22*t19; - t401 = g23*dgy01; - t402 = dgx22*t19; - t406 = t177*t12; - t407 = g03*dgx23; - t408 = t407*t388; - t411 = g03*dgy22; - t412 = t411*t388; - t415 = t192*t12; - t416 = g02*dgx22; - t417 = t416*t388; - t420 = t4*g33; - t421 = t12*dg00; - t422 = t25*t201; - t426 = t371*dg22; - t427 = t426*t422; - t430 = t4*t12; - t431 = g03*dg03; - t432 = t431*t422; - t435 = t11*t142; - t436 = g02*dg03; - t437 = t436*t422; - t440 = g03*dg02; - t441 = t440*t422; - t444 = t11*t12; - t448 = g01*t142*g02; - t449 = g03*dg22; - t453 = t42*g33; - t454 = t19*Rmin; - t455 = t407*t454; - t458 = t411*t454; - t461 = Theta23*dg23; - t462 = t461*t454; - t465 = dg23*dgy02; - t466 = t465*t454; - t469 = dgx23*dg03; - t470 = t469*t454; - t473 = dgy22*dg03; - t474 = t473*t454; - t477 = -20.0*t386*t387*t388-4.0*t386*t392*t393+2.0*t386*t392*t397-2.0*t386*t401*t402+8.0*t406*t408 & - -8.0*t406*t412+4.0*t415*t417-8.0*t420*t421*t422-10.0*t420*t427 & - +8.0*t430*t432-8.0*t435*t437-8.0*t435*t441+12.0*t444*t427 & - -16.0*t448*t449*t422+12.0*t453*t455-6.0*t453*t458+4.0*t453*t462-4.0*t453*t466-4.0*t453*t470+2.0*t453*t474; - t479 = t177*t5; - t480 = t416*t454; - t483 = dg02*dgx22; - t484 = t483*t454; - t487 = Theta22*dg22; - t488 = t487*t454; - t491 = t12*ddgxr02; - t495 = t11*g33; - t496 = t12*t198; - t500 = dg02*dg23; - t501 = t500*t273; - t504 = dg22*dg03; - t505 = t504*t273; - t508 = t4*t5; - t509 = dg00*dg22; - t510 = t509*t325; - t516 = t500*t325; - t519 = t504*t325; - t522 = t3*g22; - t523 = g01*t522; - t524 = t523*g33; - t525 = t431*t265; - t528 = g00*dg22; - t529 = t528*t265; - t532 = t279*t265; - t535 = t509*t265; - t541 = t426*t265; - t549 = t436*t265; - t552 = 6.0*t479*t480-2.0*t479*t484+2.0*t479*t488-8.0*t386*t491*t454+4.0*t495*t496*t273+4.0*t448*t501 & - -4.0*t448*t505-4.0*t508*t510-8.0*t495*t496*t325-8.0*t448*t516+8.0*t448*t519+8.0*t524*t525-14.0*t508*t529 & - +8.0*t508*t532+2.0*t508*t535+8.0*t420*t421*t265+14.0*t420*t541-8.0*t430*t525+4.0*t495*t496*t265+8.0*t435*t549; - t553 = t440*t265; - t561 = t500*t265; - t564 = t504*t265; - t569 = t528*t422; - t572 = t279*t422; - t575 = Rmin*t25; - t576 = t575*t1; - t577 = t3*g33; - t579 = t577*ddgxr23*g03; - t582 = t454*t1; - t586 = t12*dgx33*t285; - t589 = t12*dg23; - t590 = dgx23*g02; - t591 = t589*t590; - t594 = dgy22*g02; - t595 = t589*t594; - t605 = t12*dg33*t416; - t610 = t325*g01; - t611 = t3*t5; - t618 = 8.0*t435*t553-16.0*t444*t541+24.0*t448*t449*t265+4.0*t448*t561-4.0*t448*t564-8.0*t524*t432 & - +10.0*t508*t569-8.0*t508*t572+8.0*t576*t579-4.0*t582*t579+4.0*t576*t586 & - -8.0*t576*t591+8.0*t576*t595-2.0*t582*t586+4.0*t582*t591 & - -4.0*t582*t595-4.0*t576*t605+2.0*t582*t605+4.0*t610*t611*t528-4.0*t610*t577*t426; - t622 = g22*t5; - t623 = t365*dg22; - t624 = t622*t623; - t627 = g22*t12; - t631 = t13*t623; - t634 = t142*g02; - t638 = t273*g01; - t639 = g00*ddg22; - t640 = t611*t639; - t643 = dg23*dg23; - t644 = g00*t643; - t645 = t577*t644; - t648 = t371*ddg22; - t649 = t577*t648; - t658 = dg22*dg22; - t659 = g00*t658; - t660 = t622*t659; - t663 = t365*ddg22; - t664 = t622*t663; - t668 = t336*t365*t643; - t671 = t12*Theta22; - t686 = -4.0*t610*t624+4.0*t610*t627*t426+4.0*t610*t631-8.0*t610*t634*t449+2.0*t638*t640-2.0*t638*t645-2.0*t638*t649 & - -4.0*t610*t640+4.0*t610*t645+4.0*t610*t649+2.0*t610*t660+4.0*t610*t664 & - -4.0*t610*t668-10.0*t386*t671*t454+20.0*t386*t387*t454 & - -8.0*t406*t455+8.0*t406*t458-4.0*t406*t462+4.0*t406*t466; - t706 = t19*t201; - t710 = t304*t706; - t713 = t12*g00; - t717 = t265*g01; - t723 = t336*t371*t658; - t725 = t627*t644; - t728 = t627*t648; - t731 = t13*t659; - t733 = t13*t663; - t738 = 4.0*t406*t470-2.0*t406*t474-4.0*t415*t480+2.0*t415*t484-2.0*t415*t488-12.0*t453*t408+6.0*t453*t412 & - -6.0*t479*t417+10.0*t386*t671*t388+12.0*t495*t377*t706 & - -24.0*t435*t710-24.0*t420*t713*t706+10.0*t717*t624+2.0*t717*t668 & - +t717*t723+2.0*t717*t725+2.0*t717*t728+t717*t731+2.0*t717*t733-12.0*t717*t631; - t741 = dg23*dg22; - t742 = t142*g00*t741; - t746 = t634*g03*ddg22; - t749 = t265*t3; - t750 = t5*g00; - t751 = t750*t367; - t754 = g33*t371; - t755 = t754*t367; - t758 = t265*g22; - t775 = t273*t3; - t780 = t4*t25; - t782 = g00*dg33; - t783 = t201*t12*t782; - t786 = t177*Rmin; - t787 = t19*t12; - t788 = g02*dgx33; - t792 = r*t12; - t796 = dg33*Theta22; - t799 = t20*t12; - t800 = dg33*dgx02; - t804 = t25*t12; - t811 = -2.0*t717*t742-4.0*t717*t746-2.0*t749*t751+2.0*t749*t755+2.0*t758*t368-2.0*t758*t373 & - -2.0*t265*g33*t378+4.0*t265*t142*t382+2.0*t638*t733-2.0*t638*t742 & - -4.0*t638*t746-2.0*t775*t751+2.0*t775*t755-2.0*t780*t783+4.0*t786*t787*t788 & - -4.0*t786*t792*t788+t786*t787*t796-2.0*t786*t799*t800+4.0*t786*t804*t800-2.0*t786*t787*t800; - t812 = dg22*dgy03; - t822 = Theta33*dg22; - t831 = t201*g33; - t832 = t831*t782; - t835 = t4*t20; - t836 = t365*dg33; - t837 = t831*t836; - t850 = t422*g01; - t855 = t422*t3; - t856 = g00*dg01; - t857 = t13*t856; - t860 = t422*g22; - t862 = t13*t365*dg01; - t865 = t634*t339; - t871 = -2.0*t786*t799*t812+4.0*t786*t804*t812-2.0*t786*t787*t812+t786*t799*t822-2.0*t786*t804*t822+t786*t787*t822 & - -2.0*t523*t20*t832+2.0*t835*t837+2.0*t835*t783-2.0*t610*t723-4.0*t610*t725-4.0*t610*t728-2.0*t610*t731-6.0*t850*t624 & - +8.0*t850*t631+8.0*t855*t857-4.0*t860*t862+8.0*t860*t865-t638*t660-2.0*t638*t664; - t876 = dgx23*r; - t880 = dgy22*r; - t884 = dgx22*r; - t888 = t20*Rmin; - t889 = t461*t888; - t892 = t465*t888; - t895 = t469*t888; - t898 = t473*t888; - t901 = t483*t888; - t904 = t487*t888; - t922 = t461*t575; - t925 = t465*t575; - t928 = 2.0*t638*t668+8.0*t386*t392*t876-4.0*t386*t392*t880+4.0*t386*t401*t884+4.0*t453*t889-4.0*t453*t892 & - -4.0*t453*t895+2.0*t453*t898-2.0*t479*t901+2.0*t479*t904 & - -8.0*t386*t491*t888-4.0*t406*t889+4.0*t406*t892+4.0*t406*t895 & - -2.0*t406*t898+2.0*t415*t901-2.0*t415*t904-8.0*t453*t922+8.0*t453*t925; - t929 = t469*t575; - t932 = t473*t575; - t935 = t483*t575; - t938 = t487*t575; - t956 = t509*t273; - t959 = t3*dg33; - t960 = t959*t407; - t963 = t959*t411; - t970 = t577*ddgyr22*g03; - t975 = t888*t1; - t979 = dg33*dg22; - t980 = t3*t371*t979; - t983 = 8.0*t453*t929-4.0*t453*t932+4.0*t479*t935-4.0*t479*t938+16.0*t386*t491*t575+8.0*t406*t922-8.0*t406*t925 & - -8.0*t406*t929+4.0*t406*t932-4.0*t415*t935+4.0*t415*t938+2.0*t508*t956-4.0*t576*t960+2.0*t576*t963+2.0*t582*t960 & - -t582*t963-8.0*t576*t970+4.0*t582*t970+2.0*t975*t605-2.0*t610*t980; - t985 = t377*t979; - t991 = t627*t836; - t996 = t3*g23*t371*dg23; - t1001 = t201*t142*t327; - t1009 = t42*Rmin; - t1010 = r*g23; - t1011 = g02*dgy33; - t1015 = t20*g33; - t1019 = t25*g33; - t1023 = t19*g33; - t1037 = g02*dgy23; - t1041 = t19*g23; - t1042 = g03*dgx33; - t1049 = -4.0*t610*t985+t717*t980+2.0*t717*t985+4.0*t850*t991-4.0*t850*t996+4.0*t11*t25*t1001+t786*t799*t796 & - -2.0*t786*t804*t796+2.0*t1009*t1010*t1011+2.0*t1009*t1015*t812 & - -4.0*t1009*t1019*t812+2.0*t1009*t1023*t812-t1009*t1015*t822 & - +2.0*t1009*t1019*t822-t1009*t1023*t822-2.0*t1009*t1023*t788 & - +4.0*t1009*t1023*t1037-2.0*t1009*t1041*t1042+t638*t723+2.0*t638*t725; - t1065 = t325*t3; - t1070 = t325*g22; - t1090 = g03*dgy23; - t1094 = 2.0*t638*t728+t638*t731-8.0*t749*t857+4.0*t758*t862-8.0*t758*t865-4.0*t610*t733 & - +4.0*t610*t742+8.0*t610*t746+4.0*t1065*t751 & - -4.0*t1065*t755-4.0*t1070*t368+4.0*t1070*t373+4.0*t325*g33*t378 & - -8.0*t325*t142*t382+2.0*t717*t640-2.0*t717*t645-2.0*t717*t649 & - -t717*t660-2.0*t717*t664-4.0*t1009*t1041*t1090; - t1099 = r*g33; - t1113 = dgy33*dg22; - t1123 = t19*g03; - t1126 = g23*Theta23; - t1130 = g23*dgx03; - t1134 = g23*dgy02; - t1160 = 2.0*t1009*t1099*t788-4.0*t1009*t1099*t1037+2.0*t1009*t1010*t1042 & - +4.0*t1009*t1010*t1090-t1009*t20*g03*t1113+2.0*t1009*t25*g03*t1113 & - -2.0*t1009*t1041*t1011-t1009*t1123*t1113-4.0*t1009*t1023*t1126+4.0*t1009*t1023*t1130+4.0*t1009*t1023*t1134 & - +2.0*t1009*t1019*t796-t1009*t1023*t796+2.0*t1009*t1015*t800 & - -4.0*t1009*t1019*t800+2.0*t1009*t1023*t800-t1009*t1015*t796+4.0*t1009*t1099*t1126-4.0*t1009*t1099*t1130; - t1173 = g22*g03; - t1174 = t12*ddgyr22*t1173; - t1180 = t12*ddgxr23*t1173; - t1207 = -4.0*t1009*t1099*t1134+2.0*t523*t25*t832-2.0*t780*t837-4.0*t11*t20*t1001 & - +8.0*t576*t1174-4.0*t582*t1174-8.0*t576*t1180+4.0*t582*t1180-4.0*t975*t1174+4.0*t975*t1180+t638*t980 & - +2.0*t638*t985-4.0*t717*t991+4.0*t717*t996+2.0*t975*t960-t975*t963 & - +4.0*t975*t970-4.0*t975*t579-2.0*t975*t586+4.0*t975*t591; - t1211 = t143*g02; - t1218 = t143*g03; - t1222 = dgy01*dgx23; - t1223 = t1222*r; - t1226 = dgy01*dgy22; - t1227 = t1226*r; - t1230 = dgx01*dgx22; - t1231 = t1230*r; - t1234 = t12*ddgxx01; - t1240 = t11*t17; - t1242 = dg00*t25*t201; - t1245 = t197*g00; - t1248 = t523*t5; - t1250 = g00*t19*t201; - t1254 = t371*t19*t201; - t1265 = t12*t6; - t1272 = t143*dg02; - t1277 = t143*Theta23; - t1281 = -4.0*t975*t595-8.0*t1211*t876*Rmin+4.0*t1211*t880*Rmin-4.0*t1218*t884*Rmin & - -8.0*t453*t1223+4.0*t453*t1227-4.0*t479*t1231-16.0*t386*t1234*r+8.0*t406*t1223+4.0*t1240*t1242 & - +8.0*t1245*t321+12.0*t1248*t1250-12.0*t524*t1254-12.0*t508*t365*t19*t201 & - +12.0*t430*t1254+12.0*t1240*t1250-4.0*t495*t1265*t19+8.0*t495*t1265*r-4.0*t1272*dgy22*t25*Rmin-4.0*t1277*t320*Rmin; - t1282 = t143*dg23; - t1287 = t143*dg22; - t1296 = t143*dgx22; - t1301 = t42*t5; - t1308 = t393*Rmin; - t1311 = t397*Rmin; - t1325 = t92*g23; - t1326 = dgx23*dgy23; - t1330 = dgy23*dgy22; - t1334 = t92*g33; - t1335 = dgx33*dgx22; - t1338 = dgy23*dgx22; - t1348 = dgx33*dgy22; - t1351 = -4.0*t1282*Theta22*t25*Rmin-4.0*t1287*dgx03*t25*Rmin+4.0*t1287*dgy02*t25*Rmin & - +4.0*t1296*dg03*t25*Rmin+4.0*t1301*t31+6.0*t1301*t35-12.0*t1301*t39+8.0*t1211*t1308 & - -4.0*t1211*t1311+4.0*t1218*t402*Rmin-4.0*t1272*t1308 & - +2.0*t1272*t1311+2.0*t1277*dg22*t19*Rmin-8.0*t1325*t1326*r+4.0*t1325*t1330*r+t1334*t1335*t19 & - -2.0*t1334*t1338*t19-2.0*t1334*t1335*r+4.0*t1334*t1338*r-t1325*t1348*t19; - t1354 = dgy33*dgx22; - t1386 = t197*dg00; - t1398 = dg00*t20*t201; - t1411 = t1325*t1354*t19+2.0*t1325*t1348*r-2.0*t1325*t1354*r+2.0*t1282*Theta22*t20*Rmin & - +2.0*t1287*dgx03*t20*Rmin-2.0*t1287*dgy02*t20*Rmin-2.0*t1296*t315*Rmin-8.0*t1301*t27 & - +8.0*t1272*dgx23*t25*Rmin-2.0*t508*t202+2.0*t1386*dg22*t199*t201+4.0*t508*t207-4.0*t1386*dg22*t205*t201 & - -4.0*t1248*t1398-2.0*t508*t211-4.0*t1240*t1398-12.0*t1245*t306+2.0*t1386*t306+4.0*t1248*t1242; - t1426 = t142*ddgyr22*g02; - t1432 = t142*ddgxr23*g02; - t1437 = t377*t643; - t1441 = t522*t371*dg33; - t1449 = t522*t1*Rmin; - t1475 = 4.0*t1301*t22-4.0*t1272*dgx23*t20*Rmin+2.0*t1272*dgy22*t20*Rmin+2.0*t1277*t305*Rmin & - -8.0*t576*t1426+4.0*t582*t1426+8.0*t576*t1432-4.0*t582*t1432-2.0*t638*t1437-2.0*t717*t1441 & - +4.0*t975*t1426-4.0*t975*t1432+2.0*t1449*t1123*dgy33 & - -2.0*t1449*r*g03*dgy33-4.0*t1449*t1023*dgy03+4.0*t1009*t787*dgy03 & - +2.0*t1449*t1023*Theta33-2.0*t1009*t787*Theta33+4.0*t1449*t1099*dgy03-4.0*t1009*t792*dgy03; - t1483 = dgx33*dgx23; - t1496 = r*t142; - t1506 = t19*t142; - t1522 = t422*t522; - t1523 = t750*dg01; - t1526 = t754*dg01; - t1529 = t366*dg01; - t1532 = t372*dg01; - t1535 = t17*g00; - t1536 = t1535*dg01; - t1539 = -2.0*t1449*t1099*Theta33+2.0*t1009*t792*Theta33+4.0*t1325*t1483*r-2.0*t1325*t1483*t19+4.0*t1325*t1326*t19 & - -2.0*t1325*t1330*t19-4.0*t786*t1496*Theta23+4.0*t786*t1496*dgx03+4.0*t786*t1496*dgy02+4.0*t786*t1506*Theta23 & - -4.0*t786*t1506*dgx03-4.0*t786*t1506*dgy02+4.0*t610*t1437-2.0*t717*t1437+2.0*t850*t1441 & - -4.0*t1522*t1523+4.0*t1522*t1526+4.0*t855*t1529-4.0*t855*t1532-4.0*t860*t1536; - t1540 = t366*t658; - t1543 = t1535*ddg22; - t1547 = t856*dg22; - t1556 = t265*t522; - t1592 = -2.0*t610*t1540-4.0*t610*t1543+4.0*t325*t17*t1547+t717*t1540+2.0*t717*t1543 & - -2.0*t265*t17*t1547+4.0*t1556*t1523-4.0*t1556*t1526-4.0*t749*t1529+4.0*t749*t1532 & - +4.0*t758*t1536+t638*t1540+2.0*t638*t1543-2.0*t273*t17*t1547 & - +4.0*t610*t1535*dg22+2.0*t1282*t35+2.0*t1287*dgx03*t19*Rmin & - -2.0*t1287*dgy02*t19*Rmin-2.0*t1296*dg03*t19*Rmin-6.0*t1301*t48; - t1598 = t1222*t19; - t1601 = t1226*t19; - t1604 = t1230*t19; - t1629 = t11*t13; - t1636 = t365*dg23; - t1641 = t11*t12*g03; - t1646 = 12.0*t1301*t52+4.0*t453*t1598-2.0*t453*t1601+2.0*t479*t1604+8.0*t386*t1234*t19-4.0*t406*t1598 & - +2.0*t406*t1601-2.0*t415*t1604-4.0*t406*t1227+4.0*t415*t1231-4.0*t386*t392*dgx23 & - +2.0*t386*t392*dgy22-2.0*t386*t401*dgx22 & - +26.0*t1629*t529-8.0*t1629*t532-4.0*t1629*t535+4.0*t278*t1636*t265-4.0*t1641*t561+4.0*t1641*t564; - t1647 = t4*t277; - t1652 = g33*g02; - t1653 = t4*t1652; - t1654 = g03*dg23; - t1668 = t4*g33*g03; - t1673 = t177*t277; - t1674 = g03*dgx22; - t1678 = dg02*dgx23; - t1682 = dg02*dgy22; - t1686 = Theta23*dg22; - t1691 = g23*t371*t741; - t1694 = g01*g33; - t1695 = t325*t1694; - t1697 = g23*t365*t741; - t1700 = t1*g23; - t1701 = t454*t1700; - t1703 = dg23*dgx23*t1173; - t1706 = dg23*dgy22; - t1707 = t1706*t1173; - t1710 = t575*t1700; - t1711 = dg33*dgx22; - t1712 = t1711*t1173; - t1716 = t888*t1700; - t1717 = dgx33*dg22; - t1718 = t1717*t1173; - t1720 = 8.0*t1647*t437+8.0*t1647*t441+8.0*t1653*t1654*t422-18.0*t1629*t569+8.0*t1629*t572 & - -4.0*t278*t1636*t422+24.0*t1647*t710+4.0*t1668*t501 & - -4.0*t1668*t505+6.0*t1673*t1674*t388+4.0*t1673*t1678*t888-2.0*t1673*t1682*t888 & - -2.0*t1673*t1686*t888+4.0*t326*t1691+4.0*t1695*t1697-4.0*t1701*t1703 & - +2.0*t1701*t1707+2.0*t1710*t1712-t1701*t1712+t1716*t1718; - t1727 = t265*t4; - t1728 = t338*t267; - t1731 = t888*t177; - t1733 = dg33*dgx23*t338; - t1737 = dg33*dgy22*t338; - t1740 = g33*ddgyr22*t338; - t1744 = g33*ddgxr23*t338; - t1747 = dgx22*dg03; - t1760 = dg23*Theta22; - t1764 = dg22*dgx03; - t1768 = dg22*dgy02; - t1787 = -4.0*t1716*t1703+2.0*t1716*t1707-t1716*t1712+4.0*t1727*t1728-2.0*t1731*t1733+t1731*t1737 & - -4.0*t1731*t1740+4.0*t1731*t1744+2.0*t1673*t1747*t888-8.0*t1673*t1678*t575 & - +4.0*t1673*t1682*t575+4.0*t1673*t1686*t575+4.0*t1673*t1760*t575 & - +4.0*t1673*t1764*t575-4.0*t1673*t1768*t575-4.0*t1673*t1747*t575-12.0*t1673*t590*t454 & - +2.0*t1673*t594*t454-6.0*t1673*t1674*t454+4.0*t1673*t1678*t454; - t1813 = t338*t339; - t1817 = t338*g03*t658; - t1820 = g01*t12; - t1822 = t304*t741; - t1825 = t713*t367; - t1828 = t13*t639; - t1833 = t265*t1694; - t1847 = -2.0*t1673*t1682*t454-2.0*t1673*t1686*t454-2.0*t1673*t1760*t454-2.0*t1673*t1764*t454 & - +2.0*t1673*t1768*t454+2.0*t1673*t1747*t454+12.0*t1673*t590*t388-2.0*t1673*t594*t388 & - -8.0*t422*t577*t1813+4.0*t1695*t1817-8.0*t325*t1820*t1822 & - -8.0*t337*t1825-4.0*t266*t1828-2.0*t266*t1691-2.0*t1833*t1697-2.0*t1833*t1817 & - +4.0*t265*t1820*t1822+4.0*t348*t1825-4.0*t1629*t956-4.0*t1641*t501; - t1873 = t713*t979; - t1876 = g33*t365*t979; - t1882 = t1652*t1711; - t1884 = t177*t575; - t1887 = t177*t454; - t1891 = g33*g00*t979; - t1896 = 4.0*t1641*t505-8.0*t1668*t516+8.0*t1668*t519+8.0*t1629*t510+8.0*t1641*t516-8.0*t1641*t519-8.0*t1647*t549 & - -8.0*t1647*t553-8.0*t1653*t1654*t265+4.0*t1668*t561-4.0*t1668*t564-t274*t1873 & - +2.0*t326*t1876+2.0*t326*t1873-t266*t1876 & - -t1731*t1882+2.0*t1884*t1882-t1887*t1882+t4*t273*t1891-2.0*t4*t325*t1891; - t1897 = t277*t327; - t1901 = t4*t422; - t1904 = t1652*t1717; - t1906 = t1652*t1706; - t1909 = dgy23*dg22; - t1910 = t1652*t1909; - t1914 = g23*g03*t1909; - t1932 = t338*t1113; - t1934 = t888*t192; - t1935 = dg23*dgx22; - t1936 = t1935*t1173; - t1939 = t1935*t338; - t1942 = dg22*dgy22; - t1943 = t1942*t1173; - t1946 = t1942*t338; - t1949 = 4.0*t1727*t1897+t1727*t1891-4.0*t1901*t1897+t1731*t1904+2.0*t1731*t1906 & - -2.0*t1731*t1910+2.0*t1731*t1914-2.0*t1884*t1904-4.0*t1884*t1906 & - +4.0*t1884*t1910-4.0*t1884*t1914+t1887*t1904+2.0*t1887*t1906-2.0*t1887*t1910 & - +2.0*t1887*t1914+t1731*t1932+2.0*t1934*t1936-2.0*t1934*t1939-2.0*t1934*t1943+2.0*t1934*t1946; - t1973 = t575*t192; - t1982 = t454*t192; - t1995 = -4.0*t1901*t1728+4.0*t1884*t1733-2.0*t1884*t1737-2.0*t1887*t1733+t1887*t1737 & - +8.0*t1884*t1740-4.0*t1887*t1740-2.0*t1673*t1760*t888-2.0*t1673*t1764*t888 & - +2.0*t1673*t1768*t888-4.0*t1973*t1936+4.0*t1973*t1939+4.0*t1973*t1943-4.0*t1973*t1946 & - +2.0*t1982*t1936-2.0*t1982*t1939-2.0*t1982*t1943-t266*t1873+8.0*t265*t577*t1813-4.0*t274*t1828; - t1998 = t273*t1694; - t2035 = -2.0*t274*t1691-2.0*t1998*t1697+2.0*t1982*t1946-2.0*t1710*t1718+8.0*t1710*t1703 & - -4.0*t1710*t1707+t1701*t1718-8.0*t1884*t1744+4.0*t1887*t1744 & - -2.0*t1998*t1817+4.0*t273*t1820*t1822+4.0*t355*t1825-8.0*t326*t13*t528+8.0*t326*t1828 & - -2.0*t1884*t1932+t1887*t1932-t274*t1876+2.0*t197*t6-4.0*t18*ddgxx01+t56*t249; - Theta22_rhs = 1/t1*(t811+t738+t686+t618+t552+t477+t1720+t1646+t1592+t1539+t1475+t2035 & - +t385+t1995+t1411+t1351+t1281+t301+t1207+t1160+t1949+t1094+t1049+t983+t928 & - +t871+t1896+t1847+t1787+t234+t162+t88) & - /(-2.0*t627*g33-2.0*t17*r-2.0*t611*r+t17*t19+t611*t19-2.0*t627*t1023+4.0*t627*t1099+t17+t611)/Rmin/t19/4.0; - - t1 = g01*g01; - t3 = g23*g23; - t4 = t3*t3; - t5 = t1*t4; - t8 = t3*g23; - t9 = t1*g01; - t10 = t8*t9; - t17 = g01*g22; - t18 = t3*g33; - t19 = t17*t18; - t20 = dg00*dg23; - t21 = r*r; - t22 = t21*t21; - t23 = Rmin*Rmin; - t24 = t22*t23; - t25 = t20*t24; - t28 = dg02*dg03; - t29 = t28*t24; - t32 = g33*g23; - t33 = t17*t32; - t34 = g03*g03; - t35 = t34*dg22; - t39 = g01*g33; - t40 = t3*g02; - t41 = t39*t40; - t42 = g03*dg22; - t46 = t1*g22; - t47 = t46*t32; - t48 = dg23*dgx03; - t49 = t21*r; - t50 = t49*Rmin; - t54 = dg23*dgy02; - t59 = dgy22*dg03; - t63 = g02*dgx33; - t64 = t21*Rmin; - t68 = g03*dgy22; - t72 = dg02*dgx33; - t76 = Theta33*dg22; - t89 = r*Rmin; - t96 = t22*Rmin; - t100 = -2.0*t47*t48*t64-4.0*t47*t59*t50-2.0*t47*t54*t64+2.0*t47*t59*t64 & - -6.0*t47*t63*t64+6.0*t47*t63*t89-6.0*t47*t68*t64+2.0*t47*t72*t64-2.0*t47*t76*t64+6.0*t47*t68*t89+2.0*t47*t72*t96; - t120 = dg02*dg23; - t121 = t120*t24; - t124 = dg22*dg03; - t125 = t124*t24; - t128 = g22*g22; - t129 = g01*t128; - t130 = t129*t32; - t131 = g03*dg03; - t132 = t49*t23; - t133 = t131*t132; - t136 = g33*g33; - t137 = t136*g23; - t138 = t17*t137; - t139 = g02*dg02; - t140 = t139*t132; - t144 = g00*dg23; - t145 = t144*t132; - t148 = g02*dg03; - t152 = g03*dg02; - t162 = g02*g03; - t163 = t21*t23; - t168 = t17*t136*g02; - t169 = t22*t21; - t170 = t169*t23; - t171 = t120*t170; - t174 = t24*t17; - t175 = g33*ddg23; - t176 = g00*t3; - t177 = t175*t176; - t181 = dg33*dg23; - t183 = t181*g00*g33; - t185 = g02*g02; - t186 = t185*g33; - t187 = t181*t186; - t189 = t181*t176; - t191 = -20.0*t19*t145+8.0*t19*t148*t132+8.0*t19*t152*t132-2.0*t33*t35*t132-4.0*t41*t42*t132 & - +24.0*t19*t162*t163-2.0*t168*t171-4.0*t174*t177-t24*t129*t183+t174*t187+t174*t189; - t194 = g01*t136; - t196 = dg23*dg22; - t197 = g00*g22; - t198 = t196*t197; - t200 = t24*t39; - t201 = t34*g22; - t202 = t196*t201; - t204 = t196*t176; - t206 = g01*t3; - t208 = dg33*dg22; - t209 = t208*t162; - t212 = g22*g33; - t213 = t24*t212; - t214 = dg01*dg23; - t215 = t214*t176; - t219 = t3*dg01*t162; - t222 = t170*t17; - t226 = t170*t39; - t233 = t170*t212; - t236 = t22*r; - t237 = t236*t23; - t238 = t237*t17; - t239 = g33*dg23; - t247 = t1*t128; - t248 = t136*ddgxy01; - t251 = t1*t8; - t252 = dgx01*dgx33; - t255 = dgy01*dgy22; - t258 = g01*t4; - t259 = dgx01*dgy01; - t268 = 2.0*t170*t206*t209+4.0*t233*t215-8.0*t238*t239*t176-4.0*t222*t177 & - -t170*t129*t183-4.0*t247*t248+2.0*t251*t252+2.0*t251*t255+2.0*t258*t259-4.0*t10*ddgxy23*t21+8.0*t10*ddgxy23*r; - t282 = t3*t9; - t283 = dgx33*dgy22; - t285 = dgy33*dgx22; - t287 = dgx33*dgx23; - t290 = dgx23*dgy23; - t293 = dgy23*dgy22; - t296 = g23*t9; - t297 = dgy22*dgy22; - t298 = g33*t297; - t301 = dgx33*dgx33; - t302 = g22*t301; - t310 = dg33*t22; - t311 = t310*t23; - t315 = g02*dg23; - t316 = dg03*t22; - t317 = t316*t23; - t321 = t237*t212; - t322 = g23*g02; - t323 = t322*g03; - t324 = t214*t323; - t327 = t175*t323; - t330 = t181*t323; - t333 = t196*t323; - t336 = g01*g23; - t337 = t24*t336; - t339 = t208*t197*g33; - t344 = t296*t302-4.0*t5*ddgxy01*t21+8.0*t5*ddgxy01*r-2.0*t33*t139*t311+2.0*t33*t315*t317 & - +8.0*t321*t324+4.0*t174*t327-2.0*t174*t330-2.0*t200*t333+2.0*t337*t339-4.0*t213*t324; - t366 = t237*t39; - t373 = g03*dg33; - t376 = t373*dg22*g33*g02; - t384 = dg23*t169*t23; - t389 = dg03*t169*t23; - t394 = dg23*t236*t23; - t399 = dg03*t236*t23; - t404 = dg23*t22*t23; - t415 = dg23*t49*t23; - t419 = -2.0*t33*t42*t317-2.0*t33*t42*t389+4.0*t33*t42*t399+2.0*t33*t152*t384-4.0*t33*t152*t394 & - +2.0*t33*t152*t404-32.0*t33*t162*t404+24.0*t33*t162*t415-2.0*t174*t376-2.0*t222*t376+4.0*t238*t376; - t437 = g01*t8; - t438 = t437*g02; - t439 = dg23*dg03; - t440 = t439*t237; - t443 = t129*g33; - t444 = t34*dg23; - t445 = t444*t24; - t448 = t1*g33; - t449 = t448*t3; - t450 = dg22*dgy02; - t451 = t450*t64; - t453 = t247*g33; - t454 = g03*dgx33; - t455 = t454*t89; - t458 = t46*t136; - t459 = dgy22*g02; - t460 = t459*t89; - t463 = t46*g33; - t464 = t3*Theta23; - t469 = t3*dgx03; - t473 = t3*dgy02; - t477 = g23*dgx01; - t478 = dgx33*t21; - t482 = g23*dgy01; - t483 = dgy22*t21; - t487 = t46*t3; - t492 = dgx33*r; - t496 = dgy22*r; - t500 = Theta33*dg23; - t501 = t500*t96; - t503 = dgx33*dg03; - t504 = t503*t96; - t507 = dg02*dgy22; - t508 = t507*t96; - t511 = -12.0*t463*t469*t89-12.0*t463*t473*t89-2.0*t463*t477*t478-2.0*t463*t482*t483 & - +6.0*t487*t455+6.0*t449*t460+4.0*t463*t477*t492+4.0*t463*t482*t496+t453*t501-2.0*t453*t504-2.0*t458*t508; - t514 = Theta23*dg22; - t515 = t514*t96; - t517 = dg22*dgx03; - t518 = t517*t96; - t520 = t450*t96; - t522 = t3*ddgxr03; - t533 = t454*t64; - t537 = t129*t136; - t538 = t20*t237; - t541 = t28*t237; - t544 = t437*g03; - t545 = t120*t237; - t548 = t124*t237; - t551 = g23*dg00; - t555 = dg33*Theta23; - t556 = t555*t50; - t560 = t500*t50; - t563 = t503*t50; - t566 = t507*t50; - t569 = t514*t50; - t572 = -4.0*t537*t538+4.0*t537*t541+4.0*t544*t545-4.0*t544*t548-4.0*t537*t551*t24-2.0*t453*t556 & - -t449*t520-2.0*t453*t560+4.0*t453*t563+4.0*t458*t566-2.0*t458*t569; - t574 = t517*t50; - t577 = t450*t50; - t597 = t500*t64; - t599 = 8.0*t463*t522*t50-4.0*t449*t566+2.0*t449*t569-2.0*t449*t574+2.0*t449*t577+4.0*t453*t533+t453*t597 & - +2.0*t458*t574-2.0*t458*t577+2.0*t487*t560-4.0*t487*t563; - t600 = t503*t64; - t603 = t459*t64; - t606 = t507*t64; - t609 = t514*t64; - t611 = t517*t64; - t614 = t24*g01; - t616 = g00*dg22; - t617 = t8*dg33*t616; - t620 = dg23*dg23; - t621 = g23*t620; - t622 = t621*t201; - t625 = t621*t186; - t634 = -2.0*t453*t600+4.0*t458*t603-2.0*t458*t606+t458*t609-t458*t611+t458*t451 & - -2.0*t614*t617-2.0*t614*t622-2.0*t614*t625-4.0*t463*t522*t64-12.0*t463*t464*t64; - t645 = t17*g33; - t646 = t3*dgx01; - t655 = t144*t24; - t662 = t17*t136; - t663 = t185*dg23; - t664 = t663*t24; - t667 = t8*dg00; - t671 = t17*t8; - t672 = t131*t24; - t676 = t39*t8; - t677 = t139*t24; - t680 = t39*t3; - t683 = g03*dg23; - t696 = t663*t132; - t706 = -8.0*t676*t677-8.0*t680*t664+24.0*t438*t683*t24-2.0*t544*t121+2.0*t544*t125+4.0*t537*t551*t132 & - +8.0*t537*t145-8.0*t662*t696-8.0*t645*t667*t132+8.0*t671*t133+8.0*t676*t140; - t738 = t237*g01; - t739 = t128*dg33; - t740 = t739*t444; - t743 = t136*dg23; - t744 = dg22*t185; - t745 = t743*t744; - t748 = t3*ddg23; - t749 = t748*t201; - t752 = t748*t186; - t756 = t8*ddg23*t162; - t766 = t3*t620*t162; - t769 = t237*t128; - t770 = t136*dg01; - t771 = t770*t144; - t774 = -t449*t609+4.0*t738*t617+4.0*t738*t622+4.0*t738*t625-2.0*t738*t740-2.0*t738*t745 & - -4.0*t738*t749-4.0*t738*t752+8.0*t738*t756-4.0*t738*t766+4.0*t769*t771; - t778 = g33*dg01*t444; - t782 = t770*t663; - t785 = t237*t3; - t786 = t214*t201; - t789 = t214*t186; - t793 = t214*t162; - t796 = t128*t136; - t798 = t796*ddg23*g00; - t801 = t128*g33; - t803 = t801*ddg23*t34; - t806 = g22*t136; - t808 = t806*ddg23*t185; - t811 = t24*t128; - t812 = dg01*t34; - t813 = t32*t812; - t816 = t24*g22; - t817 = dg01*t185; - t818 = t137*t817; - t823 = g00*dg01; - t824 = g33*t8*t823; - t831 = dg02*dg33; - t832 = t831*t170; - t835 = t439*t170; - t838 = t831*t237; - t842 = t3*t1*Rmin; - t843 = r*g33; - t844 = dgx23*g02; - t849 = dgy23*dg22; - t857 = t17*t3; - t860 = -8.0*t816*t824+t614*t740+t614*t745+2.0*t614*t749+2.0*t438*t832-2.0*t438*t835 & - -4.0*t438*t838+4.0*t842*t843*t844+2.0*t842*t22*g03*t849-4.0*t842*t49*g03*t849-8.0*t857*t445; - t862 = t831*t24; - t865 = t439*t24; - t868 = t444*t132; - t873 = dg33*dgx03; - t874 = t873*t50; - t877 = dg33*dgy02; - t878 = t877*t50; - t881 = dg23*Theta22; - t882 = t881*t50; - t885 = t3*ddgyr02; - t895 = 2.0*t438*t862-2.0*t438*t865-8.0*t443*t868+4.0*t857*t868-2.0*t453*t874+2.0*t453*t878-2.0*t458*t882 & - +8.0*t463*t885*t50+2.0*t487*t556+2.0*t487*t874-2.0*t487*t878; - t898 = t555*t64; - t900 = t873*t64; - t902 = t877*t64; - t904 = t881*t64; - t913 = t555*t96; - t915 = -4.0*t463*t885*t64+2.0*t449*t882-t449*t904+t453*t898+t453*t900-t453*t902 & - +t453*t913+t458*t904-t487*t898-t487*t900+t487*t902; - t919 = t873*t96; - t921 = t877*t96; - t923 = t881*t96; - t932 = t20*t170; - t935 = t28*t170; - t941 = t124*t170; - t944 = t50*t1; - t946 = t806*ddgyr22*g02; - t949 = t64*t1; - t953 = t806*ddgxr23*g02; - t958 = g02*dgx22; - t959 = t743*t958; - t963 = t136*dg22*t459; - t968 = t3*dg23; - t969 = g03*dgx23; - t970 = t968*t969; - t973 = -2.0*t544*t171+2.0*t544*t941+4.0*t944*t946-4.0*t944*t953+2.0*t944*t959-2.0*t944*t963+4.0*t944*t970 & - -2.0*t949*t946+2.0*t949*t953-t949*t959+t949*t963; - t978 = g33*g02; - t979 = t3*ddgyr22*t978; - t985 = t3*ddgxr23*t978; - t990 = t137*t744; - t995 = t128*t34*dg33*g23; - t998 = t96*t1; - t1006 = t132*t128; - t1007 = t137*t823; - t1012 = t132*g22; - t1023 = t132*g01; - t1030 = t998*t963-4.0*t1006*t1007+4.0*t1006*t813+4.0*t1012*t818+8.0*t1012*t824+2.0*t614*t752-4.0*t614*t756 & - -2.0*t998*t985+2.0*t1023*t990+2.0*t1023*t995+2.0*t614*t766; - t1039 = t24*t3; - t1044 = t24*t8; - t1067 = t170*g01; - t1084 = 4.0*t738*t968*t186-8.0*t738*t8*dg23*t162+2.0*t1067*t798-2.0*t1067*t803-2.0*t1067*t808+t1067*t740+t1067*t745 & - +2.0*t1067*t749+2.0*t1067*t752-4.0*t1067*t756-2.0*t1067*t617; - t1092 = t170*t128; - t1100 = t170*t3; - t1112 = -2.0*t1067*t622-2.0*t1067*t625+2.0*t1067*t766-2.0*t1092*t771+2.0*t1092*t778+2.0*t170*g22*t782 & - -2.0*t1100*t786-2.0*t1100*t789+4.0*t170*t8*t793+4.0*t811*t1007-4.0*t738*t798; - t1117 = t21*g03; - t1121 = r*g22; - t1122 = g03*dgy23; - t1126 = t21*g22; - t1127 = g02*dgy33; - t1131 = t437*t49; - t1133 = g00*dg33; - t1134 = t23*g22*t1133; - t1138 = t23*g33*t616; - t1141 = t1*g23; - t1142 = t1141*Rmin; - t1143 = t21*t128; - t1144 = g03*dgy33; - t1148 = r*t128; - t1160 = 4.0*t738*t803+4.0*t738*t808+2.0*t842*t1117*t849+4.0*t842*t1121*t1122 & - -2.0*t842*t1126*t1127-2.0*t1131*t1134-2.0*t1131*t1138+2.0*t1142*t1143*t1144 & - -2.0*t1142*t1148*t1144+2.0*t1142*t21*t136*t958-2.0*t1142*r*t136*t958; - t1166 = t136*dgx02; - t1173 = t136*Theta22; - t1177 = g33*dgy03; - t1181 = g33*Theta33; - t1191 = t437*t22; - t1203 = t21*g33; - t1204 = g03*dgx22; - t1212 = dg33*dgx23; - t1231 = t128*dgy33*t683; - t1234 = g22*g03; - t1235 = t3*ddgyr23*t1234; - t1239 = t3*ddgxr33*t1234; - t1242 = 2.0*t842*t1121*t1127-2.0*t842*t1203*t1204+2.0*t842*t843*t1204+2.0*t842*t22*g02*t1212 & - -4.0*t842*t49*g02*t1212-4.0*t842*t1203*t844+2.0*t842*t21*g02*t1212 & - -4.0*t842*t1126*t1122-t998*t1231-2.0*t998*t1235+2.0*t998*t1239; - t1245 = t801*ddgyr23*g03; - t1249 = t801*ddgxr33*g03; - t1252 = g02*dgy23; - t1253 = t968*t1252; - t1256 = t739*t454; - t1289 = t96*t46; - t1291 = dg33*dgx33*t322; - t1293 = 2.0*t944*t1231-t949*t1231+4.0*t944*t1235-2.0*t949*t1235-4.0*t944*t1239 & - +2.0*t949*t1239-2.0*t944*t1256+t949*t1256-t1289*t1291-2.0*t998*t970+2.0*t998*t979; - t1313 = t1141*t64; - t1314 = t212*t1252; - t1317 = t1141*t89; - t1320 = t1141*t96; - t1322 = t212*dg33*dgx02; - t1326 = t1141*t50; - t1331 = t336*t132; - t1332 = t801*t1133; - t1335 = t806*t616; - t1342 = t212*t969; - t1348 = t212*dg22*dgy03; - t1355 = 2.0*t1313*t1322+4.0*t1313*t1342+2.0*t1313*t1348-4.0*t1317*t1342+2.0*t1320*t1348 & - -4.0*t1326*t1322-4.0*t1326*t1348+2.0*t1331*t1332+2.0*t1331*t1335-2.0*t337*t1332-2.0*t337*t1335; - t1357 = t50*t46; - t1359 = g33*ddgxr33*t322; - t1362 = t64*t46; - t1366 = dg23*dgy23*t1234; - t1374 = dgy33*dg23*t322; - t1379 = t50*t448; - t1380 = dgx33*dg22; - t1381 = t1380*t1234; - t1384 = dg23*dgy22; - t1385 = t1384*t1234; - t1388 = t849*t1234; - t1391 = 2.0*t1357*t1291-t1362*t1291+2.0*t1313*t1366-4.0*t1326*t1366-4.0*t1357*t1359-2.0*t1357*t1374 & - +2.0*t1362*t1359+t1362*t1374-2.0*t1379*t1381-2.0*t1379*t1385+4.0*t1379*t1388; - t1392 = t64*t448; - t1398 = g33*ddgyr23*t322; - t1405 = dgx33*dg23; - t1406 = t1405*t978; - t1409 = g23*g03; - t1410 = t1405*t1409; - t1413 = t1212*t978; - t1416 = dg33*dgy22; - t1417 = t1416*t978; - t1419 = t1416*t1409; - t1421 = t1392*t1381+t1392*t1385-2.0*t1392*t1388-2.0*t1289*t1398+2.0*t1289*t1359 & - +2.0*t1320*t1366-2.0*t1357*t1406+2.0*t1357*t1410-2.0*t1362*t1413+t1362*t1417-t1362*t1419; - t1428 = g33*ddgyr22*t1409; - t1434 = g33*ddgxr23*t1409; - t1440 = dg23*dgx22*t1409; - t1444 = dg22*dgy22*t1409; - t1450 = t1380*t978; - t1454 = dg23*dgx23*t978; - t1457 = t1384*t978; - t1473 = g03*t620*t978; - t1476 = 2.0*t237*t129*t183-t1313*t1450+2.0*t1313*t1454-t1313*t1457+2.0*t1326*t1450-4.0*t1326*t1454 & - +2.0*t1326*t1457+2.0*t222*t1473+8.0*t238*t177+t222*t187-2.0*t238*t187; - t1488 = t96*t448; - t1490 = dg33*Theta22; - t1501 = t185*dg33; - t1505 = t17*t40; - t1510 = t129*g33*g03; - t1516 = t17*t3*g03; - t1529 = -2.0*t33*t1501*t132-2.0*t47*t1490*t96-4.0*t1505*t373*t132+4.0*t1510*t440 & - +2.0*t1510*t832-2.0*t1510*t835-4.0*t1510*t838-4.0*t1516*t440-2.0*t1516*t832+2.0*t1516*t835+4.0*t1516*t838; - t1577 = 8.0*t19*t538-8.0*t19*t541-4.0*t41*t545+4.0*t41*t548-2.0*t41*t941-2.0*t168*t121+2.0*t168*t125 & - +8.0*t130*t672+8.0*t138*t677+4.0*t168*t545-4.0*t168*t548; - t1598 = 28.0*t19*t655-8.0*t19*t148*t24-8.0*t19*t152*t24+t1289*t1374+t1488*t1381+t1488*t1385 & - -2.0*t1488*t1388+4.0*t1357*t1398-2.0*t1362*t1398-t1488*t1444-t1320*t1450; - t1612 = t437*t185; - t1615 = dg33*t49; - t1619 = t251*dg23; - t1624 = t251*dgy22; - t1625 = dg03*t49; - t1629 = 2.0*t1320*t1454-t1320*t1457-4.0*t238*t1473+2.0*t174*t1473+4.0*t1357*t1413-2.0*t1357*t1417 & - +2.0*t1357*t1419-4.0*t1612*t311+4.0*t1612*t1615*t23-4.0*t1619*dgy02*t49*Rmin+4.0*t1624*t1625*Rmin; - t1634 = t247*t136; - t1636 = ddgxr03*t21*Rmin; - t1640 = Theta23*t21*Rmin; - t1644 = dgx03*t21*Rmin; - t1648 = dgy02*t21*Rmin; - t1651 = t251*g02; - t1652 = t478*Rmin; - t1655 = t251*g03; - t1660 = t251*dg02; - t1663 = t251*Theta33; - t1664 = dg22*t21; - t1678 = Theta23*r*Rmin; - t1682 = dgx03*r*Rmin; - t1686 = dgy02*r*Rmin; - t1689 = dgy01*dgx33; - t1690 = t1689*t21; - t1693 = t258*dg00; - t1696 = t258*dg02; - t1703 = t258*g00; - t1706 = 2.0*t1619*t1648-2.0*t1624*dg03*t21*Rmin-4.0*t1634*t1678+4.0*t1634*t1682+4.0*t1634*t1686 & - +2.0*t453*t1690+2.0*t1693*t384-2.0*t1696*t389-4.0*t1693*t394+4.0*t1696*t399-16.0*t1703*t404; - t1708 = t258*g02; - t1711 = t258*g03; - t1720 = dg01*g02*g03; - t1724 = ddgyr02*t21*Rmin; - t1727 = t251*dg33; - t1733 = ddgyr02*t22*Rmin; - t1741 = ddgyr02*t49*Rmin; - t1752 = dg22*t22; - t1768 = ddgxr03*t49*Rmin; - t1775 = dg22*t49; - t1783 = t251*Rmin; - t1788 = t8*ddgyr23*g02; - t1791 = 4.0*t282*t287*r+2.0*t1663*t1752*Rmin+2.0*t1619*dgx03*t22*Rmin+2.0*t1619*dgy02*t22*Rmin & - -2.0*t1624*t316*Rmin-4.0*t1634*t1768+4.0*t1660*dgx33*t49*Rmin & - -4.0*t1663*t1775*Rmin-4.0*t1619*dgx03*t49*Rmin-2.0*t1783*t1203*Theta22+2.0*t998*t1788; - t1795 = t8*ddgxr33*g02; - t1823 = t296*g33; - t1824 = dgy23*dgx22; - t1828 = dgx33*dgx22; - t1836 = t8*ddgyr22*g03; - t1842 = t8*ddgxr23*g03; - t1852 = t4*ddg23*g00; - t1856 = t214*g00; - t1859 = 4.0*t1823*t1824*r-2.0*t1823*t1828*r-2.0*t1823*t1824*t21+4.0*t237*t4*t1856+4.0*t944*t1836 & - -2.0*t949*t1836-2.0*t998*t1836-4.0*t944*t1842+2.0*t949*t1842+2.0*t998*t1842-4.0*t738*t1852; - t1863 = t24*t4; - t1875 = t812*g22; - t1878 = t817*g33; - t1883 = t132*t8; - t1890 = 2.0*t614*t1852-2.0*t1863*t1856+2.0*t1067*t1852-2.0*t170*t4*t1856 & - +4.0*t738*t4*dg23*g00+4.0*t1044*t1875+4.0*t1044*t1878 & - -8.0*t1863*t1720-4.0*t1883*t1875-4.0*t1883*t1878-2.0*t1696*t317; - t1891 = t437*t34; - t1918 = t259*t21; - t1921 = t259*r; - t1927 = -4.0*t1891*t1752*t23+12.0*t1703*t415-8.0*t1708*t1625*t23-8.0*t1711*dg02*t49*t23 & - +4.0*t1891*t1775*t23+12.0*t671*t34*t21*t23+12.0*t676*t185*t21*t23 & - -24.0*t1708*t1117*t23+2.0*t537*t1918-4.0*t537*t1921-4.0*t645*t646*dgy01; - t1931 = dgx01*dgy22; - t1932 = t1931*t21; - t1935 = t3*ddgxy01; - t1949 = t1689*r; - t1952 = t1931*r; - t1970 = ddgxr03*t22*Rmin; - t1995 = 4.0*t449*t1952-2.0*t463*t477*dgx33-2.0*t463*t482*dgy22+2.0*t1634*t1970-2.0*t1660*dgx33*t22*Rmin & - +2.0*t1783*t843*Theta22-2.0*t1783*t1752*dgy03 & - +4.0*t1783*t1126*dgy03+4.0*t1783*t1775*dgy03-2.0*t1783*t1664*dgy03-2.0*t1783*t1126*Theta33; - t2003 = t296*g22; - t2004 = dgy33*dgx23; - t2008 = dgy33*dgy22; - t2017 = g33*ddgxy23; - t2024 = g33*ddgyy22; - t2032 = g33*ddgxx33; - t2065 = -2.0*t2003*t2032*t21+4.0*t2003*t2032*r+t1823*t1828*t21+2.0*t282*t283*r & - -2.0*t282*t285*r-2.0*t282*t287*t21+4.0*t282*t290*t21-2.0*t282*t293*t21 & - +4.0*t296*t212*ddgxy23-2.0*t296*t212*ddgyy22-2.0*t296*t212*ddgxx33; - t2085 = g22*dgy33; - t2091 = t4*g23; - t2093 = t2091*dg01*g00; - t2122 = t136*dgx01; - t2133 = 8.0*t5*t1682+8.0*t5*t1686+2.0*t251*t252*t21+2.0*t251*t255*t21+8.0*t247*t248*r-4.0*t251*t252*r-4.0*t251*t255*r & - +2.0*t247*g33*dgy01*dgx33+2.0*t46*t2122*dgy22+8.0*t46*t18*ddgxy01-2.0*t46*t3*dgy01*dgx33; - t2138 = g01*t2091; - t2166 = -2.0*t448*t646*dgy22 & - -4.0*t2138*dg00*t22*t23+4.0*t2138*dg00*t49*t23+12.0*t2138*g00*t21*t23 & - +2.0*t258*t1918-4.0*t258*t1921+2.0*t129*t2122*dgy01+2.0*t5*t1733-4.0*t5*t1741+2.0*t5*t1724+2.0*t5*t1970; - t2192 = -4.0*t5*t1768+2.0*t5*t1636+8.0*t5*t1640-8.0*t5*t1644-8.0*t5*t1648-4.0*t247*t248*t21 & - -8.0*t5*t1678-8.0*t282*t290*r+4.0*t282*t293*r-t282*t283*t21+t282*t285*t21; - t2201 = t3*g22; - Theta23_rhs = 1/t1& - *(-12.0*t443*g23*t34*t163-12.0*t662*g23*t185*t163 & - -24.0*t645*t8*g00*t163+8.0*t1711*dg02*t22*t23 & - +2.0*t1727*Theta22*t21*Rmin+2.0*t1727*Theta22*t22*Rmin & - -4.0*t1727*Theta22*t49*Rmin-2.0*t1783*t21*dg33*dgx02 & - +t296*g33*dgx33*dgx22-2.0*t296*g33*dgy23*dgx22 & - -4.0*t645*t646*dgy01*t21+8.0*t645*t646*dgy01*r & - +12.0*t537*g23*g00*t163-2.0*t33*t139*dg33*t169*t23 & - +4.0*t33*t139*dg33*t236*t23 & - +t100+t344+t268+t191+t2133+t2065+t1927 & - +t706+t599+t634+t511+t572+t419+t1706+t1476 & - +t1629+t1421+t1598+t1391+t1355+t1529-4.0*t453*t455 & - +t1859+t1995+t1791+t2166+t2192+t1293+t1242 & - +t1890+t1112+t1160+t1084 & - -2.0*t1783*t310*dgx02+4.0*t1783*t1203*dgx02 & - +4.0*t1783*t1615*dgx02-4.0*t1783*t843*dgx02 & - +8.0*t463*t1935*t21-8.0*t1651*t492*Rmin & - -8.0*t1655*t496*Rmin-16.0*t463*t1935*r & - -4.0*t1783*t1121*dgy03+2.0*t1783*t1121*Theta33 & - -2.0*t2003*t2004*t21+t2003*t2008*t21+4.0*t2003*t2004*r & - -2.0*t2003*t2008*r+4.0*t2003*t2017*t21 & - -8.0*t2003*t2017*r-2.0*t2003*t2024*t21+4.0*t2003*t2024*r & - +t296*t298*t21-2.0*t296*t298*r+t296*t302*t21 & - -2.0*t296*t302*r-2.0*t296*t2085*dgx23+t296*t2085*dgy22 & - +4.0*t738*t968*t201-4.0*t1142*t1126*t1166 & - +4.0*t1142*t1121*t1166-2.0*t1142*t1121*t1173 & - -4.0*t1142*t1143*t1177+2.0*t1142*t1143*t1181 & - +4.0*t1142*t1148*t1177-2.0*t1142*t1148*t1181 & - +2.0*t1142*t1126*t1173-8.0*t132*t212*t219 & - +2.0*t237*t194*t198-4.0*t237*t206*t209+4.0*t47*t1490*t50 & - -2.0*t47*t1490*t64+2.0*t33*t1501*t24+4.0*t1505*t373*t24 & - +8.0*t1655*t483*Rmin+2.0*t1663*t1664*Rmin & - +8.0*t132*t4*t1720+2.0*t33*t315*t389-4.0*t33*t315*t399 & - +12.0*t463*t464*t89-4.0*t463*t522*t96+12.0*t463*t469*t64 & - +12.0*t463*t473*t64+8.0*t645*t667*t24-16.0*t438*t683*t132 & - -4.0*t237*g22*t782-8.0*t237*t8*t793-4.0*t463*t885*t96 & - +4.0*t738*t796*t144-4.0*t738*t801*t444-4.0*t738*t806*t663 & - -t24*t194*t198+2.0*t24*t206*t209-t170*t194*t198 & - +2.0*t10*ddgyy22*t21-4.0*t10*ddgyy22*r+2.0*t10*ddgxx33*t21 & - -4.0*t10*ddgxx33*r+8.0*t238*t239*t323+2.0*t170*t336*t339 & - -4.0*t237*t336*t339+2.0*t33*t35*t24 & - +4.0*t41*t42*t24+4.0*t47*t48*t50+4.0*t47*t54*t50 & - -2.0*t47*t76*t96-2.0*t47*t48*t96-2.0*t47*t54*t96 & - +2.0*t47*t59*t96-4.0*t47*t72*t50+4.0*t47*t76*t50+t1030+t973 & - +t915+t895+t774+t860+t1577+4.0*t785*t786+2.0*t1619*t1644 & - -4.0*t1634*t1648+8.0*t1651*t1652+t449*t611-2.0*t1660*t1652 & - +2.0*t1634*t1636+4.0*t1634*t1640-4.0*t1634*t1644 & - +2.0*t1516*t865+2.0*t168*t941-4.0*t19*t932+4.0*t19*t935 & - +2.0*t41*t171+2.0*t1510*t862-2.0*t1510*t865 & - -2.0*t1516*t862+4.0*t222*t327-2.0*t222*t330-2.0*t226*t333 & - -8.0*t238*t327+4.0*t238*t330+4.0*t366*t333-4.0*t233*t324 & - +t282*t285-2.0*t282*t287+4.0*t282*t290-2.0*t282*t293 & - +t296*t298-t282*t283+t222*t189+t226*t202+t226*t204 & - +4.0*t213*t215+8.0*t213*t219+t200*t204+t200*t202 & - +4.0*t24*t2093-4.0*t132*t2093-4.0*t453*t1949 & - -4.0*t458*t1952+4.0*t487*t1949+2.0*t458*t1932 & - -2.0*t487*t1690-2.0*t449*t1932-t487*t597 & - +2.0*t487*t600-6.0*t449*t603+2.0*t449*t606+4.0*t680*t696 & - -8.0*t671*t672-12.0*t537*t655+2.0*t537*t25-2.0*t537*t29 & - +12.0*t662*t664 & - +2.0*t449*t508-t449*t515+t449*t518-6.0*t487*t533 & - +t458*t515-t458*t518+t458*t520-t487*t501 & - +2.0*t487*t504-4.0*t458*t460+4.0*t438*t440 & - +12.0*t443*t445-t449*t451 & - -8.0*t138*t140-t1289*t1419+t1289*t1406-t1289*t1410 & - +2.0*t1289*t1428-2.0*t1289*t1434+t1488*t1440 & - -2.0*t1289*t1413+t1289*t1417+4.0*t1357*t1434 & - -2.0*t1362*t1434-2.0*t1379*t1440+2.0*t1379*t1444 & - +t1392*t1440-t1392*t1444+t1362*t1406-t1362*t1410 & - -4.0*t1357*t1428+2.0*t1362*t1428+2.0*t1320*t1322 & - -8.0*t321*t215+4.0*t1313*t1314 & - -4.0*t1317*t1314+2.0*t41*t121-2.0*t41*t125-8.0*t130*t133 & - -2.0*t998*t1795-4.0*t944*t1788 & - +2.0*t949*t1788+4.0*t944*t1795 & - -2.0*t949*t1795-2.0*t238*t189-2.0*t366*t202 & - -2.0*t366*t204-4.0*t944*t1245+2.0*t949*t1245+4.0*t944*t1249 & - -2.0*t949*t1249+4.0*t944*t1253-2.0*t949*t1253 & - +2.0*t998*t1245-2.0*t998*t1249-2.0*t998*t1253 & - +t998*t1256+2.0*t1191*t1134+2.0*t1191*t1138 & - -4.0*t5*ddgxy01-4.0*t10*ddgxy23 & - +2.0*t10*ddgyy22+2.0*t10*ddgxx33 & - -4.0*t19*t25+4.0*t19*t29+2.0*t816*t782-2.0*t1039*t786 & - -2.0*t1039*t789+4.0*t1044*t793+2.0*t1634*t1733 & - -4.0*t1634*t1741+8.0*t1708*t317+2.0*t1693*t404 & - +2.0*t1634*t1724-2.0*t811*t771+2.0*t811*t778-t998*t959 & - -4.0*t944*t979+2.0*t949*t979+4.0*t944*t985-2.0*t949*t985 & - -2.0*t614*t990-2.0*t614*t995-2.0*t998*t946+2.0*t998*t953 & - -2.0*t949*t970-t449*t923+2.0*t537*t932 & - -2.0*t537*t935+t453*t919-t453*t921+t458*t923-t487*t913 & - -t487*t919+t487*t921-4.0*t811*t813-4.0*t816*t818 & - +4.0*t785*t789+2.0*t614*t798-2.0*t614*t803-2.0*t614*t808 & - -4.0*t769*t778) & - /(-2.0*t2201*g33-2.0*t4*r-2.0*t796*r+t4*t21+t796*t21-2.0*t2201*t1203+4.0*t2201*t843+t4+t796)/Rmin/t21/4.0; - - t1 = g01*g01; - t3 = g23*g23; - t4 = t3*t3; - t5 = g01*t4; - t6 = dgy01*dgy01; - t9 = t1*t4; - t12 = g33*g33; - t13 = t1*g01; - t14 = t12*t13; - t15 = dgy22*dgy22; - t17 = g22*ddgxy23; - t18 = r*r; - t23 = ddgyr03*t18*Rmin; - t27 = Theta33*t18*Rmin; - t31 = dgy03*t18*Rmin; - t34 = g22*g22; - t35 = t1*t34; - t36 = t12*ddgyy01; - t41 = Theta33*r*Rmin; - t45 = dgy03*r*Rmin; - t48 = t3*g23; - t49 = t1*t48; - t50 = dgx01*dgy33; - t54 = dgy01*dgx33; - t58 = dgy01*dgy23; - t78 = t1*g22; - t79 = t12*dgx01; - t83 = 2.0*t5*t6-4.0*t9*ddgyy01+t14*t15+4.0*t14*t17*t18+4.0*t9*t23+4.0*t9*t27 & - -8.0*t9*t31-4.0*t35*t36*t18-4.0*t9*t41+8.0*t9*t45+2.0*t49*t50*t18 & - -2.0*t49*t54*t18+4.0*t49*t58*t18+8.0*t35*t36*r-4.0*t49*t50*r & - +4.0*t49*t54*r-8.0*t49*t58*r+2.0*t35*g33*dgy01*dgy33-2.0*t78*t79*dgx33; - t87 = t3*g33; - t95 = t1*g33; - t96 = t3*dgx01; - t103 = dg03*dg03; - t104 = t18*t18; - t105 = t104*t18; - t107 = Rmin*Rmin; - t108 = t103*t105*t107; - t111 = t104*r; - t113 = t103*t111*t107; - t117 = t103*t104*t107; - t120 = g01*t34; - t121 = t12*t6; - t128 = g01*g22; - t133 = ddgyr03*t104*Rmin; - t136 = t18*r; - t138 = ddgyr03*t136*Rmin; - t144 = g22*ddgyy22; - t151 = g22*ddgxx33; - t158 = dgx33*dgx22; - t161 = dgy23*dgx22; - t165 = 4.0*t78*t79*dgy23+8.0*t78*t87*ddgyy01-2.0*t78*t3*dgy01*dgy33+2.0*t95*t96*dgx33 & - -4.0*t95*t96*dgy23-2.0*t5*t108+4.0*t5*t113-2.0*t5*t117+2.0*t120*t121*t18 & - -4.0*t120*t121*r-4.0*t128*t87*t6+4.0*t9*t133-8.0*t9*t138-8.0*t14*t17*r & - -2.0*t14*t144*t18+4.0*t14*t144*r-2.0*t14*t151*t18+4.0*t14*t151*r+t14*t158*t18-2.0*t14*t161*t18; - t173 = g33*t13; - t174 = t3*ddgxy23; - t181 = t3*ddgyy22; - t188 = t3*ddgxx33; - t195 = g23*dgx33; - t212 = dgx33*dgx33; - t213 = g22*t212; - t219 = g22*dgy33; - t225 = t111*t107; - t226 = t225*t128; - t227 = g23*g02; - t228 = dg33*dg33; - t230 = t227*g03*t228; - t233 = g03*g03; - t235 = dg33*dg23; - t236 = g23*t233*t235; - t239 = g01*g33; - t240 = t225*t239; - t241 = g02*g02; - t243 = g23*t241*t235; - t246 = -2.0*t14*t158*r+4.0*t14*t161*r-4.0*t173*t174*t18+8.0*t173*t174*r+2.0*t173*t181*t18 & - -4.0*t173*t181*r+2.0*t173*t188*t18-4.0*t173*t188*r-t173*t195*dgy22 & - +t173*g23*dgy33*dgx22-2.0*t173*t195*dgx23+4.0*t173*g23*dgx23*dgy23-2.0*t173*g23*dgy23*dgy22+t173*t213*t18 & - -2.0*t173*t213*r-2.0*t173*t219*dgx23+t173*t219*dgy22+4.0*t226*t230+4.0*t226*t236+4.0*t240*t243; - t247 = g01*t3; - t249 = g02*g03; - t250 = t249*t235; - t253 = g22*g33; - t254 = t225*t253; - t255 = g00*t3; - t256 = dg01*dg33; - t257 = t255*t256; - t260 = t104*t107; - t261 = t260*t128; - t262 = g00*ddg33; - t263 = t87*t262; - t270 = t260*t239; - t276 = t260*t253; - t279 = t105*t107; - t280 = t279*t128; - t283 = t12*g01; - t284 = t136*t107; - t285 = t283*t284; - t287 = g00*dg23; - t288 = g22*g23*t287; - t291 = Rmin*t104; - t292 = t95*t291; - t293 = g22*g03; - t294 = dgx33*dg23; - t295 = t293*t294; - t298 = dgy33*dg22; - t299 = t293*t298; - t301 = Rmin*t136; - t302 = t95*t301; - t307 = Rmin*t18; - t308 = t95*t307; - t312 = t291*t78; - t314 = g23*g03; - t315 = g33*ddgyr23*t314; - t319 = g33*ddgxr33*t314; - t322 = t1*g23; - t323 = t291*t322; - t324 = g33*g02; - t325 = t294*t324; - t328 = dg33*dg22; - t329 = t255*t328; - t331 = -8.0*t225*t247*t250-8.0*t254*t257-4.0*t261*t263-2.0*t261*t230-2.0*t261*t236-2.0*t270*t243 & - +4.0*t260*t247*t250+4.0*t276*t257-4.0*t280*t263-4.0*t285*t288 & - +2.0*t292*t295-t292*t299-4.0*t302*t295+2.0*t302*t299+2.0*t308*t295-t308*t299 & - +4.0*t312*t315-4.0*t312*t319+2.0*t323*t325-t270*t329; - t334 = t239*t279; - t336 = g22*t233*t328; - t344 = dg33*dgx22; - t345 = t314*t344; - t347 = t128*t87; - t348 = g03*dg03; - t349 = t348*t260; - t352 = dg00*dg33; - t353 = t352*t260; - t356 = g33*g23; - t357 = t128*t356; - t358 = t233*dg23; - t363 = t239*t3*g02; - t364 = dg02*dg33; - t365 = t364*t260; - t368 = dg23*dg03; - t369 = t368*t260; - t372 = t78*t356; - t373 = dg02*dgy33; - t377 = Theta33*dg23; - t381 = dg33*Theta23; - t385 = dg33*dgx03; - t389 = dg33*dgy02; - t393 = dgx33*dg03; - t397 = dgy23*dg03; - t403 = -t334*t336-t334*t329+2.0*t240*t336+2.0*t240*t329-t270*t336+t292*t345 & - -8.0*t347*t349-4.0*t347*t353+4.0*t357*t358*t260+4.0*t363*t365-4.0*t363*t369 & - -4.0*t372*t373*t301+4.0*t372*t377*t301+4.0*t372*t381*t301-4.0*t372*t385*t301 & - +4.0*t372*t389*t301+4.0*t372*t393*t301-8.0*t372*t397*t301-2.0*t302*t345; - t405 = dg33*dgx23; - t406 = t293*t405; - t409 = dg33*dgy22; - t410 = t293*t409; - t412 = t227*t405; - t428 = g22*g00*t328; - t433 = t283*t260; - t437 = g02*dg22; - t438 = t437*t314; - t442 = dgx33*dg22*t314; - t445 = dgy23*dg22*t314; - t448 = t301*t78; - t451 = t307*t78; - t456 = t308*t345-2.0*t292*t406+t292*t410+2.0*t292*t412+4.0*t302*t406-2.0*t302*t410-4.0*t302*t412 & - -2.0*t308*t406+t308*t410+2.0*t308*t412+t283*t279*t428 & - -2.0*t283*t225*t428+4.0*t433*t288+t433*t428+4.0*t433*t438+t292*t442 & - -2.0*t292*t445-8.0*t448*t315+4.0*t451*t315+8.0*t448*t319; - t460 = t301*t322; - t463 = t298*t324; - t466 = t307*t322; - t470 = t409*t324; - t474 = dg23*dgy23*t324; - t480 = dg33*dgx33; - t481 = t480*t324; - t484 = t480*t314; - t487 = dgy33*dg23; - t488 = t487*t324; - t491 = t487*t314; - t508 = -4.0*t451*t319-4.0*t460*t325+2.0*t460*t463+2.0*t466*t325-t466*t463 & - -2.0*t460*t470+8.0*t460*t474+t466*t470-4.0*t466*t474+4.0*t448*t481-4.0*t448*t484 & - -4.0*t448*t488+4.0*t448*t491-2.0*t451*t481+2.0*t451*t484+2.0*t451*t488 & - -2.0*t451*t491-4.0*t285*t438-2.0*t302*t442+4.0*t302*t445; - t514 = g03*dgy23; - t539 = g02*dgy33; - t540 = r*Rmin; - t544 = g03*dgx33; - t563 = t279*t253; - t566 = t308*t442-2.0*t308*t445+8.0*t226*t263-12.0*t372*t514*t307+2.0*t372*t373*t307 & - -2.0*t372*t377*t307-2.0*t372*t381*t307+2.0*t372*t385*t307-2.0*t372*t389*t307 & - -2.0*t372*t393*t307+4.0*t372*t397*t307+6.0*t372*t539*t540-2.0*t372*t544*t540 & - +12.0*t372*t514*t540+2.0*t372*t373*t291-2.0*t280*t230-2.0*t280*t236 & - -2.0*t334*t243+4.0*t279*t247*t250+4.0*t563*t257; - t570 = g00*dg33; - t574 = g22*t12; - t576 = g03*dg01; - t577 = t227*t576; - t613 = t12*g23; - t614 = t128*t613; - t615 = g02*dg03; - t616 = t615*t284; - t619 = g03*dg02; - t620 = t619*t284; - t624 = t128*t12*g02; - t625 = g03*dg23; - t629 = -8.0*t226*t87*t570+8.0*t260*t574*t577-8.0*t284*t574*t577-t323*t463+t323*t470 & - -4.0*t323*t474-2.0*t312*t481+2.0*t312*t484+2.0*t312*t488-2.0*t312*t491 & - -2.0*t372*t377*t291-2.0*t372*t381*t291+2.0*t372*t385*t291-2.0*t372*t389*t291 & - -2.0*t372*t393*t291+4.0*t372*t397*t291+8.0*t614*t616+8.0*t614*t620+8.0*t624*t625*t284; - t630 = t570*t284; - t633 = t348*t284; - t639 = t18*t107; - t640 = t249*t639; - t643 = t364*t279; - t646 = t368*t279; - t649 = t352*t279; - t656 = t364*t225; - t659 = t368*t225; - t662 = t352*t225; - t669 = t615*t260; - t672 = t619*t260; - t682 = t570*t260; - t685 = -18.0*t347*t630+8.0*t347*t633-4.0*t357*t358*t284+24.0*t614*t640 & - -4.0*t624*t643+4.0*t624*t646-4.0*t347*t649+4.0*t363*t643-4.0*t363*t646+8.0*t624*t656 & - -8.0*t624*t659+8.0*t347*t662-8.0*t363*t656+8.0*t363*t659-8.0*t614*t669-8.0*t614*t672 & - -8.0*t624*t625*t260-4.0*t624*t365+4.0*t624*t369+26.0*t347*t682; - t732 = -6.0*t372*t539*t307+2.0*t372*t544*t307+8.0*t9*ddgyy01*r & - -4.0*t35*t36+2.0*t49*t50-2.0*t49*t54+4.0*t49*t58+2.0*t5*t6*t18-4.0*t5*t6*r+2.0*t120*t121 & - +4.0*t14*t17-2.0*t14*t144-2.0*t14*t151+t14*t15*t18-2.0*t14*t15*r+t14*t158 & - -2.0*t14*t161-4.0*t173*t174+2.0*t173*t181+2.0*t173*t188; - t737 = t78*t3; - t738 = dgy01*dgy33; - t739 = t738*r; - t742 = t95*t3; - t743 = dgx01*dgx33; - t744 = t743*r; - t747 = dgx01*dgy23; - t748 = t747*r; - t751 = t78*g33; - t752 = g23*dgx01; - t756 = g23*dgy01; - t764 = t12*t1*Rmin; - t765 = t18*t3; - t769 = t12*g33; - t771 = t769*t1*Rmin; - t772 = r*g22; - t776 = r*t3; - t781 = g00*dg01; - t782 = t781*dg33; - t785 = t260*g01; - t787 = t34*t233*t228; - t789 = t4*g00; - t790 = t789*ddg33; - t796 = t279*g01; - t803 = t225*g01; - t807 = t260*t34; - t809 = t769*g00*dg01; - t812 = t173*t213-4.0*t9*ddgyy01*t18+4.0*t737*t739-4.0*t742*t744+8.0*t742*t748 & - -2.0*t751*t752*dgy33+2.0*t751*t756*dgx33-4.0*t751*t756*dgy23+4.0*t764*t765*dgx02 & - +4.0*t771*t772*dgx02-4.0*t764*t776*dgx02+4.0*t225*t4*t782+t785*t787 & - +2.0*t785*t790-2.0*t260*t4*t782+t796*t787+2.0*t796*t790-2.0*t279*t4*t782+4.0*t803*t789*dg33+4.0*t807*t809; - t816 = t12*t233*dg01; - t819 = t260*g22; - t820 = t769*t241; - t821 = t820*dg01; - t825 = t3*t241; - t826 = t825*dg01; - t829 = t260*g33; - t830 = t789*dg01; - t833 = t284*t34; - t838 = dg33*t49; - t851 = t49*dgx33; - t853 = dg03*t18*Rmin; - t856 = t49*dgy23; - t859 = t35*t12; - t864 = t35*g33; - t865 = t738*t18; - t868 = t78*t12; - t869 = t743*t18; - t872 = t747*t18; - t875 = t3*ddgyy01; - t883 = -4.0*t807*t816-4.0*t819*t821+4.0*t260*t12*t826+4.0*t829*t830-4.0*t833*t809+4.0*t833*t816 & - +2.0*t838*Theta23*t18*Rmin-2.0*t838*dgx03*t18*Rmin & - +2.0*t838*dgy02*t18*Rmin+2.0*t851*t853-4.0*t856*t853-6.0*t859*t41+12.0*t859*t45+2.0*t864*t865 & - -2.0*t868*t869+4.0*t868*t872+8.0*t751*t875*t18-2.0*t737*t865+2.0*t742*t869; - t886 = t49*g02; - t887 = dgy33*r; - t891 = t49*g03; - t892 = dgx33*r; - t896 = dgy23*r; - t910 = t173*g23; - t911 = dgx33*dgx23; - t915 = dgx23*dgy23; - t919 = dgy23*dgy22; - t923 = t173*g22; - t924 = dgy33*dgx23; - t928 = dgy33*dgy22; - t937 = dgx33*dgy22; - t940 = dgy33*dgx22; - t952 = -4.0*t742*t872-4.0*t886*t887*Rmin+4.0*t891*t892*Rmin-8.0*t891*t896*Rmin & - -4.0*t864*t739+4.0*t868*t744-2.0*t771*t772*Theta22+2.0*t764*t776*Theta22 & - +4.0*t910*t911*r-8.0*t910*t915*r+4.0*t910*t919*r-2.0*t923*t924*t18+t923*t928*t18 & - +4.0*t923*t924*r-2.0*t923*t928*r-t910*t937*t18+t910*t940*t18+2.0*t910*t937*r & - -2.0*t910*t940*r-2.0*t910*t911*t18; - t960 = t95*Rmin; - t961 = r*t48; - t971 = t18*t48; - t981 = t18*g22; - t988 = t291*t1; - t990 = t48*ddgyr23*g03; - t994 = t48*ddgxr33*g03; - t997 = t3*t233; - t998 = dg23*dg23; - t999 = t997*t998; - t1004 = t284*g01; - t1005 = t820*dg22; - t1008 = t301*t1; - t1011 = t307*t1; - t1020 = 4.0*t910*t915*t18-2.0*t910*t919*t18-4.0*t960*t961*Theta23 & - +4.0*t960*t961*dgx03+4.0*t960*t961*dgy02+4.0*t960*t971*Theta23-4.0*t960*t971*dgx03 & - -4.0*t960*t971*dgy02+2.0*t771*t981*Theta22-2.0*t764*t765*Theta22 & - -4.0*t988*t990+4.0*t988*t994+4.0*t803*t999-2.0*t785*t999+2.0*t1004*t1005+8.0*t1008*t990 & - -4.0*t1011*t990-8.0*t1008*t994+4.0*t1011*t994-2.0*t796*t999; - t1023 = t18*g02; - t1051 = t284*g22; - t1057 = t284*g33; - t1064 = dg03*t104; - t1065 = t1064*Rmin; - t1072 = t49*dg02; - t1077 = t49*Theta33; - t1086 = -2.0*t785*t1005+2.0*t771*t1023*dgx22-2.0*t771*r*g02*dgx22-4.0*t771*t981*dgx02-8.0*t868*t748 & - -16.0*t751*t875*r+2.0*t838*Theta23*t104*Rmin & - -2.0*t838*dgx03*t104*Rmin+2.0*t838*dgy02*t104*Rmin & - +4.0*t1051*t821-4.0*t284*t12*t826-4.0*t1057*t830-2.0*t803*t787 & - -4.0*t803*t790+2.0*t851*t1065-4.0*t856*t1065 & - -8.0*t859*t138+4.0*t1072*dgy33*t136*Rmin-4.0*t1077*dg23*t136*Rmin-4.0*t838*Theta23*t136*Rmin; - t1100 = dg03*t136*Rmin; - t1111 = dgy33*t18; - t1112 = t1111*Rmin; - t1115 = dgx33*t18; - t1119 = dgy23*t18; - t1125 = t120*t12; - t1128 = t5*dg00; - t1130 = dg33*t105*t107; - t1136 = dg33*t111*t107; - t1139 = t120*t769; - t1141 = dg00*t104*t107; - t1146 = t239*t4; - t1149 = t5*g00; - t1151 = dg33*t104*t107; - t1154 = 4.0*t838*dgx03*t136*Rmin-4.0*t838*dgy02*t136*Rmin-4.0*t851*t1100+8.0*t856*t1100 & - +4.0*t859*t23+6.0*t859*t27-12.0*t859*t31+4.0*t886*t1112 & - -4.0*t891*t1115*Rmin+8.0*t891*t1119*Rmin-2.0*t1072*t1112-2.0*t1125*t108 & - +2.0*t1128*t1130+4.0*t1125*t113-4.0*t1128*t1136-4.0*t1139*t1141 & - -2.0*t1125*t117-4.0*t1146*t1141-12.0*t1149*t1151; - t1158 = dg00*t136*t107; - t1164 = dg33*t136*t107; - t1168 = g00*t18*t107; - t1175 = t128*t769; - t1177 = t241*t18*t107; - t1180 = t283*t3; - t1185 = t128*g33; - t1186 = t3*t6; - t1208 = t227*t576*dg33; - t1212 = t356*t570*dg23; - t1216 = t356*t249*ddg33; - t1223 = 2.0*t1128*t1151+4.0*t1139*t1158+4.0*t1146*t1158+8.0*t1149*t1164 & - +12.0*t1139*t1168-12.0*t1125*t233*t18*t107-12.0*t1175*t1177+12.0*t1180*t1177 & - +12.0*t1146*t1168-4.0*t1185*t1186*t18+8.0*t1185*t1186*r+2.0*t1077*dg23*t18*Rmin & - +4.0*t859*t133-2.0*t1072*dgy33*t104*Rmin+2.0*t1077*dg23*t104*Rmin & - +8.0*t254*t1208+2.0*t261*t1212+4.0*t261*t1216-4.0*t276*t1208+2.0*t280*t1212; - t1232 = g02*dg33*dg22*g23*g03; - t1276 = t241*ddg33; - t1277 = t87*t1276; - t1281 = t48*g00*t235; - t1284 = t48*g02; - t1286 = t1284*g03*ddg33; - t1290 = t12*g00*t256; - t1293 = 4.0*t280*t1216-4.0*t563*t1208+4.0*t240*t1232-2.0*t270*t1232-2.0*t334*t1232 & - +4.0*t357*t619*t1130-4.0*t357*t625*dg03*t105*t107-8.0*t357*t619*t1136 & - +8.0*t357*t625*dg03*t111*t107-20.0*t357*t249*t1151+4.0*t357*t619*t1151 & - -4.0*t357*t625*t1064*t107+12.0*t357*t249*t1164+8.0*t226*t356*t249*dg33-4.0*t226*t1212 & - -8.0*t226*t1216+2.0*t785*t1277-2.0*t785*t1281-4.0*t785*t1286-2.0*t807*t1290; - t1295 = g33*t233*t256; - t1298 = t12*t241; - t1299 = t1298*t256; - t1302 = t997*t256; - t1305 = t825*t256; - t1309 = t249*t256; - t1313 = t12*t3*t781; - t1317 = t87*t233*dg01; - t1320 = t1284*t576; - t1323 = t3*g22; - t1324 = t233*dg33; - t1325 = t1323*t1324; - t1328 = t241*dg33; - t1332 = g03*dgy33; - t1333 = t1332*t540; - t1336 = g02*dgx33; - t1337 = t1336*t540; - t1340 = g02*dgy23; - t1341 = t1340*t540; - t1344 = t3*Theta33; - t1348 = t3*dgy03; - t1365 = 2.0*t807*t1295+2.0*t819*t1299-2.0*t819*t1302-2.0*t829*t1305+4.0*t260*t48*t1309 & - -8.0*t819*t1313+4.0*t819*t1317-8.0*t829*t1320+4.0*t803*t1325 & - +4.0*t803*t87*t1328-6.0*t864*t1333+6.0*t868*t1337-12.0*t868*t1341+10.0*t751*t1344*t540 & - -20.0*t751*t1348*t540-2.0*t751*t752*t1111+2.0*t751*t756*t1115 & - -4.0*t751*t756*t1119+4.0*t737*t1333-8.0*t742*t1337; - t1381 = dgy33*dg03; - t1382 = t1381*t307; - t1385 = t3*ddgyr03; - t1389 = Theta33*dg33; - t1390 = t1389*t291; - t1393 = t1381*t291; - t1396 = dg02*dgx33; - t1397 = t1396*t291; - t1400 = dg02*dgy23; - t1401 = t1400*t291; - t1404 = Theta23*dg23; - t1405 = t1404*t291; - t1408 = dg23*dgx03; - t1409 = t1408*t291; - t1412 = t1389*t301; - t1415 = t1381*t301; - t1418 = t1396*t301; - t1421 = t1400*t301; - t1424 = t1404*t301; - t1427 = t1408*t301; - t1430 = 8.0*t742*t1341+4.0*t751*t752*t887-4.0*t751*t756*t892+8.0*t751*t756*t896 & - +2.0*t1125*t649+2.0*t737*t1382-8.0*t751*t1385*t291-2.0*t737*t1390+2.0*t737*t1393 & - -2.0*t742*t1397+4.0*t742*t1401-4.0*t742*t1405+4.0*t742*t1409-4.0*t864*t1412 & - +4.0*t864*t1415-4.0*t868*t1418+8.0*t868*t1421-8.0*t868*t1424+8.0*t868*t1427; - t1436 = t1336*t307; - t1439 = t1340*t307; - t1442 = t1396*t307; - t1445 = t1400*t307; - t1448 = t1404*t307; - t1453 = t1332*t307; - t1456 = t1389*t307; - t1471 = t1408*t307; - t1477 = g03*dgx23; - t1481 = g03*dgy22; - t1485 = 16.0*t751*t1385*t301+4.0*t737*t1412+8.0*t742*t1436-8.0*t742*t1439-2.0*t742*t1442 & - +4.0*t742*t1445-4.0*t742*t1448-8.0*t742*t1427+6.0*t864*t1453 & - +2.0*t864*t1456-2.0*t864*t1382-6.0*t868*t1436+12.0*t868*t1439 & - +2.0*t868*t1442-4.0*t868*t1445+4.0*t868*t1448-4.0*t868*t1471 & - -8.0*t751*t1385*t307-4.0*t764*t772*t1477+2.0*t764*t772*t1481; - t1487 = r*g23; - t1488 = dgx23*g02; - t1493 = t12*dgx33*t437; - t1496 = t12*dgy23*t437; - t1500 = t3*ddgyr23*t324; - t1504 = t3*ddgxr33*t324; - t1507 = t1298*t328; - t1509 = t997*t328; - t1513 = t613*t241*dg23; - t1516 = t233*dg22; - t1517 = t87*t1516; - t1521 = t574*ddgyr23*g02; - t1527 = t574*ddgxr33*g02; - t1540 = t34*g33; - t1541 = t1540*t1324; - t1550 = 4.0*t764*t1487*t1488-t988*t1493+2.0*t988*t1496+4.0*t988*t1500-4.0*t988*t1504+t796*t1507+2.0*t796*t1509 & - +4.0*t785*t1513-4.0*t785*t1517+8.0*t1008*t1521 & - -4.0*t1011*t1521-8.0*t1008*t1527-10.0*t751*t1344*t307+20.0*t751*t1348*t307-4.0*t737*t1453 & - -2.0*t737*t1456-6.0*t1004*t1541+8.0*t1004*t1325+8.0*t1051*t1313-4.0*t1051*t1317; - t1553 = t3*t103; - t1557 = g01*t48; - t1558 = t1557*g03; - t1578 = g02*dg02; - t1579 = t1578*t260; - t1582 = t128*t12; - t1583 = t3*dg00; - t1587 = t1328*t260; - t1595 = t239*t48; - t1600 = t239*t3; - t1603 = t1557*g02; - t1604 = g03*dg33; - t1608 = 8.0*t1057*t1320+4.0*t1185*t1553*t279-4.0*t1558*t643+4.0*t1558*t646-4.0*t1125*t662 & - -8.0*t1185*t1553*t225+8.0*t1558*t656-8.0*t1558*t659-14.0*t1125*t682 & - +8.0*t1125*t349+2.0*t1125*t353+8.0*t1175*t1579+8.0*t1582*t1583*t260+14.0*t1582*t1587 & - +4.0*t1185*t1553*t260-8.0*t1180*t1579+8.0*t1595*t669+8.0*t1595*t672-16.0*t1600*t1587+24.0*t1603*t1604*t260; - t1620 = t1578*t284; - t1626 = t1328*t284; - t1656 = -4.0*t1558*t365+4.0*t1558*t369+10.0*t1125*t630-8.0*t1125*t633-8.0*t1175*t1620-8.0*t1582*t1583*t284 & - -10.0*t1582*t1626+8.0*t1180*t1620-8.0*t1595*t616 & - -8.0*t1595*t620+12.0*t1600*t1626-16.0*t1603*t1604*t284-24.0*t1582*t255*t639 & - +12.0*t1185*t997*t639-24.0*t1595*t640+2.0*t864*t1390-2.0*t864*t1393+2.0*t868*t1397-4.0*t868*t1401; - t1661 = g00*t998; - t1662 = t87*t1661; - t1665 = t18*g23; - t1666 = dgy22*g02; - t1673 = g23*Theta23; - t1677 = g23*dgx03; - t1681 = g23*dgy02; - t1685 = g22*t136; - t1686 = dg33*Theta22; - t1692 = t104*g22; - t1693 = dg33*dgx02; - t1717 = t34*t12; - t1718 = t1717*t262; - t1721 = g00*t228; - t1722 = t1540*t1721; - t1724 = 4.0*t868*t1405-4.0*t868*t1409+2.0*t785*t1662-2.0*t764*t1665*t1666+2.0*t764*t1487*t1666 & - -4.0*t764*t981*t1673+4.0*t764*t981*t1677+4.0*t764*t981*t1681 & - +2.0*t764*t1685*t1686-t764*t981*t1686+2.0*t764*t1692*t1693-4.0*t764*t1685*t1693 & - +2.0*t764*t981*t1693-t764*t1692*t1686+4.0*t764*t772*t1673-4.0*t764*t772*t1677 & - -4.0*t764*t772*t1681-8.0*t803*t1284*t1604+2.0*t796*t1718-t796*t1722; - t1726 = t233*ddg33; - t1727 = t1540*t1726; - t1730 = t574*t1661; - t1733 = t574*t1276; - t1737 = t253*t241*t228; - t1740 = t253*t233*t998; - t1743 = t1323*t1721; - t1745 = t1323*t1726; - t1756 = t279*t34; - t1761 = t279*g22; - t1780 = -2.0*t796*t1727-2.0*t796*t1730-2.0*t796*t1733+t796*t1737+2.0*t796*t1740+t796*t1743 & - +2.0*t796*t1745+2.0*t796*t1662+2.0*t796*t1277-2.0*t796*t1281 & - -4.0*t796*t1286-2.0*t1756*t1290+2.0*t1756*t1295+2.0*t1761*t1299-2.0*t1761*t1302 & - -2.0*t279*g33*t1305+4.0*t279*t48*t1309+4.0*t803*t1717*t570-4.0*t803*t1541-4.0*t803*t574*t1328; - t1807 = t225*t34; - t1812 = t225*g22; - t1825 = -4.0*t803*t1718+2.0*t803*t1722+4.0*t803*t1727+4.0*t803*t1730+4.0*t803*t1733 & - -2.0*t803*t1737-4.0*t803*t1740-2.0*t803*t1743-4.0*t803*t1745-4.0*t803*t1662 & - -4.0*t803*t1277+4.0*t803*t1281+8.0*t803*t1286+4.0*t1807*t1290-4.0*t1807*t1295 & - -4.0*t1812*t1299+4.0*t1812*t1302+4.0*t225*g33*t1305-8.0*t225*t48*t1309+2.0*t785*t1718; - t1845 = t136*t3; - t1846 = Theta33*dg22; - t1852 = t769*g01; - t1854 = t107*g22; - t1855 = g00*dg22; - t1856 = t1854*t1855; - t1859 = t283*t104; - t1860 = t1854*t1516; - t1864 = t107*t3*t1855; - t1869 = t107*t48*t287; - t1875 = t104*t3; - t1888 = g03*dgx22; - t1894 = -4.0*t737*t1415+4.0*t742*t1418-8.0*t742*t1421+8.0*t742*t1424+4.0*t764*t981*t1477 & - -2.0*t764*t981*t1481-4.0*t764*t1665*t1488-2.0*t960*t1845*t1846 & - +t960*t765*t1846-2.0*t1852*t104*t1856+2.0*t1859*t1860+2.0*t1859*t1864 & - -4.0*t239*t104*t1869+4.0*t239*t136*t1869+t960*t1875*t1686-2.0*t960*t1845*t1686 & - -t764*t104*g02*t344+2.0*t764*t136*g02*t344-2.0*t764*t1665*t1888-t764*t1023*t344; - t1901 = t3*dgx33*t625; - t1906 = t3*dgy33*dg22*g03; - t1914 = t3*dg33*t1481; - t1918 = t3*dg23*t514; - t1944 = 2.0*t764*t1487*t1888+4.0*t1011*t1527+8.0*t1008*t1901-4.0*t1008*t1906 & - -4.0*t1011*t1901+2.0*t1011*t1906+4.0*t1008*t1914-8.0*t1008*t1918-2.0*t1011*t1914 & - +4.0*t1011*t1918+2.0*t1008*t1493-4.0*t1008*t1496-t1011*t1493+2.0*t1011*t1496 & - -8.0*t1008*t1500+4.0*t1011*t1500+8.0*t1008*t1504-4.0*t1011*t1504-2.0*t803*t1507-4.0*t803*t1509; - t1956 = t283*t136; - t1988 = t785*t1507+2.0*t785*t1509-4.0*t1004*t1513+4.0*t1004*t1517+2.0*t1852*t136*t1856 & - -2.0*t1956*t1860-2.0*t1956*t1864+4.0*t960*t765*t1481-4.0*t960*t776*t1481 & - -4.0*t988*t1521+4.0*t988*t1527-4.0*t988*t1901+2.0*t988*t1906-2.0*t988*t1914 & - +4.0*t988*t1918-t785*t1722-2.0*t785*t1727+10.0*t785*t1541-2.0*t785*t1730-2.0*t785*t1733; - t1997 = dg22*dgy03; - t2038 = t785*t1737+2.0*t785*t1740+t785*t1743+2.0*t785*t1745-12.0*t785*t1325+2.0*t764*t1692*t1997 & - -4.0*t764*t1685*t1997+2.0*t764*t981*t1997-t764*t1692*t1846 & - +2.0*t764*t1685*t1846-t764*t981*t1846+t960*t765*t1686-2.0*t960*t1875*t1693 & - +4.0*t960*t1845*t1693-2.0*t960*t765*t1693-2.0*t960*t1875*t1997+4.0*t960*t1845*t1997 & - -2.0*t960*t765*t1997+t960*t1875*t1846+4.0*t742*t1471; - Theta33_rhs = 1/t1 & - *(t2038+t83+t1988+t1944+t1894+t1825+t1430+t1365+t812+t566+t508+t1550+t685+t629 & - +t456+t403+t1086+t1020+t1223+t1154+t1485+t1293+t331+t246+t165 & - +t1780+t1608+t952+t883+t1724+t1656+t732) / & - (4.0*t1323*g33*r-2.0*t1323*g33*t18-2.0*t1323*g33-2.0*t4*r-2.0*t1717*r+t4*t18+t1717*t18+t4+t1717)/Rmin/t18/4.0; - - return - -end subroutine Theta_rhs2 -!--------------------------------------------------------------------------------- -subroutine pg0a_rhs(Rmin,r,p02,p03,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01, & - dg01,dg02,dg03, & - dgx01,dgx22,dgx23,dgx33, & - dgy01,dgy22,dgy23,dgy33, & - ddgxr01,ddgxr22,ddgxr23,ddgxr33, & - ddgyr01,ddgyr22,ddgyr23,ddgyr33, & - g02_rhs,g03_rhs,p02_rhs,p03_rhs) - - implicit none - -!~~~~~~% Input parameters: - real*8,intent(in) :: Rmin,r,p02,p03,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01 - real*8,intent(in) :: dg01,dg02,dg03 - real*8,intent(in) :: dgx01,dgx22,dgx23,dgx33 - real*8,intent(in) :: dgy01,dgy22,dgy23,dgy33 - real*8,intent(in) :: ddgxr01,ddgxr22,ddgxr23,ddgxr33 - real*8,intent(in) :: ddgyr01,ddgyr22,ddgyr23,ddgyr33 - real*8,intent(out) :: g02_rhs,g03_rhs,p02_rhs,p03_rhs - - real*8 :: t1; - real*8 :: t10; - real*8 :: t100; - real*8 :: t101; - real*8 :: t104; - real*8 :: t105; - real*8 :: t108; - real*8 :: t11; - real*8 :: t110; - real*8 :: t112; - real*8 :: t117; - real*8 :: t118; - real*8 :: t123; - real*8 :: t125; - real*8 :: t126; - real*8 :: t129; - real*8 :: t130; - real*8 :: t132; - real*8 :: t136; - real*8 :: t14; - real*8 :: t141; - real*8 :: t142; - real*8 :: t143; - real*8 :: t150; - real*8 :: t151; - real*8 :: t155; - real*8 :: t158; - real*8 :: t16; - real*8 :: t161; - real*8 :: t162; - real*8 :: t167; - real*8 :: t168; - real*8 :: t17; - real*8 :: t172; - real*8 :: t177; - real*8 :: t179; - real*8 :: t185; - real*8 :: t186; - real*8 :: t190; - real*8 :: t191; - real*8 :: t192; - real*8 :: t196; - real*8 :: t2; - real*8 :: t20; - real*8 :: t202; - real*8 :: t203; - real*8 :: t21; - real*8 :: t213; - real*8 :: t216; - real*8 :: t22; - real*8 :: t220; - real*8 :: t221; - real*8 :: t224; - real*8 :: t225; - real*8 :: t23; - real*8 :: t230; - real*8 :: t231; - real*8 :: t234; - real*8 :: t235; - real*8 :: t243; - real*8 :: t250; - real*8 :: t255; - real*8 :: t256; - real*8 :: t26; - real*8 :: t260; - real*8 :: t261; - real*8 :: t264; - real*8 :: t265; - real*8 :: t269; - real*8 :: t27; - real*8 :: t272; - real*8 :: t275; - real*8 :: t279; - real*8 :: t283; - real*8 :: t292; - real*8 :: t30; - real*8 :: t302; - real*8 :: t304; - real*8 :: t309; - real*8 :: t31; - real*8 :: t310; - real*8 :: t315; - real*8 :: t316; - real*8 :: t317; - real*8 :: t32; - real*8 :: t320; - real*8 :: t327; - real*8 :: t328; - real*8 :: t329; - real*8 :: t339; - real*8 :: t342; - real*8 :: t345; - real*8 :: t353; - real*8 :: t36; - real*8 :: t363; - real*8 :: t374; - real*8 :: t378; - real*8 :: t381; - real*8 :: t39; - real*8 :: t392; - real*8 :: t394; - real*8 :: t398; - real*8 :: t401; - real*8 :: t403; - real*8 :: t406; - real*8 :: t410; - real*8 :: t415; - real*8 :: t43; - real*8 :: t430; - real*8 :: t431; - real*8 :: t433; - real*8 :: t434; - real*8 :: t436; - real*8 :: t44; - real*8 :: t442; - real*8 :: t445; - real*8 :: t448; - real*8 :: t45; - real*8 :: t451; - real*8 :: t453; - real*8 :: t459; - real*8 :: t462; - real*8 :: t464; - real*8 :: t466; - real*8 :: t469; - real*8 :: t475; - real*8 :: t48; - real*8 :: t483; - real*8 :: t487; - real*8 :: t49; - real*8 :: t492; - real*8 :: t496; - real*8 :: t499; - real*8 :: t514; - real*8 :: t518; - real*8 :: t530; - real*8 :: t541; - real*8 :: t544; - real*8 :: t56; - real*8 :: t568; - real*8 :: t58; - real*8 :: t594; - real*8 :: t6; - real*8 :: t67; - real*8 :: t69; - real*8 :: t7; - real*8 :: t71; - real*8 :: t73; - real*8 :: t77; - real*8 :: t8; - real*8 :: t80; - real*8 :: t81; - real*8 :: t82; - real*8 :: t86; - real*8 :: t87; - real*8 :: t89; - real*8 :: t9; - real*8 :: t93; - real*8 :: t94; - real*8 :: t97; - real*8 :: t98; - real*8 :: t99; - - real*8 :: t111; - real*8 :: t115; - real*8 :: t12; - real*8 :: t121; - real*8 :: t13; - real*8 :: t133; - real*8 :: t134; - real*8 :: t137; - real*8 :: t139; - real*8 :: t140; - real*8 :: t144; - real*8 :: t147; - real*8 :: t148; - real*8 :: t15; - real*8 :: t153; - real*8 :: t164; - real*8 :: t170; - real*8 :: t18; - real*8 :: t182; - real*8 :: t188; - real*8 :: t19; - real*8 :: t193; - real*8 :: t197; - real*8 :: t206; - real*8 :: t215; - real*8 :: t222; - real*8 :: t227; - real*8 :: t238; - real*8 :: t239; - real*8 :: t24; - real*8 :: t240; - real*8 :: t241; - real*8 :: t244; - real*8 :: t245; - real*8 :: t249; - real*8 :: t25; - real*8 :: t252; - real*8 :: t257; - real*8 :: t259; - real*8 :: t263; - real*8 :: t266; - real*8 :: t270; - real*8 :: t274; - real*8 :: t288; - real*8 :: t29; - real*8 :: t293; - real*8 :: t294; - real*8 :: t301; - real*8 :: t323; - real*8 :: t326; - real*8 :: t330; - real*8 :: t331; - real*8 :: t334; - real*8 :: t335; - real*8 :: t338; - real*8 :: t343; - real*8 :: t35; - real*8 :: t350; - real*8 :: t351; - real*8 :: t356; - real*8 :: t357; - real*8 :: t361; - real*8 :: t375; - real*8 :: t38; - real*8 :: t385; - real*8 :: t388; - real*8 :: t389; - real*8 :: t40; - real*8 :: t407; - real*8 :: t41; - real*8 :: t411; - real*8 :: t419; - real*8 :: t422; - real*8 :: t428; - real*8 :: t443; - real*8 :: t450; - real*8 :: t456; - real*8 :: t46; - real*8 :: t465; - real*8 :: t471; - real*8 :: t481; - real*8 :: t486; - real*8 :: t50; - real*8 :: t504; - real*8 :: t51; - real*8 :: t534; - real*8 :: t547; - real*8 :: t55; - real*8 :: t562; - real*8 :: t592; - real*8 :: t62; - real*8 :: t63; - real*8 :: t66; - real*8 :: t70; - real*8 :: t72; - real*8 :: t76; - real*8 :: t84; - real*8 :: t92; - - t1 = r*r; - t2 = t1*r; - t6 = g22*g01; - t7 = t6*Rmin; - t8 = t1*t1; - t9 = t8*dg02; - t10 = g23*g23; - t11 = dg33*t10; - t14 = Rmin*t2; - t16 = t10*t10; - t17 = g01*dg02*t16; - t20 = g33*g33; - t21 = t20*g01; - t22 = t21*dgx01; - t23 = r*dg22; - t26 = g01*t1; - t27 = ddgxr01*t16; - t30 = t10*g23; - t31 = g01*g01; - t32 = t30*t31; - t36 = g01*r; - t39 = dgx01*t1; - t43 = dgx01*g01; - t44 = g22*g22; - t45 = t44*t20; - t48 = dgx01*dg01; - t49 = r*t16; - t56 = t14*g02; - t58 = t21*ddg22*g22; - t67 = t14*g03; - t69 = dg22*dg22; - t71 = g23*g33*g01*t69; - t73 = t30*g01; - t77 = t73*ddg22; - t80 = g23*t31; - t81 = t80*g22; - t82 = r*dg33; - t86 = g03*g23; - t87 = t14*t86; - t89 = g22*g33; - t93 = t10*t31; - t94 = dgx22*r; - t97 = Rmin*t8; - t98 = t97*g03; - t99 = t10*g01; - t100 = dg22*dg23; - t101 = t99*t100; - t104 = t30*dg01; - t105 = t104*dg22; - t108 = -2.0*t56*t58+2.0*t32*r*ddgyr22-2.0*t32*t1*ddgyr22-t67*t71+4.0*t67*t73*dg22-2.0*t67*t77 & - -2.0*t81*t82*dgx23-4.0*t87*g01*dg22*t89+t93*t94*dg33-2.0*t98*t101+2.0*t67*t105; - t110 = t80*r; - t112 = ddgyr22*g22*g33; - t117 = dg33*dg22; - t118 = Rmin*g02*t117; - t123 = g02*g33; - t125 = g23*g01; - t126 = t125*t100; - t129 = t97*g02; - t130 = g33*g01; - t132 = t130*ddg22*t10; - t136 = g01*ddg22*t89; - t141 = dg23*dg23; - t142 = g01*t141; - t143 = t89*t142; - t150 = dg22*g22; - t151 = t20*dg01*t150; - t155 = dg01*dg22*t89; - t158 = -2.0*t110*t112+2.0*t99*t2*t118+4.0*t43*t16+3.0*t97*t123*t126-2.0*t129*t132+2.0*t87*t136 & - +2.0*t67*t101+2.0*t56*t143-3.0*t14*t123*t126+2.0*t56*t151-2.0*t87*t155; - t161 = g22*t31; - t162 = t161*g33; - t167 = dg22*t10; - t168 = g33*dg01*t167; - t172 = g23*g22*t142; - t177 = t21*t69; - t179 = t97*t86; - t185 = t1*g03; - t186 = dg23*t10; - t190 = t44*g01; - t191 = t190*Rmin; - t192 = dg23*g33; - t196 = -2.0*t129*t143-2.0*t162*t23*dgy23+2.0*t129*t168-2.0*t67*t172+2.0*t98*t172-t129*t177 & - +2.0*t179*t155+t98*t71+2.0*t98*t77+8.0*t7*t185*t186-8.0*t191*t185*t192; - t202 = t130*Rmin; - t203 = t1*g02; - t213 = dgy33*t1; - t216 = t21*Rmin; - t220 = t44*t31; - t221 = dgy33*r; - t224 = r*dg23; - t225 = t224*dgy22; - t230 = t6*dgx01; - t231 = t1*dg33; - t234 = Rmin*t1; - t235 = t125*t234; - t243 = t2*dg02; - t250 = dg02*dg01*t16; - t255 = t125*dgx01; - t256 = t1*dg23; - t260 = dg01*t44; - t261 = t260*t20; - t264 = t73*Rmin; - t265 = t2*dg03; - t269 = t97*dg02; - t272 = t230*t231*t10+8.0*t235*g03*dg22*t89-2.0*t99*t8*t118-t216*t243*t150-2.0*t73*t39*dg23 & - +2.0*t97*t250+t202*t243*t167+2.0*t255*t256*t89-2.0*t39*t261-2.0*t264*t265*dg22+2.0*t269*t261; - t275 = r*t44*t20; - t279 = t89*t10; - t283 = ddgxr01*t44*t20; - t292 = t1*dg22; - t302 = t14*g01; - t304 = dg02*t44*t20; - t309 = 2.0*t48*t275+4.0*t36*ddgxr01*t279+2.0*t26*t283-8.0*t264*t203*dg23-8.0*t264*t185*dg22 & - -t22*t292*g22-2.0*t36*t283+4.0*t39*dg01*t279+8.0*t234*t17-4.0*t302*t304-t202*t9*t167; - t310 = t234*g01; - t315 = dg01*g22; - t316 = g33*t10; - t317 = t315*t316; - t320 = t8*dg03; - t327 = t125*t14; - t328 = g03*g22; - t329 = t328*t117; - t339 = t14*dg02; - t342 = t256*dgy22; - t345 = 8.0*t310*t304+t216*t9*t150-4.0*t269*t317+2.0*t191*t320*t192-2.0*t7*t320*t186-t327*t329 & - +2.0*t81*t231*dgx23-2.0*t14*t250-4.0*t26*ddgxr01*t279+4.0*t339*t317+2.0*t93*t342; - t353 = dg03*dg22*t89; - t363 = dg33*g33; - t374 = dgx33*t1; - t378 = dgx33*r; - t381 = r*ddgyr23; - t392 = t378*dg22; - t394 = t80*g33; - t398 = dgx22*t1; - t401 = t80*t1; - t403 = ddgxr23*g22*g33; - t406 = t130*dgx01; - t410 = dg02*g22*t316; - t415 = t220*t378*dg33-2.0*t161*t381*t10-2.0*t93*t256*dgx23+2.0*t73*dgx01*r*dg23-t93*t392 & - -t394*dgy22*t1*dg22-t93*t398*dg33-2.0*t401*t403-t406*t23*t10+8.0*t302*t410-16.0*t310*t410; - t430 = dg33*dg23; - t431 = t190*t430; - t433 = g02*g23; - t434 = t14*t433; - t436 = g01*ddg23*t89; - t442 = t104*dg23; - t445 = t73*ddg23; - t448 = t315*t186; - t451 = -t394*t94*dg23+t81*t374*dg23+8.0*t235*g02*dg23*t89+t81*t221*dg22+4.0*t67*t190*t192+t67*t431 & - +2.0*t434*t436-4.0*t67*t6*t186+2.0*t56*t442-2.0*t56*t445+2.0*t98*t448; - t453 = t6*ddg23*t10; - t459 = t260*t192; - t462 = t374*dg22; - t464 = t97*t433; - t466 = dg01*dg23*t89; - t469 = t1*ddgxr33; - t475 = r*ddgxr33; - t483 = t1*ddgyr23; - t487 = -2.0*t98*t453+4.0*t56*t73*dg23-2.0*t98*t459-t162*t462+2.0*t464*t466-2.0*t161*t469*t10 & - -2.0*t434*t466-2.0*t220*t475*g33-2.0*t129*t151-t191*t9*t363+2.0*t161*t483*t10; - t492 = t190*dgx01; - t496 = t190*ddg23*g33; - t499 = t6*t430; - t514 = t130*t100; - t518 = -t7*t243*t11+t492*t82*g33+2.0*t98*t496+t464*t499+2.0*t129*t445-4.0*t434*g01*dg23*t89 & - -t434*t499+2.0*t220*t469*g33-2.0*t67*t496+t14*t328*t514-t97*t328*t514; - t530 = t123*t117; - t541 = t125*t97; - t544 = 2.0*t67*t453+2.0*t67*t459-2.0*t464*t436-t98*t431+2.0*t220*t381*g33+t6*t97*t530 & - -2.0*t67*t448+t162*t392+2.0*t264*t320*dg22+2.0*t7*t265*t186-2.0*t541*t353; - t568 = -t81*t378*dg23-2.0*t93*t225+t93*t462+2.0*t110*t403-2.0*t81*t256*dgy23+2.0*t401*t112-t162*t342 & - +4.0*t56*t21*t150+t541*t329-2.0*t191*t265*t192-t6*t14*t530; - t594 = t56*t177-2.0*t129*t442-t492*t231*g33-t230*t82*t10+t394*dgy22*r*dg22-2.0*t220*t483*g33 & - +2.0*t161*t475*t10+2.0*t93*t224*dgx23+2.0*t129*t58+t406*t292*t10+t394*t398*dg23; - p02_rhs = 1/t2/g01*(2.0*t81*t224*dgy23-4.0*t48*r*t279+2.0*t32*t1*ddgxr23+8.0*t202*t203*t167-t81*t213*dg22 & - -8.0*t216*t203*t150-t220*t221*dg23+t7*t9*t11+t220*t213*dg23-t220*t374*dg33-2.0*t255*t224*t89 & - -2.0*t32*r*ddgxr23+t22*t23*g22+2.0*t162*t292*dgy23+t191*t243*t363-4.0*t56*t130*t167-2.0*t39*dg01*t16 & - +t108-2.0*t179*t136+2.0*t48*t49-2.0*t339*t261-2.0*t36*t27-4.0*t14*t17+4.0*t43*t45-2.0*t56*t168 & - -2.0*t98*t105+t162*t225+2.0*t56*t132+2.0*t26*t27-8.0*t43*t279+2.0*t327*t353+t345+t158+t196+t272 & - +t309+t415+t451+t487+t544+t518+t594+t568)/(-2.0*r*t10*t89-t16+t49+2.0*t279-t45+t275)/Rmin/2.0 -!!! - t1 = r*r; - t2 = t1*r; - t6 = dgy01*g01; - t7 = g23*g23; - t8 = t7*t7; - t11 = Rmin*t2; - t12 = g03*g23; - t13 = t11*t12; - t14 = g33*g01; - t15 = dg22*dg23; - t16 = t14*t15; - t18 = g22*g01; - t19 = dg33*dg23; - t20 = t18*t19; - t23 = g33*g33; - t24 = g01*g01; - t25 = t23*t24; - t29 = g33*t24; - t30 = t29*g22; - t31 = r*dg33; - t35 = dgx22*t1; - t38 = t1*t1; - t39 = Rmin*t38; - t40 = g02*g33; - t41 = t39*t40; - t43 = t11*g03; - t44 = t7*g23; - t45 = t44*g01; - t46 = t45*ddg23; - t49 = t11*g02; - t50 = t23*g01; - t51 = dg23*g22; - t55 = t11*t40; - t58 = dg23*t7; - t62 = g01*r; - t63 = ddgyr01*t8; - t66 = t29*g23; - t67 = dgx22*r; - t70 = t31*dgy22; - t72 = g22*g22; - t73 = t72*t23; - t76 = dgy01*t1; - t80 = t44*t24; - t84 = t50*t15; - t92 = t39*g02; - t94 = t50*ddg23*g22; - t97 = -4.0*t49*t14*t58-2.0*t62*t63+t66*t67*dg33+t30*t70+4.0*t6*t73-2.0*t76*dg01*t8+2.0*t80*t1*ddgyr23+t49*t84 & - -2.0*t80*t1*ddgxr33+2.0*t80*r*ddgxr33+2.0*t92*t94; - t99 = g23*g01; - t100 = dg33*dg22; - t101 = t99*t100; - t104 = g33*dg01*t58; - t108 = g01*t1; - t111 = dgy01*dg01; - t112 = r*t8; - t115 = t39*t12; - t117 = t1*ddgxr23; - t121 = t1*ddgyr22; - t126 = t23*dg01*t51; - t129 = dg01*t44; - t130 = t129*dg23; - t133 = t7*g01; - t134 = t133*t100; - t137 = -t55*t101+2.0*t92*t104+t41*t101+2.0*t108*t63+2.0*t111*t112+t115*t16+2.0*t29*t117*t7+2.0*t25*t121*g22 & - -2.0*t92*t126+2.0*t43*t130+2.0*t43*t134; - t139 = g22*g33; - t140 = g01*ddg23*t139; - t144 = dg01*dg23*t139; - t147 = g23*t24; - t148 = t147*r; - t150 = ddgyr23*g22*g33; - t153 = t147*t1; - t155 = ddgxr33*g22*g33; - t162 = dg23*dg23; - t164 = Rmin*g03*g22*t162; - t170 = t39*g03; - t179 = 2.0*t13*t140-2.0*t13*t144+2.0*t148*t150+2.0*t153*t155-2.0*t148*t155+2.0*t14*t2*t164+4.0*t43*t45*dg23 & - -2.0*t170*t134-2.0*t115*t140+3.0*t115*t20-2.0*t170*t130; - t182 = t133*t19; - t186 = dg33*dg33; - t188 = g23*g22*g01*t186; - t190 = g02*g23; - t191 = t39*t190; - t193 = g01*ddg33*t139; - t197 = dg01*dg33*t139; - t202 = g33*g23*g01*t162; - t206 = t14*ddg23*t7; - t215 = t147*g22; - t216 = dgy33*r; - t222 = t7*t24; - t224 = dgx33*t1; - t227 = dgy33*t1; - t230 = dgx33*r; - t231 = t230*dg23; - t234 = r*dg22; - t238 = t39*dg03; - t239 = dg01*g22; - t240 = g33*t7; - t241 = t239*t240; - t244 = dg01*t72; - t245 = t244*t23; - t249 = dg03*dg01*t8; - t252 = t11*dg03; - t257 = -2.0*t153*t150-t222*t70-t215*t224*dg33-t222*t227*dg22-2.0*t222*t231-2.0*t66*t234*dgy23-4.0*t238*t241 & - +2.0*t238*t245-2.0*t11*t249+4.0*t252*t241-2.0*t252*t245; - t259 = dg33*t7; - t260 = t239*t259; - t263 = t45*ddg33; - t266 = t129*dg33; - t269 = t1*dg33; - t270 = t269*dgy22; - t274 = t224*dg23; - t279 = t1*dg23; - t283 = r*dg23; - t288 = t1*dg22; - t292 = 2.0*t170*t260-2.0*t49*t263+2.0*t49*t266+t222*t270+t215*t230*dg33+2.0*t222*t274+t215*t227*dg23 & - -2.0*t222*t279*dgy23+2.0*t222*t283*dgy23-t92*t84+2.0*t66*t288*dgy23; - t293 = dg33*g33; - t294 = t244*t293; - t301 = dg02*dg33*t139; - t316 = t139*t7; - t323 = ddgyr01*t72*t23; - t326 = -2.0*t170*t294+t222*t216*dg22+2.0*t99*t11*t301+2.0*t170*t46-2.0*t49*t94+2.0*t49*t126-2.0*t49*t202 & - -4.0*t13*g01*dg23*t139-8.0*t6*t316+4.0*t62*ddgyr01*t316-2.0*t62*t323; - t330 = t18*Rmin; - t331 = t38*dg03; - t334 = t72*g01; - t335 = t334*Rmin; - t338 = t99*dgy01; - t342 = t45*Rmin; - t343 = t2*dg02; - t350 = Rmin*t1; - t351 = t350*g01; - t353 = dg03*g22*t240; - t356 = t14*Rmin; - t357 = t1*g02; - t361 = t50*Rmin; - t375 = r*t72*t23; - t381 = dg03*t72*t23; - t385 = g01*dg03*t8; - t388 = t2*dg03; - t389 = dg22*t7; - t392 = t14*dgy01; - t398 = r*ddgyr22; - t407 = -4.0*t111*r*t316+2.0*t111*t375+2.0*t39*t249+8.0*t351*t381-4.0*t11*t385-t356*t388*t389-t392*t234*t7 & - -2.0*t29*t121*t7+2.0*t29*t398*t7-t25*t67*dg23+2.0*t66*t283*dgx23; - t411 = g03*g22*t100; - t415 = t1*g03; - t419 = t18*dgy01; - t422 = t334*dgy01; - t428 = t99*t350; - t443 = t334*t186; - t445 = -t14*t11*t411+8.0*t350*t385-8.0*t335*t415*t293-t419*t31*t7+t422*t31*g33-8.0*t342*t415*dg23 & - +8.0*t428*g03*dg23*t139-8.0*t342*t357*dg33+8.0*t428*g02*dg33*t139-4.0*t108*ddgyr01*t316+t43*t443; - t450 = t334*ddg33*g33; - t456 = t18*ddg33*t7; - t465 = t11*g01; - t471 = t38*dg02; - t475 = -4.0*t43*t18*t259-2.0*t43*t450+2.0*t43*t294+2.0*t43*t456-2.0*t43*t260-t170*t443+2.0*t170*t450-t30*t274 & - -4.0*t465*t381-2.0*t45*t76*dg23-2.0*t356*t471*t58; - t481 = dg22*g22; - t486 = t50*dgy01; - t504 = 2.0*t361*t471*t51+t361*t388*t481+t356*t331*t389+t486*t234*g22+t14*t39*t411+t392*t288*t7+t30*t231 & - +4.0*t43*t334*t293+2.0*t108*t323-2.0*t80*r*ddgyr23-t66*t283*dgy22; - t530 = r*ddgxr23; - t534 = t419*t269*t7-t422*t269*g33+t330*t388*t259-t335*t388*t293+2.0*t45*dgy01*r*dg23-2.0*t338*t283*t139 & - -2.0*t92*t266+2.0*t92*t263-2.0*t25*t398*g22-2.0*t25*t117*g22+2.0*t25*t530*g22; - t547 = t11*t190; - t562 = -t361*t331*t481+8.0*t465*t353-t66*t35*dg33+t66*t279*dgy22-2.0*t29*t530*t7-4.0*t547*g01*dg33*t139 & - -t49*t188+2.0*t49*t182+4.0*t49*t45*dg33+2.0*t547*t193-2.0*t547*t197; - t592 = -2.0*t66*t279*dgx23-t486*t288*g22-2.0*t14*t38*t164-2.0*t170*t456+8.0*t330*t415*t259+2.0*t342*t471*dg33 & - +2.0*t356*t343*t58-2.0*t361*t343*t51+2.0*t30*t269*dgx23-t25*dgy22*t1*dg22-t30*t270; - p03_rhs = 1/t2/g01*(t504+t534+t562+t592+t137+t97+t257+t179+t326-2.0*t43*t46-2.0*t92*t206-t41*t20+2.0*t115*t144 & - -2.0*t49*t104+2.0*t49*t206-3.0*t13*t20-t13*t16+4.0*t6*t8-16.0*t351*t353+t55*t20-2.0*t76*t245+t292 & - +2.0*t191*t197-t330*t331*t259-2.0*t99*t39*t301+4.0*t76*dg01*t316-8.0*t361*t357*t51+8.0*t356*t357*t58 & - +4.0*t49*t50*t51+t25*t35*dg23+2.0*t338*t279*t139-t215*t216*dg23+t335*t331*t293-2.0*t342*t343*dg33 & - -2.0*t30*t31*dgx23+t92*t188-2.0*t92*t182+t25*dgy22*r*dg22-2.0*t191*t193+t475+t445+t407 & - +2.0*t92*t202)/(-2.0*r*t7*t139-t8+t112+2.0*t316-t73+t375)/Rmin/2.0 - - g02_rhs = p02 - g03_rhs = p03 - - return - -end subroutine pg0a_rhs -!------------------------------------------------------------------------------ -subroutine get_g01_rhs(r,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01,g01_rhs) - - implicit none - -!~~~~~~% Input parameters: - real*8,intent(in) :: r,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01 - real*8,intent(out) :: g01_rhs - - real*8 :: t107; - real*8 :: t11; - real*8 :: t110; - real*8 :: t14; - real*8 :: t19; - real*8 :: t2; - real*8 :: t23; - real*8 :: t25; - real*8 :: t28; - real*8 :: t3; - real*8 :: t33; - real*8 :: t34; - real*8 :: t40; - real*8 :: t45; - real*8 :: t49; - real*8 :: t54; - real*8 :: t6; - real*8 :: t7; - real*8 :: t73; - real*8 :: t76; - real*8 :: t81; - real*8 :: t89; - real*8 :: t98; - - t2 = g23*g23; - t3 = t2*g23; - t6 = g22*g33; - t7 = dg23*dg23; - t11 = t2*r; - t14 = g23*r; - t19 = g22*r; - t23 = g33*g33; - t25 = dg22*dg22; - t28 = r*dg22; - t33 = g22*g22; - t34 = t33*g33; - t40 = g33*r; - t45 = g22*t23; - t49 = r*dg33; - t54 = dg33*dg33; - t73 = 4.0*r*ddg23*t3-2.0*t6*r*t7-2.0*t11*t7-4.0*t14*ddg23*g22*g33-2.0*t19*ddg33*t2-t23*r*t25 & - +4.0*g33*g23*t28*dg23+2.0*r*ddg33*t34-2.0*t11*dg33*dg22-2.0*t40*ddg22*t2+2.0*r*ddg22*t45 & - +4.0*g23*g22*t49*dg23-t33*r*t54-4.0*g33*dg22*t2-4.0*g22*dg33*t2+4.0*dg33*t33*g33 & - +4.0*dg22*g22*t23-8.0*g23*dg23*t6+8.0*dg23*t3; - t76 = t2*t2; - t81 = r*r; - t89 = dg23*g22*g33; - t98 = dg33*t2; - t107 = dg22*t2; - t110 = -4.0*t76-2.0*r*dg23*t3+2.0*t81*dg23*t3+8.0*t6*t2-t28*t45+2.0*t14*t89-2.0*g23*t81*t89 & - +t81*dg33*t34-g22*t81*t98-t49*t34+t19*t98+t81*dg22*t45-4.0*t33*t23-g33*t81*t107+t40*t107; - g01_rhs = g01*t73*(-1.0+r)/t110/2.0 - - return - -end subroutine get_g01_rhs -!------------------------------------------------------------------------------ + + +#include "macrodef.fh" + +!--------------------------------------------------------------------------------- +! fill symmetric boundary buffer points +!--------------------------------------------------------------------------------- +subroutine fill_symmetric_boundarybuffer2(ex,crho,sigma,R,drho,dsigma, & + var,Symmetry,sst,AoS) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in),dimension(3) :: ex + integer,intent(in) :: Symmetry,sst + real*8,dimension(3) :: AoS + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8,intent(in) :: drho,dsigma + real*8,intent(inout),dimension(ex(1),ex(2),ex(3)) :: var + + integer :: i,j,k,t + + select case (Symmetry) + case (0) + return + case (1) + if((sst==2.or.sst==4).and.dabs(sigma(1)+ghost_width*dsigma) < dsigma/2.d0)then + do k=1,ex(3) + do j=1,ghost_width + do i=1,ex(1) +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+2-j +#endif +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+1-j +#endif + var(i,j,k) = AoS(2)*var(i,t,k) + enddo + enddo + enddo + endif + if((sst==3.or.sst==5).and.dabs(sigma(ex(2))-ghost_width*dsigma) < dsigma/2.d0)then + do k=1,ex(3) + do j=ex(2)-ghost_width+1,ex(2) + do i=1,ex(1) + t = ex(2)-j+1 +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + t = ex(2)-2*ghost_width-1+t +#endif +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + t = ex(2)-2*ghost_width+t +#endif + var(i,j,k) = AoS(2)*var(i,t,k) + enddo + enddo + enddo + endif + case (2) + if(dabs(crho(1)+ghost_width*drho) < drho/2.d0)then + if(dabs(sigma(1)+ghost_width*dsigma) < dsigma/2.d0)then + do k=1,ex(3) + do j=1,ghost_width + do i=ghost_width+1,ex(1) +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+2-j +#endif +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+1-j +#endif + var(i,j,k) = AoS(2)*var(i,t,k) + enddo + enddo + enddo + endif + do k=1,ex(3) + do j=1,ex(2) + do i=1,ghost_width +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+2-i +#endif +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+1-i +#endif + var(i,j,k) = AoS(1)*var(t,j,k) + enddo + enddo + enddo + else + if(dabs(sigma(1)+ghost_width*dsigma) < dsigma/2.d0)then + do k=1,ex(3) + do j=1,ghost_width + do i=1,ex(1) +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+2-j +#endif +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + t = 2*ghost_width+1-j +#endif + var(i,j,k) = AoS(2)*var(i,t,k) + enddo + enddo + enddo + endif + endif + end select + + return + + end subroutine fill_symmetric_boundarybuffer2 +!--------------------------------------------------------------------------------- +!!!! using r^2g_AB instead of g_AB +!!!! using r^2g_0A instead of g_0A +!!!! using r^2g_00 instead of g_00 +!!!! using x in the metric form directly instead of r +!--------------------------------------------------------------------------------- +! this R is indeed x +function NullEvol_g01(ex,crho,sigma,R, & + g22,g23,g33,g01,Rmin) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in ):: Rmin + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: g01 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g22,g23,g33 +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + real*8, dimension(ex(3)):: dg22,dg23,dg33,ddg22,ddg23,ddg33 + real*8, dimension(ex(3)):: Hg22,Hg23,Hg33 + real*8, dimension(ex(3)):: Hdg22,Hdg23,Hdg33,Hddg22,Hddg23,Hddg33 + real*8 :: g010,g011,g01h,rhs + integer :: i,j,k,RK4 + +!!! sanity check + dR = sum(g22)+sum(g23)+sum(g33)+sum(g01) + if(dR.ne.dR) then + if(sum(g22).ne.sum(g22))write(*,*)"NullEvol_g01: find NaN in g22" + if(sum(g23).ne.sum(g23))write(*,*)"NullEvol_g01: find NaN in g23" + if(sum(g33).ne.sum(g33))write(*,*)"NullEvol_g01: find NaN in g33" + if(sum(g01).ne.sum(g01))write(*,*)"NullEvol_g01: find NaN in g01" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + g010 = g01(i,j,1) + + call rderivs_x(ex(3),R,g22(i,j,:),dg22) + call rderivs_x(ex(3),R,g23(i,j,:),dg23) + call rderivs_x(ex(3),R,g33(i,j,:),dg33) + call rdderivs_x(ex(3),R,g22(i,j,:),ddg22) + call rdderivs_x(ex(3),R,g23(i,j,:),ddg23) + call rdderivs_x(ex(3),R,g33(i,j,:),ddg33) + + call rget_half_x(ex(3),g22(i,j,:),Hg22) + call rget_half_x(ex(3),g23(i,j,:),Hg23) + call rget_half_x(ex(3),g33(i,j,:),Hg33) + + call rget_half_x(ex(3),dg22,Hdg22) + call rget_half_x(ex(3),dg23,Hdg23) + call rget_half_x(ex(3),dg33,Hdg33) + + call rget_half_x(ex(3),ddg22,Hddg22) + call rget_half_x(ex(3),ddg23,Hddg23) + call rget_half_x(ex(3),ddg33,Hddg33) + + do k=1,ex(3)-2 + RK4 = 0 + call get_g01_rhs(R(k),g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & + dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k),rhs) + call rungekutta4_scalar(dR,g010,g01h,rhs,RK4) + + RK4 = 1 + call get_g01_rhs(R(k)+dR/2,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & + Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),g01h,g011) + call rungekutta4_scalar(dR,g010,g011,rhs,RK4) + call rswap(g01h,g011) + + RK4 = 2 + call get_g01_rhs(R(k)+dR/2,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & + Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),g01h,g011) + call rungekutta4_scalar(dR,g010,g011,rhs,RK4) + call rswap(g01h,g011) + + RK4 = 3 + call get_g01_rhs(R(k+1),g22(i,j,k+1),g23(i,j,k+1),g33(i,j,k+1),dg22(k+1),dg23(k+1), & + dg33(k+1),ddg22(k+1),ddg23(k+1),ddg33(k+1),g01h,g011) + call rungekutta4_scalar(dR,g010,g011,rhs,RK4) + call rswap(g010,g011) + + g01(i,j,k+1) = g010 + enddo +! closing step + k = ex(3)-1 + call get_g01_rhs(R(k),g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & + dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k),rhs) + g01(i,j,k+1) = g01(i,j,k) + rhs*dR + + enddo + enddo + + gont = 0 + + return + +end function NullEvol_g01 +!------------------------------------------------------------------------------ +! this R is indeed x +function NullEvol_pg0a(ex,crho,sigma,R, & + g22,g23,g33,g01,p02,p03,g02,g03,Rmin) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in ):: Rmin + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: p02,p03,g02,g03 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g22,g23,g33,g01 +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + real*8, dimension(ex(3)) :: Hg01 + real*8, dimension(ex(3)) :: Hg22,Hg23,Hg33 + + real*8, dimension(ex(3)) :: dg01,dg02,dg03 + real*8, dimension(ex(3)) :: dgx01,dgx22,dgx23,dgx33 + real*8, dimension(ex(3)) :: dgy01,dgy22,dgy23,dgy33 + real*8, dimension(ex(3)) :: ddgxr01,ddgxr22,ddgxr23,ddgxr33 + real*8, dimension(ex(3)) :: ddgyr01,ddgyr22,ddgyr23,ddgyr33 + real*8, dimension(ex(3)) :: dg22,dg23,dg33,ddg22,ddg23,ddg33 + real*8, dimension(ex(3)) :: Hdg01,Hdg02,Hdg03 + real*8, dimension(ex(3)) :: Hdgx01,Hdgx22,Hdgx23,Hdgx33 + real*8, dimension(ex(3)) :: Hdgy01,Hdgy22,Hdgy23,Hdgy33 + real*8, dimension(ex(3)) :: Hddgxr01,Hddgxr22,Hddgxr23,Hddgxr33 + real*8, dimension(ex(3)) :: Hddgyr01,Hddgyr22,Hddgyr23,Hddgyr33 + real*8, dimension(ex(3)) :: Hdg22,Hdg23,Hdg33,Hddg22,Hddg23,Hddg33 + + real*8 :: p020,p021,p02h,p02_rhs + real*8 :: p030,p031,p03h,p03_rhs + real*8 :: g020,g021,g02h,g02_rhs + real*8 :: g030,g031,g03h,g03_rhs + integer :: i,j,k,RK4 + +!!! sanity check + dR = sum(g22)+sum(g23)+sum(g33)+sum(g01) & + +sum(p02)+sum(p03)+sum(g02)+sum(g03) + if(dR.ne.dR) then + if(sum(g22).ne.sum(g22))write(*,*)"NullEvol_pg0a: find NaN in g22" + if(sum(g23).ne.sum(g23))write(*,*)"NullEvol_pg0a: find NaN in g23" + if(sum(g33).ne.sum(g33))write(*,*)"NullEvol_pg0a: find NaN in g33" + if(sum(g01).ne.sum(g01))write(*,*)"NullEvol_pg0a: find NaN in g01" + if(sum(p02).ne.sum(p02))write(*,*)"NullEvol_pg0a: find NaN in p02" + if(sum(p03).ne.sum(p03))write(*,*)"NullEvol_pg0a: find NaN in p03" + if(sum(g02).ne.sum(g02))write(*,*)"NullEvol_pg0a: find NaN in g02" + if(sum(g03).ne.sum(g03))write(*,*)"NullEvol_pg0a: find NaN in g03" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + + call rderivs_x(ex(3),R,g01(i,j,:),dg01) + dg02 = p02(i,j,:) + dg03 = p03(i,j,:) + call rderivs_x(ex(3),R,g22(i,j,:),dg22) + call rderivs_x(ex(3),R,g23(i,j,:),dg23) + call rderivs_x(ex(3),R,g33(i,j,:),dg33) + call rdderivs_x(ex(3),R,g22(i,j,:),ddg22) + call rdderivs_x(ex(3),R,g23(i,j,:),ddg23) + call rdderivs_x(ex(3),R,g33(i,j,:),ddg33) + + do k=1,ex(3) + call rderivs_x_point(ex(1),crho,g01(:,j,k),dgx01(k),i) + call rderivs_x_point(ex(1),crho,g22(:,j,k),dgx22(k),i) + call rderivs_x_point(ex(1),crho,g23(:,j,k),dgx23(k),i) + call rderivs_x_point(ex(1),crho,g33(:,j,k),dgx33(k),i) + + call rderivs_x_point(ex(2),sigma,g01(i,:,k),dgy01(k),j) + call rderivs_x_point(ex(2),sigma,g22(i,:,k),dgy22(k),j) + call rderivs_x_point(ex(2),sigma,g23(i,:,k),dgy23(k),j) + call rderivs_x_point(ex(2),sigma,g33(i,:,k),dgy33(k),j) + + call rdderivs_xy_point(ex(1),ex(3),crho,R,g01(:,j,:),ddgxr01(k),i,k) + call rdderivs_xy_point(ex(1),ex(3),crho,R,g22(:,j,:),ddgxr22(k),i,k) + call rdderivs_xy_point(ex(1),ex(3),crho,R,g23(:,j,:),ddgxr23(k),i,k) + call rdderivs_xy_point(ex(1),ex(3),crho,R,g33(:,j,:),ddgxr33(k),i,k) + + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g01(i,:,:),ddgyr01(k),j,k) + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g22(i,:,:),ddgyr22(k),j,k) + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g23(i,:,:),ddgyr23(k),j,k) + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g33(i,:,:),ddgyr33(k),j,k) + enddo + + call rget_half_x(ex(3),g01(i,j,:),Hg01) + call rget_half_x(ex(3),g22(i,j,:),Hg22) + call rget_half_x(ex(3),g23(i,j,:),Hg23) + call rget_half_x(ex(3),g33(i,j,:),Hg33) + + call rget_half_x(ex(3),dg01,Hdg01) + call rget_half_x(ex(3),dg02,Hdg02) + call rget_half_x(ex(3),dg03,Hdg03) + + call rget_half_x(ex(3),dgx01,Hdgx01) + call rget_half_x(ex(3),dgy01,Hdgy01) + + call rget_half_x(ex(3),dgx22,Hdgx22) + call rget_half_x(ex(3),dgx23,Hdgx23) + call rget_half_x(ex(3),dgx33,Hdgx33) + call rget_half_x(ex(3),dgy22,Hdgy22) + call rget_half_x(ex(3),dgy23,Hdgy23) + call rget_half_x(ex(3),dgy33,Hdgy33) + + call rget_half_x(ex(3),ddgxr01,Hddgxr01) + call rget_half_x(ex(3),ddgyr01,Hddgyr01) + + call rget_half_x(ex(3),ddgxr22,Hddgxr22) + call rget_half_x(ex(3),ddgxr23,Hddgxr23) + call rget_half_x(ex(3),ddgxr33,Hddgxr33) + call rget_half_x(ex(3),ddgyr22,Hddgyr22) + call rget_half_x(ex(3),ddgyr23,Hddgyr23) + call rget_half_x(ex(3),ddgyr33,Hddgyr33) + + call rget_half_x(ex(3),dg22,Hdg22) + call rget_half_x(ex(3),dg23,Hdg23) + call rget_half_x(ex(3),dg33,Hdg33) + call rget_half_x(ex(3),ddg22,Hddg22) + call rget_half_x(ex(3),ddg23,Hddg23) + call rget_half_x(ex(3),ddg33,Hddg33) + +#if 0 + g020 = g02(i,j,1) + g030 = g03(i,j,1) + p020 = p02(i,j,1) + p030 = p03(i,j,1) + + do k=1,ex(3)-2 + RK4 = 0 + call pg0a_rhs(Rmin,R(k),p020,p030,g020,g030,g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & + dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & + dg01(k),dg02(k),dg03(k), & + dgx01(k),dgx22(k),dgx23(k),dgx33(k), & + dgy01(k),dgy22(k),dgy23(k),dgy33(k), & + ddgxr01(k),ddgxr22(k),ddgxr23(k),ddgxr33(k), & + ddgyr01(k),ddgyr22(k),ddgyr23(k),ddgyr33(k), & + g02_rhs,g03_rhs,p02_rhs,p03_rhs) + call rungekutta4_scalar(dR,g020,g02h,g02_rhs,RK4) + call rungekutta4_scalar(dR,g030,g03h,g03_rhs,RK4) + call rungekutta4_scalar(dR,p020,p02h,p02_rhs,RK4) + call rungekutta4_scalar(dR,p030,p03h,p03_rhs,RK4) + + RK4 = 1 + call pg0a_rhs(Rmin,R(k)+dR/2,p02h,p03h,g02h,g03h,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & + Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & + Hdg01(k),Hdg02(k),Hdg03(k), & + Hdgx01(k),Hdgx22(k),Hdgx23(k),Hdgx33(k), & + Hdgy01(k),Hdgy22(k),Hdgy23(k),Hdgy33(k), & + Hddgxr01(k),Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & + Hddgyr01(k),Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & + g021,g031,p021,p031) + call rungekutta4_scalar(dR,g020,g021,g02_rhs,RK4) + call rungekutta4_scalar(dR,g030,g031,g03_rhs,RK4) + call rungekutta4_scalar(dR,p020,p021,p02_rhs,RK4) + call rungekutta4_scalar(dR,p030,p031,p03_rhs,RK4) + call rswap(g02h,g021) + call rswap(g03h,g031) + call rswap(p02h,p021) + call rswap(p03h,p031) + + RK4 = 2 + call pg0a_rhs(Rmin,R(k)+dR/2,p02h,p03h,g02h,g03h,Hg22(k),Hg23(k),Hg33(k),Hdg22(k),Hdg23(k), & + Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & + Hdg01(k),Hdg02(k),Hdg03(k), & + Hdgx01(k),Hdgx22(k),Hdgx23(k),Hdgx33(k), & + Hdgy01(k),Hdgy22(k),Hdgy23(k),Hdgy33(k), & + Hddgxr01(k),Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & + Hddgyr01(k),Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & + g021,g031,p021,p031) + call rungekutta4_scalar(dR,g020,g021,g02_rhs,RK4) + call rungekutta4_scalar(dR,g030,g031,g03_rhs,RK4) + call rungekutta4_scalar(dR,p020,p021,p02_rhs,RK4) + call rungekutta4_scalar(dR,p030,p031,p03_rhs,RK4) + call rswap(g02h,g021) + call rswap(g03h,g031) + call rswap(p02h,p021) + call rswap(p03h,p031) + + RK4 = 3 + call pg0a_rhs(Rmin,R(k+1),p02h,p03h,g02h,g03h,Hg22(k+1),Hg23(k+1),Hg33(k+1),Hdg22(k+1),Hdg23(k+1), & + Hdg33(k+1),Hddg22(k+1),Hddg23(k+1),Hddg33(k+1),Hg01(k+1), & + Hdg01(k+1),Hdg02(k+1),Hdg03(k+1), & + Hdgx01(k+1),Hdgx22(k+1),Hdgx23(k+1),Hdgx33(k+1), & + Hdgy01(k+1),Hdgy22(k+1),Hdgy23(k+1),Hdgy33(k+1), & + Hddgxr01(k+1),Hddgxr22(k+1),Hddgxr23(k+1),Hddgxr33(k+1), & + Hddgyr01(k+1),Hddgyr22(k+1),Hddgyr23(k+1),Hddgyr33(k+1), & + g021,g031,p021,p031) + call rungekutta4_scalar(dR,g020,g021,g02_rhs,RK4) + call rungekutta4_scalar(dR,g030,g031,g03_rhs,RK4) + call rungekutta4_scalar(dR,p020,p021,p02_rhs,RK4) + call rungekutta4_scalar(dR,p030,p031,p03_rhs,RK4) + call rswap(g020,g021) + call rswap(g030,g031) + call rswap(p020,p021) + call rswap(p030,p031) + + g02(i,j,k+1) = g020 + g03(i,j,k+1) = g030 + p02(i,j,k+1) = p020 + p03(i,j,k+1) = p030 + + enddo + k=ex(3)-1 +! closing step + call pg0a_rhs(Rmin,R(k),p020,p030,g020,g030,g22(i,j,k),g23(i,j,k),g33(i,j,k),dg22(k),dg23(k), & + dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & + dg01(k),dg02(k),dg03(k), & + dgx01(k),dgx22(k),dgx23(k),dgx33(k), & + dgy01(k),dgy22(k),dgy23(k),dgy33(k), & + ddgxr01(k),ddgxr22(k),ddgxr23(k),ddgxr33(k), & + ddgyr01(k),ddgyr22(k),ddgyr23(k),ddgyr33(k), & + g02_rhs,g03_rhs,p02_rhs,p03_rhs) + g02(i,j,k+1) = g02(i,j,k) + g02_rhs*dR + g03(i,j,k+1) = g03(i,j,k) + g03_rhs*dR + p02(i,j,k+1) = p02(i,j,k) + p02_rhs*dR + p03(i,j,k+1) = p03(i,j,k) + p03_rhs*dR +#endif + + enddo + enddo + + gont = 0 + + return + +end function NullEvol_pg0a +!------------------------------------------------------------------------------ +! this R is indeed x +function NullEvol_Theta2(ex,crho,sigma,R, & + g22,g23,g33,g00,g01,g02,g03,p02,p03, & + Theta22,Theta23,Theta33,Rmin) result(gont) + implicit none + integer,intent(in ):: ex(1:3) + real*8,intent(in ):: Rmin + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g00 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g02,g03,p02,p03 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: g22,g23,g33,g01 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Theta22,Theta23,Theta33 +! gont = 0: success; gont = 1: something wrong + integer::gont + real*8 :: dR + + real*8,dimension(ex(3)) :: dg22,dg23,dg33,ddg22,ddg23,ddg33 + real*8,dimension(ex(3)) :: dg00,dg01,dg02,dg03 + real*8,dimension(ex(3)) :: dgx01,dgx02,dgx03 + real*8,dimension(ex(3)) :: dgy01,dgy02,dgy03 + real*8,dimension(ex(3)) :: dgx22,dgx23,dgx33 + real*8,dimension(ex(3)) :: dgy22,dgy23,dgy33 + real*8,dimension(ex(3)) :: ddgxx01,ddgxx33,ddgyy01,ddgyy22,ddgxy23 + real*8,dimension(ex(3)) :: ddgxy01,ddgxr02,ddgxr03,ddgyr02,ddgyr03 + real*8,dimension(ex(3)) :: ddgxr22,ddgxr23,ddgxr33,ddgyr22,ddgyr23,ddgyr33 + + real*8,dimension(ex(3)) :: Hdg22,Hdg23,Hdg33,Hddg22,Hddg23,Hddg33 + real*8,dimension(ex(3)) :: Hdg00,Hdg01,Hdg02,Hdg03 + real*8,dimension(ex(3)) :: Hdgx01,Hdgx02,Hdgx03 + real*8,dimension(ex(3)) :: Hdgy01,Hdgy02,Hdgy03 + real*8,dimension(ex(3)) :: Hdgx22,Hdgx23,Hdgx33 + real*8,dimension(ex(3)) :: Hdgy22,Hdgy23,Hdgy33 + real*8,dimension(ex(3)) :: Hddgxx01,Hddgxx33,Hddgyy01,Hddgyy22,Hddgxy23 + real*8,dimension(ex(3)) :: Hddgxy01,Hddgxr02,Hddgxr03,Hddgyr02,Hddgyr03 + real*8,dimension(ex(3)) :: Hddgxr22,Hddgxr23,Hddgxr33,Hddgyr22,Hddgyr23,Hddgyr33 + + real*8,dimension(ex(3)) :: Hg00,Hg01,Hg02,Hg03,Hg22,Hg23,Hg33 + real*8,dimension(ex(3)) :: HTheta22,HTheta23,HTheta33 + + real*8 :: Theta220,Theta221,Theta22h,Theta22_rhs + real*8 :: Theta230,Theta231,Theta23h,Theta23_rhs + real*8 :: Theta330,Theta331,Theta33h,Theta33_rhs + integer :: i,j,k,RK4 + +!!! sanity check + dR = sum(g22)+sum(g23)+sum(g33)+sum(g01) & + +sum(g00)+sum(g02)+sum(g03) & + +sum(Theta22)+sum(Theta23)+sum(Theta33) + if(dR.ne.dR) then + if(sum(g22).ne.sum(g22))write(*,*)"NullEvol_Theta: find NaN in g22" + if(sum(g23).ne.sum(g23))write(*,*)"NullEvol_Theta: find NaN in g23" + if(sum(g33).ne.sum(g33))write(*,*)"NullEvol_Theta: find NaN in g33" + if(sum(g01).ne.sum(g01))write(*,*)"NullEvol_Theta: find NaN in g01" + if(sum(g00).ne.sum(g00))write(*,*)"NullEvol_Theta: find NaN in g00" + if(sum(g02).ne.sum(g02))write(*,*)"NullEvol_Theta: find NaN in g02" + if(sum(g03).ne.sum(g03))write(*,*)"NullEvol_Theta: find NaN in g03" + if(sum(Theta22).ne.sum(Theta22))write(*,*)"NullEvol_Theta: find NaN in Theta22" + if(sum(Theta23).ne.sum(Theta23))write(*,*)"NullEvol_Theta: find NaN in Theta23" + if(sum(Theta33).ne.sum(Theta33))write(*,*)"NullEvol_Theta: find NaN in Theta33" + gont = 1 + return + endif + + dR = R(2) - R(1) + + do j=1,ex(2) + do i=1,ex(1) + call rderivs_x(ex(3),R,g00(i,j,:),dg00) + call rderivs_x(ex(3),R,g01(i,j,:),dg01) + dg02 = p02(i,j,:) + dg03 = p03(i,j,:) + + call rderivs_x(ex(3),R,g22(i,j,:),dg22) + call rderivs_x(ex(3),R,g23(i,j,:),dg23) + call rderivs_x(ex(3),R,g33(i,j,:),dg33) + call rdderivs_x(ex(3),R,g22(i,j,:),ddg22) + call rdderivs_x(ex(3),R,g23(i,j,:),ddg23) + call rdderivs_x(ex(3),R,g33(i,j,:),ddg33) + + do k=1,ex(3) + call rderivs_x_point(ex(1),crho,g01(:,j,k),dgx01(k),i) + call rderivs_x_point(ex(1),crho,g02(:,j,k),dgx02(k),i) + call rderivs_x_point(ex(1),crho,g03(:,j,k),dgx03(k),i) + + call rderivs_x_point(ex(2),sigma,g01(i,:,k),dgy01(k),j) + call rderivs_x_point(ex(2),sigma,g02(i,:,k),dgy02(k),j) + call rderivs_x_point(ex(2),sigma,g03(i,:,k),dgy03(k),j) + + call rderivs_x_point(ex(1),crho,g22(:,j,k),dgx22(k),i) + call rderivs_x_point(ex(1),crho,g23(:,j,k),dgx23(k),i) + call rderivs_x_point(ex(1),crho,g33(:,j,k),dgx33(k),i) + + call rderivs_x_point(ex(2),sigma,g22(i,:,k),dgy22(k),j) + call rderivs_x_point(ex(2),sigma,g23(i,:,k),dgy23(k),j) + call rderivs_x_point(ex(2),sigma,g33(i,:,k),dgy33(k),j) + + call rdderivs_x_point(ex(1),crho,g01(:,j,k),ddgxx01(k),i) + call rdderivs_x_point(ex(1),crho,g33(:,j,k),ddgxx33(k),i) + + call rdderivs_x_point(ex(2),sigma,g01(i,:,k),ddgyy01(k),j) + call rdderivs_x_point(ex(2),sigma,g22(i,:,k),ddgyy22(k),j) + + call rderivs_x_point(ex(1),crho,p02(:,j,k),ddgxr02(k),i) + call rderivs_x_point(ex(1),crho,p03(:,j,k),ddgxr03(k),i) + + call rderivs_x_point(ex(2),sigma,p02(i,:,k),ddgyr02(k),j) + call rderivs_x_point(ex(2),sigma,p03(i,:,k),ddgyr03(k),j) + + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,g01(:,:,k),ddgxy01(k),i,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,g23(:,:,k),ddgxy23(k),i,j) + + call rdderivs_xy_point(ex(1),ex(3),crho,R,g22(:,j,:),ddgxr22(k),i,k) + call rdderivs_xy_point(ex(1),ex(3),crho,R,g23(:,j,:),ddgxr23(k),i,k) + call rdderivs_xy_point(ex(1),ex(3),crho,R,g33(:,j,:),ddgxr33(k),i,k) + + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g22(i,:,:),ddgyr22(k),j,k) + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g23(i,:,:),ddgyr23(k),j,k) + call rdderivs_xy_point(ex(2),ex(3),sigma,R,g33(i,:,:),ddgyr33(k),j,k) + enddo + + call rget_half_x(ex(3),g00(i,j,:),Hg00) + call rget_half_x(ex(3),g01(i,j,:),Hg01) + call rget_half_x(ex(3),g02(i,j,:),Hg02) + call rget_half_x(ex(3),g03(i,j,:),Hg03) + call rget_half_x(ex(3),g22(i,j,:),Hg22) + call rget_half_x(ex(3),g23(i,j,:),Hg23) + call rget_half_x(ex(3),g33(i,j,:),Hg33) + call rget_half_x(ex(3),Theta22(i,j,:),HTheta22) + call rget_half_x(ex(3),Theta23(i,j,:),HTheta23) + call rget_half_x(ex(3),Theta33(i,j,:),HTheta33) + + call rget_half_x(ex(3),dg22,Hdg22) + call rget_half_x(ex(3),dg23,Hdg23) + call rget_half_x(ex(3),dg33,Hdg33) + call rget_half_x(ex(3),ddg22,Hddg22) + call rget_half_x(ex(3),ddg23,Hddg23) + call rget_half_x(ex(3),ddg33,Hddg33) + call rget_half_x(ex(3),dg00,Hdg00) + call rget_half_x(ex(3),dg01,Hdg01) + call rget_half_x(ex(3),dg02,Hdg02) + call rget_half_x(ex(3),dg03,Hdg03) + call rget_half_x(ex(3),dgx01,Hdgx01) + call rget_half_x(ex(3),dgx02,Hdgx02) + call rget_half_x(ex(3),dgx03,Hdgx03) + call rget_half_x(ex(3),dgy01,Hdgy01) + call rget_half_x(ex(3),dgy02,Hdgy02) + call rget_half_x(ex(3),dgy03,Hdgy03) + call rget_half_x(ex(3),dgx22,Hdgx22) + call rget_half_x(ex(3),dgx23,Hdgx23) + call rget_half_x(ex(3),dgx33,Hdgx33) + call rget_half_x(ex(3),dgy22,Hdgy22) + call rget_half_x(ex(3),dgy23,Hdgy23) + call rget_half_x(ex(3),dgy33,Hdgy33) + call rget_half_x(ex(3),ddgxx01,Hddgxx01) + call rget_half_x(ex(3),ddgxx33,Hddgxx33) + call rget_half_x(ex(3),ddgyy01,Hddgyy01) + call rget_half_x(ex(3),ddgyy22,Hddgyy22) + call rget_half_x(ex(3),ddgxy23,Hddgxy23) + call rget_half_x(ex(3),ddgxy01,Hddgxy01) + call rget_half_x(ex(3),ddgxr02,Hddgxr02) + call rget_half_x(ex(3),ddgxr03,Hddgxr03) + call rget_half_x(ex(3),ddgyr02,Hddgyr02) + call rget_half_x(ex(3),ddgyr03,Hddgyr03) + call rget_half_x(ex(3),ddgxr22,Hddgxr22) + call rget_half_x(ex(3),ddgxr23,Hddgxr23) + call rget_half_x(ex(3),ddgxr33,Hddgxr33) + call rget_half_x(ex(3),ddgyr22,Hddgyr22) + call rget_half_x(ex(3),ddgyr23,Hddgyr23) + call rget_half_x(ex(3),ddgyr33,Hddgyr33) + +#if 0 + Theta220 = Theta22(i,j,1) + Theta230 = Theta23(i,j,1) + Theta330 = Theta33(i,j,1) + + do k=1,ex(3)-2 + RK4 = 0 + call Theta_rhs2(Rmin,R(k),g00(i,j,k),g02(i,j,k),g03(i,j,k),g22(i,j,k),g23(i,j,k),g33(i,j,k), & + dg22(k),dg23(k),dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & + Theta220,Theta230,Theta330, & + dg01(k),dg02(k),dg03(k), & + dgx01(k),dgx02(k),dgx03(k), & + dgy01(k),dgy02(k),dgy03(k), & + dgx22(k),dgx23(k),dgx33(k), & + dgy22(k),dgy23(k),dgy33(k), & + dg00(k), & + ddgxx01(k), & + ddgxx33(k), & + ddgyy01(k), & + ddgyy22(k), & + ddgxy23(k), & + ddgxy01(k), & + ddgxr02(k),ddgxr03(k), & + ddgyr02(k),ddgyr03(k), & + ddgxr22(k),ddgxr23(k),ddgxr33(k), & + ddgyr22(k),ddgyr23(k),ddgyr33(k), & + Theta22_rhs,Theta23_rhs,Theta33_rhs) + call rungekutta4_scalar(dR,Theta220,Theta22h,Theta22_rhs,RK4) + call rungekutta4_scalar(dR,Theta230,Theta23h,Theta23_rhs,RK4) + call rungekutta4_scalar(dR,Theta330,Theta33h,Theta33_rhs,RK4) + + RK4 = 1 + + call Theta_rhs2(Rmin,R(k)+dR/2,Hg00(k),Hg02(k),Hg03(k),Hg22(k),Hg23(k),Hg33(k), & + Hdg22(k),Hdg23(k),Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & + Theta22h,Theta23h,Theta33h, & + Hdg01(k),Hdg02(k),Hdg03(k), & + Hdgx01(k),Hdgx02(k),Hdgx03(k), & + Hdgy01(k),Hdgy02(k),Hdgy03(k), & + Hdgx22(k),Hdgx23(k),Hdgx33(k), & + Hdgy22(k),Hdgy23(k),Hdgy33(k), & + Hdg00(k), & + Hddgxx01(k), & + Hddgxx33(k), & + Hddgyy01(k), & + Hddgyy22(k), & + Hddgxy23(k), & + Hddgxy01(k), & + Hddgxr02(k),Hddgxr03(k), & + Hddgyr02(k),Hddgyr03(k), & + Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & + Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & + Theta221,Theta231,Theta331) + + call rungekutta4_scalar(dR,Theta220,Theta221,Theta22_rhs,RK4) + call rungekutta4_scalar(dR,Theta230,Theta231,Theta23_rhs,RK4) + call rungekutta4_scalar(dR,Theta330,Theta331,Theta33_rhs,RK4) + call rswap(Theta22h,Theta221) + call rswap(Theta23h,Theta231) + call rswap(Theta33h,Theta331) + + RK4 = 2 + call Theta_rhs2(Rmin,R(k)+dR/2,Hg00(k),Hg02(k),Hg03(k),Hg22(k),Hg23(k),Hg33(k), & + Hdg22(k),Hdg23(k),Hdg33(k),Hddg22(k),Hddg23(k),Hddg33(k),Hg01(k), & + Theta22h,Theta23h,Theta33h, & + Hdg01(k),Hdg02(k),Hdg03(k), & + Hdgx01(k),Hdgx02(k),Hdgx03(k), & + Hdgy01(k),Hdgy02(k),Hdgy03(k), & + Hdgx22(k),Hdgx23(k),Hdgx33(k), & + Hdgy22(k),Hdgy23(k),Hdgy33(k), & + Hdg00(k), & + Hddgxx01(k), & + Hddgxx33(k), & + Hddgyy01(k), & + Hddgyy22(k), & + Hddgxy23(k), & + Hddgxy01(k), & + Hddgxr02(k),Hddgxr03(k), & + Hddgyr02(k),Hddgyr03(k), & + Hddgxr22(k),Hddgxr23(k),Hddgxr33(k), & + Hddgyr22(k),Hddgyr23(k),Hddgyr33(k), & + Theta221,Theta231,Theta331) + + call rungekutta4_scalar(dR,Theta220,Theta221,Theta22_rhs,RK4) + call rungekutta4_scalar(dR,Theta230,Theta231,Theta23_rhs,RK4) + call rungekutta4_scalar(dR,Theta330,Theta331,Theta33_rhs,RK4) + call rswap(Theta22h,Theta221) + call rswap(Theta23h,Theta231) + call rswap(Theta33h,Theta331) + + RK4 = 3 + call Theta_rhs2(Rmin,R(k+1),g00(i,j,k+1),g02(i,j,k+1),g03(i,j,k+1),g22(i,j,k+1),g23(i,j,k+1),g33(i,j,k+1), & + dg22(k+1),dg23(k+1),dg33(k+1),ddg22(k+1),ddg23(k+1),ddg33(k+1),g01(i,j,k+1), & + Theta22h,Theta23h,Theta33h, & + dg01(k+1),dg02(k+1),dg03(k+1), & + dgx01(k+1),dgx02(k+1),dgx03(k+1), & + dgy01(k+1),dgy02(k+1),dgy03(k+1), & + dgx22(k+1),dgx23(k+1),dgx33(k+1), & + dgy22(k+1),dgy23(k+1),dgy33(k+1), & + dg00(k+1), & + ddgxx01(k+1), & + ddgxx33(k+1), & + ddgyy01(k+1), & + ddgyy22(k+1), & + ddgxy23(k+1), & + ddgxy01(k+1), & + ddgxr02(k+1),ddgxr03(k+1), & + ddgyr02(k+1),ddgyr03(k+1), & + ddgxr22(k+1),ddgxr23(k+1),ddgxr33(k+1), & + ddgyr22(k+1),ddgyr23(k+1),ddgyr33(k+1), & + Theta221,Theta231,Theta331) + + call rungekutta4_scalar(dR,Theta220,Theta221,Theta22_rhs,RK4) + call rungekutta4_scalar(dR,Theta230,Theta231,Theta23_rhs,RK4) + call rungekutta4_scalar(dR,Theta330,Theta331,Theta33_rhs,RK4) + call rswap(Theta220,Theta221) + call rswap(Theta230,Theta231) + call rswap(Theta330,Theta331) + + Theta22(i,j,k+1) = Theta220 + Theta23(i,j,k+1) = Theta230 + Theta33(i,j,k+1) = Theta330 + enddo + + k=ex(3)-1 +! closing step + + call Theta_rhs2(Rmin,R(k),g00(i,j,k),g02(i,j,k),g03(i,j,k),g22(i,j,k),g23(i,j,k),g33(i,j,k), & + dg22(k),dg23(k),dg33(k),ddg22(k),ddg23(k),ddg33(k),g01(i,j,k), & + Theta22(i,j,k),Theta23(i,j,k),Theta33(i,j,k), & + dg01(k),dg02(k),dg03(k), & + dgx01(k),dgx02(k),dgx03(k), & + dgy01(k),dgy02(k),dgy03(k), & + dgx22(k),dgx23(k),dgx33(k), & + dgy22(k),dgy23(k),dgy33(k), & + dg00(k), & + ddgxx01(k), & + ddgxx33(k), & + ddgyy01(k), & + ddgyy22(k), & + ddgxy23(k), & + ddgxy01(k), & + ddgxr02(k),ddgxr03(k), & + ddgyr02(k),ddgyr03(k), & + ddgxr22(k),ddgxr23(k),ddgxr33(k), & + ddgyr22(k),ddgyr23(k),ddgyr33(k), & + Theta22_rhs,Theta23_rhs,Theta33_rhs) + + Theta22(i,j,k+1) = Theta22(i,j,k) + Theta22_rhs*dR + Theta23(i,j,k+1) = Theta23(i,j,k) + Theta23_rhs*dR + Theta33(i,j,k+1) = Theta33(i,j,k) + Theta33_rhs*dR + +#endif + enddo + enddo + + gont = 0 + + return + +end function NullEvol_Theta2 +!--------------------------------------------------------------------------------- +subroutine Theta_rhs2(Rmin,r,g00,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01, & + Theta22,Theta23,Theta33, & + dg01,dg02,dg03, & + dgx01,dgx02,dgx03, & + dgy01,dgy02,dgy03, & + dgx22,dgx23,dgx33, & + dgy22,dgy23,dgy33, & + dg00, & + ddgxx01, & + ddgxx33, & + ddgyy01, & + ddgyy22, & + ddgxy23, & + ddgxy01, & + ddgxr02,ddgxr03, & + ddgyr02,ddgyr03, & + ddgxr22,ddgxr23,ddgxr33, & + ddgyr22,ddgyr23,ddgyr33, & + Theta22_rhs,Theta23_rhs,Theta33_rhs) + + implicit none + +!~~~~~~% Input parameters: + real*8,intent(in) :: Rmin,r,g00,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01 + real*8,intent(in) :: Theta22,Theta23,Theta33,dg01,dg02,dg03 + real*8,intent(in) :: dgx01,dgx02,dgx03,dgx22,dgx23,dgx33 + real*8,intent(in) :: dgy01,dgy02,dgy03,dgy22,dgy23,dgy33 + real*8,intent(in) :: dg00 + real*8,intent(out) :: Theta22_rhs,Theta23_rhs,Theta33_rhs + real*8,intent(in) :: ddgxx01 + real*8,intent(in) :: ddgxx33 + real*8,intent(in) :: ddgyy01 + real*8,intent(in) :: ddgyy22 + real*8,intent(in) :: ddgxy23 + real*8,intent(in) :: ddgxy01 + real*8,intent(in) :: ddgxr02,ddgxr03 + real*8,intent(in) :: ddgyr02,ddgyr03 + real*8,intent(in) :: ddgxr22,ddgxr23,ddgxr33,ddgyr22,ddgyr23,ddgyr33 + + real*8 :: t1; + real*8 :: t100; + real*8 :: t1001; + real*8 :: t1009; + real*8 :: t1010; + real*8 :: t1011; + real*8 :: t1015; + real*8 :: t1019; + real*8 :: t1023; + real*8 :: t1037; + real*8 :: t104; + real*8 :: t1041; + real*8 :: t1042; + real*8 :: t1049; + real*8 :: t1065; + real*8 :: t1070; + real*8 :: t1090; + real*8 :: t1094; + real*8 :: t1099; + real*8 :: t11; + real*8 :: t111; + real*8 :: t1113; + real*8 :: t112; + real*8 :: t1123; + real*8 :: t1126; + real*8 :: t1130; + real*8 :: t1134; + real*8 :: t1160; + real*8 :: t1173; + real*8 :: t1174; + real*8 :: t1180; + real*8 :: t12; + real*8 :: t1207; + real*8 :: t1211; + real*8 :: t1218; + real*8 :: t1222; + real*8 :: t1223; + real*8 :: t1226; + real*8 :: t1227; + real*8 :: t1230; + real*8 :: t1231; + real*8 :: t1234; + real*8 :: t1240; + real*8 :: t1242; + real*8 :: t1245; + real*8 :: t1248; + real*8 :: t125; + real*8 :: t1250; + real*8 :: t1254; + real*8 :: t1265; + real*8 :: t1272; + real*8 :: t1277; + real*8 :: t1281; + real*8 :: t1282; + real*8 :: t1287; + real*8 :: t1296; + real*8 :: t13; + real*8 :: t1301; + real*8 :: t1308; + real*8 :: t1311; + real*8 :: t1325; + real*8 :: t1326; + real*8 :: t1330; + real*8 :: t1334; + real*8 :: t1335; + real*8 :: t1338; + real*8 :: t1348; + real*8 :: t1351; + real*8 :: t1354; + real*8 :: t1386; + real*8 :: t1398; + real*8 :: t1411; + real*8 :: t142; + real*8 :: t1426; + real*8 :: t143; + real*8 :: t1432; + real*8 :: t1437; + real*8 :: t144; + real*8 :: t1441; + real*8 :: t1449; + real*8 :: t1475; + real*8 :: t148; + real*8 :: t1483; + real*8 :: t1496; + real*8 :: t1506; + real*8 :: t152; + real*8 :: t1522; + real*8 :: t1523; + real*8 :: t1526; + real*8 :: t1529; + real*8 :: t1532; + real*8 :: t1535; + real*8 :: t1536; + real*8 :: t1539; + real*8 :: t1540; + real*8 :: t1543; + real*8 :: t1547; + real*8 :: t1556; + real*8 :: t1592; + real*8 :: t1598; + real*8 :: t1601; + real*8 :: t1604; + real*8 :: t162; + real*8 :: t1629; + real*8 :: t1636; + real*8 :: t1641; + real*8 :: t1646; + real*8 :: t1647; + real*8 :: t1652; + real*8 :: t1653; + real*8 :: t1654; + real*8 :: t1668; + real*8 :: t1673; + real*8 :: t1674; + real*8 :: t1678; + real*8 :: t1682; + real*8 :: t1686; + real*8 :: t1691; + real*8 :: t1694; + real*8 :: t1695; + real*8 :: t1697; + real*8 :: t17; + real*8 :: t170; + real*8 :: t1700; + real*8 :: t1701; + real*8 :: t1703; + real*8 :: t1706; + real*8 :: t1707; + real*8 :: t1710; + real*8 :: t1711; + real*8 :: t1712; + real*8 :: t1716; + real*8 :: t1717; + real*8 :: t1718; + real*8 :: t1720; + real*8 :: t1727; + real*8 :: t1728; + real*8 :: t1731; + real*8 :: t1733; + real*8 :: t1737; + real*8 :: t1740; + real*8 :: t1744; + real*8 :: t1747; + real*8 :: t1760; + real*8 :: t1764; + real*8 :: t1768; + real*8 :: t177; + real*8 :: t1787; + real*8 :: t18; + real*8 :: t1813; + real*8 :: t1817; + real*8 :: t1820; + real*8 :: t1822; + real*8 :: t1825; + real*8 :: t1828; + real*8 :: t1833; + real*8 :: t1847; + real*8 :: t185; + real*8 :: t1873; + real*8 :: t1876; + real*8 :: t1882; + real*8 :: t1884; + real*8 :: t1887; + real*8 :: t1891; + real*8 :: t1896; + real*8 :: t1897; + real*8 :: t19; + real*8 :: t1901; + real*8 :: t1904; + real*8 :: t1906; + real*8 :: t1909; + real*8 :: t1910; + real*8 :: t1914; + real*8 :: t192; + real*8 :: t1932; + real*8 :: t1934; + real*8 :: t1935; + real*8 :: t1936; + real*8 :: t1939; + real*8 :: t1942; + real*8 :: t1943; + real*8 :: t1946; + real*8 :: t1949; + real*8 :: t197; + real*8 :: t1973; + real*8 :: t198; + real*8 :: t1982; + real*8 :: t199; + real*8 :: t1995; + real*8 :: t1998; + real*8 :: t20; + real*8 :: t201; + real*8 :: t202; + real*8 :: t2035; + real*8 :: t205; + real*8 :: t207; + real*8 :: t211; + real*8 :: t22; + real*8 :: t234; + real*8 :: t249; + real*8 :: t25; + real*8 :: t265; + real*8 :: t266; + real*8 :: t267; + real*8 :: t27; + real*8 :: t270; + real*8 :: t273; + real*8 :: t274; + real*8 :: t277; + real*8 :: t278; + real*8 :: t279; + real*8 :: t285; + real*8 :: t3; + real*8 :: t301; + real*8 :: t304; + real*8 :: t305; + real*8 :: t306; + real*8 :: t31; + real*8 :: t315; + real*8 :: t320; + real*8 :: t321; + real*8 :: t325; + real*8 :: t326; + real*8 :: t327; + real*8 :: t329; + real*8 :: t333; + real*8 :: t336; + real*8 :: t337; + real*8 :: t338; + real*8 :: t339; + real*8 :: t341; + real*8 :: t348; + real*8 :: t35; + real*8 :: t355; + real*8 :: t364; + real*8 :: t365; + real*8 :: t366; + real*8 :: t367; + real*8 :: t368; + real*8 :: t371; + real*8 :: t372; + real*8 :: t373; + real*8 :: t377; + real*8 :: t378; + real*8 :: t382; + real*8 :: t385; + real*8 :: t386; + real*8 :: t387; + real*8 :: t388; + real*8 :: t39; + real*8 :: t392; + real*8 :: t393; + real*8 :: t397; + real*8 :: t4; + real*8 :: t401; + real*8 :: t402; + real*8 :: t406; + real*8 :: t407; + real*8 :: t408; + real*8 :: t411; + real*8 :: t412; + real*8 :: t415; + real*8 :: t416; + real*8 :: t417; + real*8 :: t42; + real*8 :: t420; + real*8 :: t421; + real*8 :: t422; + real*8 :: t426; + real*8 :: t427; + real*8 :: t43; + real*8 :: t430; + real*8 :: t431; + real*8 :: t432; + real*8 :: t435; + real*8 :: t436; + real*8 :: t437; + real*8 :: t440; + real*8 :: t441; + real*8 :: t444; + real*8 :: t448; + real*8 :: t449; + real*8 :: t453; + real*8 :: t454; + real*8 :: t455; + real*8 :: t458; + real*8 :: t461; + real*8 :: t462; + real*8 :: t465; + real*8 :: t466; + real*8 :: t469; + real*8 :: t470; + real*8 :: t473; + real*8 :: t474; + real*8 :: t477; + real*8 :: t479; + real*8 :: t48; + real*8 :: t480; + real*8 :: t483; + real*8 :: t484; + real*8 :: t487; + real*8 :: t488; + real*8 :: t491; + real*8 :: t495; + real*8 :: t496; + real*8 :: t5; + real*8 :: t500; + real*8 :: t501; + real*8 :: t504; + real*8 :: t505; + real*8 :: t508; + real*8 :: t509; + real*8 :: t510; + real*8 :: t516; + real*8 :: t519; + real*8 :: t52; + real*8 :: t522; + real*8 :: t523; + real*8 :: t524; + real*8 :: t525; + real*8 :: t528; + real*8 :: t529; + real*8 :: t532; + real*8 :: t535; + real*8 :: t541; + real*8 :: t549; + real*8 :: t55; + real*8 :: t552; + real*8 :: t553; + real*8 :: t56; + real*8 :: t561; + real*8 :: t564; + real*8 :: t569; + real*8 :: t57; + real*8 :: t572; + real*8 :: t575; + real*8 :: t576; + real*8 :: t577; + real*8 :: t579; + real*8 :: t582; + real*8 :: t586; + real*8 :: t589; + real*8 :: t590; + real*8 :: t591; + real*8 :: t594; + real*8 :: t595; + real*8 :: t6; + real*8 :: t605; + real*8 :: t61; + real*8 :: t610; + real*8 :: t611; + real*8 :: t618; + real*8 :: t622; + real*8 :: t623; + real*8 :: t624; + real*8 :: t627; + real*8 :: t631; + real*8 :: t634; + real*8 :: t638; + real*8 :: t639; + real*8 :: t640; + real*8 :: t643; + real*8 :: t644; + real*8 :: t645; + real*8 :: t648; + real*8 :: t649; + real*8 :: t658; + real*8 :: t659; + real*8 :: t660; + real*8 :: t663; + real*8 :: t664; + real*8 :: t668; + real*8 :: t671; + real*8 :: t686; + real*8 :: t7; + real*8 :: t70; + real*8 :: t706; + real*8 :: t710; + real*8 :: t713; + real*8 :: t717; + real*8 :: t723; + real*8 :: t725; + real*8 :: t728; + real*8 :: t731; + real*8 :: t733; + real*8 :: t738; + real*8 :: t741; + real*8 :: t742; + real*8 :: t746; + real*8 :: t749; + real*8 :: t750; + real*8 :: t751; + real*8 :: t754; + real*8 :: t755; + real*8 :: t758; + real*8 :: t77; + real*8 :: t775; + real*8 :: t780; + real*8 :: t782; + real*8 :: t783; + real*8 :: t786; + real*8 :: t787; + real*8 :: t788; + real*8 :: t792; + real*8 :: t796; + real*8 :: t799; + real*8 :: t800; + real*8 :: t804; + real*8 :: t811; + real*8 :: t812; + real*8 :: t822; + real*8 :: t831; + real*8 :: t832; + real*8 :: t835; + real*8 :: t836; + real*8 :: t837; + real*8 :: t84; + real*8 :: t850; + real*8 :: t855; + real*8 :: t856; + real*8 :: t857; + real*8 :: t860; + real*8 :: t862; + real*8 :: t865; + real*8 :: t871; + real*8 :: t876; + real*8 :: t88; + real*8 :: t880; + real*8 :: t884; + real*8 :: t888; + real*8 :: t889; + real*8 :: t892; + real*8 :: t895; + real*8 :: t898; + real*8 :: t901; + real*8 :: t904; + real*8 :: t92; + real*8 :: t922; + real*8 :: t925; + real*8 :: t928; + real*8 :: t929; + real*8 :: t93; + real*8 :: t932; + real*8 :: t935; + real*8 :: t938; + real*8 :: t956; + real*8 :: t959; + real*8 :: t960; + real*8 :: t963; + real*8 :: t970; + real*8 :: t975; + real*8 :: t979; + real*8 :: t980; + real*8 :: t983; + real*8 :: t985; + real*8 :: t991; + real*8 :: t996; + + real*8 :: t10; + real*8 :: t1006; + real*8 :: t1007; + real*8 :: t1012; + real*8 :: t1030; + real*8 :: t1039; + real*8 :: t1044; + real*8 :: t1067; + real*8 :: t1084; + real*8 :: t1092; + real*8 :: t1100; + real*8 :: t1112; + real*8 :: t1117; + real*8 :: t1121; + real*8 :: t1122; + real*8 :: t1127; + real*8 :: t1131; + real*8 :: t1133; + real*8 :: t1138; + real*8 :: t1141; + real*8 :: t1142; + real*8 :: t1143; + real*8 :: t1144; + real*8 :: t1148; + real*8 :: t1166; + real*8 :: t1177; + real*8 :: t1181; + real*8 :: t1191; + real*8 :: t120; + real*8 :: t1203; + real*8 :: t1204; + real*8 :: t121; + real*8 :: t1212; + real*8 :: t1235; + real*8 :: t1239; + real*8 :: t124; + real*8 :: t1249; + real*8 :: t1252; + real*8 :: t1253; + real*8 :: t1256; + real*8 :: t128; + real*8 :: t1289; + real*8 :: t129; + real*8 :: t1291; + real*8 :: t1293; + real*8 :: t130; + real*8 :: t131; + real*8 :: t1313; + real*8 :: t1314; + real*8 :: t1317; + real*8 :: t132; + real*8 :: t1320; + real*8 :: t1322; + real*8 :: t133; + real*8 :: t1331; + real*8 :: t1332; + real*8 :: t1342; + real*8 :: t1355; + real*8 :: t1357; + real*8 :: t1359; + real*8 :: t136; + real*8 :: t1362; + real*8 :: t1366; + real*8 :: t137; + real*8 :: t1374; + real*8 :: t1379; + real*8 :: t138; + real*8 :: t1380; + real*8 :: t1381; + real*8 :: t1384; + real*8 :: t1385; + real*8 :: t1388; + real*8 :: t139; + real*8 :: t1391; + real*8 :: t1392; + real*8 :: t140; + real*8 :: t1405; + real*8 :: t1406; + real*8 :: t1409; + real*8 :: t1410; + real*8 :: t1413; + real*8 :: t1416; + real*8 :: t1417; + real*8 :: t1419; + real*8 :: t1421; + real*8 :: t1428; + real*8 :: t1434; + real*8 :: t1440; + real*8 :: t1444; + real*8 :: t145; + real*8 :: t1450; + real*8 :: t1454; + real*8 :: t1457; + real*8 :: t1473; + real*8 :: t1476; + real*8 :: t1488; + real*8 :: t1490; + real*8 :: t1501; + real*8 :: t1505; + real*8 :: t1510; + real*8 :: t1516; + real*8 :: t1577; + real*8 :: t1612; + real*8 :: t1615; + real*8 :: t1619; + real*8 :: t1624; + real*8 :: t1625; + real*8 :: t163; + real*8 :: t1634; + real*8 :: t1640; + real*8 :: t1644; + real*8 :: t1648; + real*8 :: t1651; + real*8 :: t1655; + real*8 :: t1660; + real*8 :: t1663; + real*8 :: t1664; + real*8 :: t168; + real*8 :: t1689; + real*8 :: t169; + real*8 :: t1690; + real*8 :: t1693; + real*8 :: t1696; + real*8 :: t1708; + real*8 :: t171; + real*8 :: t1724; + real*8 :: t174; + real*8 :: t1741; + real*8 :: t175; + real*8 :: t1752; + real*8 :: t176; + real*8 :: t1775; + real*8 :: t1783; + real*8 :: t1788; + real*8 :: t1791; + real*8 :: t1795; + real*8 :: t181; + real*8 :: t1823; + real*8 :: t1824; + real*8 :: t183; + real*8 :: t1836; + real*8 :: t1842; + real*8 :: t1852; + real*8 :: t1856; + real*8 :: t1859; + real*8 :: t186; + real*8 :: t1863; + real*8 :: t187; + real*8 :: t1875; + real*8 :: t1878; + real*8 :: t1883; + real*8 :: t189; + real*8 :: t1890; + real*8 :: t191; + real*8 :: t1918; + real*8 :: t1921; + real*8 :: t1927; + real*8 :: t1931; + real*8 :: t194; + real*8 :: t1952; + real*8 :: t196; + real*8 :: t1970; + real*8 :: t200; + real*8 :: t2003; + real*8 :: t2004; + real*8 :: t2008; + real*8 :: t2017; + real*8 :: t2024; + real*8 :: t2032; + real*8 :: t204; + real*8 :: t206; + real*8 :: t2065; + real*8 :: t208; + real*8 :: t2085; + real*8 :: t209; + real*8 :: t2091; + real*8 :: t2093; + real*8 :: t21; + real*8 :: t212; + real*8 :: t2122; + real*8 :: t213; + real*8 :: t2133; + real*8 :: t2138; + real*8 :: t214; + real*8 :: t215; + real*8 :: t2166; + real*8 :: t219; + real*8 :: t2192; + real*8 :: t2201; + real*8 :: t222; + real*8 :: t226; + real*8 :: t23; + real*8 :: t233; + real*8 :: t236; + real*8 :: t237; + real*8 :: t238; + real*8 :: t239; + real*8 :: t24; + real*8 :: t247; + real*8 :: t248; + real*8 :: t251; + real*8 :: t252; + real*8 :: t255; + real*8 :: t258; + real*8 :: t259; + real*8 :: t268; + real*8 :: t28; + real*8 :: t282; + real*8 :: t283; + real*8 :: t287; + real*8 :: t29; + real*8 :: t290; + real*8 :: t293; + real*8 :: t296; + real*8 :: t297; + real*8 :: t298; + real*8 :: t302; + real*8 :: t310; + real*8 :: t311; + real*8 :: t316; + real*8 :: t317; + real*8 :: t32; + real*8 :: t322; + real*8 :: t323; + real*8 :: t324; + real*8 :: t33; + real*8 :: t330; + real*8 :: t34; + real*8 :: t344; + real*8 :: t376; + real*8 :: t384; + real*8 :: t389; + real*8 :: t394; + real*8 :: t399; + real*8 :: t40; + real*8 :: t404; + real*8 :: t41; + real*8 :: t419; + real*8 :: t438; + real*8 :: t439; + real*8 :: t443; + real*8 :: t445; + real*8 :: t450; + real*8 :: t451; + real*8 :: t459; + real*8 :: t46; + real*8 :: t460; + real*8 :: t463; + real*8 :: t464; + real*8 :: t47; + real*8 :: t478; + real*8 :: t482; + real*8 :: t49; + real*8 :: t492; + real*8 :: t50; + real*8 :: t503; + real*8 :: t507; + real*8 :: t511; + real*8 :: t514; + real*8 :: t515; + real*8 :: t517; + real*8 :: t518; + real*8 :: t520; + real*8 :: t533; + real*8 :: t537; + real*8 :: t538; + real*8 :: t54; + real*8 :: t544; + real*8 :: t545; + real*8 :: t548; + real*8 :: t551; + real*8 :: t555; + real*8 :: t556; + real*8 :: t560; + real*8 :: t563; + real*8 :: t566; + real*8 :: t574; + real*8 :: t59; + real*8 :: t597; + real*8 :: t599; + real*8 :: t600; + real*8 :: t603; + real*8 :: t606; + real*8 :: t609; + real*8 :: t614; + real*8 :: t616; + real*8 :: t617; + real*8 :: t620; + real*8 :: t621; + real*8 :: t625; + real*8 :: t63; + real*8 :: t64; + real*8 :: t646; + real*8 :: t655; + real*8 :: t662; + real*8 :: t667; + real*8 :: t672; + real*8 :: t676; + real*8 :: t677; + real*8 :: t68; + real*8 :: t680; + real*8 :: t683; + real*8 :: t696; + real*8 :: t72; + real*8 :: t739; + real*8 :: t740; + real*8 :: t743; + real*8 :: t744; + real*8 :: t745; + real*8 :: t748; + real*8 :: t752; + real*8 :: t756; + real*8 :: t76; + real*8 :: t766; + real*8 :: t769; + real*8 :: t770; + real*8 :: t771; + real*8 :: t774; + real*8 :: t778; + real*8 :: t785; + real*8 :: t789; + real*8 :: t793; + real*8 :: t798; + real*8 :: t8; + real*8 :: t801; + real*8 :: t803; + real*8 :: t806; + real*8 :: t808; + real*8 :: t813; + real*8 :: t816; + real*8 :: t817; + real*8 :: t818; + real*8 :: t823; + real*8 :: t824; + real*8 :: t838; + real*8 :: t842; + real*8 :: t843; + real*8 :: t844; + real*8 :: t849; + real*8 :: t868; + real*8 :: t873; + real*8 :: t874; + real*8 :: t877; + real*8 :: t878; + real*8 :: t881; + real*8 :: t882; + real*8 :: t885; + real*8 :: t89; + real*8 :: t9; + real*8 :: t900; + real*8 :: t902; + real*8 :: t913; + real*8 :: t915; + real*8 :: t919; + real*8 :: t921; + real*8 :: t923; + real*8 :: t941; + real*8 :: t944; + real*8 :: t946; + real*8 :: t949; + real*8 :: t953; + real*8 :: t958; + real*8 :: t96; + real*8 :: t968; + real*8 :: t969; + real*8 :: t973; + real*8 :: t978; + real*8 :: t990; + real*8 :: t995; + real*8 :: t998; + + real*8 :: t1004; + real*8 :: t1005; + real*8 :: t1008; + real*8 :: t1020; + real*8 :: t103; + real*8 :: t105; + real*8 :: t1051; + real*8 :: t1057; + real*8 :: t1064; + real*8 :: t107; + real*8 :: t1072; + real*8 :: t1077; + real*8 :: t108; + real*8 :: t1086; + real*8 :: t1111; + real*8 :: t1115; + real*8 :: t1119; + real*8 :: t1125; + real*8 :: t1128; + real*8 :: t113; + real*8 :: t1136; + real*8 :: t1139; + real*8 :: t1146; + real*8 :: t1149; + real*8 :: t1151; + real*8 :: t1154; + real*8 :: t1158; + real*8 :: t1164; + real*8 :: t1168; + real*8 :: t117; + real*8 :: t1175; + real*8 :: t1185; + real*8 :: t1186; + real*8 :: t1208; + real*8 :: t1216; + real*8 :: t1232; + real*8 :: t1276; + real*8 :: t1284; + real*8 :: t1286; + real*8 :: t1290; + real*8 :: t1295; + real*8 :: t1298; + real*8 :: t1299; + real*8 :: t1302; + real*8 :: t1305; + real*8 :: t1309; + real*8 :: t1323; + real*8 :: t1324; + real*8 :: t1328; + real*8 :: t1333; + real*8 :: t1336; + real*8 :: t1337; + real*8 :: t1340; + real*8 :: t1341; + real*8 :: t1344; + real*8 :: t1365; + real*8 :: t1382; + real*8 :: t1389; + real*8 :: t1390; + real*8 :: t1393; + real*8 :: t1396; + real*8 :: t1397; + real*8 :: t14; + real*8 :: t1400; + real*8 :: t1401; + real*8 :: t1404; + real*8 :: t1408; + real*8 :: t1412; + real*8 :: t1415; + real*8 :: t1418; + real*8 :: t1424; + real*8 :: t1427; + real*8 :: t1430; + real*8 :: t1436; + real*8 :: t1439; + real*8 :: t1442; + real*8 :: t1445; + real*8 :: t1448; + real*8 :: t1453; + real*8 :: t1456; + real*8 :: t1471; + real*8 :: t1477; + real*8 :: t1481; + real*8 :: t1485; + real*8 :: t1487; + real*8 :: t1493; + real*8 :: t15; + real*8 :: t1500; + real*8 :: t1504; + real*8 :: t1507; + real*8 :: t1509; + real*8 :: t151; + real*8 :: t1513; + real*8 :: t1517; + real*8 :: t1521; + real*8 :: t1527; + real*8 :: t1541; + real*8 :: t1550; + real*8 :: t1553; + real*8 :: t1557; + real*8 :: t1558; + real*8 :: t1578; + real*8 :: t1579; + real*8 :: t158; + real*8 :: t1582; + real*8 :: t1583; + real*8 :: t1587; + real*8 :: t1595; + real*8 :: t1600; + real*8 :: t1603; + real*8 :: t1608; + real*8 :: t161; + real*8 :: t1620; + real*8 :: t1626; + real*8 :: t165; + real*8 :: t1656; + real*8 :: t1661; + real*8 :: t1662; + real*8 :: t1665; + real*8 :: t1666; + real*8 :: t1677; + real*8 :: t1681; + real*8 :: t1685; + real*8 :: t1692; + real*8 :: t1721; + real*8 :: t1722; + real*8 :: t1726; + real*8 :: t173; + real*8 :: t1730; + real*8 :: t1743; + real*8 :: t1745; + real*8 :: t1756; + real*8 :: t1761; + real*8 :: t1780; + real*8 :: t1807; + real*8 :: t1812; + real*8 :: t1845; + real*8 :: t1846; + real*8 :: t1854; + real*8 :: t1855; + real*8 :: t1860; + real*8 :: t1864; + real*8 :: t1869; + real*8 :: t188; + real*8 :: t1888; + real*8 :: t1894; + real*8 :: t1944; + real*8 :: t195; + real*8 :: t1956; + real*8 :: t1988; + real*8 :: t1997; + real*8 :: t2038; + real*8 :: t225; + real*8 :: t227; + real*8 :: t228; + real*8 :: t230; + real*8 :: t235; + real*8 :: t240; + real*8 :: t241; + real*8 :: t243; + real*8 :: t246; + real*8 :: t250; + real*8 :: t253; + real*8 :: t254; + real*8 :: t256; + real*8 :: t257; + real*8 :: t260; + real*8 :: t261; + real*8 :: t262; + real*8 :: t263; + real*8 :: t276; + real*8 :: t280; + real*8 :: t284; + real*8 :: t288; + real*8 :: t291; + real*8 :: t292; + real*8 :: t294; + real*8 :: t295; + real*8 :: t299; + real*8 :: t307; + real*8 :: t308; + real*8 :: t312; + real*8 :: t314; + real*8 :: t319; + real*8 :: t328; + real*8 :: t331; + real*8 :: t334; + real*8 :: t345; + real*8 :: t347; + real*8 :: t349; + real*8 :: t352; + real*8 :: t353; + real*8 :: t356; + real*8 :: t357; + real*8 :: t358; + real*8 :: t36; + real*8 :: t363; + real*8 :: t369; + real*8 :: t381; + real*8 :: t403; + real*8 :: t405; + real*8 :: t409; + real*8 :: t410; + real*8 :: t428; + real*8 :: t433; + real*8 :: t442; + real*8 :: t45; + real*8 :: t456; + real*8 :: t481; + real*8 :: t539; + real*8 :: t540; + real*8 :: t570; + real*8 :: t58; + real*8 :: t613; + real*8 :: t615; + real*8 :: t619; + real*8 :: t629; + real*8 :: t630; + real*8 :: t633; + real*8 :: t656; + real*8 :: t669; + real*8 :: t682; + real*8 :: t685; + real*8 :: t732; + real*8 :: t737; + real*8 :: t747; + real*8 :: t764; + real*8 :: t765; + real*8 :: t772; + real*8 :: t776; + real*8 :: t78; + real*8 :: t781; + real*8 :: t79; + real*8 :: t790; + real*8 :: t807; + real*8 :: t809; + real*8 :: t819; + real*8 :: t820; + real*8 :: t821; + real*8 :: t825; + real*8 :: t826; + real*8 :: t829; + real*8 :: t83; + real*8 :: t830; + real*8 :: t833; + real*8 :: t851; + real*8 :: t853; + real*8 :: t859; + real*8 :: t864; + real*8 :: t869; + real*8 :: t87; + real*8 :: t872; + real*8 :: t875; + real*8 :: t883; + real*8 :: t886; + real*8 :: t887; + real*8 :: t891; + real*8 :: t896; + real*8 :: t910; + real*8 :: t911; + real*8 :: t924; + real*8 :: t937; + real*8 :: t940; + real*8 :: t95; + real*8 :: t952; + real*8 :: t961; + real*8 :: t971; + real*8 :: t981; + real*8 :: t988; + real*8 :: t994; + real*8 :: t997; + real*8 :: t999; + + t1 = g01*g01; + t3 = g22*g22; + t4 = g01*t3; + t5 = g33*g33; + t6 = dgx01*dgx01; + t7 = t5*t6; + t11 = g01*g22; + t12 = g23*g23; + t13 = g33*t12; + t17 = t12*t12; + t18 = t1*t17; + t19 = r*r; + t20 = t19*t19; + t22 = ddgxr02*t20*Rmin; + t25 = t19*r; + t27 = ddgxr02*t25*Rmin; + t31 = ddgxr02*t19*Rmin; + t35 = Theta22*t19*Rmin; + t39 = dgx02*t19*Rmin; + t42 = t1*t3; + t43 = t5*ddgxx01; + t48 = Theta22*r*Rmin; + t52 = dgx02*r*Rmin; + t55 = t1*g01; + t56 = t3*t55; + t57 = dgy33*dgx23; + t61 = dgy33*dgy22; + t70 = g33*ddgxy23; + t77 = g33*ddgyy22; + t84 = g33*ddgxx33; + t88 = -4.0*t4*t7*r-4.0*t11*t13*t6+4.0*t18*t22-8.0*t18*t27+4.0*t18*t31+4.0*t18*t35 & + -8.0*t18*t39-4.0*t42*t43*t19-4.0*t18*t48+8.0*t18*t52-2.0*t56*t57*t19 & + +t56*t61*t19+4.0*t56*t57*r-2.0*t56*t61*r+4.0*t56*t70*t19-8.0*t56*t70*r & + -2.0*t56*t77*t19+4.0*t56*t77*r-2.0*t56*t84*t19; + t92 = g22*t55; + t93 = t12*ddgxy23; + t100 = t12*ddgyy22; + t104 = t12*ddgxx33; + t111 = dgy22*dgy22; + t112 = g33*t111; + t125 = g23*dgx33; + t142 = t12*g23; + t143 = t1*t142; + t144 = dgx01*dgx23; + t148 = dgx01*dgy22; + t152 = dgy01*dgx22; + t162 = 4.0*t56*t84*r-4.0*t92*t93*t19+8.0*t92*t93*r-4.0*t92*t100*r+2.0*t92*t104*t19 & + -4.0*t92*t104*r+t92*t112*t19-2.0*t92*t112*r+t92*g33*dgx33*dgx22-2.0*t92*g33*dgy23*dgx22 & + -t92*t125*dgy22+t92*g23*dgy33*dgx22-2.0*t92*t125*dgx23+4.0*t92*g23*dgx23*dgy23 & + -2.0*t92*g23*dgy23*dgy22+4.0*t143*t144*t19-2.0*t143*t148*t19+2.0*t143*t152*t19+8.0*t42*t43*r-8.0*t143*t144*r; + t170 = g33*dgy01; + t177 = t1*g22; + t185 = t12*dgy01; + t192 = t1*g33; + t197 = g01*t17; + t198 = dg02*dg02; + t199 = t20*t19; + t201 = Rmin*Rmin; + t202 = t198*t199*t201; + t205 = t20*r; + t207 = t198*t205*t201; + t211 = t198*t20*t201; + t234 = 4.0*t143*t148*r-4.0*t143*t152*r+4.0*t42*t170*dgx23-2.0*t42*t170*dgy22 & + +2.0*t177*t5*dgx01*dgx22+8.0*t177*t13*ddgxx01-4.0*t177*t185*dgx23+2.0*t177*t185*dgy22 & + -2.0*t192*t12*dgx01*dgx22-2.0*t197*t202+4.0*t197*t207-2.0*t197*t211+2.0*t4*t7*t19 & + +2.0*t92*t100*t19-4.0*t18*ddgxx01*t19+8.0*t18*ddgxx01*r & + -4.0*t42*t43+4.0*t143*t144-2.0*t143*t148+2.0*t143*t152; + t249 = dgx33*dgx33; + t265 = t201*t20; + t266 = t265*t11; + t267 = g03*dg33; + t270 = t267*dg22*g23*g02; + t273 = t201*t199; + t274 = t273*t11; + t277 = g33*g23; + t278 = t11*t277; + t279 = g02*dg02; + t285 = g02*dg22; + t301 = 2.0*t197*t6*t19-4.0*t197*t6*r+2.0*t4*t7+4.0*t56*t70-2.0*t56*t77-2.0*t56*t84+t56*t249*t19 & + -2.0*t56*t249*r-2.0*t56*t57+t56*t61-4.0*t92*t93+2.0*t92*t100+2.0*t92*t104+t92*t112-2.0*t266*t270 & + -2.0*t274*t270-4.0*t278*t279*dg23*t199*t201+4.0*t278*t285*dg03*t199*t201 & + +8.0*t278*t279*dg23*t205*t201-8.0*t278*t285*dg03*t205*t201; + t304 = g02*g03; + t305 = dg22*t20; + t306 = t305*t201; + t315 = dg03*t20; + t320 = dg22*t25; + t321 = t320*t201; + t325 = t205*t201; + t326 = t325*t11; + t327 = g00*dg23; + t329 = t277*t327*dg22; + t333 = t277*t304*ddg22; + t336 = g22*g33; + t337 = t325*t336; + t338 = g23*g02; + t339 = g03*dg01; + t341 = t338*t339*dg22; + t348 = t265*t336; + t355 = t273*t336; + t364 = t273*g22; + t365 = g02*g02; + t366 = t5*t365; + t367 = dg01*dg22; + t368 = t366*t367; + t371 = g03*g03; + t372 = t12*t371; + t373 = t372*t367; + t377 = t12*t365; + t378 = t377*t367; + t382 = t304*t367; + t385 = -20.0*t278*t304*t306-4.0*t278*t279*dg23*t20*t201+4.0*t278*t285*t315*t201+12.0*t278*t304*t321 & + -4.0*t326*t329-8.0*t326*t333+8.0*t337*t341+2.0*t266*t329+4.0*t266*t333-4.0*t348*t341+2.0*t274*t329+4.0*t274*t333 & + -4.0*t355*t341+8.0*t326*t277*t304*dg22+4.0*t326*t270+2.0*t364*t368-2.0*t364*t373-2.0*t273*g33*t378+4.0*t273*t142*t382; + t386 = t177*g33; + t387 = t12*dgx02; + t388 = r*Rmin; + t392 = g23*dgx01; + t393 = dgx23*t19; + t397 = dgy22*t19; + t401 = g23*dgy01; + t402 = dgx22*t19; + t406 = t177*t12; + t407 = g03*dgx23; + t408 = t407*t388; + t411 = g03*dgy22; + t412 = t411*t388; + t415 = t192*t12; + t416 = g02*dgx22; + t417 = t416*t388; + t420 = t4*g33; + t421 = t12*dg00; + t422 = t25*t201; + t426 = t371*dg22; + t427 = t426*t422; + t430 = t4*t12; + t431 = g03*dg03; + t432 = t431*t422; + t435 = t11*t142; + t436 = g02*dg03; + t437 = t436*t422; + t440 = g03*dg02; + t441 = t440*t422; + t444 = t11*t12; + t448 = g01*t142*g02; + t449 = g03*dg22; + t453 = t42*g33; + t454 = t19*Rmin; + t455 = t407*t454; + t458 = t411*t454; + t461 = Theta23*dg23; + t462 = t461*t454; + t465 = dg23*dgy02; + t466 = t465*t454; + t469 = dgx23*dg03; + t470 = t469*t454; + t473 = dgy22*dg03; + t474 = t473*t454; + t477 = -20.0*t386*t387*t388-4.0*t386*t392*t393+2.0*t386*t392*t397-2.0*t386*t401*t402+8.0*t406*t408 & + -8.0*t406*t412+4.0*t415*t417-8.0*t420*t421*t422-10.0*t420*t427 & + +8.0*t430*t432-8.0*t435*t437-8.0*t435*t441+12.0*t444*t427 & + -16.0*t448*t449*t422+12.0*t453*t455-6.0*t453*t458+4.0*t453*t462-4.0*t453*t466-4.0*t453*t470+2.0*t453*t474; + t479 = t177*t5; + t480 = t416*t454; + t483 = dg02*dgx22; + t484 = t483*t454; + t487 = Theta22*dg22; + t488 = t487*t454; + t491 = t12*ddgxr02; + t495 = t11*g33; + t496 = t12*t198; + t500 = dg02*dg23; + t501 = t500*t273; + t504 = dg22*dg03; + t505 = t504*t273; + t508 = t4*t5; + t509 = dg00*dg22; + t510 = t509*t325; + t516 = t500*t325; + t519 = t504*t325; + t522 = t3*g22; + t523 = g01*t522; + t524 = t523*g33; + t525 = t431*t265; + t528 = g00*dg22; + t529 = t528*t265; + t532 = t279*t265; + t535 = t509*t265; + t541 = t426*t265; + t549 = t436*t265; + t552 = 6.0*t479*t480-2.0*t479*t484+2.0*t479*t488-8.0*t386*t491*t454+4.0*t495*t496*t273+4.0*t448*t501 & + -4.0*t448*t505-4.0*t508*t510-8.0*t495*t496*t325-8.0*t448*t516+8.0*t448*t519+8.0*t524*t525-14.0*t508*t529 & + +8.0*t508*t532+2.0*t508*t535+8.0*t420*t421*t265+14.0*t420*t541-8.0*t430*t525+4.0*t495*t496*t265+8.0*t435*t549; + t553 = t440*t265; + t561 = t500*t265; + t564 = t504*t265; + t569 = t528*t422; + t572 = t279*t422; + t575 = Rmin*t25; + t576 = t575*t1; + t577 = t3*g33; + t579 = t577*ddgxr23*g03; + t582 = t454*t1; + t586 = t12*dgx33*t285; + t589 = t12*dg23; + t590 = dgx23*g02; + t591 = t589*t590; + t594 = dgy22*g02; + t595 = t589*t594; + t605 = t12*dg33*t416; + t610 = t325*g01; + t611 = t3*t5; + t618 = 8.0*t435*t553-16.0*t444*t541+24.0*t448*t449*t265+4.0*t448*t561-4.0*t448*t564-8.0*t524*t432 & + +10.0*t508*t569-8.0*t508*t572+8.0*t576*t579-4.0*t582*t579+4.0*t576*t586 & + -8.0*t576*t591+8.0*t576*t595-2.0*t582*t586+4.0*t582*t591 & + -4.0*t582*t595-4.0*t576*t605+2.0*t582*t605+4.0*t610*t611*t528-4.0*t610*t577*t426; + t622 = g22*t5; + t623 = t365*dg22; + t624 = t622*t623; + t627 = g22*t12; + t631 = t13*t623; + t634 = t142*g02; + t638 = t273*g01; + t639 = g00*ddg22; + t640 = t611*t639; + t643 = dg23*dg23; + t644 = g00*t643; + t645 = t577*t644; + t648 = t371*ddg22; + t649 = t577*t648; + t658 = dg22*dg22; + t659 = g00*t658; + t660 = t622*t659; + t663 = t365*ddg22; + t664 = t622*t663; + t668 = t336*t365*t643; + t671 = t12*Theta22; + t686 = -4.0*t610*t624+4.0*t610*t627*t426+4.0*t610*t631-8.0*t610*t634*t449+2.0*t638*t640-2.0*t638*t645-2.0*t638*t649 & + -4.0*t610*t640+4.0*t610*t645+4.0*t610*t649+2.0*t610*t660+4.0*t610*t664 & + -4.0*t610*t668-10.0*t386*t671*t454+20.0*t386*t387*t454 & + -8.0*t406*t455+8.0*t406*t458-4.0*t406*t462+4.0*t406*t466; + t706 = t19*t201; + t710 = t304*t706; + t713 = t12*g00; + t717 = t265*g01; + t723 = t336*t371*t658; + t725 = t627*t644; + t728 = t627*t648; + t731 = t13*t659; + t733 = t13*t663; + t738 = 4.0*t406*t470-2.0*t406*t474-4.0*t415*t480+2.0*t415*t484-2.0*t415*t488-12.0*t453*t408+6.0*t453*t412 & + -6.0*t479*t417+10.0*t386*t671*t388+12.0*t495*t377*t706 & + -24.0*t435*t710-24.0*t420*t713*t706+10.0*t717*t624+2.0*t717*t668 & + +t717*t723+2.0*t717*t725+2.0*t717*t728+t717*t731+2.0*t717*t733-12.0*t717*t631; + t741 = dg23*dg22; + t742 = t142*g00*t741; + t746 = t634*g03*ddg22; + t749 = t265*t3; + t750 = t5*g00; + t751 = t750*t367; + t754 = g33*t371; + t755 = t754*t367; + t758 = t265*g22; + t775 = t273*t3; + t780 = t4*t25; + t782 = g00*dg33; + t783 = t201*t12*t782; + t786 = t177*Rmin; + t787 = t19*t12; + t788 = g02*dgx33; + t792 = r*t12; + t796 = dg33*Theta22; + t799 = t20*t12; + t800 = dg33*dgx02; + t804 = t25*t12; + t811 = -2.0*t717*t742-4.0*t717*t746-2.0*t749*t751+2.0*t749*t755+2.0*t758*t368-2.0*t758*t373 & + -2.0*t265*g33*t378+4.0*t265*t142*t382+2.0*t638*t733-2.0*t638*t742 & + -4.0*t638*t746-2.0*t775*t751+2.0*t775*t755-2.0*t780*t783+4.0*t786*t787*t788 & + -4.0*t786*t792*t788+t786*t787*t796-2.0*t786*t799*t800+4.0*t786*t804*t800-2.0*t786*t787*t800; + t812 = dg22*dgy03; + t822 = Theta33*dg22; + t831 = t201*g33; + t832 = t831*t782; + t835 = t4*t20; + t836 = t365*dg33; + t837 = t831*t836; + t850 = t422*g01; + t855 = t422*t3; + t856 = g00*dg01; + t857 = t13*t856; + t860 = t422*g22; + t862 = t13*t365*dg01; + t865 = t634*t339; + t871 = -2.0*t786*t799*t812+4.0*t786*t804*t812-2.0*t786*t787*t812+t786*t799*t822-2.0*t786*t804*t822+t786*t787*t822 & + -2.0*t523*t20*t832+2.0*t835*t837+2.0*t835*t783-2.0*t610*t723-4.0*t610*t725-4.0*t610*t728-2.0*t610*t731-6.0*t850*t624 & + +8.0*t850*t631+8.0*t855*t857-4.0*t860*t862+8.0*t860*t865-t638*t660-2.0*t638*t664; + t876 = dgx23*r; + t880 = dgy22*r; + t884 = dgx22*r; + t888 = t20*Rmin; + t889 = t461*t888; + t892 = t465*t888; + t895 = t469*t888; + t898 = t473*t888; + t901 = t483*t888; + t904 = t487*t888; + t922 = t461*t575; + t925 = t465*t575; + t928 = 2.0*t638*t668+8.0*t386*t392*t876-4.0*t386*t392*t880+4.0*t386*t401*t884+4.0*t453*t889-4.0*t453*t892 & + -4.0*t453*t895+2.0*t453*t898-2.0*t479*t901+2.0*t479*t904 & + -8.0*t386*t491*t888-4.0*t406*t889+4.0*t406*t892+4.0*t406*t895 & + -2.0*t406*t898+2.0*t415*t901-2.0*t415*t904-8.0*t453*t922+8.0*t453*t925; + t929 = t469*t575; + t932 = t473*t575; + t935 = t483*t575; + t938 = t487*t575; + t956 = t509*t273; + t959 = t3*dg33; + t960 = t959*t407; + t963 = t959*t411; + t970 = t577*ddgyr22*g03; + t975 = t888*t1; + t979 = dg33*dg22; + t980 = t3*t371*t979; + t983 = 8.0*t453*t929-4.0*t453*t932+4.0*t479*t935-4.0*t479*t938+16.0*t386*t491*t575+8.0*t406*t922-8.0*t406*t925 & + -8.0*t406*t929+4.0*t406*t932-4.0*t415*t935+4.0*t415*t938+2.0*t508*t956-4.0*t576*t960+2.0*t576*t963+2.0*t582*t960 & + -t582*t963-8.0*t576*t970+4.0*t582*t970+2.0*t975*t605-2.0*t610*t980; + t985 = t377*t979; + t991 = t627*t836; + t996 = t3*g23*t371*dg23; + t1001 = t201*t142*t327; + t1009 = t42*Rmin; + t1010 = r*g23; + t1011 = g02*dgy33; + t1015 = t20*g33; + t1019 = t25*g33; + t1023 = t19*g33; + t1037 = g02*dgy23; + t1041 = t19*g23; + t1042 = g03*dgx33; + t1049 = -4.0*t610*t985+t717*t980+2.0*t717*t985+4.0*t850*t991-4.0*t850*t996+4.0*t11*t25*t1001+t786*t799*t796 & + -2.0*t786*t804*t796+2.0*t1009*t1010*t1011+2.0*t1009*t1015*t812 & + -4.0*t1009*t1019*t812+2.0*t1009*t1023*t812-t1009*t1015*t822 & + +2.0*t1009*t1019*t822-t1009*t1023*t822-2.0*t1009*t1023*t788 & + +4.0*t1009*t1023*t1037-2.0*t1009*t1041*t1042+t638*t723+2.0*t638*t725; + t1065 = t325*t3; + t1070 = t325*g22; + t1090 = g03*dgy23; + t1094 = 2.0*t638*t728+t638*t731-8.0*t749*t857+4.0*t758*t862-8.0*t758*t865-4.0*t610*t733 & + +4.0*t610*t742+8.0*t610*t746+4.0*t1065*t751 & + -4.0*t1065*t755-4.0*t1070*t368+4.0*t1070*t373+4.0*t325*g33*t378 & + -8.0*t325*t142*t382+2.0*t717*t640-2.0*t717*t645-2.0*t717*t649 & + -t717*t660-2.0*t717*t664-4.0*t1009*t1041*t1090; + t1099 = r*g33; + t1113 = dgy33*dg22; + t1123 = t19*g03; + t1126 = g23*Theta23; + t1130 = g23*dgx03; + t1134 = g23*dgy02; + t1160 = 2.0*t1009*t1099*t788-4.0*t1009*t1099*t1037+2.0*t1009*t1010*t1042 & + +4.0*t1009*t1010*t1090-t1009*t20*g03*t1113+2.0*t1009*t25*g03*t1113 & + -2.0*t1009*t1041*t1011-t1009*t1123*t1113-4.0*t1009*t1023*t1126+4.0*t1009*t1023*t1130+4.0*t1009*t1023*t1134 & + +2.0*t1009*t1019*t796-t1009*t1023*t796+2.0*t1009*t1015*t800 & + -4.0*t1009*t1019*t800+2.0*t1009*t1023*t800-t1009*t1015*t796+4.0*t1009*t1099*t1126-4.0*t1009*t1099*t1130; + t1173 = g22*g03; + t1174 = t12*ddgyr22*t1173; + t1180 = t12*ddgxr23*t1173; + t1207 = -4.0*t1009*t1099*t1134+2.0*t523*t25*t832-2.0*t780*t837-4.0*t11*t20*t1001 & + +8.0*t576*t1174-4.0*t582*t1174-8.0*t576*t1180+4.0*t582*t1180-4.0*t975*t1174+4.0*t975*t1180+t638*t980 & + +2.0*t638*t985-4.0*t717*t991+4.0*t717*t996+2.0*t975*t960-t975*t963 & + +4.0*t975*t970-4.0*t975*t579-2.0*t975*t586+4.0*t975*t591; + t1211 = t143*g02; + t1218 = t143*g03; + t1222 = dgy01*dgx23; + t1223 = t1222*r; + t1226 = dgy01*dgy22; + t1227 = t1226*r; + t1230 = dgx01*dgx22; + t1231 = t1230*r; + t1234 = t12*ddgxx01; + t1240 = t11*t17; + t1242 = dg00*t25*t201; + t1245 = t197*g00; + t1248 = t523*t5; + t1250 = g00*t19*t201; + t1254 = t371*t19*t201; + t1265 = t12*t6; + t1272 = t143*dg02; + t1277 = t143*Theta23; + t1281 = -4.0*t975*t595-8.0*t1211*t876*Rmin+4.0*t1211*t880*Rmin-4.0*t1218*t884*Rmin & + -8.0*t453*t1223+4.0*t453*t1227-4.0*t479*t1231-16.0*t386*t1234*r+8.0*t406*t1223+4.0*t1240*t1242 & + +8.0*t1245*t321+12.0*t1248*t1250-12.0*t524*t1254-12.0*t508*t365*t19*t201 & + +12.0*t430*t1254+12.0*t1240*t1250-4.0*t495*t1265*t19+8.0*t495*t1265*r-4.0*t1272*dgy22*t25*Rmin-4.0*t1277*t320*Rmin; + t1282 = t143*dg23; + t1287 = t143*dg22; + t1296 = t143*dgx22; + t1301 = t42*t5; + t1308 = t393*Rmin; + t1311 = t397*Rmin; + t1325 = t92*g23; + t1326 = dgx23*dgy23; + t1330 = dgy23*dgy22; + t1334 = t92*g33; + t1335 = dgx33*dgx22; + t1338 = dgy23*dgx22; + t1348 = dgx33*dgy22; + t1351 = -4.0*t1282*Theta22*t25*Rmin-4.0*t1287*dgx03*t25*Rmin+4.0*t1287*dgy02*t25*Rmin & + +4.0*t1296*dg03*t25*Rmin+4.0*t1301*t31+6.0*t1301*t35-12.0*t1301*t39+8.0*t1211*t1308 & + -4.0*t1211*t1311+4.0*t1218*t402*Rmin-4.0*t1272*t1308 & + +2.0*t1272*t1311+2.0*t1277*dg22*t19*Rmin-8.0*t1325*t1326*r+4.0*t1325*t1330*r+t1334*t1335*t19 & + -2.0*t1334*t1338*t19-2.0*t1334*t1335*r+4.0*t1334*t1338*r-t1325*t1348*t19; + t1354 = dgy33*dgx22; + t1386 = t197*dg00; + t1398 = dg00*t20*t201; + t1411 = t1325*t1354*t19+2.0*t1325*t1348*r-2.0*t1325*t1354*r+2.0*t1282*Theta22*t20*Rmin & + +2.0*t1287*dgx03*t20*Rmin-2.0*t1287*dgy02*t20*Rmin-2.0*t1296*t315*Rmin-8.0*t1301*t27 & + +8.0*t1272*dgx23*t25*Rmin-2.0*t508*t202+2.0*t1386*dg22*t199*t201+4.0*t508*t207-4.0*t1386*dg22*t205*t201 & + -4.0*t1248*t1398-2.0*t508*t211-4.0*t1240*t1398-12.0*t1245*t306+2.0*t1386*t306+4.0*t1248*t1242; + t1426 = t142*ddgyr22*g02; + t1432 = t142*ddgxr23*g02; + t1437 = t377*t643; + t1441 = t522*t371*dg33; + t1449 = t522*t1*Rmin; + t1475 = 4.0*t1301*t22-4.0*t1272*dgx23*t20*Rmin+2.0*t1272*dgy22*t20*Rmin+2.0*t1277*t305*Rmin & + -8.0*t576*t1426+4.0*t582*t1426+8.0*t576*t1432-4.0*t582*t1432-2.0*t638*t1437-2.0*t717*t1441 & + +4.0*t975*t1426-4.0*t975*t1432+2.0*t1449*t1123*dgy33 & + -2.0*t1449*r*g03*dgy33-4.0*t1449*t1023*dgy03+4.0*t1009*t787*dgy03 & + +2.0*t1449*t1023*Theta33-2.0*t1009*t787*Theta33+4.0*t1449*t1099*dgy03-4.0*t1009*t792*dgy03; + t1483 = dgx33*dgx23; + t1496 = r*t142; + t1506 = t19*t142; + t1522 = t422*t522; + t1523 = t750*dg01; + t1526 = t754*dg01; + t1529 = t366*dg01; + t1532 = t372*dg01; + t1535 = t17*g00; + t1536 = t1535*dg01; + t1539 = -2.0*t1449*t1099*Theta33+2.0*t1009*t792*Theta33+4.0*t1325*t1483*r-2.0*t1325*t1483*t19+4.0*t1325*t1326*t19 & + -2.0*t1325*t1330*t19-4.0*t786*t1496*Theta23+4.0*t786*t1496*dgx03+4.0*t786*t1496*dgy02+4.0*t786*t1506*Theta23 & + -4.0*t786*t1506*dgx03-4.0*t786*t1506*dgy02+4.0*t610*t1437-2.0*t717*t1437+2.0*t850*t1441 & + -4.0*t1522*t1523+4.0*t1522*t1526+4.0*t855*t1529-4.0*t855*t1532-4.0*t860*t1536; + t1540 = t366*t658; + t1543 = t1535*ddg22; + t1547 = t856*dg22; + t1556 = t265*t522; + t1592 = -2.0*t610*t1540-4.0*t610*t1543+4.0*t325*t17*t1547+t717*t1540+2.0*t717*t1543 & + -2.0*t265*t17*t1547+4.0*t1556*t1523-4.0*t1556*t1526-4.0*t749*t1529+4.0*t749*t1532 & + +4.0*t758*t1536+t638*t1540+2.0*t638*t1543-2.0*t273*t17*t1547 & + +4.0*t610*t1535*dg22+2.0*t1282*t35+2.0*t1287*dgx03*t19*Rmin & + -2.0*t1287*dgy02*t19*Rmin-2.0*t1296*dg03*t19*Rmin-6.0*t1301*t48; + t1598 = t1222*t19; + t1601 = t1226*t19; + t1604 = t1230*t19; + t1629 = t11*t13; + t1636 = t365*dg23; + t1641 = t11*t12*g03; + t1646 = 12.0*t1301*t52+4.0*t453*t1598-2.0*t453*t1601+2.0*t479*t1604+8.0*t386*t1234*t19-4.0*t406*t1598 & + +2.0*t406*t1601-2.0*t415*t1604-4.0*t406*t1227+4.0*t415*t1231-4.0*t386*t392*dgx23 & + +2.0*t386*t392*dgy22-2.0*t386*t401*dgx22 & + +26.0*t1629*t529-8.0*t1629*t532-4.0*t1629*t535+4.0*t278*t1636*t265-4.0*t1641*t561+4.0*t1641*t564; + t1647 = t4*t277; + t1652 = g33*g02; + t1653 = t4*t1652; + t1654 = g03*dg23; + t1668 = t4*g33*g03; + t1673 = t177*t277; + t1674 = g03*dgx22; + t1678 = dg02*dgx23; + t1682 = dg02*dgy22; + t1686 = Theta23*dg22; + t1691 = g23*t371*t741; + t1694 = g01*g33; + t1695 = t325*t1694; + t1697 = g23*t365*t741; + t1700 = t1*g23; + t1701 = t454*t1700; + t1703 = dg23*dgx23*t1173; + t1706 = dg23*dgy22; + t1707 = t1706*t1173; + t1710 = t575*t1700; + t1711 = dg33*dgx22; + t1712 = t1711*t1173; + t1716 = t888*t1700; + t1717 = dgx33*dg22; + t1718 = t1717*t1173; + t1720 = 8.0*t1647*t437+8.0*t1647*t441+8.0*t1653*t1654*t422-18.0*t1629*t569+8.0*t1629*t572 & + -4.0*t278*t1636*t422+24.0*t1647*t710+4.0*t1668*t501 & + -4.0*t1668*t505+6.0*t1673*t1674*t388+4.0*t1673*t1678*t888-2.0*t1673*t1682*t888 & + -2.0*t1673*t1686*t888+4.0*t326*t1691+4.0*t1695*t1697-4.0*t1701*t1703 & + +2.0*t1701*t1707+2.0*t1710*t1712-t1701*t1712+t1716*t1718; + t1727 = t265*t4; + t1728 = t338*t267; + t1731 = t888*t177; + t1733 = dg33*dgx23*t338; + t1737 = dg33*dgy22*t338; + t1740 = g33*ddgyr22*t338; + t1744 = g33*ddgxr23*t338; + t1747 = dgx22*dg03; + t1760 = dg23*Theta22; + t1764 = dg22*dgx03; + t1768 = dg22*dgy02; + t1787 = -4.0*t1716*t1703+2.0*t1716*t1707-t1716*t1712+4.0*t1727*t1728-2.0*t1731*t1733+t1731*t1737 & + -4.0*t1731*t1740+4.0*t1731*t1744+2.0*t1673*t1747*t888-8.0*t1673*t1678*t575 & + +4.0*t1673*t1682*t575+4.0*t1673*t1686*t575+4.0*t1673*t1760*t575 & + +4.0*t1673*t1764*t575-4.0*t1673*t1768*t575-4.0*t1673*t1747*t575-12.0*t1673*t590*t454 & + +2.0*t1673*t594*t454-6.0*t1673*t1674*t454+4.0*t1673*t1678*t454; + t1813 = t338*t339; + t1817 = t338*g03*t658; + t1820 = g01*t12; + t1822 = t304*t741; + t1825 = t713*t367; + t1828 = t13*t639; + t1833 = t265*t1694; + t1847 = -2.0*t1673*t1682*t454-2.0*t1673*t1686*t454-2.0*t1673*t1760*t454-2.0*t1673*t1764*t454 & + +2.0*t1673*t1768*t454+2.0*t1673*t1747*t454+12.0*t1673*t590*t388-2.0*t1673*t594*t388 & + -8.0*t422*t577*t1813+4.0*t1695*t1817-8.0*t325*t1820*t1822 & + -8.0*t337*t1825-4.0*t266*t1828-2.0*t266*t1691-2.0*t1833*t1697-2.0*t1833*t1817 & + +4.0*t265*t1820*t1822+4.0*t348*t1825-4.0*t1629*t956-4.0*t1641*t501; + t1873 = t713*t979; + t1876 = g33*t365*t979; + t1882 = t1652*t1711; + t1884 = t177*t575; + t1887 = t177*t454; + t1891 = g33*g00*t979; + t1896 = 4.0*t1641*t505-8.0*t1668*t516+8.0*t1668*t519+8.0*t1629*t510+8.0*t1641*t516-8.0*t1641*t519-8.0*t1647*t549 & + -8.0*t1647*t553-8.0*t1653*t1654*t265+4.0*t1668*t561-4.0*t1668*t564-t274*t1873 & + +2.0*t326*t1876+2.0*t326*t1873-t266*t1876 & + -t1731*t1882+2.0*t1884*t1882-t1887*t1882+t4*t273*t1891-2.0*t4*t325*t1891; + t1897 = t277*t327; + t1901 = t4*t422; + t1904 = t1652*t1717; + t1906 = t1652*t1706; + t1909 = dgy23*dg22; + t1910 = t1652*t1909; + t1914 = g23*g03*t1909; + t1932 = t338*t1113; + t1934 = t888*t192; + t1935 = dg23*dgx22; + t1936 = t1935*t1173; + t1939 = t1935*t338; + t1942 = dg22*dgy22; + t1943 = t1942*t1173; + t1946 = t1942*t338; + t1949 = 4.0*t1727*t1897+t1727*t1891-4.0*t1901*t1897+t1731*t1904+2.0*t1731*t1906 & + -2.0*t1731*t1910+2.0*t1731*t1914-2.0*t1884*t1904-4.0*t1884*t1906 & + +4.0*t1884*t1910-4.0*t1884*t1914+t1887*t1904+2.0*t1887*t1906-2.0*t1887*t1910 & + +2.0*t1887*t1914+t1731*t1932+2.0*t1934*t1936-2.0*t1934*t1939-2.0*t1934*t1943+2.0*t1934*t1946; + t1973 = t575*t192; + t1982 = t454*t192; + t1995 = -4.0*t1901*t1728+4.0*t1884*t1733-2.0*t1884*t1737-2.0*t1887*t1733+t1887*t1737 & + +8.0*t1884*t1740-4.0*t1887*t1740-2.0*t1673*t1760*t888-2.0*t1673*t1764*t888 & + +2.0*t1673*t1768*t888-4.0*t1973*t1936+4.0*t1973*t1939+4.0*t1973*t1943-4.0*t1973*t1946 & + +2.0*t1982*t1936-2.0*t1982*t1939-2.0*t1982*t1943-t266*t1873+8.0*t265*t577*t1813-4.0*t274*t1828; + t1998 = t273*t1694; + t2035 = -2.0*t274*t1691-2.0*t1998*t1697+2.0*t1982*t1946-2.0*t1710*t1718+8.0*t1710*t1703 & + -4.0*t1710*t1707+t1701*t1718-8.0*t1884*t1744+4.0*t1887*t1744 & + -2.0*t1998*t1817+4.0*t273*t1820*t1822+4.0*t355*t1825-8.0*t326*t13*t528+8.0*t326*t1828 & + -2.0*t1884*t1932+t1887*t1932-t274*t1876+2.0*t197*t6-4.0*t18*ddgxx01+t56*t249; + Theta22_rhs = 1/t1*(t811+t738+t686+t618+t552+t477+t1720+t1646+t1592+t1539+t1475+t2035 & + +t385+t1995+t1411+t1351+t1281+t301+t1207+t1160+t1949+t1094+t1049+t983+t928 & + +t871+t1896+t1847+t1787+t234+t162+t88) & + /(-2.0*t627*g33-2.0*t17*r-2.0*t611*r+t17*t19+t611*t19-2.0*t627*t1023+4.0*t627*t1099+t17+t611)/Rmin/t19/4.0; + + t1 = g01*g01; + t3 = g23*g23; + t4 = t3*t3; + t5 = t1*t4; + t8 = t3*g23; + t9 = t1*g01; + t10 = t8*t9; + t17 = g01*g22; + t18 = t3*g33; + t19 = t17*t18; + t20 = dg00*dg23; + t21 = r*r; + t22 = t21*t21; + t23 = Rmin*Rmin; + t24 = t22*t23; + t25 = t20*t24; + t28 = dg02*dg03; + t29 = t28*t24; + t32 = g33*g23; + t33 = t17*t32; + t34 = g03*g03; + t35 = t34*dg22; + t39 = g01*g33; + t40 = t3*g02; + t41 = t39*t40; + t42 = g03*dg22; + t46 = t1*g22; + t47 = t46*t32; + t48 = dg23*dgx03; + t49 = t21*r; + t50 = t49*Rmin; + t54 = dg23*dgy02; + t59 = dgy22*dg03; + t63 = g02*dgx33; + t64 = t21*Rmin; + t68 = g03*dgy22; + t72 = dg02*dgx33; + t76 = Theta33*dg22; + t89 = r*Rmin; + t96 = t22*Rmin; + t100 = -2.0*t47*t48*t64-4.0*t47*t59*t50-2.0*t47*t54*t64+2.0*t47*t59*t64 & + -6.0*t47*t63*t64+6.0*t47*t63*t89-6.0*t47*t68*t64+2.0*t47*t72*t64-2.0*t47*t76*t64+6.0*t47*t68*t89+2.0*t47*t72*t96; + t120 = dg02*dg23; + t121 = t120*t24; + t124 = dg22*dg03; + t125 = t124*t24; + t128 = g22*g22; + t129 = g01*t128; + t130 = t129*t32; + t131 = g03*dg03; + t132 = t49*t23; + t133 = t131*t132; + t136 = g33*g33; + t137 = t136*g23; + t138 = t17*t137; + t139 = g02*dg02; + t140 = t139*t132; + t144 = g00*dg23; + t145 = t144*t132; + t148 = g02*dg03; + t152 = g03*dg02; + t162 = g02*g03; + t163 = t21*t23; + t168 = t17*t136*g02; + t169 = t22*t21; + t170 = t169*t23; + t171 = t120*t170; + t174 = t24*t17; + t175 = g33*ddg23; + t176 = g00*t3; + t177 = t175*t176; + t181 = dg33*dg23; + t183 = t181*g00*g33; + t185 = g02*g02; + t186 = t185*g33; + t187 = t181*t186; + t189 = t181*t176; + t191 = -20.0*t19*t145+8.0*t19*t148*t132+8.0*t19*t152*t132-2.0*t33*t35*t132-4.0*t41*t42*t132 & + +24.0*t19*t162*t163-2.0*t168*t171-4.0*t174*t177-t24*t129*t183+t174*t187+t174*t189; + t194 = g01*t136; + t196 = dg23*dg22; + t197 = g00*g22; + t198 = t196*t197; + t200 = t24*t39; + t201 = t34*g22; + t202 = t196*t201; + t204 = t196*t176; + t206 = g01*t3; + t208 = dg33*dg22; + t209 = t208*t162; + t212 = g22*g33; + t213 = t24*t212; + t214 = dg01*dg23; + t215 = t214*t176; + t219 = t3*dg01*t162; + t222 = t170*t17; + t226 = t170*t39; + t233 = t170*t212; + t236 = t22*r; + t237 = t236*t23; + t238 = t237*t17; + t239 = g33*dg23; + t247 = t1*t128; + t248 = t136*ddgxy01; + t251 = t1*t8; + t252 = dgx01*dgx33; + t255 = dgy01*dgy22; + t258 = g01*t4; + t259 = dgx01*dgy01; + t268 = 2.0*t170*t206*t209+4.0*t233*t215-8.0*t238*t239*t176-4.0*t222*t177 & + -t170*t129*t183-4.0*t247*t248+2.0*t251*t252+2.0*t251*t255+2.0*t258*t259-4.0*t10*ddgxy23*t21+8.0*t10*ddgxy23*r; + t282 = t3*t9; + t283 = dgx33*dgy22; + t285 = dgy33*dgx22; + t287 = dgx33*dgx23; + t290 = dgx23*dgy23; + t293 = dgy23*dgy22; + t296 = g23*t9; + t297 = dgy22*dgy22; + t298 = g33*t297; + t301 = dgx33*dgx33; + t302 = g22*t301; + t310 = dg33*t22; + t311 = t310*t23; + t315 = g02*dg23; + t316 = dg03*t22; + t317 = t316*t23; + t321 = t237*t212; + t322 = g23*g02; + t323 = t322*g03; + t324 = t214*t323; + t327 = t175*t323; + t330 = t181*t323; + t333 = t196*t323; + t336 = g01*g23; + t337 = t24*t336; + t339 = t208*t197*g33; + t344 = t296*t302-4.0*t5*ddgxy01*t21+8.0*t5*ddgxy01*r-2.0*t33*t139*t311+2.0*t33*t315*t317 & + +8.0*t321*t324+4.0*t174*t327-2.0*t174*t330-2.0*t200*t333+2.0*t337*t339-4.0*t213*t324; + t366 = t237*t39; + t373 = g03*dg33; + t376 = t373*dg22*g33*g02; + t384 = dg23*t169*t23; + t389 = dg03*t169*t23; + t394 = dg23*t236*t23; + t399 = dg03*t236*t23; + t404 = dg23*t22*t23; + t415 = dg23*t49*t23; + t419 = -2.0*t33*t42*t317-2.0*t33*t42*t389+4.0*t33*t42*t399+2.0*t33*t152*t384-4.0*t33*t152*t394 & + +2.0*t33*t152*t404-32.0*t33*t162*t404+24.0*t33*t162*t415-2.0*t174*t376-2.0*t222*t376+4.0*t238*t376; + t437 = g01*t8; + t438 = t437*g02; + t439 = dg23*dg03; + t440 = t439*t237; + t443 = t129*g33; + t444 = t34*dg23; + t445 = t444*t24; + t448 = t1*g33; + t449 = t448*t3; + t450 = dg22*dgy02; + t451 = t450*t64; + t453 = t247*g33; + t454 = g03*dgx33; + t455 = t454*t89; + t458 = t46*t136; + t459 = dgy22*g02; + t460 = t459*t89; + t463 = t46*g33; + t464 = t3*Theta23; + t469 = t3*dgx03; + t473 = t3*dgy02; + t477 = g23*dgx01; + t478 = dgx33*t21; + t482 = g23*dgy01; + t483 = dgy22*t21; + t487 = t46*t3; + t492 = dgx33*r; + t496 = dgy22*r; + t500 = Theta33*dg23; + t501 = t500*t96; + t503 = dgx33*dg03; + t504 = t503*t96; + t507 = dg02*dgy22; + t508 = t507*t96; + t511 = -12.0*t463*t469*t89-12.0*t463*t473*t89-2.0*t463*t477*t478-2.0*t463*t482*t483 & + +6.0*t487*t455+6.0*t449*t460+4.0*t463*t477*t492+4.0*t463*t482*t496+t453*t501-2.0*t453*t504-2.0*t458*t508; + t514 = Theta23*dg22; + t515 = t514*t96; + t517 = dg22*dgx03; + t518 = t517*t96; + t520 = t450*t96; + t522 = t3*ddgxr03; + t533 = t454*t64; + t537 = t129*t136; + t538 = t20*t237; + t541 = t28*t237; + t544 = t437*g03; + t545 = t120*t237; + t548 = t124*t237; + t551 = g23*dg00; + t555 = dg33*Theta23; + t556 = t555*t50; + t560 = t500*t50; + t563 = t503*t50; + t566 = t507*t50; + t569 = t514*t50; + t572 = -4.0*t537*t538+4.0*t537*t541+4.0*t544*t545-4.0*t544*t548-4.0*t537*t551*t24-2.0*t453*t556 & + -t449*t520-2.0*t453*t560+4.0*t453*t563+4.0*t458*t566-2.0*t458*t569; + t574 = t517*t50; + t577 = t450*t50; + t597 = t500*t64; + t599 = 8.0*t463*t522*t50-4.0*t449*t566+2.0*t449*t569-2.0*t449*t574+2.0*t449*t577+4.0*t453*t533+t453*t597 & + +2.0*t458*t574-2.0*t458*t577+2.0*t487*t560-4.0*t487*t563; + t600 = t503*t64; + t603 = t459*t64; + t606 = t507*t64; + t609 = t514*t64; + t611 = t517*t64; + t614 = t24*g01; + t616 = g00*dg22; + t617 = t8*dg33*t616; + t620 = dg23*dg23; + t621 = g23*t620; + t622 = t621*t201; + t625 = t621*t186; + t634 = -2.0*t453*t600+4.0*t458*t603-2.0*t458*t606+t458*t609-t458*t611+t458*t451 & + -2.0*t614*t617-2.0*t614*t622-2.0*t614*t625-4.0*t463*t522*t64-12.0*t463*t464*t64; + t645 = t17*g33; + t646 = t3*dgx01; + t655 = t144*t24; + t662 = t17*t136; + t663 = t185*dg23; + t664 = t663*t24; + t667 = t8*dg00; + t671 = t17*t8; + t672 = t131*t24; + t676 = t39*t8; + t677 = t139*t24; + t680 = t39*t3; + t683 = g03*dg23; + t696 = t663*t132; + t706 = -8.0*t676*t677-8.0*t680*t664+24.0*t438*t683*t24-2.0*t544*t121+2.0*t544*t125+4.0*t537*t551*t132 & + +8.0*t537*t145-8.0*t662*t696-8.0*t645*t667*t132+8.0*t671*t133+8.0*t676*t140; + t738 = t237*g01; + t739 = t128*dg33; + t740 = t739*t444; + t743 = t136*dg23; + t744 = dg22*t185; + t745 = t743*t744; + t748 = t3*ddg23; + t749 = t748*t201; + t752 = t748*t186; + t756 = t8*ddg23*t162; + t766 = t3*t620*t162; + t769 = t237*t128; + t770 = t136*dg01; + t771 = t770*t144; + t774 = -t449*t609+4.0*t738*t617+4.0*t738*t622+4.0*t738*t625-2.0*t738*t740-2.0*t738*t745 & + -4.0*t738*t749-4.0*t738*t752+8.0*t738*t756-4.0*t738*t766+4.0*t769*t771; + t778 = g33*dg01*t444; + t782 = t770*t663; + t785 = t237*t3; + t786 = t214*t201; + t789 = t214*t186; + t793 = t214*t162; + t796 = t128*t136; + t798 = t796*ddg23*g00; + t801 = t128*g33; + t803 = t801*ddg23*t34; + t806 = g22*t136; + t808 = t806*ddg23*t185; + t811 = t24*t128; + t812 = dg01*t34; + t813 = t32*t812; + t816 = t24*g22; + t817 = dg01*t185; + t818 = t137*t817; + t823 = g00*dg01; + t824 = g33*t8*t823; + t831 = dg02*dg33; + t832 = t831*t170; + t835 = t439*t170; + t838 = t831*t237; + t842 = t3*t1*Rmin; + t843 = r*g33; + t844 = dgx23*g02; + t849 = dgy23*dg22; + t857 = t17*t3; + t860 = -8.0*t816*t824+t614*t740+t614*t745+2.0*t614*t749+2.0*t438*t832-2.0*t438*t835 & + -4.0*t438*t838+4.0*t842*t843*t844+2.0*t842*t22*g03*t849-4.0*t842*t49*g03*t849-8.0*t857*t445; + t862 = t831*t24; + t865 = t439*t24; + t868 = t444*t132; + t873 = dg33*dgx03; + t874 = t873*t50; + t877 = dg33*dgy02; + t878 = t877*t50; + t881 = dg23*Theta22; + t882 = t881*t50; + t885 = t3*ddgyr02; + t895 = 2.0*t438*t862-2.0*t438*t865-8.0*t443*t868+4.0*t857*t868-2.0*t453*t874+2.0*t453*t878-2.0*t458*t882 & + +8.0*t463*t885*t50+2.0*t487*t556+2.0*t487*t874-2.0*t487*t878; + t898 = t555*t64; + t900 = t873*t64; + t902 = t877*t64; + t904 = t881*t64; + t913 = t555*t96; + t915 = -4.0*t463*t885*t64+2.0*t449*t882-t449*t904+t453*t898+t453*t900-t453*t902 & + +t453*t913+t458*t904-t487*t898-t487*t900+t487*t902; + t919 = t873*t96; + t921 = t877*t96; + t923 = t881*t96; + t932 = t20*t170; + t935 = t28*t170; + t941 = t124*t170; + t944 = t50*t1; + t946 = t806*ddgyr22*g02; + t949 = t64*t1; + t953 = t806*ddgxr23*g02; + t958 = g02*dgx22; + t959 = t743*t958; + t963 = t136*dg22*t459; + t968 = t3*dg23; + t969 = g03*dgx23; + t970 = t968*t969; + t973 = -2.0*t544*t171+2.0*t544*t941+4.0*t944*t946-4.0*t944*t953+2.0*t944*t959-2.0*t944*t963+4.0*t944*t970 & + -2.0*t949*t946+2.0*t949*t953-t949*t959+t949*t963; + t978 = g33*g02; + t979 = t3*ddgyr22*t978; + t985 = t3*ddgxr23*t978; + t990 = t137*t744; + t995 = t128*t34*dg33*g23; + t998 = t96*t1; + t1006 = t132*t128; + t1007 = t137*t823; + t1012 = t132*g22; + t1023 = t132*g01; + t1030 = t998*t963-4.0*t1006*t1007+4.0*t1006*t813+4.0*t1012*t818+8.0*t1012*t824+2.0*t614*t752-4.0*t614*t756 & + -2.0*t998*t985+2.0*t1023*t990+2.0*t1023*t995+2.0*t614*t766; + t1039 = t24*t3; + t1044 = t24*t8; + t1067 = t170*g01; + t1084 = 4.0*t738*t968*t186-8.0*t738*t8*dg23*t162+2.0*t1067*t798-2.0*t1067*t803-2.0*t1067*t808+t1067*t740+t1067*t745 & + +2.0*t1067*t749+2.0*t1067*t752-4.0*t1067*t756-2.0*t1067*t617; + t1092 = t170*t128; + t1100 = t170*t3; + t1112 = -2.0*t1067*t622-2.0*t1067*t625+2.0*t1067*t766-2.0*t1092*t771+2.0*t1092*t778+2.0*t170*g22*t782 & + -2.0*t1100*t786-2.0*t1100*t789+4.0*t170*t8*t793+4.0*t811*t1007-4.0*t738*t798; + t1117 = t21*g03; + t1121 = r*g22; + t1122 = g03*dgy23; + t1126 = t21*g22; + t1127 = g02*dgy33; + t1131 = t437*t49; + t1133 = g00*dg33; + t1134 = t23*g22*t1133; + t1138 = t23*g33*t616; + t1141 = t1*g23; + t1142 = t1141*Rmin; + t1143 = t21*t128; + t1144 = g03*dgy33; + t1148 = r*t128; + t1160 = 4.0*t738*t803+4.0*t738*t808+2.0*t842*t1117*t849+4.0*t842*t1121*t1122 & + -2.0*t842*t1126*t1127-2.0*t1131*t1134-2.0*t1131*t1138+2.0*t1142*t1143*t1144 & + -2.0*t1142*t1148*t1144+2.0*t1142*t21*t136*t958-2.0*t1142*r*t136*t958; + t1166 = t136*dgx02; + t1173 = t136*Theta22; + t1177 = g33*dgy03; + t1181 = g33*Theta33; + t1191 = t437*t22; + t1203 = t21*g33; + t1204 = g03*dgx22; + t1212 = dg33*dgx23; + t1231 = t128*dgy33*t683; + t1234 = g22*g03; + t1235 = t3*ddgyr23*t1234; + t1239 = t3*ddgxr33*t1234; + t1242 = 2.0*t842*t1121*t1127-2.0*t842*t1203*t1204+2.0*t842*t843*t1204+2.0*t842*t22*g02*t1212 & + -4.0*t842*t49*g02*t1212-4.0*t842*t1203*t844+2.0*t842*t21*g02*t1212 & + -4.0*t842*t1126*t1122-t998*t1231-2.0*t998*t1235+2.0*t998*t1239; + t1245 = t801*ddgyr23*g03; + t1249 = t801*ddgxr33*g03; + t1252 = g02*dgy23; + t1253 = t968*t1252; + t1256 = t739*t454; + t1289 = t96*t46; + t1291 = dg33*dgx33*t322; + t1293 = 2.0*t944*t1231-t949*t1231+4.0*t944*t1235-2.0*t949*t1235-4.0*t944*t1239 & + +2.0*t949*t1239-2.0*t944*t1256+t949*t1256-t1289*t1291-2.0*t998*t970+2.0*t998*t979; + t1313 = t1141*t64; + t1314 = t212*t1252; + t1317 = t1141*t89; + t1320 = t1141*t96; + t1322 = t212*dg33*dgx02; + t1326 = t1141*t50; + t1331 = t336*t132; + t1332 = t801*t1133; + t1335 = t806*t616; + t1342 = t212*t969; + t1348 = t212*dg22*dgy03; + t1355 = 2.0*t1313*t1322+4.0*t1313*t1342+2.0*t1313*t1348-4.0*t1317*t1342+2.0*t1320*t1348 & + -4.0*t1326*t1322-4.0*t1326*t1348+2.0*t1331*t1332+2.0*t1331*t1335-2.0*t337*t1332-2.0*t337*t1335; + t1357 = t50*t46; + t1359 = g33*ddgxr33*t322; + t1362 = t64*t46; + t1366 = dg23*dgy23*t1234; + t1374 = dgy33*dg23*t322; + t1379 = t50*t448; + t1380 = dgx33*dg22; + t1381 = t1380*t1234; + t1384 = dg23*dgy22; + t1385 = t1384*t1234; + t1388 = t849*t1234; + t1391 = 2.0*t1357*t1291-t1362*t1291+2.0*t1313*t1366-4.0*t1326*t1366-4.0*t1357*t1359-2.0*t1357*t1374 & + +2.0*t1362*t1359+t1362*t1374-2.0*t1379*t1381-2.0*t1379*t1385+4.0*t1379*t1388; + t1392 = t64*t448; + t1398 = g33*ddgyr23*t322; + t1405 = dgx33*dg23; + t1406 = t1405*t978; + t1409 = g23*g03; + t1410 = t1405*t1409; + t1413 = t1212*t978; + t1416 = dg33*dgy22; + t1417 = t1416*t978; + t1419 = t1416*t1409; + t1421 = t1392*t1381+t1392*t1385-2.0*t1392*t1388-2.0*t1289*t1398+2.0*t1289*t1359 & + +2.0*t1320*t1366-2.0*t1357*t1406+2.0*t1357*t1410-2.0*t1362*t1413+t1362*t1417-t1362*t1419; + t1428 = g33*ddgyr22*t1409; + t1434 = g33*ddgxr23*t1409; + t1440 = dg23*dgx22*t1409; + t1444 = dg22*dgy22*t1409; + t1450 = t1380*t978; + t1454 = dg23*dgx23*t978; + t1457 = t1384*t978; + t1473 = g03*t620*t978; + t1476 = 2.0*t237*t129*t183-t1313*t1450+2.0*t1313*t1454-t1313*t1457+2.0*t1326*t1450-4.0*t1326*t1454 & + +2.0*t1326*t1457+2.0*t222*t1473+8.0*t238*t177+t222*t187-2.0*t238*t187; + t1488 = t96*t448; + t1490 = dg33*Theta22; + t1501 = t185*dg33; + t1505 = t17*t40; + t1510 = t129*g33*g03; + t1516 = t17*t3*g03; + t1529 = -2.0*t33*t1501*t132-2.0*t47*t1490*t96-4.0*t1505*t373*t132+4.0*t1510*t440 & + +2.0*t1510*t832-2.0*t1510*t835-4.0*t1510*t838-4.0*t1516*t440-2.0*t1516*t832+2.0*t1516*t835+4.0*t1516*t838; + t1577 = 8.0*t19*t538-8.0*t19*t541-4.0*t41*t545+4.0*t41*t548-2.0*t41*t941-2.0*t168*t121+2.0*t168*t125 & + +8.0*t130*t672+8.0*t138*t677+4.0*t168*t545-4.0*t168*t548; + t1598 = 28.0*t19*t655-8.0*t19*t148*t24-8.0*t19*t152*t24+t1289*t1374+t1488*t1381+t1488*t1385 & + -2.0*t1488*t1388+4.0*t1357*t1398-2.0*t1362*t1398-t1488*t1444-t1320*t1450; + t1612 = t437*t185; + t1615 = dg33*t49; + t1619 = t251*dg23; + t1624 = t251*dgy22; + t1625 = dg03*t49; + t1629 = 2.0*t1320*t1454-t1320*t1457-4.0*t238*t1473+2.0*t174*t1473+4.0*t1357*t1413-2.0*t1357*t1417 & + +2.0*t1357*t1419-4.0*t1612*t311+4.0*t1612*t1615*t23-4.0*t1619*dgy02*t49*Rmin+4.0*t1624*t1625*Rmin; + t1634 = t247*t136; + t1636 = ddgxr03*t21*Rmin; + t1640 = Theta23*t21*Rmin; + t1644 = dgx03*t21*Rmin; + t1648 = dgy02*t21*Rmin; + t1651 = t251*g02; + t1652 = t478*Rmin; + t1655 = t251*g03; + t1660 = t251*dg02; + t1663 = t251*Theta33; + t1664 = dg22*t21; + t1678 = Theta23*r*Rmin; + t1682 = dgx03*r*Rmin; + t1686 = dgy02*r*Rmin; + t1689 = dgy01*dgx33; + t1690 = t1689*t21; + t1693 = t258*dg00; + t1696 = t258*dg02; + t1703 = t258*g00; + t1706 = 2.0*t1619*t1648-2.0*t1624*dg03*t21*Rmin-4.0*t1634*t1678+4.0*t1634*t1682+4.0*t1634*t1686 & + +2.0*t453*t1690+2.0*t1693*t384-2.0*t1696*t389-4.0*t1693*t394+4.0*t1696*t399-16.0*t1703*t404; + t1708 = t258*g02; + t1711 = t258*g03; + t1720 = dg01*g02*g03; + t1724 = ddgyr02*t21*Rmin; + t1727 = t251*dg33; + t1733 = ddgyr02*t22*Rmin; + t1741 = ddgyr02*t49*Rmin; + t1752 = dg22*t22; + t1768 = ddgxr03*t49*Rmin; + t1775 = dg22*t49; + t1783 = t251*Rmin; + t1788 = t8*ddgyr23*g02; + t1791 = 4.0*t282*t287*r+2.0*t1663*t1752*Rmin+2.0*t1619*dgx03*t22*Rmin+2.0*t1619*dgy02*t22*Rmin & + -2.0*t1624*t316*Rmin-4.0*t1634*t1768+4.0*t1660*dgx33*t49*Rmin & + -4.0*t1663*t1775*Rmin-4.0*t1619*dgx03*t49*Rmin-2.0*t1783*t1203*Theta22+2.0*t998*t1788; + t1795 = t8*ddgxr33*g02; + t1823 = t296*g33; + t1824 = dgy23*dgx22; + t1828 = dgx33*dgx22; + t1836 = t8*ddgyr22*g03; + t1842 = t8*ddgxr23*g03; + t1852 = t4*ddg23*g00; + t1856 = t214*g00; + t1859 = 4.0*t1823*t1824*r-2.0*t1823*t1828*r-2.0*t1823*t1824*t21+4.0*t237*t4*t1856+4.0*t944*t1836 & + -2.0*t949*t1836-2.0*t998*t1836-4.0*t944*t1842+2.0*t949*t1842+2.0*t998*t1842-4.0*t738*t1852; + t1863 = t24*t4; + t1875 = t812*g22; + t1878 = t817*g33; + t1883 = t132*t8; + t1890 = 2.0*t614*t1852-2.0*t1863*t1856+2.0*t1067*t1852-2.0*t170*t4*t1856 & + +4.0*t738*t4*dg23*g00+4.0*t1044*t1875+4.0*t1044*t1878 & + -8.0*t1863*t1720-4.0*t1883*t1875-4.0*t1883*t1878-2.0*t1696*t317; + t1891 = t437*t34; + t1918 = t259*t21; + t1921 = t259*r; + t1927 = -4.0*t1891*t1752*t23+12.0*t1703*t415-8.0*t1708*t1625*t23-8.0*t1711*dg02*t49*t23 & + +4.0*t1891*t1775*t23+12.0*t671*t34*t21*t23+12.0*t676*t185*t21*t23 & + -24.0*t1708*t1117*t23+2.0*t537*t1918-4.0*t537*t1921-4.0*t645*t646*dgy01; + t1931 = dgx01*dgy22; + t1932 = t1931*t21; + t1935 = t3*ddgxy01; + t1949 = t1689*r; + t1952 = t1931*r; + t1970 = ddgxr03*t22*Rmin; + t1995 = 4.0*t449*t1952-2.0*t463*t477*dgx33-2.0*t463*t482*dgy22+2.0*t1634*t1970-2.0*t1660*dgx33*t22*Rmin & + +2.0*t1783*t843*Theta22-2.0*t1783*t1752*dgy03 & + +4.0*t1783*t1126*dgy03+4.0*t1783*t1775*dgy03-2.0*t1783*t1664*dgy03-2.0*t1783*t1126*Theta33; + t2003 = t296*g22; + t2004 = dgy33*dgx23; + t2008 = dgy33*dgy22; + t2017 = g33*ddgxy23; + t2024 = g33*ddgyy22; + t2032 = g33*ddgxx33; + t2065 = -2.0*t2003*t2032*t21+4.0*t2003*t2032*r+t1823*t1828*t21+2.0*t282*t283*r & + -2.0*t282*t285*r-2.0*t282*t287*t21+4.0*t282*t290*t21-2.0*t282*t293*t21 & + +4.0*t296*t212*ddgxy23-2.0*t296*t212*ddgyy22-2.0*t296*t212*ddgxx33; + t2085 = g22*dgy33; + t2091 = t4*g23; + t2093 = t2091*dg01*g00; + t2122 = t136*dgx01; + t2133 = 8.0*t5*t1682+8.0*t5*t1686+2.0*t251*t252*t21+2.0*t251*t255*t21+8.0*t247*t248*r-4.0*t251*t252*r-4.0*t251*t255*r & + +2.0*t247*g33*dgy01*dgx33+2.0*t46*t2122*dgy22+8.0*t46*t18*ddgxy01-2.0*t46*t3*dgy01*dgx33; + t2138 = g01*t2091; + t2166 = -2.0*t448*t646*dgy22 & + -4.0*t2138*dg00*t22*t23+4.0*t2138*dg00*t49*t23+12.0*t2138*g00*t21*t23 & + +2.0*t258*t1918-4.0*t258*t1921+2.0*t129*t2122*dgy01+2.0*t5*t1733-4.0*t5*t1741+2.0*t5*t1724+2.0*t5*t1970; + t2192 = -4.0*t5*t1768+2.0*t5*t1636+8.0*t5*t1640-8.0*t5*t1644-8.0*t5*t1648-4.0*t247*t248*t21 & + -8.0*t5*t1678-8.0*t282*t290*r+4.0*t282*t293*r-t282*t283*t21+t282*t285*t21; + t2201 = t3*g22; + Theta23_rhs = 1/t1& + *(-12.0*t443*g23*t34*t163-12.0*t662*g23*t185*t163 & + -24.0*t645*t8*g00*t163+8.0*t1711*dg02*t22*t23 & + +2.0*t1727*Theta22*t21*Rmin+2.0*t1727*Theta22*t22*Rmin & + -4.0*t1727*Theta22*t49*Rmin-2.0*t1783*t21*dg33*dgx02 & + +t296*g33*dgx33*dgx22-2.0*t296*g33*dgy23*dgx22 & + -4.0*t645*t646*dgy01*t21+8.0*t645*t646*dgy01*r & + +12.0*t537*g23*g00*t163-2.0*t33*t139*dg33*t169*t23 & + +4.0*t33*t139*dg33*t236*t23 & + +t100+t344+t268+t191+t2133+t2065+t1927 & + +t706+t599+t634+t511+t572+t419+t1706+t1476 & + +t1629+t1421+t1598+t1391+t1355+t1529-4.0*t453*t455 & + +t1859+t1995+t1791+t2166+t2192+t1293+t1242 & + +t1890+t1112+t1160+t1084 & + -2.0*t1783*t310*dgx02+4.0*t1783*t1203*dgx02 & + +4.0*t1783*t1615*dgx02-4.0*t1783*t843*dgx02 & + +8.0*t463*t1935*t21-8.0*t1651*t492*Rmin & + -8.0*t1655*t496*Rmin-16.0*t463*t1935*r & + -4.0*t1783*t1121*dgy03+2.0*t1783*t1121*Theta33 & + -2.0*t2003*t2004*t21+t2003*t2008*t21+4.0*t2003*t2004*r & + -2.0*t2003*t2008*r+4.0*t2003*t2017*t21 & + -8.0*t2003*t2017*r-2.0*t2003*t2024*t21+4.0*t2003*t2024*r & + +t296*t298*t21-2.0*t296*t298*r+t296*t302*t21 & + -2.0*t296*t302*r-2.0*t296*t2085*dgx23+t296*t2085*dgy22 & + +4.0*t738*t968*t201-4.0*t1142*t1126*t1166 & + +4.0*t1142*t1121*t1166-2.0*t1142*t1121*t1173 & + -4.0*t1142*t1143*t1177+2.0*t1142*t1143*t1181 & + +4.0*t1142*t1148*t1177-2.0*t1142*t1148*t1181 & + +2.0*t1142*t1126*t1173-8.0*t132*t212*t219 & + +2.0*t237*t194*t198-4.0*t237*t206*t209+4.0*t47*t1490*t50 & + -2.0*t47*t1490*t64+2.0*t33*t1501*t24+4.0*t1505*t373*t24 & + +8.0*t1655*t483*Rmin+2.0*t1663*t1664*Rmin & + +8.0*t132*t4*t1720+2.0*t33*t315*t389-4.0*t33*t315*t399 & + +12.0*t463*t464*t89-4.0*t463*t522*t96+12.0*t463*t469*t64 & + +12.0*t463*t473*t64+8.0*t645*t667*t24-16.0*t438*t683*t132 & + -4.0*t237*g22*t782-8.0*t237*t8*t793-4.0*t463*t885*t96 & + +4.0*t738*t796*t144-4.0*t738*t801*t444-4.0*t738*t806*t663 & + -t24*t194*t198+2.0*t24*t206*t209-t170*t194*t198 & + +2.0*t10*ddgyy22*t21-4.0*t10*ddgyy22*r+2.0*t10*ddgxx33*t21 & + -4.0*t10*ddgxx33*r+8.0*t238*t239*t323+2.0*t170*t336*t339 & + -4.0*t237*t336*t339+2.0*t33*t35*t24 & + +4.0*t41*t42*t24+4.0*t47*t48*t50+4.0*t47*t54*t50 & + -2.0*t47*t76*t96-2.0*t47*t48*t96-2.0*t47*t54*t96 & + +2.0*t47*t59*t96-4.0*t47*t72*t50+4.0*t47*t76*t50+t1030+t973 & + +t915+t895+t774+t860+t1577+4.0*t785*t786+2.0*t1619*t1644 & + -4.0*t1634*t1648+8.0*t1651*t1652+t449*t611-2.0*t1660*t1652 & + +2.0*t1634*t1636+4.0*t1634*t1640-4.0*t1634*t1644 & + +2.0*t1516*t865+2.0*t168*t941-4.0*t19*t932+4.0*t19*t935 & + +2.0*t41*t171+2.0*t1510*t862-2.0*t1510*t865 & + -2.0*t1516*t862+4.0*t222*t327-2.0*t222*t330-2.0*t226*t333 & + -8.0*t238*t327+4.0*t238*t330+4.0*t366*t333-4.0*t233*t324 & + +t282*t285-2.0*t282*t287+4.0*t282*t290-2.0*t282*t293 & + +t296*t298-t282*t283+t222*t189+t226*t202+t226*t204 & + +4.0*t213*t215+8.0*t213*t219+t200*t204+t200*t202 & + +4.0*t24*t2093-4.0*t132*t2093-4.0*t453*t1949 & + -4.0*t458*t1952+4.0*t487*t1949+2.0*t458*t1932 & + -2.0*t487*t1690-2.0*t449*t1932-t487*t597 & + +2.0*t487*t600-6.0*t449*t603+2.0*t449*t606+4.0*t680*t696 & + -8.0*t671*t672-12.0*t537*t655+2.0*t537*t25-2.0*t537*t29 & + +12.0*t662*t664 & + +2.0*t449*t508-t449*t515+t449*t518-6.0*t487*t533 & + +t458*t515-t458*t518+t458*t520-t487*t501 & + +2.0*t487*t504-4.0*t458*t460+4.0*t438*t440 & + +12.0*t443*t445-t449*t451 & + -8.0*t138*t140-t1289*t1419+t1289*t1406-t1289*t1410 & + +2.0*t1289*t1428-2.0*t1289*t1434+t1488*t1440 & + -2.0*t1289*t1413+t1289*t1417+4.0*t1357*t1434 & + -2.0*t1362*t1434-2.0*t1379*t1440+2.0*t1379*t1444 & + +t1392*t1440-t1392*t1444+t1362*t1406-t1362*t1410 & + -4.0*t1357*t1428+2.0*t1362*t1428+2.0*t1320*t1322 & + -8.0*t321*t215+4.0*t1313*t1314 & + -4.0*t1317*t1314+2.0*t41*t121-2.0*t41*t125-8.0*t130*t133 & + -2.0*t998*t1795-4.0*t944*t1788 & + +2.0*t949*t1788+4.0*t944*t1795 & + -2.0*t949*t1795-2.0*t238*t189-2.0*t366*t202 & + -2.0*t366*t204-4.0*t944*t1245+2.0*t949*t1245+4.0*t944*t1249 & + -2.0*t949*t1249+4.0*t944*t1253-2.0*t949*t1253 & + +2.0*t998*t1245-2.0*t998*t1249-2.0*t998*t1253 & + +t998*t1256+2.0*t1191*t1134+2.0*t1191*t1138 & + -4.0*t5*ddgxy01-4.0*t10*ddgxy23 & + +2.0*t10*ddgyy22+2.0*t10*ddgxx33 & + -4.0*t19*t25+4.0*t19*t29+2.0*t816*t782-2.0*t1039*t786 & + -2.0*t1039*t789+4.0*t1044*t793+2.0*t1634*t1733 & + -4.0*t1634*t1741+8.0*t1708*t317+2.0*t1693*t404 & + +2.0*t1634*t1724-2.0*t811*t771+2.0*t811*t778-t998*t959 & + -4.0*t944*t979+2.0*t949*t979+4.0*t944*t985-2.0*t949*t985 & + -2.0*t614*t990-2.0*t614*t995-2.0*t998*t946+2.0*t998*t953 & + -2.0*t949*t970-t449*t923+2.0*t537*t932 & + -2.0*t537*t935+t453*t919-t453*t921+t458*t923-t487*t913 & + -t487*t919+t487*t921-4.0*t811*t813-4.0*t816*t818 & + +4.0*t785*t789+2.0*t614*t798-2.0*t614*t803-2.0*t614*t808 & + -4.0*t769*t778) & + /(-2.0*t2201*g33-2.0*t4*r-2.0*t796*r+t4*t21+t796*t21-2.0*t2201*t1203+4.0*t2201*t843+t4+t796)/Rmin/t21/4.0; + + t1 = g01*g01; + t3 = g23*g23; + t4 = t3*t3; + t5 = g01*t4; + t6 = dgy01*dgy01; + t9 = t1*t4; + t12 = g33*g33; + t13 = t1*g01; + t14 = t12*t13; + t15 = dgy22*dgy22; + t17 = g22*ddgxy23; + t18 = r*r; + t23 = ddgyr03*t18*Rmin; + t27 = Theta33*t18*Rmin; + t31 = dgy03*t18*Rmin; + t34 = g22*g22; + t35 = t1*t34; + t36 = t12*ddgyy01; + t41 = Theta33*r*Rmin; + t45 = dgy03*r*Rmin; + t48 = t3*g23; + t49 = t1*t48; + t50 = dgx01*dgy33; + t54 = dgy01*dgx33; + t58 = dgy01*dgy23; + t78 = t1*g22; + t79 = t12*dgx01; + t83 = 2.0*t5*t6-4.0*t9*ddgyy01+t14*t15+4.0*t14*t17*t18+4.0*t9*t23+4.0*t9*t27 & + -8.0*t9*t31-4.0*t35*t36*t18-4.0*t9*t41+8.0*t9*t45+2.0*t49*t50*t18 & + -2.0*t49*t54*t18+4.0*t49*t58*t18+8.0*t35*t36*r-4.0*t49*t50*r & + +4.0*t49*t54*r-8.0*t49*t58*r+2.0*t35*g33*dgy01*dgy33-2.0*t78*t79*dgx33; + t87 = t3*g33; + t95 = t1*g33; + t96 = t3*dgx01; + t103 = dg03*dg03; + t104 = t18*t18; + t105 = t104*t18; + t107 = Rmin*Rmin; + t108 = t103*t105*t107; + t111 = t104*r; + t113 = t103*t111*t107; + t117 = t103*t104*t107; + t120 = g01*t34; + t121 = t12*t6; + t128 = g01*g22; + t133 = ddgyr03*t104*Rmin; + t136 = t18*r; + t138 = ddgyr03*t136*Rmin; + t144 = g22*ddgyy22; + t151 = g22*ddgxx33; + t158 = dgx33*dgx22; + t161 = dgy23*dgx22; + t165 = 4.0*t78*t79*dgy23+8.0*t78*t87*ddgyy01-2.0*t78*t3*dgy01*dgy33+2.0*t95*t96*dgx33 & + -4.0*t95*t96*dgy23-2.0*t5*t108+4.0*t5*t113-2.0*t5*t117+2.0*t120*t121*t18 & + -4.0*t120*t121*r-4.0*t128*t87*t6+4.0*t9*t133-8.0*t9*t138-8.0*t14*t17*r & + -2.0*t14*t144*t18+4.0*t14*t144*r-2.0*t14*t151*t18+4.0*t14*t151*r+t14*t158*t18-2.0*t14*t161*t18; + t173 = g33*t13; + t174 = t3*ddgxy23; + t181 = t3*ddgyy22; + t188 = t3*ddgxx33; + t195 = g23*dgx33; + t212 = dgx33*dgx33; + t213 = g22*t212; + t219 = g22*dgy33; + t225 = t111*t107; + t226 = t225*t128; + t227 = g23*g02; + t228 = dg33*dg33; + t230 = t227*g03*t228; + t233 = g03*g03; + t235 = dg33*dg23; + t236 = g23*t233*t235; + t239 = g01*g33; + t240 = t225*t239; + t241 = g02*g02; + t243 = g23*t241*t235; + t246 = -2.0*t14*t158*r+4.0*t14*t161*r-4.0*t173*t174*t18+8.0*t173*t174*r+2.0*t173*t181*t18 & + -4.0*t173*t181*r+2.0*t173*t188*t18-4.0*t173*t188*r-t173*t195*dgy22 & + +t173*g23*dgy33*dgx22-2.0*t173*t195*dgx23+4.0*t173*g23*dgx23*dgy23-2.0*t173*g23*dgy23*dgy22+t173*t213*t18 & + -2.0*t173*t213*r-2.0*t173*t219*dgx23+t173*t219*dgy22+4.0*t226*t230+4.0*t226*t236+4.0*t240*t243; + t247 = g01*t3; + t249 = g02*g03; + t250 = t249*t235; + t253 = g22*g33; + t254 = t225*t253; + t255 = g00*t3; + t256 = dg01*dg33; + t257 = t255*t256; + t260 = t104*t107; + t261 = t260*t128; + t262 = g00*ddg33; + t263 = t87*t262; + t270 = t260*t239; + t276 = t260*t253; + t279 = t105*t107; + t280 = t279*t128; + t283 = t12*g01; + t284 = t136*t107; + t285 = t283*t284; + t287 = g00*dg23; + t288 = g22*g23*t287; + t291 = Rmin*t104; + t292 = t95*t291; + t293 = g22*g03; + t294 = dgx33*dg23; + t295 = t293*t294; + t298 = dgy33*dg22; + t299 = t293*t298; + t301 = Rmin*t136; + t302 = t95*t301; + t307 = Rmin*t18; + t308 = t95*t307; + t312 = t291*t78; + t314 = g23*g03; + t315 = g33*ddgyr23*t314; + t319 = g33*ddgxr33*t314; + t322 = t1*g23; + t323 = t291*t322; + t324 = g33*g02; + t325 = t294*t324; + t328 = dg33*dg22; + t329 = t255*t328; + t331 = -8.0*t225*t247*t250-8.0*t254*t257-4.0*t261*t263-2.0*t261*t230-2.0*t261*t236-2.0*t270*t243 & + +4.0*t260*t247*t250+4.0*t276*t257-4.0*t280*t263-4.0*t285*t288 & + +2.0*t292*t295-t292*t299-4.0*t302*t295+2.0*t302*t299+2.0*t308*t295-t308*t299 & + +4.0*t312*t315-4.0*t312*t319+2.0*t323*t325-t270*t329; + t334 = t239*t279; + t336 = g22*t233*t328; + t344 = dg33*dgx22; + t345 = t314*t344; + t347 = t128*t87; + t348 = g03*dg03; + t349 = t348*t260; + t352 = dg00*dg33; + t353 = t352*t260; + t356 = g33*g23; + t357 = t128*t356; + t358 = t233*dg23; + t363 = t239*t3*g02; + t364 = dg02*dg33; + t365 = t364*t260; + t368 = dg23*dg03; + t369 = t368*t260; + t372 = t78*t356; + t373 = dg02*dgy33; + t377 = Theta33*dg23; + t381 = dg33*Theta23; + t385 = dg33*dgx03; + t389 = dg33*dgy02; + t393 = dgx33*dg03; + t397 = dgy23*dg03; + t403 = -t334*t336-t334*t329+2.0*t240*t336+2.0*t240*t329-t270*t336+t292*t345 & + -8.0*t347*t349-4.0*t347*t353+4.0*t357*t358*t260+4.0*t363*t365-4.0*t363*t369 & + -4.0*t372*t373*t301+4.0*t372*t377*t301+4.0*t372*t381*t301-4.0*t372*t385*t301 & + +4.0*t372*t389*t301+4.0*t372*t393*t301-8.0*t372*t397*t301-2.0*t302*t345; + t405 = dg33*dgx23; + t406 = t293*t405; + t409 = dg33*dgy22; + t410 = t293*t409; + t412 = t227*t405; + t428 = g22*g00*t328; + t433 = t283*t260; + t437 = g02*dg22; + t438 = t437*t314; + t442 = dgx33*dg22*t314; + t445 = dgy23*dg22*t314; + t448 = t301*t78; + t451 = t307*t78; + t456 = t308*t345-2.0*t292*t406+t292*t410+2.0*t292*t412+4.0*t302*t406-2.0*t302*t410-4.0*t302*t412 & + -2.0*t308*t406+t308*t410+2.0*t308*t412+t283*t279*t428 & + -2.0*t283*t225*t428+4.0*t433*t288+t433*t428+4.0*t433*t438+t292*t442 & + -2.0*t292*t445-8.0*t448*t315+4.0*t451*t315+8.0*t448*t319; + t460 = t301*t322; + t463 = t298*t324; + t466 = t307*t322; + t470 = t409*t324; + t474 = dg23*dgy23*t324; + t480 = dg33*dgx33; + t481 = t480*t324; + t484 = t480*t314; + t487 = dgy33*dg23; + t488 = t487*t324; + t491 = t487*t314; + t508 = -4.0*t451*t319-4.0*t460*t325+2.0*t460*t463+2.0*t466*t325-t466*t463 & + -2.0*t460*t470+8.0*t460*t474+t466*t470-4.0*t466*t474+4.0*t448*t481-4.0*t448*t484 & + -4.0*t448*t488+4.0*t448*t491-2.0*t451*t481+2.0*t451*t484+2.0*t451*t488 & + -2.0*t451*t491-4.0*t285*t438-2.0*t302*t442+4.0*t302*t445; + t514 = g03*dgy23; + t539 = g02*dgy33; + t540 = r*Rmin; + t544 = g03*dgx33; + t563 = t279*t253; + t566 = t308*t442-2.0*t308*t445+8.0*t226*t263-12.0*t372*t514*t307+2.0*t372*t373*t307 & + -2.0*t372*t377*t307-2.0*t372*t381*t307+2.0*t372*t385*t307-2.0*t372*t389*t307 & + -2.0*t372*t393*t307+4.0*t372*t397*t307+6.0*t372*t539*t540-2.0*t372*t544*t540 & + +12.0*t372*t514*t540+2.0*t372*t373*t291-2.0*t280*t230-2.0*t280*t236 & + -2.0*t334*t243+4.0*t279*t247*t250+4.0*t563*t257; + t570 = g00*dg33; + t574 = g22*t12; + t576 = g03*dg01; + t577 = t227*t576; + t613 = t12*g23; + t614 = t128*t613; + t615 = g02*dg03; + t616 = t615*t284; + t619 = g03*dg02; + t620 = t619*t284; + t624 = t128*t12*g02; + t625 = g03*dg23; + t629 = -8.0*t226*t87*t570+8.0*t260*t574*t577-8.0*t284*t574*t577-t323*t463+t323*t470 & + -4.0*t323*t474-2.0*t312*t481+2.0*t312*t484+2.0*t312*t488-2.0*t312*t491 & + -2.0*t372*t377*t291-2.0*t372*t381*t291+2.0*t372*t385*t291-2.0*t372*t389*t291 & + -2.0*t372*t393*t291+4.0*t372*t397*t291+8.0*t614*t616+8.0*t614*t620+8.0*t624*t625*t284; + t630 = t570*t284; + t633 = t348*t284; + t639 = t18*t107; + t640 = t249*t639; + t643 = t364*t279; + t646 = t368*t279; + t649 = t352*t279; + t656 = t364*t225; + t659 = t368*t225; + t662 = t352*t225; + t669 = t615*t260; + t672 = t619*t260; + t682 = t570*t260; + t685 = -18.0*t347*t630+8.0*t347*t633-4.0*t357*t358*t284+24.0*t614*t640 & + -4.0*t624*t643+4.0*t624*t646-4.0*t347*t649+4.0*t363*t643-4.0*t363*t646+8.0*t624*t656 & + -8.0*t624*t659+8.0*t347*t662-8.0*t363*t656+8.0*t363*t659-8.0*t614*t669-8.0*t614*t672 & + -8.0*t624*t625*t260-4.0*t624*t365+4.0*t624*t369+26.0*t347*t682; + t732 = -6.0*t372*t539*t307+2.0*t372*t544*t307+8.0*t9*ddgyy01*r & + -4.0*t35*t36+2.0*t49*t50-2.0*t49*t54+4.0*t49*t58+2.0*t5*t6*t18-4.0*t5*t6*r+2.0*t120*t121 & + +4.0*t14*t17-2.0*t14*t144-2.0*t14*t151+t14*t15*t18-2.0*t14*t15*r+t14*t158 & + -2.0*t14*t161-4.0*t173*t174+2.0*t173*t181+2.0*t173*t188; + t737 = t78*t3; + t738 = dgy01*dgy33; + t739 = t738*r; + t742 = t95*t3; + t743 = dgx01*dgx33; + t744 = t743*r; + t747 = dgx01*dgy23; + t748 = t747*r; + t751 = t78*g33; + t752 = g23*dgx01; + t756 = g23*dgy01; + t764 = t12*t1*Rmin; + t765 = t18*t3; + t769 = t12*g33; + t771 = t769*t1*Rmin; + t772 = r*g22; + t776 = r*t3; + t781 = g00*dg01; + t782 = t781*dg33; + t785 = t260*g01; + t787 = t34*t233*t228; + t789 = t4*g00; + t790 = t789*ddg33; + t796 = t279*g01; + t803 = t225*g01; + t807 = t260*t34; + t809 = t769*g00*dg01; + t812 = t173*t213-4.0*t9*ddgyy01*t18+4.0*t737*t739-4.0*t742*t744+8.0*t742*t748 & + -2.0*t751*t752*dgy33+2.0*t751*t756*dgx33-4.0*t751*t756*dgy23+4.0*t764*t765*dgx02 & + +4.0*t771*t772*dgx02-4.0*t764*t776*dgx02+4.0*t225*t4*t782+t785*t787 & + +2.0*t785*t790-2.0*t260*t4*t782+t796*t787+2.0*t796*t790-2.0*t279*t4*t782+4.0*t803*t789*dg33+4.0*t807*t809; + t816 = t12*t233*dg01; + t819 = t260*g22; + t820 = t769*t241; + t821 = t820*dg01; + t825 = t3*t241; + t826 = t825*dg01; + t829 = t260*g33; + t830 = t789*dg01; + t833 = t284*t34; + t838 = dg33*t49; + t851 = t49*dgx33; + t853 = dg03*t18*Rmin; + t856 = t49*dgy23; + t859 = t35*t12; + t864 = t35*g33; + t865 = t738*t18; + t868 = t78*t12; + t869 = t743*t18; + t872 = t747*t18; + t875 = t3*ddgyy01; + t883 = -4.0*t807*t816-4.0*t819*t821+4.0*t260*t12*t826+4.0*t829*t830-4.0*t833*t809+4.0*t833*t816 & + +2.0*t838*Theta23*t18*Rmin-2.0*t838*dgx03*t18*Rmin & + +2.0*t838*dgy02*t18*Rmin+2.0*t851*t853-4.0*t856*t853-6.0*t859*t41+12.0*t859*t45+2.0*t864*t865 & + -2.0*t868*t869+4.0*t868*t872+8.0*t751*t875*t18-2.0*t737*t865+2.0*t742*t869; + t886 = t49*g02; + t887 = dgy33*r; + t891 = t49*g03; + t892 = dgx33*r; + t896 = dgy23*r; + t910 = t173*g23; + t911 = dgx33*dgx23; + t915 = dgx23*dgy23; + t919 = dgy23*dgy22; + t923 = t173*g22; + t924 = dgy33*dgx23; + t928 = dgy33*dgy22; + t937 = dgx33*dgy22; + t940 = dgy33*dgx22; + t952 = -4.0*t742*t872-4.0*t886*t887*Rmin+4.0*t891*t892*Rmin-8.0*t891*t896*Rmin & + -4.0*t864*t739+4.0*t868*t744-2.0*t771*t772*Theta22+2.0*t764*t776*Theta22 & + +4.0*t910*t911*r-8.0*t910*t915*r+4.0*t910*t919*r-2.0*t923*t924*t18+t923*t928*t18 & + +4.0*t923*t924*r-2.0*t923*t928*r-t910*t937*t18+t910*t940*t18+2.0*t910*t937*r & + -2.0*t910*t940*r-2.0*t910*t911*t18; + t960 = t95*Rmin; + t961 = r*t48; + t971 = t18*t48; + t981 = t18*g22; + t988 = t291*t1; + t990 = t48*ddgyr23*g03; + t994 = t48*ddgxr33*g03; + t997 = t3*t233; + t998 = dg23*dg23; + t999 = t997*t998; + t1004 = t284*g01; + t1005 = t820*dg22; + t1008 = t301*t1; + t1011 = t307*t1; + t1020 = 4.0*t910*t915*t18-2.0*t910*t919*t18-4.0*t960*t961*Theta23 & + +4.0*t960*t961*dgx03+4.0*t960*t961*dgy02+4.0*t960*t971*Theta23-4.0*t960*t971*dgx03 & + -4.0*t960*t971*dgy02+2.0*t771*t981*Theta22-2.0*t764*t765*Theta22 & + -4.0*t988*t990+4.0*t988*t994+4.0*t803*t999-2.0*t785*t999+2.0*t1004*t1005+8.0*t1008*t990 & + -4.0*t1011*t990-8.0*t1008*t994+4.0*t1011*t994-2.0*t796*t999; + t1023 = t18*g02; + t1051 = t284*g22; + t1057 = t284*g33; + t1064 = dg03*t104; + t1065 = t1064*Rmin; + t1072 = t49*dg02; + t1077 = t49*Theta33; + t1086 = -2.0*t785*t1005+2.0*t771*t1023*dgx22-2.0*t771*r*g02*dgx22-4.0*t771*t981*dgx02-8.0*t868*t748 & + -16.0*t751*t875*r+2.0*t838*Theta23*t104*Rmin & + -2.0*t838*dgx03*t104*Rmin+2.0*t838*dgy02*t104*Rmin & + +4.0*t1051*t821-4.0*t284*t12*t826-4.0*t1057*t830-2.0*t803*t787 & + -4.0*t803*t790+2.0*t851*t1065-4.0*t856*t1065 & + -8.0*t859*t138+4.0*t1072*dgy33*t136*Rmin-4.0*t1077*dg23*t136*Rmin-4.0*t838*Theta23*t136*Rmin; + t1100 = dg03*t136*Rmin; + t1111 = dgy33*t18; + t1112 = t1111*Rmin; + t1115 = dgx33*t18; + t1119 = dgy23*t18; + t1125 = t120*t12; + t1128 = t5*dg00; + t1130 = dg33*t105*t107; + t1136 = dg33*t111*t107; + t1139 = t120*t769; + t1141 = dg00*t104*t107; + t1146 = t239*t4; + t1149 = t5*g00; + t1151 = dg33*t104*t107; + t1154 = 4.0*t838*dgx03*t136*Rmin-4.0*t838*dgy02*t136*Rmin-4.0*t851*t1100+8.0*t856*t1100 & + +4.0*t859*t23+6.0*t859*t27-12.0*t859*t31+4.0*t886*t1112 & + -4.0*t891*t1115*Rmin+8.0*t891*t1119*Rmin-2.0*t1072*t1112-2.0*t1125*t108 & + +2.0*t1128*t1130+4.0*t1125*t113-4.0*t1128*t1136-4.0*t1139*t1141 & + -2.0*t1125*t117-4.0*t1146*t1141-12.0*t1149*t1151; + t1158 = dg00*t136*t107; + t1164 = dg33*t136*t107; + t1168 = g00*t18*t107; + t1175 = t128*t769; + t1177 = t241*t18*t107; + t1180 = t283*t3; + t1185 = t128*g33; + t1186 = t3*t6; + t1208 = t227*t576*dg33; + t1212 = t356*t570*dg23; + t1216 = t356*t249*ddg33; + t1223 = 2.0*t1128*t1151+4.0*t1139*t1158+4.0*t1146*t1158+8.0*t1149*t1164 & + +12.0*t1139*t1168-12.0*t1125*t233*t18*t107-12.0*t1175*t1177+12.0*t1180*t1177 & + +12.0*t1146*t1168-4.0*t1185*t1186*t18+8.0*t1185*t1186*r+2.0*t1077*dg23*t18*Rmin & + +4.0*t859*t133-2.0*t1072*dgy33*t104*Rmin+2.0*t1077*dg23*t104*Rmin & + +8.0*t254*t1208+2.0*t261*t1212+4.0*t261*t1216-4.0*t276*t1208+2.0*t280*t1212; + t1232 = g02*dg33*dg22*g23*g03; + t1276 = t241*ddg33; + t1277 = t87*t1276; + t1281 = t48*g00*t235; + t1284 = t48*g02; + t1286 = t1284*g03*ddg33; + t1290 = t12*g00*t256; + t1293 = 4.0*t280*t1216-4.0*t563*t1208+4.0*t240*t1232-2.0*t270*t1232-2.0*t334*t1232 & + +4.0*t357*t619*t1130-4.0*t357*t625*dg03*t105*t107-8.0*t357*t619*t1136 & + +8.0*t357*t625*dg03*t111*t107-20.0*t357*t249*t1151+4.0*t357*t619*t1151 & + -4.0*t357*t625*t1064*t107+12.0*t357*t249*t1164+8.0*t226*t356*t249*dg33-4.0*t226*t1212 & + -8.0*t226*t1216+2.0*t785*t1277-2.0*t785*t1281-4.0*t785*t1286-2.0*t807*t1290; + t1295 = g33*t233*t256; + t1298 = t12*t241; + t1299 = t1298*t256; + t1302 = t997*t256; + t1305 = t825*t256; + t1309 = t249*t256; + t1313 = t12*t3*t781; + t1317 = t87*t233*dg01; + t1320 = t1284*t576; + t1323 = t3*g22; + t1324 = t233*dg33; + t1325 = t1323*t1324; + t1328 = t241*dg33; + t1332 = g03*dgy33; + t1333 = t1332*t540; + t1336 = g02*dgx33; + t1337 = t1336*t540; + t1340 = g02*dgy23; + t1341 = t1340*t540; + t1344 = t3*Theta33; + t1348 = t3*dgy03; + t1365 = 2.0*t807*t1295+2.0*t819*t1299-2.0*t819*t1302-2.0*t829*t1305+4.0*t260*t48*t1309 & + -8.0*t819*t1313+4.0*t819*t1317-8.0*t829*t1320+4.0*t803*t1325 & + +4.0*t803*t87*t1328-6.0*t864*t1333+6.0*t868*t1337-12.0*t868*t1341+10.0*t751*t1344*t540 & + -20.0*t751*t1348*t540-2.0*t751*t752*t1111+2.0*t751*t756*t1115 & + -4.0*t751*t756*t1119+4.0*t737*t1333-8.0*t742*t1337; + t1381 = dgy33*dg03; + t1382 = t1381*t307; + t1385 = t3*ddgyr03; + t1389 = Theta33*dg33; + t1390 = t1389*t291; + t1393 = t1381*t291; + t1396 = dg02*dgx33; + t1397 = t1396*t291; + t1400 = dg02*dgy23; + t1401 = t1400*t291; + t1404 = Theta23*dg23; + t1405 = t1404*t291; + t1408 = dg23*dgx03; + t1409 = t1408*t291; + t1412 = t1389*t301; + t1415 = t1381*t301; + t1418 = t1396*t301; + t1421 = t1400*t301; + t1424 = t1404*t301; + t1427 = t1408*t301; + t1430 = 8.0*t742*t1341+4.0*t751*t752*t887-4.0*t751*t756*t892+8.0*t751*t756*t896 & + +2.0*t1125*t649+2.0*t737*t1382-8.0*t751*t1385*t291-2.0*t737*t1390+2.0*t737*t1393 & + -2.0*t742*t1397+4.0*t742*t1401-4.0*t742*t1405+4.0*t742*t1409-4.0*t864*t1412 & + +4.0*t864*t1415-4.0*t868*t1418+8.0*t868*t1421-8.0*t868*t1424+8.0*t868*t1427; + t1436 = t1336*t307; + t1439 = t1340*t307; + t1442 = t1396*t307; + t1445 = t1400*t307; + t1448 = t1404*t307; + t1453 = t1332*t307; + t1456 = t1389*t307; + t1471 = t1408*t307; + t1477 = g03*dgx23; + t1481 = g03*dgy22; + t1485 = 16.0*t751*t1385*t301+4.0*t737*t1412+8.0*t742*t1436-8.0*t742*t1439-2.0*t742*t1442 & + +4.0*t742*t1445-4.0*t742*t1448-8.0*t742*t1427+6.0*t864*t1453 & + +2.0*t864*t1456-2.0*t864*t1382-6.0*t868*t1436+12.0*t868*t1439 & + +2.0*t868*t1442-4.0*t868*t1445+4.0*t868*t1448-4.0*t868*t1471 & + -8.0*t751*t1385*t307-4.0*t764*t772*t1477+2.0*t764*t772*t1481; + t1487 = r*g23; + t1488 = dgx23*g02; + t1493 = t12*dgx33*t437; + t1496 = t12*dgy23*t437; + t1500 = t3*ddgyr23*t324; + t1504 = t3*ddgxr33*t324; + t1507 = t1298*t328; + t1509 = t997*t328; + t1513 = t613*t241*dg23; + t1516 = t233*dg22; + t1517 = t87*t1516; + t1521 = t574*ddgyr23*g02; + t1527 = t574*ddgxr33*g02; + t1540 = t34*g33; + t1541 = t1540*t1324; + t1550 = 4.0*t764*t1487*t1488-t988*t1493+2.0*t988*t1496+4.0*t988*t1500-4.0*t988*t1504+t796*t1507+2.0*t796*t1509 & + +4.0*t785*t1513-4.0*t785*t1517+8.0*t1008*t1521 & + -4.0*t1011*t1521-8.0*t1008*t1527-10.0*t751*t1344*t307+20.0*t751*t1348*t307-4.0*t737*t1453 & + -2.0*t737*t1456-6.0*t1004*t1541+8.0*t1004*t1325+8.0*t1051*t1313-4.0*t1051*t1317; + t1553 = t3*t103; + t1557 = g01*t48; + t1558 = t1557*g03; + t1578 = g02*dg02; + t1579 = t1578*t260; + t1582 = t128*t12; + t1583 = t3*dg00; + t1587 = t1328*t260; + t1595 = t239*t48; + t1600 = t239*t3; + t1603 = t1557*g02; + t1604 = g03*dg33; + t1608 = 8.0*t1057*t1320+4.0*t1185*t1553*t279-4.0*t1558*t643+4.0*t1558*t646-4.0*t1125*t662 & + -8.0*t1185*t1553*t225+8.0*t1558*t656-8.0*t1558*t659-14.0*t1125*t682 & + +8.0*t1125*t349+2.0*t1125*t353+8.0*t1175*t1579+8.0*t1582*t1583*t260+14.0*t1582*t1587 & + +4.0*t1185*t1553*t260-8.0*t1180*t1579+8.0*t1595*t669+8.0*t1595*t672-16.0*t1600*t1587+24.0*t1603*t1604*t260; + t1620 = t1578*t284; + t1626 = t1328*t284; + t1656 = -4.0*t1558*t365+4.0*t1558*t369+10.0*t1125*t630-8.0*t1125*t633-8.0*t1175*t1620-8.0*t1582*t1583*t284 & + -10.0*t1582*t1626+8.0*t1180*t1620-8.0*t1595*t616 & + -8.0*t1595*t620+12.0*t1600*t1626-16.0*t1603*t1604*t284-24.0*t1582*t255*t639 & + +12.0*t1185*t997*t639-24.0*t1595*t640+2.0*t864*t1390-2.0*t864*t1393+2.0*t868*t1397-4.0*t868*t1401; + t1661 = g00*t998; + t1662 = t87*t1661; + t1665 = t18*g23; + t1666 = dgy22*g02; + t1673 = g23*Theta23; + t1677 = g23*dgx03; + t1681 = g23*dgy02; + t1685 = g22*t136; + t1686 = dg33*Theta22; + t1692 = t104*g22; + t1693 = dg33*dgx02; + t1717 = t34*t12; + t1718 = t1717*t262; + t1721 = g00*t228; + t1722 = t1540*t1721; + t1724 = 4.0*t868*t1405-4.0*t868*t1409+2.0*t785*t1662-2.0*t764*t1665*t1666+2.0*t764*t1487*t1666 & + -4.0*t764*t981*t1673+4.0*t764*t981*t1677+4.0*t764*t981*t1681 & + +2.0*t764*t1685*t1686-t764*t981*t1686+2.0*t764*t1692*t1693-4.0*t764*t1685*t1693 & + +2.0*t764*t981*t1693-t764*t1692*t1686+4.0*t764*t772*t1673-4.0*t764*t772*t1677 & + -4.0*t764*t772*t1681-8.0*t803*t1284*t1604+2.0*t796*t1718-t796*t1722; + t1726 = t233*ddg33; + t1727 = t1540*t1726; + t1730 = t574*t1661; + t1733 = t574*t1276; + t1737 = t253*t241*t228; + t1740 = t253*t233*t998; + t1743 = t1323*t1721; + t1745 = t1323*t1726; + t1756 = t279*t34; + t1761 = t279*g22; + t1780 = -2.0*t796*t1727-2.0*t796*t1730-2.0*t796*t1733+t796*t1737+2.0*t796*t1740+t796*t1743 & + +2.0*t796*t1745+2.0*t796*t1662+2.0*t796*t1277-2.0*t796*t1281 & + -4.0*t796*t1286-2.0*t1756*t1290+2.0*t1756*t1295+2.0*t1761*t1299-2.0*t1761*t1302 & + -2.0*t279*g33*t1305+4.0*t279*t48*t1309+4.0*t803*t1717*t570-4.0*t803*t1541-4.0*t803*t574*t1328; + t1807 = t225*t34; + t1812 = t225*g22; + t1825 = -4.0*t803*t1718+2.0*t803*t1722+4.0*t803*t1727+4.0*t803*t1730+4.0*t803*t1733 & + -2.0*t803*t1737-4.0*t803*t1740-2.0*t803*t1743-4.0*t803*t1745-4.0*t803*t1662 & + -4.0*t803*t1277+4.0*t803*t1281+8.0*t803*t1286+4.0*t1807*t1290-4.0*t1807*t1295 & + -4.0*t1812*t1299+4.0*t1812*t1302+4.0*t225*g33*t1305-8.0*t225*t48*t1309+2.0*t785*t1718; + t1845 = t136*t3; + t1846 = Theta33*dg22; + t1852 = t769*g01; + t1854 = t107*g22; + t1855 = g00*dg22; + t1856 = t1854*t1855; + t1859 = t283*t104; + t1860 = t1854*t1516; + t1864 = t107*t3*t1855; + t1869 = t107*t48*t287; + t1875 = t104*t3; + t1888 = g03*dgx22; + t1894 = -4.0*t737*t1415+4.0*t742*t1418-8.0*t742*t1421+8.0*t742*t1424+4.0*t764*t981*t1477 & + -2.0*t764*t981*t1481-4.0*t764*t1665*t1488-2.0*t960*t1845*t1846 & + +t960*t765*t1846-2.0*t1852*t104*t1856+2.0*t1859*t1860+2.0*t1859*t1864 & + -4.0*t239*t104*t1869+4.0*t239*t136*t1869+t960*t1875*t1686-2.0*t960*t1845*t1686 & + -t764*t104*g02*t344+2.0*t764*t136*g02*t344-2.0*t764*t1665*t1888-t764*t1023*t344; + t1901 = t3*dgx33*t625; + t1906 = t3*dgy33*dg22*g03; + t1914 = t3*dg33*t1481; + t1918 = t3*dg23*t514; + t1944 = 2.0*t764*t1487*t1888+4.0*t1011*t1527+8.0*t1008*t1901-4.0*t1008*t1906 & + -4.0*t1011*t1901+2.0*t1011*t1906+4.0*t1008*t1914-8.0*t1008*t1918-2.0*t1011*t1914 & + +4.0*t1011*t1918+2.0*t1008*t1493-4.0*t1008*t1496-t1011*t1493+2.0*t1011*t1496 & + -8.0*t1008*t1500+4.0*t1011*t1500+8.0*t1008*t1504-4.0*t1011*t1504-2.0*t803*t1507-4.0*t803*t1509; + t1956 = t283*t136; + t1988 = t785*t1507+2.0*t785*t1509-4.0*t1004*t1513+4.0*t1004*t1517+2.0*t1852*t136*t1856 & + -2.0*t1956*t1860-2.0*t1956*t1864+4.0*t960*t765*t1481-4.0*t960*t776*t1481 & + -4.0*t988*t1521+4.0*t988*t1527-4.0*t988*t1901+2.0*t988*t1906-2.0*t988*t1914 & + +4.0*t988*t1918-t785*t1722-2.0*t785*t1727+10.0*t785*t1541-2.0*t785*t1730-2.0*t785*t1733; + t1997 = dg22*dgy03; + t2038 = t785*t1737+2.0*t785*t1740+t785*t1743+2.0*t785*t1745-12.0*t785*t1325+2.0*t764*t1692*t1997 & + -4.0*t764*t1685*t1997+2.0*t764*t981*t1997-t764*t1692*t1846 & + +2.0*t764*t1685*t1846-t764*t981*t1846+t960*t765*t1686-2.0*t960*t1875*t1693 & + +4.0*t960*t1845*t1693-2.0*t960*t765*t1693-2.0*t960*t1875*t1997+4.0*t960*t1845*t1997 & + -2.0*t960*t765*t1997+t960*t1875*t1846+4.0*t742*t1471; + Theta33_rhs = 1/t1 & + *(t2038+t83+t1988+t1944+t1894+t1825+t1430+t1365+t812+t566+t508+t1550+t685+t629 & + +t456+t403+t1086+t1020+t1223+t1154+t1485+t1293+t331+t246+t165 & + +t1780+t1608+t952+t883+t1724+t1656+t732) / & + (4.0*t1323*g33*r-2.0*t1323*g33*t18-2.0*t1323*g33-2.0*t4*r-2.0*t1717*r+t4*t18+t1717*t18+t4+t1717)/Rmin/t18/4.0; + + return + +end subroutine Theta_rhs2 +!--------------------------------------------------------------------------------- +subroutine pg0a_rhs(Rmin,r,p02,p03,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01, & + dg01,dg02,dg03, & + dgx01,dgx22,dgx23,dgx33, & + dgy01,dgy22,dgy23,dgy33, & + ddgxr01,ddgxr22,ddgxr23,ddgxr33, & + ddgyr01,ddgyr22,ddgyr23,ddgyr33, & + g02_rhs,g03_rhs,p02_rhs,p03_rhs) + + implicit none + +!~~~~~~% Input parameters: + real*8,intent(in) :: Rmin,r,p02,p03,g02,g03,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01 + real*8,intent(in) :: dg01,dg02,dg03 + real*8,intent(in) :: dgx01,dgx22,dgx23,dgx33 + real*8,intent(in) :: dgy01,dgy22,dgy23,dgy33 + real*8,intent(in) :: ddgxr01,ddgxr22,ddgxr23,ddgxr33 + real*8,intent(in) :: ddgyr01,ddgyr22,ddgyr23,ddgyr33 + real*8,intent(out) :: g02_rhs,g03_rhs,p02_rhs,p03_rhs + + real*8 :: t1; + real*8 :: t10; + real*8 :: t100; + real*8 :: t101; + real*8 :: t104; + real*8 :: t105; + real*8 :: t108; + real*8 :: t11; + real*8 :: t110; + real*8 :: t112; + real*8 :: t117; + real*8 :: t118; + real*8 :: t123; + real*8 :: t125; + real*8 :: t126; + real*8 :: t129; + real*8 :: t130; + real*8 :: t132; + real*8 :: t136; + real*8 :: t14; + real*8 :: t141; + real*8 :: t142; + real*8 :: t143; + real*8 :: t150; + real*8 :: t151; + real*8 :: t155; + real*8 :: t158; + real*8 :: t16; + real*8 :: t161; + real*8 :: t162; + real*8 :: t167; + real*8 :: t168; + real*8 :: t17; + real*8 :: t172; + real*8 :: t177; + real*8 :: t179; + real*8 :: t185; + real*8 :: t186; + real*8 :: t190; + real*8 :: t191; + real*8 :: t192; + real*8 :: t196; + real*8 :: t2; + real*8 :: t20; + real*8 :: t202; + real*8 :: t203; + real*8 :: t21; + real*8 :: t213; + real*8 :: t216; + real*8 :: t22; + real*8 :: t220; + real*8 :: t221; + real*8 :: t224; + real*8 :: t225; + real*8 :: t23; + real*8 :: t230; + real*8 :: t231; + real*8 :: t234; + real*8 :: t235; + real*8 :: t243; + real*8 :: t250; + real*8 :: t255; + real*8 :: t256; + real*8 :: t26; + real*8 :: t260; + real*8 :: t261; + real*8 :: t264; + real*8 :: t265; + real*8 :: t269; + real*8 :: t27; + real*8 :: t272; + real*8 :: t275; + real*8 :: t279; + real*8 :: t283; + real*8 :: t292; + real*8 :: t30; + real*8 :: t302; + real*8 :: t304; + real*8 :: t309; + real*8 :: t31; + real*8 :: t310; + real*8 :: t315; + real*8 :: t316; + real*8 :: t317; + real*8 :: t32; + real*8 :: t320; + real*8 :: t327; + real*8 :: t328; + real*8 :: t329; + real*8 :: t339; + real*8 :: t342; + real*8 :: t345; + real*8 :: t353; + real*8 :: t36; + real*8 :: t363; + real*8 :: t374; + real*8 :: t378; + real*8 :: t381; + real*8 :: t39; + real*8 :: t392; + real*8 :: t394; + real*8 :: t398; + real*8 :: t401; + real*8 :: t403; + real*8 :: t406; + real*8 :: t410; + real*8 :: t415; + real*8 :: t43; + real*8 :: t430; + real*8 :: t431; + real*8 :: t433; + real*8 :: t434; + real*8 :: t436; + real*8 :: t44; + real*8 :: t442; + real*8 :: t445; + real*8 :: t448; + real*8 :: t45; + real*8 :: t451; + real*8 :: t453; + real*8 :: t459; + real*8 :: t462; + real*8 :: t464; + real*8 :: t466; + real*8 :: t469; + real*8 :: t475; + real*8 :: t48; + real*8 :: t483; + real*8 :: t487; + real*8 :: t49; + real*8 :: t492; + real*8 :: t496; + real*8 :: t499; + real*8 :: t514; + real*8 :: t518; + real*8 :: t530; + real*8 :: t541; + real*8 :: t544; + real*8 :: t56; + real*8 :: t568; + real*8 :: t58; + real*8 :: t594; + real*8 :: t6; + real*8 :: t67; + real*8 :: t69; + real*8 :: t7; + real*8 :: t71; + real*8 :: t73; + real*8 :: t77; + real*8 :: t8; + real*8 :: t80; + real*8 :: t81; + real*8 :: t82; + real*8 :: t86; + real*8 :: t87; + real*8 :: t89; + real*8 :: t9; + real*8 :: t93; + real*8 :: t94; + real*8 :: t97; + real*8 :: t98; + real*8 :: t99; + + real*8 :: t111; + real*8 :: t115; + real*8 :: t12; + real*8 :: t121; + real*8 :: t13; + real*8 :: t133; + real*8 :: t134; + real*8 :: t137; + real*8 :: t139; + real*8 :: t140; + real*8 :: t144; + real*8 :: t147; + real*8 :: t148; + real*8 :: t15; + real*8 :: t153; + real*8 :: t164; + real*8 :: t170; + real*8 :: t18; + real*8 :: t182; + real*8 :: t188; + real*8 :: t19; + real*8 :: t193; + real*8 :: t197; + real*8 :: t206; + real*8 :: t215; + real*8 :: t222; + real*8 :: t227; + real*8 :: t238; + real*8 :: t239; + real*8 :: t24; + real*8 :: t240; + real*8 :: t241; + real*8 :: t244; + real*8 :: t245; + real*8 :: t249; + real*8 :: t25; + real*8 :: t252; + real*8 :: t257; + real*8 :: t259; + real*8 :: t263; + real*8 :: t266; + real*8 :: t270; + real*8 :: t274; + real*8 :: t288; + real*8 :: t29; + real*8 :: t293; + real*8 :: t294; + real*8 :: t301; + real*8 :: t323; + real*8 :: t326; + real*8 :: t330; + real*8 :: t331; + real*8 :: t334; + real*8 :: t335; + real*8 :: t338; + real*8 :: t343; + real*8 :: t35; + real*8 :: t350; + real*8 :: t351; + real*8 :: t356; + real*8 :: t357; + real*8 :: t361; + real*8 :: t375; + real*8 :: t38; + real*8 :: t385; + real*8 :: t388; + real*8 :: t389; + real*8 :: t40; + real*8 :: t407; + real*8 :: t41; + real*8 :: t411; + real*8 :: t419; + real*8 :: t422; + real*8 :: t428; + real*8 :: t443; + real*8 :: t450; + real*8 :: t456; + real*8 :: t46; + real*8 :: t465; + real*8 :: t471; + real*8 :: t481; + real*8 :: t486; + real*8 :: t50; + real*8 :: t504; + real*8 :: t51; + real*8 :: t534; + real*8 :: t547; + real*8 :: t55; + real*8 :: t562; + real*8 :: t592; + real*8 :: t62; + real*8 :: t63; + real*8 :: t66; + real*8 :: t70; + real*8 :: t72; + real*8 :: t76; + real*8 :: t84; + real*8 :: t92; + + t1 = r*r; + t2 = t1*r; + t6 = g22*g01; + t7 = t6*Rmin; + t8 = t1*t1; + t9 = t8*dg02; + t10 = g23*g23; + t11 = dg33*t10; + t14 = Rmin*t2; + t16 = t10*t10; + t17 = g01*dg02*t16; + t20 = g33*g33; + t21 = t20*g01; + t22 = t21*dgx01; + t23 = r*dg22; + t26 = g01*t1; + t27 = ddgxr01*t16; + t30 = t10*g23; + t31 = g01*g01; + t32 = t30*t31; + t36 = g01*r; + t39 = dgx01*t1; + t43 = dgx01*g01; + t44 = g22*g22; + t45 = t44*t20; + t48 = dgx01*dg01; + t49 = r*t16; + t56 = t14*g02; + t58 = t21*ddg22*g22; + t67 = t14*g03; + t69 = dg22*dg22; + t71 = g23*g33*g01*t69; + t73 = t30*g01; + t77 = t73*ddg22; + t80 = g23*t31; + t81 = t80*g22; + t82 = r*dg33; + t86 = g03*g23; + t87 = t14*t86; + t89 = g22*g33; + t93 = t10*t31; + t94 = dgx22*r; + t97 = Rmin*t8; + t98 = t97*g03; + t99 = t10*g01; + t100 = dg22*dg23; + t101 = t99*t100; + t104 = t30*dg01; + t105 = t104*dg22; + t108 = -2.0*t56*t58+2.0*t32*r*ddgyr22-2.0*t32*t1*ddgyr22-t67*t71+4.0*t67*t73*dg22-2.0*t67*t77 & + -2.0*t81*t82*dgx23-4.0*t87*g01*dg22*t89+t93*t94*dg33-2.0*t98*t101+2.0*t67*t105; + t110 = t80*r; + t112 = ddgyr22*g22*g33; + t117 = dg33*dg22; + t118 = Rmin*g02*t117; + t123 = g02*g33; + t125 = g23*g01; + t126 = t125*t100; + t129 = t97*g02; + t130 = g33*g01; + t132 = t130*ddg22*t10; + t136 = g01*ddg22*t89; + t141 = dg23*dg23; + t142 = g01*t141; + t143 = t89*t142; + t150 = dg22*g22; + t151 = t20*dg01*t150; + t155 = dg01*dg22*t89; + t158 = -2.0*t110*t112+2.0*t99*t2*t118+4.0*t43*t16+3.0*t97*t123*t126-2.0*t129*t132+2.0*t87*t136 & + +2.0*t67*t101+2.0*t56*t143-3.0*t14*t123*t126+2.0*t56*t151-2.0*t87*t155; + t161 = g22*t31; + t162 = t161*g33; + t167 = dg22*t10; + t168 = g33*dg01*t167; + t172 = g23*g22*t142; + t177 = t21*t69; + t179 = t97*t86; + t185 = t1*g03; + t186 = dg23*t10; + t190 = t44*g01; + t191 = t190*Rmin; + t192 = dg23*g33; + t196 = -2.0*t129*t143-2.0*t162*t23*dgy23+2.0*t129*t168-2.0*t67*t172+2.0*t98*t172-t129*t177 & + +2.0*t179*t155+t98*t71+2.0*t98*t77+8.0*t7*t185*t186-8.0*t191*t185*t192; + t202 = t130*Rmin; + t203 = t1*g02; + t213 = dgy33*t1; + t216 = t21*Rmin; + t220 = t44*t31; + t221 = dgy33*r; + t224 = r*dg23; + t225 = t224*dgy22; + t230 = t6*dgx01; + t231 = t1*dg33; + t234 = Rmin*t1; + t235 = t125*t234; + t243 = t2*dg02; + t250 = dg02*dg01*t16; + t255 = t125*dgx01; + t256 = t1*dg23; + t260 = dg01*t44; + t261 = t260*t20; + t264 = t73*Rmin; + t265 = t2*dg03; + t269 = t97*dg02; + t272 = t230*t231*t10+8.0*t235*g03*dg22*t89-2.0*t99*t8*t118-t216*t243*t150-2.0*t73*t39*dg23 & + +2.0*t97*t250+t202*t243*t167+2.0*t255*t256*t89-2.0*t39*t261-2.0*t264*t265*dg22+2.0*t269*t261; + t275 = r*t44*t20; + t279 = t89*t10; + t283 = ddgxr01*t44*t20; + t292 = t1*dg22; + t302 = t14*g01; + t304 = dg02*t44*t20; + t309 = 2.0*t48*t275+4.0*t36*ddgxr01*t279+2.0*t26*t283-8.0*t264*t203*dg23-8.0*t264*t185*dg22 & + -t22*t292*g22-2.0*t36*t283+4.0*t39*dg01*t279+8.0*t234*t17-4.0*t302*t304-t202*t9*t167; + t310 = t234*g01; + t315 = dg01*g22; + t316 = g33*t10; + t317 = t315*t316; + t320 = t8*dg03; + t327 = t125*t14; + t328 = g03*g22; + t329 = t328*t117; + t339 = t14*dg02; + t342 = t256*dgy22; + t345 = 8.0*t310*t304+t216*t9*t150-4.0*t269*t317+2.0*t191*t320*t192-2.0*t7*t320*t186-t327*t329 & + +2.0*t81*t231*dgx23-2.0*t14*t250-4.0*t26*ddgxr01*t279+4.0*t339*t317+2.0*t93*t342; + t353 = dg03*dg22*t89; + t363 = dg33*g33; + t374 = dgx33*t1; + t378 = dgx33*r; + t381 = r*ddgyr23; + t392 = t378*dg22; + t394 = t80*g33; + t398 = dgx22*t1; + t401 = t80*t1; + t403 = ddgxr23*g22*g33; + t406 = t130*dgx01; + t410 = dg02*g22*t316; + t415 = t220*t378*dg33-2.0*t161*t381*t10-2.0*t93*t256*dgx23+2.0*t73*dgx01*r*dg23-t93*t392 & + -t394*dgy22*t1*dg22-t93*t398*dg33-2.0*t401*t403-t406*t23*t10+8.0*t302*t410-16.0*t310*t410; + t430 = dg33*dg23; + t431 = t190*t430; + t433 = g02*g23; + t434 = t14*t433; + t436 = g01*ddg23*t89; + t442 = t104*dg23; + t445 = t73*ddg23; + t448 = t315*t186; + t451 = -t394*t94*dg23+t81*t374*dg23+8.0*t235*g02*dg23*t89+t81*t221*dg22+4.0*t67*t190*t192+t67*t431 & + +2.0*t434*t436-4.0*t67*t6*t186+2.0*t56*t442-2.0*t56*t445+2.0*t98*t448; + t453 = t6*ddg23*t10; + t459 = t260*t192; + t462 = t374*dg22; + t464 = t97*t433; + t466 = dg01*dg23*t89; + t469 = t1*ddgxr33; + t475 = r*ddgxr33; + t483 = t1*ddgyr23; + t487 = -2.0*t98*t453+4.0*t56*t73*dg23-2.0*t98*t459-t162*t462+2.0*t464*t466-2.0*t161*t469*t10 & + -2.0*t434*t466-2.0*t220*t475*g33-2.0*t129*t151-t191*t9*t363+2.0*t161*t483*t10; + t492 = t190*dgx01; + t496 = t190*ddg23*g33; + t499 = t6*t430; + t514 = t130*t100; + t518 = -t7*t243*t11+t492*t82*g33+2.0*t98*t496+t464*t499+2.0*t129*t445-4.0*t434*g01*dg23*t89 & + -t434*t499+2.0*t220*t469*g33-2.0*t67*t496+t14*t328*t514-t97*t328*t514; + t530 = t123*t117; + t541 = t125*t97; + t544 = 2.0*t67*t453+2.0*t67*t459-2.0*t464*t436-t98*t431+2.0*t220*t381*g33+t6*t97*t530 & + -2.0*t67*t448+t162*t392+2.0*t264*t320*dg22+2.0*t7*t265*t186-2.0*t541*t353; + t568 = -t81*t378*dg23-2.0*t93*t225+t93*t462+2.0*t110*t403-2.0*t81*t256*dgy23+2.0*t401*t112-t162*t342 & + +4.0*t56*t21*t150+t541*t329-2.0*t191*t265*t192-t6*t14*t530; + t594 = t56*t177-2.0*t129*t442-t492*t231*g33-t230*t82*t10+t394*dgy22*r*dg22-2.0*t220*t483*g33 & + +2.0*t161*t475*t10+2.0*t93*t224*dgx23+2.0*t129*t58+t406*t292*t10+t394*t398*dg23; + p02_rhs = 1/t2/g01*(2.0*t81*t224*dgy23-4.0*t48*r*t279+2.0*t32*t1*ddgxr23+8.0*t202*t203*t167-t81*t213*dg22 & + -8.0*t216*t203*t150-t220*t221*dg23+t7*t9*t11+t220*t213*dg23-t220*t374*dg33-2.0*t255*t224*t89 & + -2.0*t32*r*ddgxr23+t22*t23*g22+2.0*t162*t292*dgy23+t191*t243*t363-4.0*t56*t130*t167-2.0*t39*dg01*t16 & + +t108-2.0*t179*t136+2.0*t48*t49-2.0*t339*t261-2.0*t36*t27-4.0*t14*t17+4.0*t43*t45-2.0*t56*t168 & + -2.0*t98*t105+t162*t225+2.0*t56*t132+2.0*t26*t27-8.0*t43*t279+2.0*t327*t353+t345+t158+t196+t272 & + +t309+t415+t451+t487+t544+t518+t594+t568)/(-2.0*r*t10*t89-t16+t49+2.0*t279-t45+t275)/Rmin/2.0 +!!! + t1 = r*r; + t2 = t1*r; + t6 = dgy01*g01; + t7 = g23*g23; + t8 = t7*t7; + t11 = Rmin*t2; + t12 = g03*g23; + t13 = t11*t12; + t14 = g33*g01; + t15 = dg22*dg23; + t16 = t14*t15; + t18 = g22*g01; + t19 = dg33*dg23; + t20 = t18*t19; + t23 = g33*g33; + t24 = g01*g01; + t25 = t23*t24; + t29 = g33*t24; + t30 = t29*g22; + t31 = r*dg33; + t35 = dgx22*t1; + t38 = t1*t1; + t39 = Rmin*t38; + t40 = g02*g33; + t41 = t39*t40; + t43 = t11*g03; + t44 = t7*g23; + t45 = t44*g01; + t46 = t45*ddg23; + t49 = t11*g02; + t50 = t23*g01; + t51 = dg23*g22; + t55 = t11*t40; + t58 = dg23*t7; + t62 = g01*r; + t63 = ddgyr01*t8; + t66 = t29*g23; + t67 = dgx22*r; + t70 = t31*dgy22; + t72 = g22*g22; + t73 = t72*t23; + t76 = dgy01*t1; + t80 = t44*t24; + t84 = t50*t15; + t92 = t39*g02; + t94 = t50*ddg23*g22; + t97 = -4.0*t49*t14*t58-2.0*t62*t63+t66*t67*dg33+t30*t70+4.0*t6*t73-2.0*t76*dg01*t8+2.0*t80*t1*ddgyr23+t49*t84 & + -2.0*t80*t1*ddgxr33+2.0*t80*r*ddgxr33+2.0*t92*t94; + t99 = g23*g01; + t100 = dg33*dg22; + t101 = t99*t100; + t104 = g33*dg01*t58; + t108 = g01*t1; + t111 = dgy01*dg01; + t112 = r*t8; + t115 = t39*t12; + t117 = t1*ddgxr23; + t121 = t1*ddgyr22; + t126 = t23*dg01*t51; + t129 = dg01*t44; + t130 = t129*dg23; + t133 = t7*g01; + t134 = t133*t100; + t137 = -t55*t101+2.0*t92*t104+t41*t101+2.0*t108*t63+2.0*t111*t112+t115*t16+2.0*t29*t117*t7+2.0*t25*t121*g22 & + -2.0*t92*t126+2.0*t43*t130+2.0*t43*t134; + t139 = g22*g33; + t140 = g01*ddg23*t139; + t144 = dg01*dg23*t139; + t147 = g23*t24; + t148 = t147*r; + t150 = ddgyr23*g22*g33; + t153 = t147*t1; + t155 = ddgxr33*g22*g33; + t162 = dg23*dg23; + t164 = Rmin*g03*g22*t162; + t170 = t39*g03; + t179 = 2.0*t13*t140-2.0*t13*t144+2.0*t148*t150+2.0*t153*t155-2.0*t148*t155+2.0*t14*t2*t164+4.0*t43*t45*dg23 & + -2.0*t170*t134-2.0*t115*t140+3.0*t115*t20-2.0*t170*t130; + t182 = t133*t19; + t186 = dg33*dg33; + t188 = g23*g22*g01*t186; + t190 = g02*g23; + t191 = t39*t190; + t193 = g01*ddg33*t139; + t197 = dg01*dg33*t139; + t202 = g33*g23*g01*t162; + t206 = t14*ddg23*t7; + t215 = t147*g22; + t216 = dgy33*r; + t222 = t7*t24; + t224 = dgx33*t1; + t227 = dgy33*t1; + t230 = dgx33*r; + t231 = t230*dg23; + t234 = r*dg22; + t238 = t39*dg03; + t239 = dg01*g22; + t240 = g33*t7; + t241 = t239*t240; + t244 = dg01*t72; + t245 = t244*t23; + t249 = dg03*dg01*t8; + t252 = t11*dg03; + t257 = -2.0*t153*t150-t222*t70-t215*t224*dg33-t222*t227*dg22-2.0*t222*t231-2.0*t66*t234*dgy23-4.0*t238*t241 & + +2.0*t238*t245-2.0*t11*t249+4.0*t252*t241-2.0*t252*t245; + t259 = dg33*t7; + t260 = t239*t259; + t263 = t45*ddg33; + t266 = t129*dg33; + t269 = t1*dg33; + t270 = t269*dgy22; + t274 = t224*dg23; + t279 = t1*dg23; + t283 = r*dg23; + t288 = t1*dg22; + t292 = 2.0*t170*t260-2.0*t49*t263+2.0*t49*t266+t222*t270+t215*t230*dg33+2.0*t222*t274+t215*t227*dg23 & + -2.0*t222*t279*dgy23+2.0*t222*t283*dgy23-t92*t84+2.0*t66*t288*dgy23; + t293 = dg33*g33; + t294 = t244*t293; + t301 = dg02*dg33*t139; + t316 = t139*t7; + t323 = ddgyr01*t72*t23; + t326 = -2.0*t170*t294+t222*t216*dg22+2.0*t99*t11*t301+2.0*t170*t46-2.0*t49*t94+2.0*t49*t126-2.0*t49*t202 & + -4.0*t13*g01*dg23*t139-8.0*t6*t316+4.0*t62*ddgyr01*t316-2.0*t62*t323; + t330 = t18*Rmin; + t331 = t38*dg03; + t334 = t72*g01; + t335 = t334*Rmin; + t338 = t99*dgy01; + t342 = t45*Rmin; + t343 = t2*dg02; + t350 = Rmin*t1; + t351 = t350*g01; + t353 = dg03*g22*t240; + t356 = t14*Rmin; + t357 = t1*g02; + t361 = t50*Rmin; + t375 = r*t72*t23; + t381 = dg03*t72*t23; + t385 = g01*dg03*t8; + t388 = t2*dg03; + t389 = dg22*t7; + t392 = t14*dgy01; + t398 = r*ddgyr22; + t407 = -4.0*t111*r*t316+2.0*t111*t375+2.0*t39*t249+8.0*t351*t381-4.0*t11*t385-t356*t388*t389-t392*t234*t7 & + -2.0*t29*t121*t7+2.0*t29*t398*t7-t25*t67*dg23+2.0*t66*t283*dgx23; + t411 = g03*g22*t100; + t415 = t1*g03; + t419 = t18*dgy01; + t422 = t334*dgy01; + t428 = t99*t350; + t443 = t334*t186; + t445 = -t14*t11*t411+8.0*t350*t385-8.0*t335*t415*t293-t419*t31*t7+t422*t31*g33-8.0*t342*t415*dg23 & + +8.0*t428*g03*dg23*t139-8.0*t342*t357*dg33+8.0*t428*g02*dg33*t139-4.0*t108*ddgyr01*t316+t43*t443; + t450 = t334*ddg33*g33; + t456 = t18*ddg33*t7; + t465 = t11*g01; + t471 = t38*dg02; + t475 = -4.0*t43*t18*t259-2.0*t43*t450+2.0*t43*t294+2.0*t43*t456-2.0*t43*t260-t170*t443+2.0*t170*t450-t30*t274 & + -4.0*t465*t381-2.0*t45*t76*dg23-2.0*t356*t471*t58; + t481 = dg22*g22; + t486 = t50*dgy01; + t504 = 2.0*t361*t471*t51+t361*t388*t481+t356*t331*t389+t486*t234*g22+t14*t39*t411+t392*t288*t7+t30*t231 & + +4.0*t43*t334*t293+2.0*t108*t323-2.0*t80*r*ddgyr23-t66*t283*dgy22; + t530 = r*ddgxr23; + t534 = t419*t269*t7-t422*t269*g33+t330*t388*t259-t335*t388*t293+2.0*t45*dgy01*r*dg23-2.0*t338*t283*t139 & + -2.0*t92*t266+2.0*t92*t263-2.0*t25*t398*g22-2.0*t25*t117*g22+2.0*t25*t530*g22; + t547 = t11*t190; + t562 = -t361*t331*t481+8.0*t465*t353-t66*t35*dg33+t66*t279*dgy22-2.0*t29*t530*t7-4.0*t547*g01*dg33*t139 & + -t49*t188+2.0*t49*t182+4.0*t49*t45*dg33+2.0*t547*t193-2.0*t547*t197; + t592 = -2.0*t66*t279*dgx23-t486*t288*g22-2.0*t14*t38*t164-2.0*t170*t456+8.0*t330*t415*t259+2.0*t342*t471*dg33 & + +2.0*t356*t343*t58-2.0*t361*t343*t51+2.0*t30*t269*dgx23-t25*dgy22*t1*dg22-t30*t270; + p03_rhs = 1/t2/g01*(t504+t534+t562+t592+t137+t97+t257+t179+t326-2.0*t43*t46-2.0*t92*t206-t41*t20+2.0*t115*t144 & + -2.0*t49*t104+2.0*t49*t206-3.0*t13*t20-t13*t16+4.0*t6*t8-16.0*t351*t353+t55*t20-2.0*t76*t245+t292 & + +2.0*t191*t197-t330*t331*t259-2.0*t99*t39*t301+4.0*t76*dg01*t316-8.0*t361*t357*t51+8.0*t356*t357*t58 & + +4.0*t49*t50*t51+t25*t35*dg23+2.0*t338*t279*t139-t215*t216*dg23+t335*t331*t293-2.0*t342*t343*dg33 & + -2.0*t30*t31*dgx23+t92*t188-2.0*t92*t182+t25*dgy22*r*dg22-2.0*t191*t193+t475+t445+t407 & + +2.0*t92*t202)/(-2.0*r*t7*t139-t8+t112+2.0*t316-t73+t375)/Rmin/2.0 + + g02_rhs = p02 + g03_rhs = p03 + + return + +end subroutine pg0a_rhs +!------------------------------------------------------------------------------ +subroutine get_g01_rhs(r,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01,g01_rhs) + + implicit none + +!~~~~~~% Input parameters: + real*8,intent(in) :: r,g22,g23,g33,dg22,dg23,dg33,ddg22,ddg23,ddg33,g01 + real*8,intent(out) :: g01_rhs + + real*8 :: t107; + real*8 :: t11; + real*8 :: t110; + real*8 :: t14; + real*8 :: t19; + real*8 :: t2; + real*8 :: t23; + real*8 :: t25; + real*8 :: t28; + real*8 :: t3; + real*8 :: t33; + real*8 :: t34; + real*8 :: t40; + real*8 :: t45; + real*8 :: t49; + real*8 :: t54; + real*8 :: t6; + real*8 :: t7; + real*8 :: t73; + real*8 :: t76; + real*8 :: t81; + real*8 :: t89; + real*8 :: t98; + + t2 = g23*g23; + t3 = t2*g23; + t6 = g22*g33; + t7 = dg23*dg23; + t11 = t2*r; + t14 = g23*r; + t19 = g22*r; + t23 = g33*g33; + t25 = dg22*dg22; + t28 = r*dg22; + t33 = g22*g22; + t34 = t33*g33; + t40 = g33*r; + t45 = g22*t23; + t49 = r*dg33; + t54 = dg33*dg33; + t73 = 4.0*r*ddg23*t3-2.0*t6*r*t7-2.0*t11*t7-4.0*t14*ddg23*g22*g33-2.0*t19*ddg33*t2-t23*r*t25 & + +4.0*g33*g23*t28*dg23+2.0*r*ddg33*t34-2.0*t11*dg33*dg22-2.0*t40*ddg22*t2+2.0*r*ddg22*t45 & + +4.0*g23*g22*t49*dg23-t33*r*t54-4.0*g33*dg22*t2-4.0*g22*dg33*t2+4.0*dg33*t33*g33 & + +4.0*dg22*g22*t23-8.0*g23*dg23*t6+8.0*dg23*t3; + t76 = t2*t2; + t81 = r*r; + t89 = dg23*g22*g33; + t98 = dg33*t2; + t107 = dg22*t2; + t110 = -4.0*t76-2.0*r*dg23*t3+2.0*t81*dg23*t3+8.0*t6*t2-t28*t45+2.0*t14*t89-2.0*g23*t81*t89 & + +t81*dg33*t34-g22*t81*t98-t49*t34+t19*t98+t81*dg22*t45-4.0*t33*t23-g33*t81*t107+t40*t107; + g01_rhs = g01*t73*(-1.0+r)/t110/2.0 + + return + +end subroutine get_g01_rhs +!------------------------------------------------------------------------------ diff --git a/AMSS_NCKU_source/NullNews.f90 b/AMSS_NCKU_source/Null_Evolve/NullNews.f90 similarity index 97% rename from AMSS_NCKU_source/NullNews.f90 rename to AMSS_NCKU_source/Null_Evolve/NullNews.f90 index 291c035..e6588f4 100644 --- a/AMSS_NCKU_source/NullNews.f90 +++ b/AMSS_NCKU_source/Null_Evolve/NullNews.f90 @@ -1,688 +1,688 @@ - - -#include "macrodef.fh" - -!------------------------------------------------------------------------------ -function omega_rhs(ex,crho,sigma,R,omega,RU,IU,omegarhs, & - quR1,quR2,quI1,quI2,gR,gI) result(gont) - - implicit none - - integer,intent(in) :: ex(3) - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: omega,RU,IU - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: omegarhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI -! gont = 0: success; gont = 1: something wrong - integer::gont - - double complex, dimension(ex(1),ex(2),ex(3)) :: comega,eth_omega,U,eth_Ub - real*8 :: dR - integer :: k - -!!! sanity check - dR = sum(omega)+sum(RU)+sum(IU) - if(dR.ne.dR) then - if(sum(omega).ne.sum(omega))write(*,*)"NullEvol_beta: find NaN in omega" - if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_beta: find NaN in RU" - if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_beta: find NaN in IU" - gont = 1 - return - endif - - comega = dcmplx(omega,0.d0) - U = dcmplx(RU,IU) - - do k=1,ex(3) - call derivs_eth(ex(1:2),crho,sigma,comega(:,:,k),eth_omega(:,:,k),0,1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - call derivs_eth(ex(1:2),crho,sigma,U(:,:,k),eth_Ub(:,:,k),1,-1, & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) - enddo - -!!! The term * e^{-2beta} has been added so as to be consistent with HPN. Nigel - !omega_u = - dble(eth_omega * conjg(U) + 0.5d0 * omega * eth_Ub * exp(-2*beta)) - -!!! - update .. I thought this may have been wrong so I removed the -!!! e^{-2beta} for testing. Yosef -! omegarhs = - dreal(eth_omega * dconjg(U) + 0.5d0 * omega * eth_Ub) - - omegarhs = - 0.5d0*dreal(eth_Ub) - - gont = 0 - - return - -end function omega_rhs -!--------------------------------------------------------------------------------------------------------- -subroutine drive_null_news(ex,crho,sigma,R,RJ,IJ,RU,IU,RTheta,ITheta,omega,beta, & - qlR1,qlR2,qlI1,qlI2, & - quR1,quR2,quI1,quI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,RNews,INews,Rmin,sst) - - implicit none - - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: Rmin - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RTheta,ITheta,omega,beta - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dquR1,dquR2,dquI1,dquI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dgR,dgI,bdgR,bdgI - - integer :: i,j,k - double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,U,J_u,J_l,J_l_u,News -#if 0 - call get_fake_Ju(ex,crho,sigma,R,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) -#endif - - CJ = dcmplx(RJ,IJ) - U = dcmplx(RU,IU) - J_u = dcmplx(RTheta,ITheta) - - do j=1,ex(2) - do i=1,ex(1) - call cderivs_x(ex(3),R,CJ(i,j,:),J_l(i,j,:)) - call cderivs_x(ex(3),R,J_u(i,j,:),J_l_u(i,j,:)) - J_l(i,j,:) = -J_l(i,j,:)*Rmin*R**2 - J_l_u(i,j,:) = -J_l_u(i,j,:)*Rmin*R**2 - enddo - enddo - -#if 0 -if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then - call get_exact_Jul(ex,crho,sigma,R,RNews,INews, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) -write(*,*) J_u(ex(1)/2,ex(2)/2,ex(3)-1),J_u(ex(1)/2,ex(2)/2,ex(3)) -write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) -write(*,*) J_l_u(ex(1)/2,ex(2)/2,ex(3)) -write(*,*)dcmplx(RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)))/J_l_u(ex(1)/2,ex(2)/2,ex(3)) -endif -stop -#endif - - do k=1,ex(3) - call get_null_news(ex(1:2),crho,sigma,CJ(:,:,k),U(:,:,k),J_u(:,:,k),J_l(:,:,k),J_l_u(:,:,k),omega(:,:,k),beta(:,:,k), & - qlR1(:,:,k),qlR2(:,:,k),qlI1(:,:,k),qlI2(:,:,k), & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k), & - gR(:,:,k),gI(:,:,k), & - dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & - bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & - dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k),News(:,:,k)) - enddo - - RNews = dreal(News) - INews = dimag(News) - -#if 0 -if(sst ==0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then - call get_exact_eth2omega(ex,crho,sigma,R,RNews,INews, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) -write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) -endif -stop -#endif - -#if 0 -! check orthornormality - RNews = RJ - INews = IJ - - RNews = 0.5d0*dreal(J_l_u) - INews = 0.5d0*dimag(J_l_u) -#endif - - call six2spher(ex,crho,sigma,R,RNews,INews,2,Rmin,sst) - - return - -end subroutine drive_null_news -!--------------------------------------------------------------------------------------------------------- -subroutine drive_null_news_diff(ex,crho,sigma,R,RJ,IJ,RU,IU,RTheta,ITheta,omega,beta, & - qlR1,qlR2,qlI1,qlI2, & - quR1,quR2,quI1,quI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,RNews,INews,Rmin,sst,Time) - - implicit none - - integer,intent(in) :: ex(3),sst - real*8,intent(in) :: Rmin,Time - real*8,intent(in),dimension(ex(1))::crho - real*8,intent(in),dimension(ex(2))::sigma - real*8,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RTheta,ITheta,omega,beta - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: qlR1,qlR2,qlI1,qlI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dquR1,dquR2,dquI1,dquI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dgR,dgI,bdgR,bdgI - - integer :: i,j,k - double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,U,J_u,J_l,J_l_u,News -#if 0 - call get_fake_Ju(ex,crho,sigma,R,RTheta,ITheta, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) -#endif - - CJ = dcmplx(RJ,IJ) - U = dcmplx(RU,IU) - J_u = dcmplx(RTheta,ITheta) - - do j=1,ex(2) - do i=1,ex(1) - call cderivs_x(ex(3),R,CJ(i,j,:),J_l(i,j,:)) - call cderivs_x(ex(3),R,J_u(i,j,:),J_l_u(i,j,:)) - J_l(i,j,:) = -J_l(i,j,:)*Rmin*R**2 - J_l_u(i,j,:) = -J_l_u(i,j,:)*Rmin*R**2 - enddo - enddo - -#if 0 -if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then - call get_exact_Jul(ex,crho,sigma,R,RNews,INews, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) -write(*,*) J_u(ex(1)/2,ex(2)/2,ex(3)-1),J_u(ex(1)/2,ex(2)/2,ex(3)) -write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) -write(*,*) J_l_u(ex(1)/2,ex(2)/2,ex(3)) -write(*,*)dcmplx(RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)))/J_l_u(ex(1)/2,ex(2)/2,ex(3)) -endif -stop -#endif - - do k=1,ex(3) - call get_null_news(ex(1:2),crho,sigma,CJ(:,:,k),U(:,:,k),J_u(:,:,k),J_l(:,:,k),J_l_u(:,:,k),omega(:,:,k),beta(:,:,k), & - qlR1(:,:,k),qlR2(:,:,k),qlI1(:,:,k),qlI2(:,:,k), & - quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k), & - gR(:,:,k),gI(:,:,k), & - dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & - bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & - dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k),News(:,:,k)) - enddo - - call get_exact_news(ex,crho,sigma,R,RNews,INews,sst,Rmin,Time) - - RNews = dreal(News) - Rnews - INews = dimag(News) - INews - -!this part is nonsence - RNews(:,:,1:ex(3)-1) = 0.d0 - INews(:,:,1:ex(3)-1) = 0.d0 -#if 0 -if(sst ==0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then - call get_exact_eth2omega(ex,crho,sigma,R,RNews,INews, & - quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) -write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) -endif -stop -#endif - -#if 0 -! check orthornormality - RNews = RJ - INews = IJ - - RNews = 0.5d0*dreal(J_l_u) - INews = 0.5d0*dimag(J_l_u) -#endif - - call six2spher(ex,crho,sigma,R,RNews,INews,2,Rmin,sst) - - return - -end subroutine drive_null_news_diff -!------------------------------------------------------------------------------------------------------------ -subroutine get_null_news(ex,crho,sigma,J,U,J_u,J_l,J_l_u,omega,beta, & - qlR1,qlR2,qlI1,qlI2, & - quR1,quR2,quI1,quI2, & - gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI,News) - -implicit none - -integer,intent(in) :: ex(2) -real*8,intent(in),dimension(ex(1))::crho -real*8,intent(in),dimension(ex(2))::sigma -double complex,dimension(ex(1),ex(2)),intent(in) :: J,U -double complex,dimension(ex(1),ex(2)),intent(in) :: J_u,J_l,J_l_u -real*8,dimension(ex(1),ex(2)),intent(in) :: omega,beta -real*8,dimension(ex(1),ex(2)),intent(in) :: qlR1,qlR2,qlI1,qlI2 -real*8,dimension(ex(1),ex(2)),intent(in) :: quR1,quR2,quI1,quI2 -real*8,dimension(ex(1),ex(2)),intent(in) :: gR,gI -real*8,dimension(ex(1),ex(2)),intent(in) :: dquR1,dquR2,dquI1,dquI2 -real*8,dimension(ex(1),ex(2)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2 -real*8,dimension(ex(1),ex(2)),intent(in) :: dgR,dgI,bdgR,bdgI -double complex,dimension(ex(1),ex(2)),intent(out) :: News - -! local variables -real*8,dimension(ex(1),ex(2)) :: K,K_u,K_l,K_l_u -real*8,dimension(ex(1),ex(2)) :: a -double complex,dimension(ex(1),ex(2)) :: Comega,Cbeta -double complex,dimension(ex(1),ex(2)) :: Jb,Ub -double complex,dimension(ex(1),ex(2)) :: eth_a,eth2_a,eth_ethb_a -double complex,dimension(ex(1),ex(2)) :: s1,s2,s3,s4,s5 -double complex,dimension(ex(1),ex(2)) :: eth_U,ethb_U,eth_J,ethb_J -double complex,dimension(ex(1),ex(2)) :: eth_J_l,ethb_J_l,eth_K_l,eth_K -double complex,dimension(ex(1),ex(2)) :: eth_omega,eth_beta -double complex,dimension(ex(1),ex(2)) :: eth2_omega,eth2_beta -double complex,dimension(ex(1),ex(2)) :: eth_ethb_omega,eth_ethb_beta - - Comega = dcmplx(omega,0.d0) - Cbeta = dcmplx(beta,0.d0) - call derivs_eth(ex,crho,sigma,Comega,eth_omega,0,1,quR1,quR2,quI1,quI2,gR,gI) - call derivs_eth(ex,crho,sigma,Cbeta,eth_beta,0,1,quR1,quR2,quI1,quI2,gR,gI) - call dderivs_eth(ex,crho,sigma,Comega,eth2_omega,0,1,1, & - quR1,quR2,quI1,quI2,gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) - call dderivs_eth(ex,crho,sigma,Cbeta,eth2_beta,0,1,1, & - quR1,quR2,quI1,quI2,gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) - call dderivs_eth(ex,crho,sigma,Comega,eth_ethb_omega,0,-1,1, & - quR1,quR2,quI1,quI2,gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) - call dderivs_eth(ex,crho,sigma,Cbeta,eth_ethb_beta,0,-1,1, & - quR1,quR2,quI1,quI2,gR,gI, & - dquR1,dquR2,dquI1,dquI2, & - bdquR1,bdquR2,bdquI1,bdquI2, & - dgR,dgI,bdgR,bdgI) - call derivs_eth(ex,crho,sigma,U,eth_U,1,1,quR1,quR2,quI1,quI2,gR,gI) - call derivs_eth(ex,crho,sigma,U,ethb_U,1,-1,quR1,quR2,quI1,quI2,gR,gI) - call derivs_eth(ex,crho,sigma,J,eth_J,2,1,quR1,quR2,quI1,quI2,gR,gI) - call derivs_eth(ex,crho,sigma,J,ethb_J,2,-1,quR1,quR2,quI1,quI2,gR,gI) - call derivs_eth(ex,crho,sigma,J_l,eth_J_l,2,1,quR1,quR2,quI1,quI2,gR,gI) - call derivs_eth(ex,crho,sigma,J_l,ethb_J_l,2,-1,quR1,quR2,quI1,quI2,gR,gI) - - Jb = dconjg(J) - Ub = dconjg(U) - K = dsqrt(1.0d0 + cdabs(J)**2) -! temp storage - Comega=dcmplx(K,0.d0) - call derivs_eth(ex,crho,sigma,Comega,eth_K,0,1,quR1,quR2,quI1,quI2,gR,gI) - - K_u = dreal( J_u * Jb ) / K - K_l = dreal( J_l * Jb ) / K -! temp storage - Comega=dcmplx(K_l,0.d0) - call derivs_eth(ex,crho,sigma,Comega,eth_K_l,0,1,quR1,quR2,quI1,quI2,gR,gI) - K_l_u = dreal( J_u * dconjg(J_l) + J_l_u * Jb )/ K - K_l * K_u / K - - a = omega * dexp(2.0d0 * beta) - - eth_a = dexp(2.0d0 * beta) * ( eth_omega + 2.0d0 * omega * eth_beta ) - - eth2_a = dexp(2.0d0 * beta) * ( 4.0d0 * eth_beta * eth_omega & - + 4.0d0 * omega * eth_beta**2 & - + eth2_omega + 2.0d0 * omega * eth2_beta ) - - eth_ethb_a = dexp(2.0d0 * beta) * ( 4.0d0 * dreal(eth_beta * dconjg(eth_omega)) & - + 4.0d0 * omega * eth_beta * dconjg(eth_beta) & - + eth_ethb_omega + 2.0d0 * omega * eth_ethb_beta ) - - s1 = ( -2.0d0 * K_l_u * J * (K + 1.0d0) + J_l_u * (K + 1.0d0)**2 & - + dconjg(J_l_u) * J**2 ) / (K + 1.0d0) - - s2 = 0.5d0 / ( K + 1.0d0) * ( & - (K + 1.0d0)* (eth_J_l *Ub * (K+1.0d0) - 2.0d0* eth_K_l * J *Ub ) & - + eth_U * (K+1.0d0)* ( -2.0d0 * J * dconjg(J_l) + K_l * 2.0d0 * (K+1.0d0) ) & - + dconjg(ethb_U) * (K+1.0d0) * ( -2.0d0* J * K_l + J_l * 2.0d0 * (K+1.0d0) ) & - + ethb_J_l * U * (K+1.0d0)**2 - dconjg(eth_K_l) * 2.0d0 * U * J * (K+1.0d0) & - + ethb_U * 2.0d0 * J * ( J * dconjg(J_l) - (K+1.0d0) * K_l) & - + J**2 * ( U * dconjg(eth_J_l) + dconjg(ethb_J_l * U) ) & - + J * 2.0d0 * dconjg(eth_U) * ( J * K_l - J_l * (K+1.0d0) ) ) - - s3 = ( J_l * (K + 1.0d0)**2 -2.0d0 * K_l * J * (K + 1.0d0) & - + dconjg(J_l) * J**2) / (K + 1.0d0) - - s4 = 0.5d0 / ( K + 1.0d0) * ( eth_a * eth_omega * (K + 1.0d0)**2 & - - (K+1.0d0) * J * 2.0d0* dreal( eth_a * dconjg(eth_omega) ) & - + J**2 * dconjg(eth_a * eth_omega) ) - - s5 = 0.25d0 / ( K + 1.0d0) * ( 2.0d0 * eth2_a * (K+1.0d0)**2 & - + 2.0d0 * J**2 * dconjg(eth2_a) & - - 4.0d0 * eth_ethb_a * J * (K+1.0d0) & - + Jb * eth_a * eth_J* (K+1.0d0)**2 & - + J * eth_a * dconjg(ethb_J) * (K+1.0d0)**2 & - - eth_a * eth_K * 2.0d0 * (K+1.0d0) * ( J*Jb + (K+1.0d0) ) & - + eth_a * ethb_J * (K+1.0d0) * ( -J*Jb + (K+1.0d0) ) & - - J**2 * eth_a * dconjg(eth_J) * K & - + J**2 * Jb * 2.0d0* eth_a * dconjg(eth_K) & - - dconjg(eth_a) * eth_J * (K+1.0d0) * ( J*Jb + K+1.0d0 ) & - - dconjg(ethb_J) * dconjg(eth_a) * J**2 * ( K + 2.0d0) & - + J * 2.0d0 * (K+1.0d0)**2 * eth_K * dconjg(eth_a) & - + J**2 * Jb * ethb_J * dconjg(eth_a) & - + J**3 * dconjg(eth_a * eth_J) & - - 2.0d0* J**2 *K*dconjg(eth_K * eth_a) ) - - ! News = 0.25d0 * ( s1 + s2 + 0.5d0 * dble(ethb_U) * s3 & - ! - 4.0d0 * s4 / omega**2 + 2.0d0 * s5 / omega ) / ( omega**2 * exp(2.0d0 * beta) ) - - ! change sign of s3 to compensate for a bug in Eqs. 30, 37, and 38 of - ! HPN -#if 1 - News = 0.25d0 * ( s1 + s2 - 0.5d0 * dreal(ethb_U) * s3 & - - 4.0d0 * s4 / omega**2 + 2.0d0 * s5 / omega ) / ( omega**2 * dexp(2.0d0 * beta) ) -#else -#if 0 -if(crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then -write(*,*) eth2_omega(ex(1)/2,ex(2)/2) -endif -#endif - News = 0.5d0*J_l_u+eth2_beta+0.5d0*eth2_omega ! if given omega error is about 6e-9 -! News = 0.5d0*J_l_u+eth2_beta-1.5d0*J ! error is about 6e-9 -#endif - return - -end subroutine get_null_news -!-------------------------------------------------------------------------------------------------- -! change spin weighted function from 6 patches to spherical coordinate - subroutine six2spher(ex,crho,sigma,R,RU,IU,spin,Rmin,sst) - - implicit none - -!~~~~~~% Input parameters: - integer,intent(in) :: ex(3),sst,spin - real*8,intent(in) :: Rmin - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU - -integer :: i,j,k -real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf -double complex :: II,swtf,ff - - II = dcmplx(0.d0,1.d0) - hgr = 1.d0 - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! hgr = R(k)*Rmin/(1.d0-R(k)) R is not invovled indeed, to avoid NaN, we set -! it to 1 above - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "six2spher: not recognized sst = ",sst - return - end select - gt = dacos(z/hgr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - ff=dcmplx(RU(i,j,k),IU(i,j,k))/swtf**spin - - RU(i,j,k) = dreal(ff) - IU(i,j,k) = dimag(ff) - enddo - enddo - enddo - - return - - end subroutine six2spher -!------------------------------------------------------------- -! Linear wave given in Eq.(27) of CQG 22, 2393 (2005) -!------------------------------------------------------------- -subroutine get_exact_omega(ex,crho,sigma,R,omega,sst,Rmin,T) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,T -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega - -integer :: i,j,k -real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts -double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -double complex :: swtf,ff - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_exact_omega: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - gr = (1.d0-R(k))/R(k)/Rmin - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3 - gr = dreal(Jr*cdexp(II*nu*T)) - Jr = Yslm(0,2,m,gt,gp) - omega(i,j,k) = 1.d0-2.d0*(2+1)/2.d0*gr*dreal(Jr) - - enddo - enddo - enddo - -return - -end subroutine get_exact_omega -!------------------------------------------------------------- -! Linear wave given in Eq.(16) of CQG 24S327 -!------------------------------------------------------------- -subroutine get_exact_news(ex,crho,sigma,R,RNews,INews,sst,Rmin,Time) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: Rmin,Time -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RNews,INews - -integer :: i,j,k -real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts -double complex :: Yslm,II,Jr - -double complex :: beta0,C1,C2 -integer :: nu,m - -double complex :: swtf,ff - -call initial_null_paramter(beta0,C1,C2,nu,m) - - II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -!fake global coordinate is enough here - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_initial_null: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - Jr = II*nu**3*C2/dsqrt(2.4d1) - gr = dreal(Jr) - Jr = Yslm(2,2,m,gt,gp) - ff = gr*Jr*swtf**2 - RNews(i,j,k) = dreal(ff) - INews(i,j,k) = dimag(ff) - - enddo - enddo - enddo - -return - -end subroutine get_exact_news + + +#include "macrodef.fh" + +!------------------------------------------------------------------------------ +function omega_rhs(ex,crho,sigma,R,omega,RU,IU,omegarhs, & + quR1,quR2,quI1,quI2,gR,gI) result(gont) + + implicit none + + integer,intent(in) :: ex(3) + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: omega,RU,IU + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: omegarhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI +! gont = 0: success; gont = 1: something wrong + integer::gont + + double complex, dimension(ex(1),ex(2),ex(3)) :: comega,eth_omega,U,eth_Ub + real*8 :: dR + integer :: k + +!!! sanity check + dR = sum(omega)+sum(RU)+sum(IU) + if(dR.ne.dR) then + if(sum(omega).ne.sum(omega))write(*,*)"NullEvol_beta: find NaN in omega" + if(sum(RU).ne.sum(RU))write(*,*)"NullEvol_beta: find NaN in RU" + if(sum(IU).ne.sum(IU))write(*,*)"NullEvol_beta: find NaN in IU" + gont = 1 + return + endif + + comega = dcmplx(omega,0.d0) + U = dcmplx(RU,IU) + + do k=1,ex(3) + call derivs_eth(ex(1:2),crho,sigma,comega(:,:,k),eth_omega(:,:,k),0,1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + call derivs_eth(ex(1:2),crho,sigma,U(:,:,k),eth_Ub(:,:,k),1,-1, & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k),gR(:,:,k),gI(:,:,k)) + enddo + +!!! The term * e^{-2beta} has been added so as to be consistent with HPN. Nigel + !omega_u = - dble(eth_omega * conjg(U) + 0.5d0 * omega * eth_Ub * exp(-2*beta)) + +!!! - update .. I thought this may have been wrong so I removed the +!!! e^{-2beta} for testing. Yosef +! omegarhs = - dreal(eth_omega * dconjg(U) + 0.5d0 * omega * eth_Ub) + + omegarhs = - 0.5d0*dreal(eth_Ub) + + gont = 0 + + return + +end function omega_rhs +!--------------------------------------------------------------------------------------------------------- +subroutine drive_null_news(ex,crho,sigma,R,RJ,IJ,RU,IU,RTheta,ITheta,omega,beta, & + qlR1,qlR2,qlI1,qlI2, & + quR1,quR2,quI1,quI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,RNews,INews,Rmin,sst) + + implicit none + + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: Rmin + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RTheta,ITheta,omega,beta + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dquR1,dquR2,dquI1,dquI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dgR,dgI,bdgR,bdgI + + integer :: i,j,k + double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,U,J_u,J_l,J_l_u,News +#if 0 + call get_fake_Ju(ex,crho,sigma,R,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) +#endif + + CJ = dcmplx(RJ,IJ) + U = dcmplx(RU,IU) + J_u = dcmplx(RTheta,ITheta) + + do j=1,ex(2) + do i=1,ex(1) + call cderivs_x(ex(3),R,CJ(i,j,:),J_l(i,j,:)) + call cderivs_x(ex(3),R,J_u(i,j,:),J_l_u(i,j,:)) + J_l(i,j,:) = -J_l(i,j,:)*Rmin*R**2 + J_l_u(i,j,:) = -J_l_u(i,j,:)*Rmin*R**2 + enddo + enddo + +#if 0 +if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then + call get_exact_Jul(ex,crho,sigma,R,RNews,INews, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) +write(*,*) J_u(ex(1)/2,ex(2)/2,ex(3)-1),J_u(ex(1)/2,ex(2)/2,ex(3)) +write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) +write(*,*) J_l_u(ex(1)/2,ex(2)/2,ex(3)) +write(*,*)dcmplx(RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)))/J_l_u(ex(1)/2,ex(2)/2,ex(3)) +endif +stop +#endif + + do k=1,ex(3) + call get_null_news(ex(1:2),crho,sigma,CJ(:,:,k),U(:,:,k),J_u(:,:,k),J_l(:,:,k),J_l_u(:,:,k),omega(:,:,k),beta(:,:,k), & + qlR1(:,:,k),qlR2(:,:,k),qlI1(:,:,k),qlI2(:,:,k), & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k), & + gR(:,:,k),gI(:,:,k), & + dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & + bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & + dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k),News(:,:,k)) + enddo + + RNews = dreal(News) + INews = dimag(News) + +#if 0 +if(sst ==0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then + call get_exact_eth2omega(ex,crho,sigma,R,RNews,INews, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) +write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) +endif +stop +#endif + +#if 0 +! check orthornormality + RNews = RJ + INews = IJ + + RNews = 0.5d0*dreal(J_l_u) + INews = 0.5d0*dimag(J_l_u) +#endif + + call six2spher(ex,crho,sigma,R,RNews,INews,2,Rmin,sst) + + return + +end subroutine drive_null_news +!--------------------------------------------------------------------------------------------------------- +subroutine drive_null_news_diff(ex,crho,sigma,R,RJ,IJ,RU,IU,RTheta,ITheta,omega,beta, & + qlR1,qlR2,qlI1,qlI2, & + quR1,quR2,quI1,quI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,RNews,INews,Rmin,sst,Time) + + implicit none + + integer,intent(in) :: ex(3),sst + real*8,intent(in) :: Rmin,Time + real*8,intent(in),dimension(ex(1))::crho + real*8,intent(in),dimension(ex(2))::sigma + real*8,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: RJ,IJ,RU,IU,RTheta,ITheta,omega,beta + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: qlR1,qlR2,qlI1,qlI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: quR1,quR2,quI1,quI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: gR,gI + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dquR1,dquR2,dquI1,dquI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: dgR,dgI,bdgR,bdgI + + integer :: i,j,k + double complex, dimension(ex(1),ex(2),ex(3)) :: CJ,U,J_u,J_l,J_l_u,News +#if 0 + call get_fake_Ju(ex,crho,sigma,R,RTheta,ITheta, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) +#endif + + CJ = dcmplx(RJ,IJ) + U = dcmplx(RU,IU) + J_u = dcmplx(RTheta,ITheta) + + do j=1,ex(2) + do i=1,ex(1) + call cderivs_x(ex(3),R,CJ(i,j,:),J_l(i,j,:)) + call cderivs_x(ex(3),R,J_u(i,j,:),J_l_u(i,j,:)) + J_l(i,j,:) = -J_l(i,j,:)*Rmin*R**2 + J_l_u(i,j,:) = -J_l_u(i,j,:)*Rmin*R**2 + enddo + enddo + +#if 0 +if(sst == 0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then + call get_exact_Jul(ex,crho,sigma,R,RNews,INews, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) +write(*,*) J_u(ex(1)/2,ex(2)/2,ex(3)-1),J_u(ex(1)/2,ex(2)/2,ex(3)) +write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) +write(*,*) J_l_u(ex(1)/2,ex(2)/2,ex(3)) +write(*,*)dcmplx(RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)))/J_l_u(ex(1)/2,ex(2)/2,ex(3)) +endif +stop +#endif + + do k=1,ex(3) + call get_null_news(ex(1:2),crho,sigma,CJ(:,:,k),U(:,:,k),J_u(:,:,k),J_l(:,:,k),J_l_u(:,:,k),omega(:,:,k),beta(:,:,k), & + qlR1(:,:,k),qlR2(:,:,k),qlI1(:,:,k),qlI2(:,:,k), & + quR1(:,:,k),quR2(:,:,k),quI1(:,:,k),quI2(:,:,k), & + gR(:,:,k),gI(:,:,k), & + dquR1(:,:,k),dquR2(:,:,k),dquI1(:,:,k),dquI2(:,:,k), & + bdquR1(:,:,k),bdquR2(:,:,k),bdquI1(:,:,k),bdquI2(:,:,k), & + dgR(:,:,k),dgI(:,:,k),bdgR(:,:,k),bdgI(:,:,k),News(:,:,k)) + enddo + + call get_exact_news(ex,crho,sigma,R,RNews,INews,sst,Rmin,Time) + + RNews = dreal(News) - Rnews + INews = dimag(News) - INews + +!this part is nonsence + RNews(:,:,1:ex(3)-1) = 0.d0 + INews(:,:,1:ex(3)-1) = 0.d0 +#if 0 +if(sst ==0 .and. crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then + call get_exact_eth2omega(ex,crho,sigma,R,RNews,INews, & + quR1,quR2,quI1,quI2,qlR1,qlR2,qlI1,qlI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,dacos(-1.d0)/2,Rmin,sst) +write(*,*) RNews(ex(1)/2,ex(2)/2,ex(3)),INews(ex(1)/2,ex(2)/2,ex(3)) +endif +stop +#endif + +#if 0 +! check orthornormality + RNews = RJ + INews = IJ + + RNews = 0.5d0*dreal(J_l_u) + INews = 0.5d0*dimag(J_l_u) +#endif + + call six2spher(ex,crho,sigma,R,RNews,INews,2,Rmin,sst) + + return + +end subroutine drive_null_news_diff +!------------------------------------------------------------------------------------------------------------ +subroutine get_null_news(ex,crho,sigma,J,U,J_u,J_l,J_l_u,omega,beta, & + qlR1,qlR2,qlI1,qlI2, & + quR1,quR2,quI1,quI2, & + gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI,News) + +implicit none + +integer,intent(in) :: ex(2) +real*8,intent(in),dimension(ex(1))::crho +real*8,intent(in),dimension(ex(2))::sigma +double complex,dimension(ex(1),ex(2)),intent(in) :: J,U +double complex,dimension(ex(1),ex(2)),intent(in) :: J_u,J_l,J_l_u +real*8,dimension(ex(1),ex(2)),intent(in) :: omega,beta +real*8,dimension(ex(1),ex(2)),intent(in) :: qlR1,qlR2,qlI1,qlI2 +real*8,dimension(ex(1),ex(2)),intent(in) :: quR1,quR2,quI1,quI2 +real*8,dimension(ex(1),ex(2)),intent(in) :: gR,gI +real*8,dimension(ex(1),ex(2)),intent(in) :: dquR1,dquR2,dquI1,dquI2 +real*8,dimension(ex(1),ex(2)),intent(in) :: bdquR1,bdquR2,bdquI1,bdquI2 +real*8,dimension(ex(1),ex(2)),intent(in) :: dgR,dgI,bdgR,bdgI +double complex,dimension(ex(1),ex(2)),intent(out) :: News + +! local variables +real*8,dimension(ex(1),ex(2)) :: K,K_u,K_l,K_l_u +real*8,dimension(ex(1),ex(2)) :: a +double complex,dimension(ex(1),ex(2)) :: Comega,Cbeta +double complex,dimension(ex(1),ex(2)) :: Jb,Ub +double complex,dimension(ex(1),ex(2)) :: eth_a,eth2_a,eth_ethb_a +double complex,dimension(ex(1),ex(2)) :: s1,s2,s3,s4,s5 +double complex,dimension(ex(1),ex(2)) :: eth_U,ethb_U,eth_J,ethb_J +double complex,dimension(ex(1),ex(2)) :: eth_J_l,ethb_J_l,eth_K_l,eth_K +double complex,dimension(ex(1),ex(2)) :: eth_omega,eth_beta +double complex,dimension(ex(1),ex(2)) :: eth2_omega,eth2_beta +double complex,dimension(ex(1),ex(2)) :: eth_ethb_omega,eth_ethb_beta + + Comega = dcmplx(omega,0.d0) + Cbeta = dcmplx(beta,0.d0) + call derivs_eth(ex,crho,sigma,Comega,eth_omega,0,1,quR1,quR2,quI1,quI2,gR,gI) + call derivs_eth(ex,crho,sigma,Cbeta,eth_beta,0,1,quR1,quR2,quI1,quI2,gR,gI) + call dderivs_eth(ex,crho,sigma,Comega,eth2_omega,0,1,1, & + quR1,quR2,quI1,quI2,gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) + call dderivs_eth(ex,crho,sigma,Cbeta,eth2_beta,0,1,1, & + quR1,quR2,quI1,quI2,gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) + call dderivs_eth(ex,crho,sigma,Comega,eth_ethb_omega,0,-1,1, & + quR1,quR2,quI1,quI2,gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) + call dderivs_eth(ex,crho,sigma,Cbeta,eth_ethb_beta,0,-1,1, & + quR1,quR2,quI1,quI2,gR,gI, & + dquR1,dquR2,dquI1,dquI2, & + bdquR1,bdquR2,bdquI1,bdquI2, & + dgR,dgI,bdgR,bdgI) + call derivs_eth(ex,crho,sigma,U,eth_U,1,1,quR1,quR2,quI1,quI2,gR,gI) + call derivs_eth(ex,crho,sigma,U,ethb_U,1,-1,quR1,quR2,quI1,quI2,gR,gI) + call derivs_eth(ex,crho,sigma,J,eth_J,2,1,quR1,quR2,quI1,quI2,gR,gI) + call derivs_eth(ex,crho,sigma,J,ethb_J,2,-1,quR1,quR2,quI1,quI2,gR,gI) + call derivs_eth(ex,crho,sigma,J_l,eth_J_l,2,1,quR1,quR2,quI1,quI2,gR,gI) + call derivs_eth(ex,crho,sigma,J_l,ethb_J_l,2,-1,quR1,quR2,quI1,quI2,gR,gI) + + Jb = dconjg(J) + Ub = dconjg(U) + K = dsqrt(1.0d0 + cdabs(J)**2) +! temp storage + Comega=dcmplx(K,0.d0) + call derivs_eth(ex,crho,sigma,Comega,eth_K,0,1,quR1,quR2,quI1,quI2,gR,gI) + + K_u = dreal( J_u * Jb ) / K + K_l = dreal( J_l * Jb ) / K +! temp storage + Comega=dcmplx(K_l,0.d0) + call derivs_eth(ex,crho,sigma,Comega,eth_K_l,0,1,quR1,quR2,quI1,quI2,gR,gI) + K_l_u = dreal( J_u * dconjg(J_l) + J_l_u * Jb )/ K - K_l * K_u / K + + a = omega * dexp(2.0d0 * beta) + + eth_a = dexp(2.0d0 * beta) * ( eth_omega + 2.0d0 * omega * eth_beta ) + + eth2_a = dexp(2.0d0 * beta) * ( 4.0d0 * eth_beta * eth_omega & + + 4.0d0 * omega * eth_beta**2 & + + eth2_omega + 2.0d0 * omega * eth2_beta ) + + eth_ethb_a = dexp(2.0d0 * beta) * ( 4.0d0 * dreal(eth_beta * dconjg(eth_omega)) & + + 4.0d0 * omega * eth_beta * dconjg(eth_beta) & + + eth_ethb_omega + 2.0d0 * omega * eth_ethb_beta ) + + s1 = ( -2.0d0 * K_l_u * J * (K + 1.0d0) + J_l_u * (K + 1.0d0)**2 & + + dconjg(J_l_u) * J**2 ) / (K + 1.0d0) + + s2 = 0.5d0 / ( K + 1.0d0) * ( & + (K + 1.0d0)* (eth_J_l *Ub * (K+1.0d0) - 2.0d0* eth_K_l * J *Ub ) & + + eth_U * (K+1.0d0)* ( -2.0d0 * J * dconjg(J_l) + K_l * 2.0d0 * (K+1.0d0) ) & + + dconjg(ethb_U) * (K+1.0d0) * ( -2.0d0* J * K_l + J_l * 2.0d0 * (K+1.0d0) ) & + + ethb_J_l * U * (K+1.0d0)**2 - dconjg(eth_K_l) * 2.0d0 * U * J * (K+1.0d0) & + + ethb_U * 2.0d0 * J * ( J * dconjg(J_l) - (K+1.0d0) * K_l) & + + J**2 * ( U * dconjg(eth_J_l) + dconjg(ethb_J_l * U) ) & + + J * 2.0d0 * dconjg(eth_U) * ( J * K_l - J_l * (K+1.0d0) ) ) + + s3 = ( J_l * (K + 1.0d0)**2 -2.0d0 * K_l * J * (K + 1.0d0) & + + dconjg(J_l) * J**2) / (K + 1.0d0) + + s4 = 0.5d0 / ( K + 1.0d0) * ( eth_a * eth_omega * (K + 1.0d0)**2 & + - (K+1.0d0) * J * 2.0d0* dreal( eth_a * dconjg(eth_omega) ) & + + J**2 * dconjg(eth_a * eth_omega) ) + + s5 = 0.25d0 / ( K + 1.0d0) * ( 2.0d0 * eth2_a * (K+1.0d0)**2 & + + 2.0d0 * J**2 * dconjg(eth2_a) & + - 4.0d0 * eth_ethb_a * J * (K+1.0d0) & + + Jb * eth_a * eth_J* (K+1.0d0)**2 & + + J * eth_a * dconjg(ethb_J) * (K+1.0d0)**2 & + - eth_a * eth_K * 2.0d0 * (K+1.0d0) * ( J*Jb + (K+1.0d0) ) & + + eth_a * ethb_J * (K+1.0d0) * ( -J*Jb + (K+1.0d0) ) & + - J**2 * eth_a * dconjg(eth_J) * K & + + J**2 * Jb * 2.0d0* eth_a * dconjg(eth_K) & + - dconjg(eth_a) * eth_J * (K+1.0d0) * ( J*Jb + K+1.0d0 ) & + - dconjg(ethb_J) * dconjg(eth_a) * J**2 * ( K + 2.0d0) & + + J * 2.0d0 * (K+1.0d0)**2 * eth_K * dconjg(eth_a) & + + J**2 * Jb * ethb_J * dconjg(eth_a) & + + J**3 * dconjg(eth_a * eth_J) & + - 2.0d0* J**2 *K*dconjg(eth_K * eth_a) ) + + ! News = 0.25d0 * ( s1 + s2 + 0.5d0 * dble(ethb_U) * s3 & + ! - 4.0d0 * s4 / omega**2 + 2.0d0 * s5 / omega ) / ( omega**2 * exp(2.0d0 * beta) ) + + ! change sign of s3 to compensate for a bug in Eqs. 30, 37, and 38 of + ! HPN +#if 1 + News = 0.25d0 * ( s1 + s2 - 0.5d0 * dreal(ethb_U) * s3 & + - 4.0d0 * s4 / omega**2 + 2.0d0 * s5 / omega ) / ( omega**2 * dexp(2.0d0 * beta) ) +#else +#if 0 +if(crho(1) < -dacos(-1.d0)/4 .and. sigma(1) < -dacos(-1.d0)/4)then +write(*,*) eth2_omega(ex(1)/2,ex(2)/2) +endif +#endif + News = 0.5d0*J_l_u+eth2_beta+0.5d0*eth2_omega ! if given omega error is about 6e-9 +! News = 0.5d0*J_l_u+eth2_beta-1.5d0*J ! error is about 6e-9 +#endif + return + +end subroutine get_null_news +!-------------------------------------------------------------------------------------------------- +! change spin weighted function from 6 patches to spherical coordinate + subroutine six2spher(ex,crho,sigma,R,RU,IU,spin,Rmin,sst) + + implicit none + +!~~~~~~% Input parameters: + integer,intent(in) :: ex(3),sst,spin + real*8,intent(in) :: Rmin + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8,dimension(ex(1),ex(2),ex(3)),intent(inout) :: RU,IU + +integer :: i,j,k +real*8 ::x,y,z,hgr,gt,gp,tgrho,tgsigma,tc,ts,rf +double complex :: II,swtf,ff + + II = dcmplx(0.d0,1.d0) + hgr = 1.d0 + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! hgr = R(k)*Rmin/(1.d0-R(k)) R is not invovled indeed, to avoid NaN, we set +! it to 1 above + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -hgr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "six2spher: not recognized sst = ",sst + return + end select + gt = dacos(z/hgr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + ff=dcmplx(RU(i,j,k),IU(i,j,k))/swtf**spin + + RU(i,j,k) = dreal(ff) + IU(i,j,k) = dimag(ff) + enddo + enddo + enddo + + return + + end subroutine six2spher +!------------------------------------------------------------- +! Linear wave given in Eq.(27) of CQG 22, 2393 (2005) +!------------------------------------------------------------- +subroutine get_exact_omega(ex,crho,sigma,R,omega,sst,Rmin,T) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,T +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega + +integer :: i,j,k +real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts +double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +double complex :: swtf,ff + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_exact_omega: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + gr = (1.d0-R(k))/R(k)/Rmin + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1+C1/4.d0*gr-C2/1.2d1*gr**3 + gr = dreal(Jr*cdexp(II*nu*T)) + Jr = Yslm(0,2,m,gt,gp) + omega(i,j,k) = 1.d0-2.d0*(2+1)/2.d0*gr*dreal(Jr) + + enddo + enddo + enddo + +return + +end subroutine get_exact_omega +!------------------------------------------------------------- +! Linear wave given in Eq.(16) of CQG 24S327 +!------------------------------------------------------------- +subroutine get_exact_news(ex,crho,sigma,R,RNews,INews,sst,Rmin,Time) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: Rmin,Time +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::RNews,INews + +integer :: i,j,k +real*8 ::x,y,z,gr,gt,gp,tgrho,tgsigma,tc,ts +double complex :: Yslm,II,Jr + +double complex :: beta0,C1,C2 +integer :: nu,m + +double complex :: swtf,ff + +call initial_null_paramter(beta0,C1,C2,nu,m) + + II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +!fake global coordinate is enough here + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_initial_null: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma(j)) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + Jr = II*nu**3*C2/dsqrt(2.4d1) + gr = dreal(Jr) + Jr = Yslm(2,2,m,gt,gp) + ff = gr*Jr*swtf**2 + RNews(i,j,k) = dreal(ff) + INews(i,j,k) = dimag(ff) + + enddo + enddo + enddo + +return + +end subroutine get_exact_news diff --git a/AMSS_NCKU_source/NullNews.h b/AMSS_NCKU_source/Null_Evolve/NullNews.h similarity index 96% rename from AMSS_NCKU_source/NullNews.h rename to AMSS_NCKU_source/Null_Evolve/NullNews.h index 12b02cc..a8a64b3 100644 --- a/AMSS_NCKU_source/NullNews.h +++ b/AMSS_NCKU_source/Null_Evolve/NullNews.h @@ -1,106 +1,106 @@ - -#ifndef NULLNEWS_H -#define NULLNEWS_H - -#ifdef fortran1 -#define f_drive_null_news drive_null_news -#define f_get_null_news2 get_null_news2 -#define f_drive_null_news_diff drive_null_news_diff -#define f_omega_rhs omega_rhs -#define f_get_exact_omega get_exact_omega -#define f_get_omega_and_dtomega_pre get_omega_and_dtomega_pre -#define f_get_omega_and_dtomega_LN get_omega_and_dtomega_ln -#define f_get_dtomega get_dtomega -#endif -#ifdef fortran2 -#define f_drive_null_news DRIVE_NULL_NEWS -#define f_get_null_news2 GET_NULL_NEWS2 -#define f_drive_null_news_diff DRIVE_NULL_NEWS_DIFF -#define f_omega_rhs OMEGA_RHS -#define f_get_exact_omega GET_EXACT_OMEGA -#define f_get_omega_and_dtomega_pre GET_OMEGA_AND_DTOMEGA_PRE -#define f_get_omega_and_dtomega_LN GET_OMEGA_AND_DTOMEGA_LN -#define f_get_dtomega GET_DTOMEGA -#endif -#ifdef fortran3 -#define f_drive_null_news drive_null_news_ -#define f_get_null_news2 get_null_news2_ -#define f_drive_null_news_diff drive_null_news_diff_ -#define f_omega_rhs omega_rhs_ -#define f_get_exact_omega get_exact_omega_ -#define f_get_omega_and_dtomega_pre get_omega_and_dtomega_pre_ -#define f_get_omega_and_dtomega_LN get_omega_and_dtomega_ln_ -#define f_get_dtomega get_dtomega_ -#endif - -extern "C" -{ - void f_drive_null_news(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double &, int &); -} - -extern "C" -{ - void f_drive_null_news_diff(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double &, int &, double &); -} - -extern "C" -{ - void f_omega_rhs(int *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, double *, - double *, double *); -} - -extern "C" -{ - void f_get_exact_omega(int *, double *, double *, double *, - double *, - int &, double &, double &); -} - -extern "C" -{ - void f_get_null_news2(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double &, int &); -} - -extern "C" -{ - void f_get_omega_and_dtomega_pre(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double &); -} - -extern "C" -{ - void f_get_dtomega(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double &); -} - -extern "C" -{ - void f_get_omega_and_dtomega_LN(double &, int *, double *, double *, double *, - double *, double *, double &, int &); -} -#endif /* NULLNEWS_H */ + +#ifndef NULLNEWS_H +#define NULLNEWS_H + +#ifdef fortran1 +#define f_drive_null_news drive_null_news +#define f_get_null_news2 get_null_news2 +#define f_drive_null_news_diff drive_null_news_diff +#define f_omega_rhs omega_rhs +#define f_get_exact_omega get_exact_omega +#define f_get_omega_and_dtomega_pre get_omega_and_dtomega_pre +#define f_get_omega_and_dtomega_LN get_omega_and_dtomega_ln +#define f_get_dtomega get_dtomega +#endif +#ifdef fortran2 +#define f_drive_null_news DRIVE_NULL_NEWS +#define f_get_null_news2 GET_NULL_NEWS2 +#define f_drive_null_news_diff DRIVE_NULL_NEWS_DIFF +#define f_omega_rhs OMEGA_RHS +#define f_get_exact_omega GET_EXACT_OMEGA +#define f_get_omega_and_dtomega_pre GET_OMEGA_AND_DTOMEGA_PRE +#define f_get_omega_and_dtomega_LN GET_OMEGA_AND_DTOMEGA_LN +#define f_get_dtomega GET_DTOMEGA +#endif +#ifdef fortran3 +#define f_drive_null_news drive_null_news_ +#define f_get_null_news2 get_null_news2_ +#define f_drive_null_news_diff drive_null_news_diff_ +#define f_omega_rhs omega_rhs_ +#define f_get_exact_omega get_exact_omega_ +#define f_get_omega_and_dtomega_pre get_omega_and_dtomega_pre_ +#define f_get_omega_and_dtomega_LN get_omega_and_dtomega_ln_ +#define f_get_dtomega get_dtomega_ +#endif + +extern "C" +{ + void f_drive_null_news(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double &, int &); +} + +extern "C" +{ + void f_drive_null_news_diff(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double &, int &, double &); +} + +extern "C" +{ + void f_omega_rhs(int *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, double *, + double *, double *); +} + +extern "C" +{ + void f_get_exact_omega(int *, double *, double *, double *, + double *, + int &, double &, double &); +} + +extern "C" +{ + void f_get_null_news2(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double &, int &); +} + +extern "C" +{ + void f_get_omega_and_dtomega_pre(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double &); +} + +extern "C" +{ + void f_get_dtomega(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double &); +} + +extern "C" +{ + void f_get_omega_and_dtomega_LN(double &, int *, double *, double *, double *, + double *, double *, double &, int &); +} +#endif /* NULLNEWS_H */ diff --git a/AMSS_NCKU_source/NullNews2.f90 b/AMSS_NCKU_source/Null_Evolve/NullNews2.f90 similarity index 96% rename from AMSS_NCKU_source/NullNews2.f90 rename to AMSS_NCKU_source/Null_Evolve/NullNews2.f90 index 084d6a1..f0ec354 100644 --- a/AMSS_NCKU_source/NullNews2.f90 +++ b/AMSS_NCKU_source/Null_Evolve/NullNews2.f90 @@ -1,588 +1,588 @@ - - -#include "macrodef.fh" - -!------------------------------------------------------------------------------ -! input R is X indeed -! input g00 is g00/r^2 indeed -! input g0A is g0A/r^2 indeed -! input gAB is gAB/r^2 indeed -! output Gamma is Gamma of omega^2 g_{munu}/r^2 at r = infinity or to say X = 1 -! ** in coordinate (u,X,x,y) ** -subroutine get_christoffel(Rmin,g00,g01,g02,g03, & - g22,g23,g33, & - dgt22,dgt23,dgt33,& - dg22,dg23,dg33,& - dgx02,dgx03,dgx22,dgx23,dgx33,& - dgy02,dgy03,dgy22,dgy23,dgy33,& - omega,dtomega,dxomega,dyomega,& - Gamuxx,Gamuxy,Gamuyy, & - Gamrxx,Gamrxy,Gamryy, & - Gamxxx,Gamxxy,Gamxyy, & - Gamyxx,Gamyxy,Gamyyy) - - implicit none - - real*8,intent(in)::Rmin - real*8,intent(in)::g00,g01,g02,g03,g22,g23,g33 - real*8,intent(in)::dgt22,dgt23,dgt33 - real*8,intent(in)::dg22,dg23,dg33 - real*8,intent(in)::dgx02,dgx03,dgx22,dgx23,dgx33 - real*8,intent(in)::dgy02,dgy03,dgy22,dgy23,dgy33 - real*8,intent(in) :: omega,dtomega,dxomega,dyomega - real*8,intent(out) :: Gamuxx,Gamuxy,Gamuyy - real*8,intent(out) :: Gamrxx,Gamrxy,Gamryy - real*8,intent(out) :: Gamxxx,Gamxxy,Gamxyy - real*8,intent(out) :: Gamyxx,Gamyxy,Gamyyy - - real*8 :: t1; - real*8 :: t10; - real*8 :: t11; - real*8 :: t117; - real*8 :: t12; - real*8 :: t121; - real*8 :: t138; - real*8 :: t142; - real*8 :: t147; - real*8 :: t18; - real*8 :: t184; - real*8 :: t190; - real*8 :: t194; - real*8 :: t198; - real*8 :: t2; - real*8 :: t204; - real*8 :: t206; - real*8 :: t208; - real*8 :: t214; - real*8 :: t216; - real*8 :: t220; - real*8 :: t222; - real*8 :: t227; - real*8 :: t230; - real*8 :: t233; - real*8 :: t239; - real*8 :: t24; - real*8 :: t241; - real*8 :: t242; - real*8 :: t244; - real*8 :: t249; - real*8 :: t25; - real*8 :: t252; - real*8 :: t28; - real*8 :: t29; - real*8 :: t32; - real*8 :: t37; - real*8 :: t47; - real*8 :: t53; - real*8 :: t54; - real*8 :: t58; - real*8 :: t64; - real*8 :: t65; - real*8 :: t66; - real*8 :: t68; - real*8 :: t71; - real*8 :: t72; - real*8 :: t73; - real*8 :: t75; - real*8 :: t76; - real*8 :: t77; - real*8 :: t80; - real*8 :: t82; - real*8 :: t84; - real*8 :: t85; - real*8 :: t88; - real*8 :: t9; - real*8 :: t91; - - t1 = 1/g01; - t2 = Rmin*t1; - t9 = 1/omega; - t10 = Rmin*t9; - t11 = g01*omega; - t12 = g22*g03; - t18 = g23*g02; - t24 = g01*g22; - t25 = t18*dyomega; - t28 = g23*g03; - t29 = t28*dxomega; - t32 = g33*g02; - t37 = g22*g33; - t47 = g23*g23; - t53 = g22*g22; - t54 = g01*t53; - t58 = t47*dtomega; - t64 = Rmin*dg22; - t65 = t64*omega; - t66 = t37*g00; - t68 = t18*g03; - t71 = omega*g22; - t72 = g03*g03; - t73 = t71*t72; - t75 = omega*g33; - t76 = g02*g02; - t77 = t75*t76; - t80 = omega*t47*g00; - t82 = 2.0*t24*t32*dxomega-2.0*t11*t47*dgx02+t11*t47*dgt22-2.0*t54*g33*dtomega & - +2.0*t24*t58+2.0*t54*g03*dyomega+t65*t66+2.0*t65*t68-t64*t73-t64*t77-t64*t80; - t84 = g01*g01; - t85 = 1/t84; - t88 = 1/(t37-t47); - t91 = Rmin*dg23; - t117 = g01*g33; - t121 = g01*t47; - t138 = t91*omega; - t142 = -t11*t12*dgx33+t11*t18*dgx33+2.0*t117*t18*dxomega-2.0*t121*g03*dxomega & - -2.0*t121*g02*dyomega+t11*t47*dgt23-t11*t47*dgx03-t11*t47*dgy02+2.0*g01*t47*g23*dtomega+t138*t66+2.0*t138*t68; - t147 = Rmin*dg33; - t184 = g33*g33; - t190 = g01*t184; - t194 = t147*omega; - t198 = -2.0*t117*t25-2.0*t117*t29-t11*t12*dgy33+t11*t18*dgy33-2.0*t11*t47*dgy03+t11*t47*dgt33-2.0*t24*t184*dtomega & - +2.0*t117*t58+2.0*t190*g02*dxomega+t194*t66+2.0*t194*t68; - t204 = g02*dg22*Rmin; - t206 = omega*g23; - t208 = g03*dg22*Rmin; - t214 = 2.0*t24*g33*dxomega; - t216 = t11*g23*dgy22; - t220 = g23*dyomega; - t222 = 2.0*t24*t220; - t227 = t1*t88; - t230 = g02*dg23*Rmin; - t233 = g03*dg23*Rmin; - t239 = 2.0*t24*g33*dyomega; - t241 = t11*g23*dgx33; - t242 = g23*dxomega; - t244 = 2.0*t117*t242; - t249 = g02*dg33*Rmin; - t252 = g03*dg33*Rmin; - Gamuxx = -t2*dg22/2.0; - Gamuxy = -t2*dg23/2.0; - Gamuyy = -t2*dg33/2.0; - Gamrxx = t10*(-2.0*t11*t12*dgx23+t11*t12*dgy22+2.0*t11*t18*dgx23-t11*t18*dgy22+t11*t28*dgx22-t11*t32*dgx22 & - -t11*t37*dgt22+2.0*t11*t37*dgx02-2.0*t24*t25-2.0*t24*t29+t82)*t85*t88/2.0; - Gamrxy = t10*(-t91*t73-t91*t77-t91*t80-2.0*t24*g33*g23*dtomega-t11*t37*dgt23+t11*t37*dgx03+t11*t37*dgy02 & - -t11*t32*dgy22+t11*t28*dgy22+2.0*t24*t28*dyomega+t142)*t85*t88/2.0; - Gamryy = t10*(-t147*t73-t147*t77-t147*t80+2.0*t11*t37*dgy03-t11*t37*dgt33+2.0*t24*g33*g03*dyomega & - -2.0*t11*t32*dgy23+t11*t32*dgx33+2.0*t11*t28*dgy23-t11*t28*dgx33+t198)*t85*t88/2.0; - Gamxxx = t9*(-2.0*t11*g23*dgx23+t11*g33*dgx22+t75*t204-4.0*t121*dxomega-t206*t208+t214+t216+t222)*t227/2.0; - Gamxxy = t9*(t11*g33*dgy22+t75*t230-t206*t233+t239-t241-t244)*t227/2.0; - Gamxyy = t9*(-t11*g23*dgy33-t11*g33*dgx33+2.0*t11*g33*dgy23+t75*t249-2.0*t190*dxomega+2.0*t117*t220-t206*t252)*t227/2.0; - Gamyxx = -t9*(-2.0*t11*g22*dgx23+t11*g22*dgy22+t11*g23*dgx22-2.0*t24*t242+2.0*t54*dyomega-t71*t208+t206*t204)*t227/2.0; - Gamyxy = -(-t11*g22*dgx33-t71*t233+t206*t230-t214+t216+t222)*t9*t227/2.0; - Gamyyy = t9*(t11*g22*dgy33-2.0*t11*g23*dgy23+t71*t252-4.0*t121*dyomega-t206*t249+t239+t241+t244)*t227/2.0; - - return - -end subroutine get_christoffel -!!---------------------------------------------------------------------------------------- -subroutine get_News(crho,sigma,& - dxxomega,dxyomega,dyyomega,& - omega,dtomega,dxomega,dyomega,& - Gamuxx,Gamuxy,Gamuyy, & - Gamrxx,Gamrxy,Gamryy, & - Gamxxx,Gamxxy,Gamxyy, & - Gamyxx,Gamyxy,Gamyyy,RNew,INew,sst) - - implicit none - - integer,intent(in) :: sst - real*8,intent(in)::crho,sigma - real*8,intent(in) :: dxxomega,dxyomega,dyyomega - real*8,intent(in) :: omega,dtomega,dxomega,dyomega - real*8,intent(in) :: Gamuxx,Gamuxy,Gamuyy - real*8,intent(in) :: Gamrxx,Gamrxy,Gamryy - real*8,intent(in) :: Gamxxx,Gamxxy,Gamxyy - real*8,intent(in) :: Gamyxx,Gamyxy,Gamyyy - - real*8,intent(out) :: RNew,INew - - - real*8 :: cs,cr,ss,sr,tc,ts - real*8 :: WWxx,WWxy,WWyy - real*8 :: Rmmxx,Rmmxy,Rmmyy - real*8 :: Immxx,Immxy,Immyy - - real*8 :: gr,tgrho,tgsigma,x,y,z,gt,gp - - double complex :: swtf,II -write(*,*) Gamrxx,Gamrxy,Gamryy - WWxx = (dxxomega-(Gamuxx*dtomega+Gamxxx*dxomega+Gamyxx*dyomega))/omega/2 - WWxy = (dxyomega-(Gamuxy*dtomega+Gamxxy*dxomega+Gamyxy*dyomega))/omega/2 - WWyy = (dyyomega-(Gamuyy*dtomega+Gamxyy*dxomega+Gamyyy*dyomega))/omega/2 - - cs = dcos(sigma) - cr = dcos(crho) - ss = dsin(sigma) - sr = dsin(crho) - tc = dsqrt((1-sr*ss)/2) - ts = dsqrt((1+sr*ss)/2) - Rmmxx = 4*tc*tc*ts*ts*(ts*ts-tc*tc)/cs/cs - Rmmxy = 4*tc*tc*ts*ts*(ts*ts+tc*tc)/cs/cr - Rmmyy = 4*tc*tc*ts*ts*(ts*ts-tc*tc)/cr/cr - Immxx = 8*tc*tc*ts*ts*ts*tc/cs/cs - Immxy = 0 - Immyy = -8*tc*tc*ts*ts*ts*tc/cr/cr - - if(sst==1 .or. sst==3 .or. sst==4)then - Immxx = -Immxx - Immxy = -Immxy - Immyy = -Immyy - endif - - RNew = Rmmxx*WWxx+2*Rmmxy*WWxy+Rmmyy*WWyy - INew = Immxx*WWxx+2*Immxy*WWxy+Immyy*WWyy -!! change to tetrad theta phi -!fake global coordinate is enough here - - II = dcmplx(0.d0,1.d0) - gr = 1.d0 - tgrho = dtan(crho) - tgsigma = dtan(sigma) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_News: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) - if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) - select case (sst) - case (0,1) - swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) - case (2,3) - swtf = II*swtf*dsin(gt) - case (4,5) - swtf = -II*swtf*dsin(gt) - end select - - swtf = (RNew+II*INew)/swtf**2 - - RNew = dreal(swtf) - INew = dimag(swtf) - - return - -end subroutine get_News -!------------------------------------------------------------------------------------------------------------ -subroutine get_null_news2(ex,crho,sigma,R,omega,dtomega, & - g00,g01,g02,g03,g22,g23,g33, & - dtg22,dtg23,dtg33, & - RNews,INews,Rmin,sst) - -implicit none - -integer,intent(in) :: ex(3),sst -real*8,intent(in) :: Rmin -real*8,intent(in),dimension(ex(1))::crho -real*8,intent(in),dimension(ex(2))::sigma -real*8,intent(in),dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3)),intent(in ) :: omega,dtomega -real*8,dimension(ex(1),ex(2),ex(3)),intent(in ) :: g00,g01,g02,g03,g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtg22,dtg23,dtg33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews - -real*8 :: Gamuxx,Gamuxy,Gamuyy -real*8 :: Gamrxx,Gamrxy,Gamryy -real*8 :: Gamxxx,Gamxxy,Gamxyy -real*8 :: Gamyxx,Gamyxy,Gamyyy -real*8 :: dg22,dg23,dg33 -real*8 :: dgx22,dgx23,dgx33 -real*8 :: dgx02,dgx03 -real*8 :: dgy22,dgy23,dgy33 -real*8 :: dgy02,dgy03 -real*8 :: dxomega,dyomega -real*8 :: dxxomega,dxyomega,dyyomega - -integer :: i,j,k - -k = ex(3) -do i=1,ex(1) -do j=1,ex(2) - call rderivs_x_point(ex(3),R,g22(i,j,:),dg22,k) - call rderivs_x_point(ex(3),R,g23(i,j,:),dg23,k) - call rderivs_x_point(ex(3),R,g33(i,j,:),dg33,k) - - call rderivs_x_point(ex(1),crho,g02(:,j,k),dgx02,i) - call rderivs_x_point(ex(1),crho,g03(:,j,k),dgx03,i) - call rderivs_x_point(ex(1),crho,g22(:,j,k),dgx22,i) - call rderivs_x_point(ex(1),crho,g23(:,j,k),dgx23,i) - call rderivs_x_point(ex(1),crho,g33(:,j,k),dgx33,i) - call rderivs_x_point(ex(1),crho,omega(:,j,k),dxomega,i) - - call rderivs_x_point(ex(2),sigma,g02(i,:,k),dgy02,j) - call rderivs_x_point(ex(2),sigma,g03(i,:,k),dgy03,j) - call rderivs_x_point(ex(2),sigma,g22(i,:,k),dgy22,j) - call rderivs_x_point(ex(2),sigma,g23(i,:,k),dgy23,j) - call rderivs_x_point(ex(2),sigma,g33(i,:,k),dgy33,j) - call rderivs_x_point(ex(2),sigma,omega(i,:,k),dyomega,j) - - call get_christoffel(Rmin,g00(i,j,k),g01(i,j,k),g02(i,j,k),g03(i,j,k), & - g22(i,j,k),g23(i,j,k),g33(i,j,k), & - dtg22(i,j,k),dtg23(i,j,k),dtg33(i,j,k),& - dg22,dg23,dg33,& - dgx02,dgx03,dgx22,dgx23,dgx33,& - dgy02,dgy03,dgy22,dgy23,dgy33,& - omega(i,j,k),dtomega(i,j,k),dxomega,dyomega,& - Gamuxx,Gamuxy,Gamuyy, & - Gamrxx,Gamrxy,Gamryy, & - Gamxxx,Gamxxy,Gamxyy, & - Gamyxx,Gamyxy,Gamyyy) - - call rdderivs_x_point(ex(1),crho,omega(:,j,k),dxxomega,i) - call rdderivs_x_point(ex(2),crho,omega(i,:,k),dyyomega,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,omega(:,:,k),dxyomega,i,j) - - call get_News(crho(i),sigma(j),& - dxxomega,dxyomega,dyyomega,& - omega(i,j,k),dtomega(i,j,k),dxomega,dyomega,& - Gamuxx,Gamuxy,Gamuyy, & - Gamrxx,Gamrxy,Gamryy, & - Gamxxx,Gamxxy,Gamxyy, & - Gamyxx,Gamyxy,Gamyyy,RNews(i,j,k),INews(i,j,k),sst) -enddo -enddo - - return - -end subroutine get_null_news2 -!!------------------------------------------------------------------------------------------------------------ -!! input g_AB and Theta_AB are divided by r^2 indeed -!! input g_00 is also divided by r^2 indeed -! the output g00 is K -subroutine get_omega_and_dtomega_pre(ex,crho,sigma,X,g22,g23,g33, & - omega,dtomega, Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega,dtomega - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - -R = X*Rmin/(1-X) -det = g22*g33-g23*g23 -gup22 = g33/det -gup23 = -g23/det -gup33 = g22/det - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - sr = dsin(crho(i)) - ss = dsin(sigma(j)) - cr = dcos(crho(i)) - cs = dcos(sigma(j)) - sr2 = sr*sr - ss2 = ss*ss - cr2 = cr*cr - cs2 = cs*cs - - tg22 = 1-sr2*ss2 - tg22 = 1/tg22/tg22 - - tg23 = -sr*cr*ss*cs*tg22 - tg33 = cr2*tg22 - tg22 = cs2*tg22 - -! ghat/(g/r^4) indeed - det(i,j,k) = (tg22*tg33-tg23*tg23)/det(i,j,k) - enddo - enddo - enddo - - omega = dsqrt(det) - k = ex(3) - do i=1,ex(1) - do j=1,ex(2) - - call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - KK(i,j,k) = dsqrt(det(i,j,k))*(1-0.25*covf/R(k)**2) - enddo - enddo - - dtomega = KK - - return - -end subroutine get_omega_and_dtomega_pre -!------------------------------------------------------------------------------------------------------ -subroutine get_dtomega(ex,crho,sigma,X,g22,g23,g33, & - omega,dtomega, Rmin) -implicit none -! argument variables -integer, intent(in ):: ex(1:3) -real*8,intent(in) :: Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::X -real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::omega,g22,g23,g33 -real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::dtomega - - -double precision,dimension(ex(3))::R -real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK - -real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 -real*8 :: fr,fs,frr,fss,frs,covf - -integer :: i,j,k - -real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam - -call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) - - KK = dtomega - - k = ex(3) - do i=1,ex(1) - do j=1,ex(2) - - call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) - call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) - call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) - call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) - call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) - - call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) - - dtomega(i,j,k) = -covf*omega(i,j,k)**3/6/m0/2 - enddo - enddo - - return - -end subroutine get_dtomega -!!------------------------------------------------------------------------------------------------------------ -!! input g_AB and Theta_AB are divided by r^2 indeed -!! input g_00 is also divided by r^2 indeed -subroutine get_omega_and_dtomega_LN(time,ex,crho,sigma,XX, & - omega,dtomega, Rmin,sst) -implicit none -! argument variables -integer, intent(in ):: ex(1:3),sst -real*8,intent(in) :: time,Rmin -double precision,intent(in),dimension(ex(1))::crho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::XX -real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega,dtomega - -integer :: i,j,k -real*8 :: gr,gt,gp,tgrho,tgsigma,tc,ts,x,y,z - -double complex :: II,Jr,Jrt -double complex :: Zslm,z020 - -double complex :: beta0,C1,C2,mx,my,mlx,mly -integer :: nu,m - -call initial_null_paramter(beta0,C1,C2,nu,m) - -II = dcmplx(0.d0,1.d0) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) -! here fake global coordinate is enough - gr = 1.d0 - tgrho = dtan(crho(i)) - tgsigma = dtan(sigma(j)) - tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) - ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) - select case (sst) - case (0) - z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (1) - z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = z*tgrho - y = z*tgsigma - case (2) - x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (3) - x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - y = x*tgrho - z = x*tgsigma - case (4) - y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case (5) - y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) - x = y*tgrho - z = y*tgsigma - case default - write(*,*) "get_null_boundary3: not recognized sst = ",sst - return - end select - gt = dacos(z/gr) - gp = datan2(y,x) - - z020 = Zslm(0,2,m,gt,gp) - - Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1 - Jr = Jr*exp(II*nu*time) - Jrt = II*nu*Jr*exp(II*nu*time) - - Jr = dsqrt(dble((2-1)))*dreal(Jr)*z020 - Jrt = dsqrt(dble((2-1)))*dreal(Jrt)*z020 - - omega(i,j,k) = 1-dreal(Jr) - dtomega(i,j,k) = -dreal(Jrt) - - enddo - enddo - enddo - - return - -end subroutine get_omega_and_dtomega_LN + + +#include "macrodef.fh" + +!------------------------------------------------------------------------------ +! input R is X indeed +! input g00 is g00/r^2 indeed +! input g0A is g0A/r^2 indeed +! input gAB is gAB/r^2 indeed +! output Gamma is Gamma of omega^2 g_{munu}/r^2 at r = infinity or to say X = 1 +! ** in coordinate (u,X,x,y) ** +subroutine get_christoffel(Rmin,g00,g01,g02,g03, & + g22,g23,g33, & + dgt22,dgt23,dgt33,& + dg22,dg23,dg33,& + dgx02,dgx03,dgx22,dgx23,dgx33,& + dgy02,dgy03,dgy22,dgy23,dgy33,& + omega,dtomega,dxomega,dyomega,& + Gamuxx,Gamuxy,Gamuyy, & + Gamrxx,Gamrxy,Gamryy, & + Gamxxx,Gamxxy,Gamxyy, & + Gamyxx,Gamyxy,Gamyyy) + + implicit none + + real*8,intent(in)::Rmin + real*8,intent(in)::g00,g01,g02,g03,g22,g23,g33 + real*8,intent(in)::dgt22,dgt23,dgt33 + real*8,intent(in)::dg22,dg23,dg33 + real*8,intent(in)::dgx02,dgx03,dgx22,dgx23,dgx33 + real*8,intent(in)::dgy02,dgy03,dgy22,dgy23,dgy33 + real*8,intent(in) :: omega,dtomega,dxomega,dyomega + real*8,intent(out) :: Gamuxx,Gamuxy,Gamuyy + real*8,intent(out) :: Gamrxx,Gamrxy,Gamryy + real*8,intent(out) :: Gamxxx,Gamxxy,Gamxyy + real*8,intent(out) :: Gamyxx,Gamyxy,Gamyyy + + real*8 :: t1; + real*8 :: t10; + real*8 :: t11; + real*8 :: t117; + real*8 :: t12; + real*8 :: t121; + real*8 :: t138; + real*8 :: t142; + real*8 :: t147; + real*8 :: t18; + real*8 :: t184; + real*8 :: t190; + real*8 :: t194; + real*8 :: t198; + real*8 :: t2; + real*8 :: t204; + real*8 :: t206; + real*8 :: t208; + real*8 :: t214; + real*8 :: t216; + real*8 :: t220; + real*8 :: t222; + real*8 :: t227; + real*8 :: t230; + real*8 :: t233; + real*8 :: t239; + real*8 :: t24; + real*8 :: t241; + real*8 :: t242; + real*8 :: t244; + real*8 :: t249; + real*8 :: t25; + real*8 :: t252; + real*8 :: t28; + real*8 :: t29; + real*8 :: t32; + real*8 :: t37; + real*8 :: t47; + real*8 :: t53; + real*8 :: t54; + real*8 :: t58; + real*8 :: t64; + real*8 :: t65; + real*8 :: t66; + real*8 :: t68; + real*8 :: t71; + real*8 :: t72; + real*8 :: t73; + real*8 :: t75; + real*8 :: t76; + real*8 :: t77; + real*8 :: t80; + real*8 :: t82; + real*8 :: t84; + real*8 :: t85; + real*8 :: t88; + real*8 :: t9; + real*8 :: t91; + + t1 = 1/g01; + t2 = Rmin*t1; + t9 = 1/omega; + t10 = Rmin*t9; + t11 = g01*omega; + t12 = g22*g03; + t18 = g23*g02; + t24 = g01*g22; + t25 = t18*dyomega; + t28 = g23*g03; + t29 = t28*dxomega; + t32 = g33*g02; + t37 = g22*g33; + t47 = g23*g23; + t53 = g22*g22; + t54 = g01*t53; + t58 = t47*dtomega; + t64 = Rmin*dg22; + t65 = t64*omega; + t66 = t37*g00; + t68 = t18*g03; + t71 = omega*g22; + t72 = g03*g03; + t73 = t71*t72; + t75 = omega*g33; + t76 = g02*g02; + t77 = t75*t76; + t80 = omega*t47*g00; + t82 = 2.0*t24*t32*dxomega-2.0*t11*t47*dgx02+t11*t47*dgt22-2.0*t54*g33*dtomega & + +2.0*t24*t58+2.0*t54*g03*dyomega+t65*t66+2.0*t65*t68-t64*t73-t64*t77-t64*t80; + t84 = g01*g01; + t85 = 1/t84; + t88 = 1/(t37-t47); + t91 = Rmin*dg23; + t117 = g01*g33; + t121 = g01*t47; + t138 = t91*omega; + t142 = -t11*t12*dgx33+t11*t18*dgx33+2.0*t117*t18*dxomega-2.0*t121*g03*dxomega & + -2.0*t121*g02*dyomega+t11*t47*dgt23-t11*t47*dgx03-t11*t47*dgy02+2.0*g01*t47*g23*dtomega+t138*t66+2.0*t138*t68; + t147 = Rmin*dg33; + t184 = g33*g33; + t190 = g01*t184; + t194 = t147*omega; + t198 = -2.0*t117*t25-2.0*t117*t29-t11*t12*dgy33+t11*t18*dgy33-2.0*t11*t47*dgy03+t11*t47*dgt33-2.0*t24*t184*dtomega & + +2.0*t117*t58+2.0*t190*g02*dxomega+t194*t66+2.0*t194*t68; + t204 = g02*dg22*Rmin; + t206 = omega*g23; + t208 = g03*dg22*Rmin; + t214 = 2.0*t24*g33*dxomega; + t216 = t11*g23*dgy22; + t220 = g23*dyomega; + t222 = 2.0*t24*t220; + t227 = t1*t88; + t230 = g02*dg23*Rmin; + t233 = g03*dg23*Rmin; + t239 = 2.0*t24*g33*dyomega; + t241 = t11*g23*dgx33; + t242 = g23*dxomega; + t244 = 2.0*t117*t242; + t249 = g02*dg33*Rmin; + t252 = g03*dg33*Rmin; + Gamuxx = -t2*dg22/2.0; + Gamuxy = -t2*dg23/2.0; + Gamuyy = -t2*dg33/2.0; + Gamrxx = t10*(-2.0*t11*t12*dgx23+t11*t12*dgy22+2.0*t11*t18*dgx23-t11*t18*dgy22+t11*t28*dgx22-t11*t32*dgx22 & + -t11*t37*dgt22+2.0*t11*t37*dgx02-2.0*t24*t25-2.0*t24*t29+t82)*t85*t88/2.0; + Gamrxy = t10*(-t91*t73-t91*t77-t91*t80-2.0*t24*g33*g23*dtomega-t11*t37*dgt23+t11*t37*dgx03+t11*t37*dgy02 & + -t11*t32*dgy22+t11*t28*dgy22+2.0*t24*t28*dyomega+t142)*t85*t88/2.0; + Gamryy = t10*(-t147*t73-t147*t77-t147*t80+2.0*t11*t37*dgy03-t11*t37*dgt33+2.0*t24*g33*g03*dyomega & + -2.0*t11*t32*dgy23+t11*t32*dgx33+2.0*t11*t28*dgy23-t11*t28*dgx33+t198)*t85*t88/2.0; + Gamxxx = t9*(-2.0*t11*g23*dgx23+t11*g33*dgx22+t75*t204-4.0*t121*dxomega-t206*t208+t214+t216+t222)*t227/2.0; + Gamxxy = t9*(t11*g33*dgy22+t75*t230-t206*t233+t239-t241-t244)*t227/2.0; + Gamxyy = t9*(-t11*g23*dgy33-t11*g33*dgx33+2.0*t11*g33*dgy23+t75*t249-2.0*t190*dxomega+2.0*t117*t220-t206*t252)*t227/2.0; + Gamyxx = -t9*(-2.0*t11*g22*dgx23+t11*g22*dgy22+t11*g23*dgx22-2.0*t24*t242+2.0*t54*dyomega-t71*t208+t206*t204)*t227/2.0; + Gamyxy = -(-t11*g22*dgx33-t71*t233+t206*t230-t214+t216+t222)*t9*t227/2.0; + Gamyyy = t9*(t11*g22*dgy33-2.0*t11*g23*dgy23+t71*t252-4.0*t121*dyomega-t206*t249+t239+t241+t244)*t227/2.0; + + return + +end subroutine get_christoffel +!!---------------------------------------------------------------------------------------- +subroutine get_News(crho,sigma,& + dxxomega,dxyomega,dyyomega,& + omega,dtomega,dxomega,dyomega,& + Gamuxx,Gamuxy,Gamuyy, & + Gamrxx,Gamrxy,Gamryy, & + Gamxxx,Gamxxy,Gamxyy, & + Gamyxx,Gamyxy,Gamyyy,RNew,INew,sst) + + implicit none + + integer,intent(in) :: sst + real*8,intent(in)::crho,sigma + real*8,intent(in) :: dxxomega,dxyomega,dyyomega + real*8,intent(in) :: omega,dtomega,dxomega,dyomega + real*8,intent(in) :: Gamuxx,Gamuxy,Gamuyy + real*8,intent(in) :: Gamrxx,Gamrxy,Gamryy + real*8,intent(in) :: Gamxxx,Gamxxy,Gamxyy + real*8,intent(in) :: Gamyxx,Gamyxy,Gamyyy + + real*8,intent(out) :: RNew,INew + + + real*8 :: cs,cr,ss,sr,tc,ts + real*8 :: WWxx,WWxy,WWyy + real*8 :: Rmmxx,Rmmxy,Rmmyy + real*8 :: Immxx,Immxy,Immyy + + real*8 :: gr,tgrho,tgsigma,x,y,z,gt,gp + + double complex :: swtf,II +write(*,*) Gamrxx,Gamrxy,Gamryy + WWxx = (dxxomega-(Gamuxx*dtomega+Gamxxx*dxomega+Gamyxx*dyomega))/omega/2 + WWxy = (dxyomega-(Gamuxy*dtomega+Gamxxy*dxomega+Gamyxy*dyomega))/omega/2 + WWyy = (dyyomega-(Gamuyy*dtomega+Gamxyy*dxomega+Gamyyy*dyomega))/omega/2 + + cs = dcos(sigma) + cr = dcos(crho) + ss = dsin(sigma) + sr = dsin(crho) + tc = dsqrt((1-sr*ss)/2) + ts = dsqrt((1+sr*ss)/2) + Rmmxx = 4*tc*tc*ts*ts*(ts*ts-tc*tc)/cs/cs + Rmmxy = 4*tc*tc*ts*ts*(ts*ts+tc*tc)/cs/cr + Rmmyy = 4*tc*tc*ts*ts*(ts*ts-tc*tc)/cr/cr + Immxx = 8*tc*tc*ts*ts*ts*tc/cs/cs + Immxy = 0 + Immyy = -8*tc*tc*ts*ts*ts*tc/cr/cr + + if(sst==1 .or. sst==3 .or. sst==4)then + Immxx = -Immxx + Immxy = -Immxy + Immyy = -Immyy + endif + + RNew = Rmmxx*WWxx+2*Rmmxy*WWxy+Rmmyy*WWyy + INew = Immxx*WWxx+2*Immxy*WWxy+Immyy*WWyy +!! change to tetrad theta phi +!fake global coordinate is enough here + + II = dcmplx(0.d0,1.d0) + gr = 1.d0 + tgrho = dtan(crho) + tgsigma = dtan(sigma) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_News: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + swtf = 2.d0*tc*ts*(ts+II*tc)/dcos(sigma) + if(sst==1 .or. sst==3 .or. sst==4) swtf = dconjg(swtf) + select case (sst) + case (0,1) + swtf = swtf/(dcos(gp)+II*dcos(gt)*dsin(gp))*(dcos(gt)**2+dsin(gt)**2*dcos(gp)**2) + case (2,3) + swtf = II*swtf*dsin(gt) + case (4,5) + swtf = -II*swtf*dsin(gt) + end select + + swtf = (RNew+II*INew)/swtf**2 + + RNew = dreal(swtf) + INew = dimag(swtf) + + return + +end subroutine get_News +!------------------------------------------------------------------------------------------------------------ +subroutine get_null_news2(ex,crho,sigma,R,omega,dtomega, & + g00,g01,g02,g03,g22,g23,g33, & + dtg22,dtg23,dtg33, & + RNews,INews,Rmin,sst) + +implicit none + +integer,intent(in) :: ex(3),sst +real*8,intent(in) :: Rmin +real*8,intent(in),dimension(ex(1))::crho +real*8,intent(in),dimension(ex(2))::sigma +real*8,intent(in),dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3)),intent(in ) :: omega,dtomega +real*8,dimension(ex(1),ex(2),ex(3)),intent(in ) :: g00,g01,g02,g03,g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtg22,dtg23,dtg33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out) :: RNews,INews + +real*8 :: Gamuxx,Gamuxy,Gamuyy +real*8 :: Gamrxx,Gamrxy,Gamryy +real*8 :: Gamxxx,Gamxxy,Gamxyy +real*8 :: Gamyxx,Gamyxy,Gamyyy +real*8 :: dg22,dg23,dg33 +real*8 :: dgx22,dgx23,dgx33 +real*8 :: dgx02,dgx03 +real*8 :: dgy22,dgy23,dgy33 +real*8 :: dgy02,dgy03 +real*8 :: dxomega,dyomega +real*8 :: dxxomega,dxyomega,dyyomega + +integer :: i,j,k + +k = ex(3) +do i=1,ex(1) +do j=1,ex(2) + call rderivs_x_point(ex(3),R,g22(i,j,:),dg22,k) + call rderivs_x_point(ex(3),R,g23(i,j,:),dg23,k) + call rderivs_x_point(ex(3),R,g33(i,j,:),dg33,k) + + call rderivs_x_point(ex(1),crho,g02(:,j,k),dgx02,i) + call rderivs_x_point(ex(1),crho,g03(:,j,k),dgx03,i) + call rderivs_x_point(ex(1),crho,g22(:,j,k),dgx22,i) + call rderivs_x_point(ex(1),crho,g23(:,j,k),dgx23,i) + call rderivs_x_point(ex(1),crho,g33(:,j,k),dgx33,i) + call rderivs_x_point(ex(1),crho,omega(:,j,k),dxomega,i) + + call rderivs_x_point(ex(2),sigma,g02(i,:,k),dgy02,j) + call rderivs_x_point(ex(2),sigma,g03(i,:,k),dgy03,j) + call rderivs_x_point(ex(2),sigma,g22(i,:,k),dgy22,j) + call rderivs_x_point(ex(2),sigma,g23(i,:,k),dgy23,j) + call rderivs_x_point(ex(2),sigma,g33(i,:,k),dgy33,j) + call rderivs_x_point(ex(2),sigma,omega(i,:,k),dyomega,j) + + call get_christoffel(Rmin,g00(i,j,k),g01(i,j,k),g02(i,j,k),g03(i,j,k), & + g22(i,j,k),g23(i,j,k),g33(i,j,k), & + dtg22(i,j,k),dtg23(i,j,k),dtg33(i,j,k),& + dg22,dg23,dg33,& + dgx02,dgx03,dgx22,dgx23,dgx33,& + dgy02,dgy03,dgy22,dgy23,dgy33,& + omega(i,j,k),dtomega(i,j,k),dxomega,dyomega,& + Gamuxx,Gamuxy,Gamuyy, & + Gamrxx,Gamrxy,Gamryy, & + Gamxxx,Gamxxy,Gamxyy, & + Gamyxx,Gamyxy,Gamyyy) + + call rdderivs_x_point(ex(1),crho,omega(:,j,k),dxxomega,i) + call rdderivs_x_point(ex(2),crho,omega(i,:,k),dyyomega,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,omega(:,:,k),dxyomega,i,j) + + call get_News(crho(i),sigma(j),& + dxxomega,dxyomega,dyyomega,& + omega(i,j,k),dtomega(i,j,k),dxomega,dyomega,& + Gamuxx,Gamuxy,Gamuyy, & + Gamrxx,Gamrxy,Gamryy, & + Gamxxx,Gamxxy,Gamxyy, & + Gamyxx,Gamyxy,Gamyyy,RNews(i,j,k),INews(i,j,k),sst) +enddo +enddo + + return + +end subroutine get_null_news2 +!!------------------------------------------------------------------------------------------------------------ +!! input g_AB and Theta_AB are divided by r^2 indeed +!! input g_00 is also divided by r^2 indeed +! the output g00 is K +subroutine get_omega_and_dtomega_pre(ex,crho,sigma,X,g22,g23,g33, & + omega,dtomega, Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega,dtomega + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + +R = X*Rmin/(1-X) +det = g22*g33-g23*g23 +gup22 = g33/det +gup23 = -g23/det +gup33 = g22/det + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + sr = dsin(crho(i)) + ss = dsin(sigma(j)) + cr = dcos(crho(i)) + cs = dcos(sigma(j)) + sr2 = sr*sr + ss2 = ss*ss + cr2 = cr*cr + cs2 = cs*cs + + tg22 = 1-sr2*ss2 + tg22 = 1/tg22/tg22 + + tg23 = -sr*cr*ss*cs*tg22 + tg33 = cr2*tg22 + tg22 = cs2*tg22 + +! ghat/(g/r^4) indeed + det(i,j,k) = (tg22*tg33-tg23*tg23)/det(i,j,k) + enddo + enddo + enddo + + omega = dsqrt(det) + k = ex(3) + do i=1,ex(1) + do j=1,ex(2) + + call rderivs_x_point(ex(1),crho,det(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,det(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,det(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,det(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,det(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + KK(i,j,k) = dsqrt(det(i,j,k))*(1-0.25*covf/R(k)**2) + enddo + enddo + + dtomega = KK + + return + +end subroutine get_omega_and_dtomega_pre +!------------------------------------------------------------------------------------------------------ +subroutine get_dtomega(ex,crho,sigma,X,g22,g23,g33, & + omega,dtomega, Rmin) +implicit none +! argument variables +integer, intent(in ):: ex(1:3) +real*8,intent(in) :: Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::X +real*8,dimension(ex(1),ex(2),ex(3)),intent(in)::omega,g22,g23,g33 +real*8,dimension(ex(1),ex(2),ex(3)),intent(inout)::dtomega + + +double precision,dimension(ex(3))::R +real*8,dimension(ex(1),ex(2),ex(3))::det,gup22,gup23,gup33,KK + +real*8 :: sr,ss,cr,cs,sr2,ss2,cr2,cs2,tg22,tg23,tg33 +real*8 :: fr,fs,frr,fss,frs,covf + +integer :: i,j,k + +real*8 :: m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam + +call get_RT_parameters(m0,Pp0,Pm0,ap,am,bp,bm,cp,cm,gam) + + KK = dtomega + + k = ex(3) + do i=1,ex(1) + do j=1,ex(2) + + call rderivs_x_point(ex(1),crho,KK(:,j,k),fr,i) + call rderivs_x_point(ex(2),sigma,KK(i,:,k),fs,j) + call rdderivs_xy_point(ex(1),ex(2),crho,sigma,KK(:,:,k),frs,i,j) + call rdderivs_x_point(ex(1),crho,KK(:,j,k),frr,i) + call rdderivs_x_point(ex(2),sigma,KK(i,:,k),fss,j) + + call std_covdiff(crho(i),sigma(j),fs,fr,fss,frr,frs,covf) + + dtomega(i,j,k) = -covf*omega(i,j,k)**3/6/m0/2 + enddo + enddo + + return + +end subroutine get_dtomega +!!------------------------------------------------------------------------------------------------------------ +!! input g_AB and Theta_AB are divided by r^2 indeed +!! input g_00 is also divided by r^2 indeed +subroutine get_omega_and_dtomega_LN(time,ex,crho,sigma,XX, & + omega,dtomega, Rmin,sst) +implicit none +! argument variables +integer, intent(in ):: ex(1:3),sst +real*8,intent(in) :: time,Rmin +double precision,intent(in),dimension(ex(1))::crho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::XX +real*8,dimension(ex(1),ex(2),ex(3)),intent(out)::omega,dtomega + +integer :: i,j,k +real*8 :: gr,gt,gp,tgrho,tgsigma,tc,ts,x,y,z + +double complex :: II,Jr,Jrt +double complex :: Zslm,z020 + +double complex :: beta0,C1,C2,mx,my,mlx,mly +integer :: nu,m + +call initial_null_paramter(beta0,C1,C2,nu,m) + +II = dcmplx(0.d0,1.d0) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) +! here fake global coordinate is enough + gr = 1.d0 + tgrho = dtan(crho(i)) + tgsigma = dtan(sigma(j)) + tc = dsqrt((1.d0-dsin(crho(i))*dsin(sigma(j)))/2.d0) + ts = dsqrt((1.d0+dsin(crho(i))*dsin(sigma(j)))/2.d0) + select case (sst) + case (0) + z = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (1) + z = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = z*tgrho + y = z*tgsigma + case (2) + x = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (3) + x = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + y = x*tgrho + z = x*tgsigma + case (4) + y = gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case (5) + y = -gr/dsqrt(1+tgrho*tgrho+tgsigma*tgsigma) + x = y*tgrho + z = y*tgsigma + case default + write(*,*) "get_null_boundary3: not recognized sst = ",sst + return + end select + gt = dacos(z/gr) + gp = datan2(y,x) + + z020 = Zslm(0,2,m,gt,gp) + + Jr = (2.4d1*beta0+3.d0*II*nu*C1-II*nu**3*C2)/3.6d1 + Jr = Jr*exp(II*nu*time) + Jrt = II*nu*Jr*exp(II*nu*time) + + Jr = dsqrt(dble((2-1)))*dreal(Jr)*z020 + Jrt = dsqrt(dble((2-1)))*dreal(Jrt)*z020 + + omega(i,j,k) = 1-dreal(Jr) + dtomega(i,j,k) = -dreal(Jrt) + + enddo + enddo + enddo + + return + +end subroutine get_omega_and_dtomega_LN diff --git a/AMSS_NCKU_source/NullShellPatch.C b/AMSS_NCKU_source/Null_Evolve/NullShellPatch.C similarity index 97% rename from AMSS_NCKU_source/NullShellPatch.C rename to AMSS_NCKU_source/Null_Evolve/NullShellPatch.C index 266dab1..33ad3de 100644 --- a/AMSS_NCKU_source/NullShellPatch.C +++ b/AMSS_NCKU_source/Null_Evolve/NullShellPatch.C @@ -1,5812 +1,5812 @@ - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "NullShellPatch.h" -#include "Parallel.h" -#include "fmisc.h" -#include "misc.h" -#include "shellfunctions.h" -#include "NullEvol.h" -#include "NullNews.h" -#include "initial_null.h" -#include "rungekutta4_rout.h" -#include "kodiss.h" - -#define PI M_PI - -// x x x x x o * -// * o x x x x x -// each side contribute an overlap points -// so we need half of that -#define overghost ((ghost_width + 1) / 2 + ghost_width) - -NullShellPatch::NullShellPatch(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetryi, int myranki) : myrank(myranki), Rmin(Rmini), xmin(xmini), xmax(xmaxi), PatL(0), Symmetry(Symmetryi) -{ - for (int i = 0; i < dim; i++) - { - shape[i] = shapei[i]; -// we always assume the input parameter is in cell center style -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - shape[i] = shape[i] + 1; -#endif - } - - if (myrank == 0) - { - cout << " null shell's range: r = [" << xmin * Rmin / (1 - xmin) << ":"; - if (xmax == 1) - cout << " +Infty]" << endl; - else - cout << xmax * Rmin / (1 - xmax) << "]" << endl; - cout << " x = [" << xmin << ":" << xmax << "]" << endl - << " shape: " << shape[2] << endl - << " resolution: [" << getdX(0) << "," << getdX(1) << "," << getdX(2) << "]" << endl; - } -// in order to touch infinity, we always use vertex center in r direction -// for Cell center it is some fake as following -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - { - double ht = (xmax - xmin) / shape[2]; - xmax = xmax + ht / 2; - xmin = xmin - ht / 2; - shape[2] = shape[2] + 1; - } -#endif - - double bbox[2 * dim]; - int shape_here[dim]; - bbox[2] = xmin; - bbox[5] = xmax; - shape_here[2] = shape[2]; - - switch (Symmetry) - { - case 0: - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] + 2 * overghost; - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank); - PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new zm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - case 1: - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] + 2 * overghost; - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); - shape_here[0] = shape[0] + 2 * overghost; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - shape_here[1] = (shape[1] + 1) / 2 + overghost; -#else -#ifdef Cell - shape_here[1] = shape[1] / 2 + overghost; -#else -#error Not define Vertex nor Cell -#endif -#endif - bbox[0] = -PI / 4 - overghost * getdX(0); - shape_here[1] += ghost_width; - bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = ghost_width * getdX(1); // buffer points method to deal with boundary - PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - case 2: -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - for (int i = 0; i < 2; i++) - shape_here[i] = (shape[i] + 1) / 2 + overghost; -#else -#ifdef Cell - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] / 2 + overghost; -#else -#error Not define Vertex nor Cell -#endif -#endif - shape_here[0] += ghost_width; - shape_here[1] += ghost_width; - bbox[0] = -ghost_width * getdX(0); // buffer points method to deal with boundary - bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); - PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - default: - cout << "not recognized Symmetry type" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int ngfs = 0; - FXZEO = new var("FXZEO", ngfs++, 1, 1, 1); - gx = new var("gx", ngfs++, 1, 1, 1); - gy = new var("gy", ngfs++, 1, 1, 1); - gz = new var("gz", ngfs++, 1, 1, 1); - // every thing is taken as scalar - beta = new var("beta", ngfs++, 1, 1, 1); - W = new var("W", ngfs++, 1, 1, 1); - KK = new var("KK", ngfs++, 1, 1, 1); - HKK = new var("HKK", ngfs++, 1, 1, 1); - KKx = new var("KKx", ngfs++, 1, 1, 1); - HKKx = new var("HKKx", ngfs++, 1, 1, 1); - Rnu = new var("Rnu", ngfs++, 1, 1, 1); - Inu = new var("Inu", ngfs++, 1, 1, 1); - Rk = new var("Rk", ngfs++, 1, 1, 1); - Ik = new var("Ik", ngfs++, 1, 1, 1); - RB = new var("RB", ngfs++, 1, 1, 1); - IB = new var("IB", ngfs++, 1, 1, 1); - RQ = new var("RQ", ngfs++, 1, 1, 1); - IQ = new var("IQ", ngfs++, 1, 1, 1); - RU = new var("RU", ngfs++, 1, 1, 1); - IU = new var("IU", ngfs++, 1, 1, 1); - RTheta = new var("RTheta", ngfs++, 1, 1, 1); - ITheta = new var("ITheta", ngfs++, 1, 1, 1); - RJo = new var("RJo", ngfs++, 1, 1, 1); - IJo = new var("IJo", ngfs++, 1, 1, 1); - omegao = new var("omegao", ngfs++, 1, 1, 1); - RJ0 = new var("RJ0", ngfs++, 1, 1, 1); - IJ0 = new var("IJ0", ngfs++, 1, 1, 1); - omega0 = new var("omega0", ngfs++, 1, 1, 1); - RJ = new var("RJ", ngfs++, 1, 1, 1); - IJ = new var("IJ", ngfs++, 1, 1, 1); - omega = new var("omega", ngfs++, 1, 1, 1); - RJ1 = new var("RJ1", ngfs++, 1, 1, 1); - IJ1 = new var("IJ1", ngfs++, 1, 1, 1); - omega1 = new var("omega1", ngfs++, 1, 1, 1); - RJ_rhs = new var("RJ_rhs", ngfs++, 1, 1, 1); - IJ_rhs = new var("IJ_rhs", ngfs++, 1, 1, 1); - omega_rhs = new var("omega_rhs", ngfs++, 1, 1, 1); - - quR1 = new var("quR1", ngfs++, 1, 1, 1); - quI1 = new var("quI1", ngfs++, 1, 1, 1); - quR2 = new var("quR2", ngfs++, 1, 1, 1); - quI2 = new var("quI2", ngfs++, 1, 1, 1); - qlR1 = new var("qlR1", ngfs++, 1, 1, 1); - qlI1 = new var("qlI1", ngfs++, 1, 1, 1); - qlR2 = new var("qlR2", ngfs++, 1, 1, 1); - qlI2 = new var("qlI2", ngfs++, 1, 1, 1); - gR = new var("gR", ngfs++, 1, 1, 1); - gI = new var("gI", ngfs++, 1, 1, 1); - - dquR1 = new var("dquR1", ngfs++, 1, 1, 1); - dquI1 = new var("dquI1", ngfs++, 1, 1, 1); - dquR2 = new var("dquR2", ngfs++, 1, 1, 1); - dquI2 = new var("dquI2", ngfs++, 1, 1, 1); - bdquR1 = new var("bdquR1", ngfs++, 1, 1, 1); - bdquI1 = new var("bdquI1", ngfs++, 1, 1, 1); - bdquR2 = new var("bdquR2", ngfs++, 1, 1, 1); - bdquI2 = new var("bdquI2", ngfs++, 1, 1, 1); - dgR = new var("dgR", ngfs++, 1, 1, 1); - dgI = new var("dgI", ngfs++, 1, 1, 1); - bdgR = new var("bdgR", ngfs++, 1, 1, 1); - bdgI = new var("bdgI", ngfs++, 1, 1, 1); - - RNews = new var("RNews", ngfs++, 1, 1, 1); - INews = new var("INews", ngfs++, 1, 1, 1); - - DumpList = new MyList(RJ0); - DumpList->insert(IJ0); - - betaList = new MyList(beta); - betaList->insert(beta); - betawt[0] = 0; - QUList = new MyList(RQ); - QUList->insert(IQ); - QUList->insert(RU); - QUList->insert(IU); - QUwt[0] = QUwt[1] = 1; - WTheList = new MyList(W); - WTheList->insert(W); - WTheList->insert(RTheta); - WTheList->insert(ITheta); - WThewt[0] = 0; - WThewt[1] = 2; - - TheList = new MyList(RTheta); - TheList->insert(ITheta); - - OldStateList = new MyList(RJo); - OldStateList->insert(IJo); - OldStateList->insert(omegao); - StateList = new MyList(RJ0); - StateList->insert(IJ0); - StateList->insert(omega0); - SynchList_pre = new MyList(RJ); - SynchList_pre->insert(IJ); - SynchList_pre->insert(omega); - RHSList = new MyList(RJ_rhs); - RHSList->insert(IJ_rhs); - RHSList->insert(omega_rhs); - SynchList_cor = new MyList(RJ1); - SynchList_cor->insert(IJ1); - SynchList_cor->insert(omega1); - - JrhsList = new MyList(RJ_rhs); - JrhsList->insert(IJ_rhs); - J1List = new MyList(RJ1); - J1List->insert(IJ1); - - ingfs = 0; - fngfs = ngfs; -} -NullShellPatch::~NullShellPatch() -{ - int nprocs = 1; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - for (int node = 0; node < nprocs; node++) - { - if (ss_src[node]) - destroypsuList(ss_src[node]); - if (ss_dst[node]) - destroypsuList(ss_dst[node]); - if (cs_src) - { - if (cs_src[node]) - destroypsuList(cs_src[node]); - if (cs_dst[node]) - destroypsuList(cs_dst[node]); - } - } - - delete[] ss_src; - delete[] ss_dst; - if (cs_src) - { - delete[] cs_src; - delete[] cs_dst; - } - - while (PatL) - { - ss_patch *sPp = PatL->data; - MyList *bg; - while (sPp->blb) - { - if (sPp->blb == sPp->ble) - break; - bg = (sPp->blb->next) ? sPp->blb->next : 0; - delete sPp->blb->data; - delete sPp->blb; - sPp->blb = bg; - } - if (sPp->ble) - { - delete sPp->ble->data; - delete sPp->ble; - } - sPp->blb = sPp->ble = 0; - PatL = PatL->next; - } - PatL->destroyList(); - - StateList->clearList(); - SynchList_pre->clearList(); - SynchList_cor->clearList(); - RHSList->clearList(); - OldStateList->clearList(); - DumpList->clearList(); - CheckList->clearList(); - betaList->clearList(); - QUList->clearList(); - WTheList->clearList(); - TheList->clearList(); - JrhsList->clearList(); - J1List->clearList(); - - delete FXZEO; - delete gx; - delete gy; - delete gz; - delete beta; - delete W; - delete Rnu; - delete Inu; - delete Rk; - delete Ik; - delete RB; - delete IB; - delete RQ; - delete IQ; - delete RU; - delete IU; - delete RTheta; - delete ITheta; - delete KK; - delete HKK; - delete KKx; - delete HKKx; - - delete RJo; - delete IJo; - delete omegao; - delete RJ0; - delete IJ0; - delete omega0; - delete RJ; - delete IJ; - delete omega; - delete RJ1; - delete IJ1; - delete omega1; - delete RJ_rhs; - delete IJ_rhs; - delete omega_rhs; - - delete quR1; - delete quR2; - delete quI1; - delete quI2; - delete qlR1; - delete qlR2; - delete qlI1; - delete qlI2; - delete gR; - delete gI; - delete dquR1; - delete dquR2; - delete dquI1; - delete dquI2; - delete bdquR1; - delete bdquR2; - delete bdquI1; - delete bdquI2; - delete dgR; - delete dgI; - delete bdgR; - delete bdgI; - - delete RNews; - delete INews; -} -void NullShellPatch::destroypsuList(MyList *ct) -{ - MyList *n; - while (ct) - { - n = ct->next; - if (ct->data->coef) - { - delete[] ct->data->coef; - delete[] ct->data->sind; - } - delete ct->data; - delete ct; - ct = n; - } -} -// the number of VarList = 2* the number of Varwt -void NullShellPatch::fill_symmetric_boundarybuffer(MyList *VarList, int *Varwt) -{ - MyList *varl; - int ind; - double drho = getdX(0), dsigma = getdX(1); - - if (Symmetry == 0) - return; - else - { - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - varl = VarList; - ind = 0; - while (varl) - { - f_fill_symmetric_boundarybuffer(cg->shape, cg->X[0], cg->X[1], cg->X[2], drho, dsigma, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl->next->data->sgfn], - Symmetry, Pp->data->sst, Varwt[ind]); - varl = varl->next; - varl = varl->next; - ind++; - } - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -} -MyList *NullShellPatch::compose_sh(int cpusize) -{ - if (dim != 3) - { - cout << "distrivute: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - // checkPatch(); - - MyList *BlL = 0; - - int split_size, min_size, block_size = 0; - - int min_width = 2 * Mymax(ghost_width, buffer_width); - int nxy[2], mmin_width[2], min_shape[2]; - - MyList *PLi = PatL; - for (int i = 0; i < 2; i++) - min_shape[i] = PLi->data->shape[i]; - PLi = PLi->next; - while (PLi) - { - ss_patch *PP = PLi->data; - for (int i = 0; i < 2; i++) - min_shape[i] = Mymin(min_shape[i], PP->shape[i]); - PLi = PLi->next; - } - - for (int i = 0; i < 2; i++) - mmin_width[i] = Mymin(min_width, min_shape[i]); - - min_size = mmin_width[0]; - for (int i = 1; i < 2; i++) - min_size = min_size * mmin_width[i]; - - PLi = PatL; - while (PLi) - { - ss_patch *PP = PLi->data; - // PP->checkPatch(true); - int bs = PP->shape[0]; - for (int i = 1; i < 2; i++) - bs = bs * PP->shape[i]; - block_size = block_size + bs; - PLi = PLi->next; - } - split_size = Mymax(min_size, block_size / cpusize); - split_size = Mymax(1, split_size); - - int n_rank = 0; - PLi = PatL; - int reacpu = 0; - while (PLi) - { - ss_patch *PP = PLi->data; - - reacpu += Parallel::partition2(nxy, split_size, mmin_width, cpusize, PP->shape); // r direction can not be splitted!! It's ode! - - Block *ng; - int shape_here[3], ibbox_here[2 * 2]; - double bbox_here[2 * 3], dd; - - // ibbox : 0,...N-1 - for (int i = 0; i < nxy[0]; i++) - for (int j = 0; j < nxy[1]; j++) - { - ibbox_here[0] = (PP->shape[0] * i) / nxy[0]; - ibbox_here[2] = (PP->shape[0] * (i + 1)) / nxy[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxy[1]; - ibbox_here[3] = (PP->shape[1] * (j + 1)) / nxy[1] - 1; - - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[2] = Mymin(PP->shape[0] - 1, ibbox_here[2] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[1] - 1, ibbox_here[3] + ghost_width); - - shape_here[0] = ibbox_here[2] - ibbox_here[0] + 1; - shape_here[1] = ibbox_here[3] - ibbox_here[1] + 1; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[2] * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[3] * dd; -#else -#ifdef Cell - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[2] + 1) * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[3] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - shape_here[2] = PP->shape[2]; - bbox_here[2] = PP->bbox[2]; - bbox_here[5] = PP->bbox[5]; - ng = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs, 0); // delete through KillBlocks - // ng->checkBlock(); - if (n_rank == cpusize) - n_rank = 0; - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks - - // set PP->blb - if (i == 0 && j == 0) - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; - PP->blb = Bp; - } - } - // set PP->ble - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; - PP->ble = Bp; - } - PLi = PLi->next; - } - if (reacpu < cpusize * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "NullShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << cpusize << " cpus run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} -int NullShellPatch::getdumydimension(int acsst, int posst) // -1 means no dumy dimension -{ - int dms; - if (acsst == -1 || posst == -1) - return -1; - switch (acsst) - { - case 0: - case 1: - switch (posst) - { - case 0: - case 1: - cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - case 2: - case 3: - return 0; - case 4: - case 5: - return 1; - default: - cout << "error in NullShellPatch::getdumydimension: posst = " << posst << endl; - return -1; - } - case 2: - case 3: - switch (posst) - { - case 0: - case 1: - return 1; - case 2: - case 3: - cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - case 4: - case 5: - return 0; - default: - cout << "error in NullShellPatch::getdumydimension: posst = " << posst << endl; - return -1; - } - case 4: - case 5: - switch (posst) - { - case 0: - case 1: - return 1; - case 2: - case 3: - return 0; - case 4: - case 5: - cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - default: - cout << "error in NullShellPatch::getdumydimension: posst = " << posst << endl; - return -1; - } - default: - cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << endl; - return -1; - } -} -void NullShellPatch::Setup_dyad() -{ - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_setup_dyad(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - cg->fgfs[gx->sgfn], cg->fgfs[gy->sgfn], cg->fgfs[gz->sgfn], - Pp->data->sst, Rmin); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -} -void NullShellPatch::Setup_Initial_Data(bool checkrun, double PhysTime) -{ - if (checkrun) - { - } - else - { - double one = 1.0; - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], Pp->data->sst, Rmin, PhysTime, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - // f_get_initial_null(cg->shape,cg->X[0],cg->X[1],cg->X[2], - // cg->fgfs[RJ0->sgfn],cg->fgfs[IJ0->sgfn],Pp->data->sst,Rmin); - // f_set_value(cg->shape,cg->fgfs[omega0->sgfn],one); - f_get_exact_omega(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega0->sgfn], Pp->data->sst, Rmin, PhysTime); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - int Varwt[1]; - MyList *DG_List; -#if 0 - eth_derivs(RJ0,IJ0,RJ1,IJ1,0,1); - Varwt[0]=1; - DG_List=new MyList(RJ1); DG_List->insert(IJ1); - Synch(DG_List,Symmetry,Varwt); - eth_derivs(RJ1,IJ1,RJ0,IJ0,1,1); - DG_List->clearList(); // after this DG_List = 0 -#elif 0 - eth_dderivs(RJ1, IJ1, RJ0, IJ0, 0, 1, 1); -#endif - DG_List = new MyList(RJ0); - DG_List->insert(IJ0); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - - Dump_Data(DG_List, 0, 0, 1); - DG_List->clearList(); - } -} -void NullShellPatch::eth_derivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e) -{ - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_eth_derivs(cg->shape, cg->X[0], cg->X[1], cg->fgfs[Rv->sgfn], cg->fgfs[Iv->sgfn], - cg->fgfs[ethRv->sgfn], cg->fgfs[ethIv->sgfn], s, e, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(ethRv); - DG_List->insert(ethIv); - Varwt[0] = s + e; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); -} -void NullShellPatch::eth_dderivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e1, int e2) -{ - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_eth_dderivs(cg->shape, cg->X[0], cg->X[1], cg->fgfs[Rv->sgfn], cg->fgfs[Iv->sgfn], - cg->fgfs[ethRv->sgfn], cg->fgfs[ethIv->sgfn], s, e1, e2, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(ethRv); - DG_List->insert(ethIv); - Varwt[0] = s + e1 + e2; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); -} -// lz is x instead of r -void NullShellPatch::getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) -{ - double r; - r = sqrt(x * x + y * y + z * z); - lz = r / (r + Rmin); - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "NullShellPatch::getlocalpox should not come here, something wrong" << endl; - } -} -// lz is x instead of r -// using fake global coordinates to get local coordinate -void NullShellPatch::getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) -{ - double r; - r = sqrt(x * x + y * y + z * z); - lz = r; - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "NullShellPatch::getlocalpox should not come here, something wrong" << endl; - } -} -// lz is x instead of r -// specially for usage from shell to shell -void NullShellPatch::getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz) -{ - // fake global coordinate - double r = 1, x, y, z; - switch (isst) - { - case 0: - x = tan(ix); - y = tan(iy); - z = r / sqrt(1 + x * x + y * y); - x = z * x; - y = z * y; - break; - case 1: - x = tan(ix); - y = tan(iy); - z = -r / sqrt(1 + x * x + y * y); - x = z * x; - y = z * y; - break; - case 2: - y = tan(ix); - z = tan(iy); - x = r / sqrt(1 + z * z + y * y); - y = x * y; - z = x * z; - break; - case 3: - y = tan(ix); - z = tan(iy); - x = -r / sqrt(1 + z * z + y * y); - y = x * y; - z = x * z; - break; - case 4: - x = tan(ix); - z = tan(iy); - y = r / sqrt(1 + x * x + z * z); - x = y * x; - z = y * z; - break; - case 5: - x = tan(ix); - z = tan(iy); - y = -r / sqrt(1 + x * x + z * z); - x = y * x; - z = y * z; - break; - } - - // map with fake global coordinate - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "NullShellPatch::getlocalpox should not come here, something wrong" << endl; - } - - lz = iz; - - // if(lx != lx) cout< NullShellPatch::get_swtf(double *pox, int tsst, int ssst) -{ - double rn = pox[0], sn = pox[1], ro, so; - double tcn, tsn, tco, tso; - tcn = sqrt((1 - sin(rn) * sin(sn)) / 2); - tsn = sqrt((1 + sin(rn) * sin(sn)) / 2); - // upper a - complex qan[2]; - qan[0] = complex(tsn, tcn); - qan[1] = complex(tsn, -tcn); - qan[0] = 2.0 * tcn * tsn / cos(sn) * qan[0]; - qan[1] = 2.0 * tcn * tsn / cos(rn) * qan[1]; - if (tsst == 1 || tsst == 3 || tsst == 4) - { - qan[0] = conj(qan[0]); - qan[1] = conj(qan[1]); - } - - complex qao[2]; - complex gont; - - double J[2][2]; - double cosro, sinro, cosso, sinso; - if (tsst == 0 || tsst == 1) // z - { - if (ssst == 2 || ssst == 3) // x - { - ro = atan(tan(sn) / tan(rn)); - so = atan(1 / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - // upper a - qao[1] = complex(tso, -tco); - qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[1] = conj(qao[1]); - } - gont = -qan[0] / qao[1]; - } - else if (ssst == 4 || ssst == 5) // y - { - ro = atan(tan(rn) / tan(sn)); - so = atan(1 / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - // upper a - qao[1] = complex(tso, -tco); - qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[1] = conj(qao[1]); - } - gont = -qan[1] / qao[1]; - } - else - cout << "Error in NullShellPatch::get_swtf 1" << endl; - } - else if (tsst == 2 || tsst == 3) - { - if (ssst == 0 || ssst == 1) - { - ro = atan(1 / tan(sn)); - so = atan(tan(rn) / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - // upper a - qao[0] = complex(tso, tco); - qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[0] = conj(qao[0]); - } - gont = -qan[1] / qao[0]; - } - else if (ssst == 4 || ssst == 5) - { - ro = atan(1 / tan(rn)); - so = atan(tan(sn) / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - // upper a - qao[0] = complex(tso, tco); - qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[0] = conj(qao[0]); - } - gont = -qan[0] / qao[0]; - } - else - cout << "Error in NullShellPatch::get_swtf 2" << endl; - } - else if (tsst == 4 || tsst == 5) - { - if (ssst == 0 || ssst == 1) - { - ro = atan(tan(rn) / tan(sn)); - so = atan(1 / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - // upper a - qao[1] = complex(tso, -tco); - qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[1] = conj(qao[1]); - } - gont = -qan[1] / qao[1]; - } - else if (ssst == 2 || ssst == 3) - { - ro = atan(1 / tan(rn)); - so = atan(tan(sn) / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - // upper a - qao[0] = complex(tso, tco); - qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[0] = conj(qao[0]); - } - gont = -qan[0] / qao[0]; - } - else - cout << "Error in NullShellPatch::get_swtf 3" << endl; - } - - return gont; -} -#else -// #define DEBUG -complex NullShellPatch::get_swtf(double *pox, int tsst, int ssst) -{ - double rn = pox[0], sn = pox[1], ro, so; - double tcn, tsn, tco, tso; - tcn = sqrt((1 - sin(rn) * sin(sn)) / 2); - tsn = sqrt((1 + sin(rn) * sin(sn)) / 2); -#ifdef DEBUG - // upper a - complex qan[2]; - qan[0] = complex(tsn, tcn); - qan[1] = complex(tsn, -tcn); - qan[0] = 2.0 * tcn * tsn / cos(sn) * qan[0]; - qan[1] = 2.0 * tcn * tsn / cos(rn) * qan[1]; - if (tsst == 1 || tsst == 3 || tsst == 4) - { - qan[0] = conj(qan[0]); - qan[1] = conj(qan[1]); - } -#endif - // lower bar a - complex lan[2]; - lan[0] = complex(tcn, -tsn); - lan[1] = complex(tcn, tsn); - lan[0] = cos(sn) / 4.0 / tcn / tcn / tsn / tsn * lan[0]; - lan[1] = cos(rn) / 4.0 / tcn / tcn / tsn / tsn * lan[1]; - - if (tsst == 1 || tsst == 3 || tsst == 4) - { - lan[0] = conj(lan[0]); - lan[1] = conj(lan[1]); - } - - complex gont = complex(2, 0); - - double J[2][2]; - double cosro, sinro, cosso, sinso; - if (tsst == 0 || tsst == 1) // z - { - if (ssst == 2 || ssst == 3) // x - { - ro = atan(tan(sn) / tan(rn)); - so = atan(1 / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = 0; - J[0][1] = -1; - J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[1][1] = -cosro * sinro / J[1][0]; - J[1][0] = cosso * sinso / J[1][0]; - } - else if (ssst == 4 || ssst == 5) // y - { - ro = atan(tan(rn) / tan(sn)); - so = atan(1 / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[0][1] = -cosro * sinro / J[0][0]; - J[0][0] = cosso * sinso / J[0][0]; - J[1][0] = 0; - J[1][1] = -1; - } - else - cout << "Error in NullShellPatch::get_swtf 1" << endl; - } - else if (tsst == 2 || tsst == 3) - { - if (ssst == 0 || ssst == 1) - { - ro = atan(1 / tan(sn)); - so = atan(tan(rn) / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[0][1] = cosro * sinro / J[0][0]; - J[0][0] = -cosso * sinso / J[0][0]; - J[1][0] = -1; - J[1][1] = 0; - } - else if (ssst == 4 || ssst == 5) - { - ro = atan(1 / tan(rn)); - so = atan(tan(sn) / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = -1; - J[0][1] = 0; - J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[1][1] = cosro * sinro / J[1][0]; - J[1][0] = -cosso * sinso / J[1][0]; - } - else - cout << "Error in NullShellPatch::get_swtf 2" << endl; - } - else if (tsst == 4 || tsst == 5) - { - if (ssst == 0 || ssst == 1) - { - ro = atan(tan(rn) / tan(sn)); - so = atan(1 / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[0][1] = -cosro * sinro / J[0][0]; - J[0][0] = cosso * sinso / J[0][0]; - J[1][0] = 0; - J[1][1] = -1; - } - else if (ssst == 2 || ssst == 3) - { - ro = atan(1 / tan(rn)); - so = atan(tan(sn) / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = -1; - J[0][1] = 0; - J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[1][1] = cosro * sinro / J[1][0]; - J[1][0] = -cosso * sinso / J[1][0]; - } - else - cout << "Error in NullShellPatch::get_swtf 3" << endl; - } - tco = sqrt((1 - sin(ro) * sin(so)) / 2); - tso = sqrt((1 + sin(ro) * sin(so)) / 2); - - complex qao[2]; - // upper a - qao[0] = complex(tso, tco); - qao[1] = complex(tso, -tco); - qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; - qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - qao[0] = conj(qao[0]); - qao[1] = conj(qao[1]); - } - - gont /= J[0][0] * lan[0] * qao[0] + J[0][1] * lan[0] * qao[1] + J[1][0] * lan[1] * qao[0] + J[1][1] * lan[1] * qao[1]; - -#ifdef DEBUG - - complex lao[2]; - // lower bar a - lao[0] = complex(tco, -tso); - lao[1] = complex(tco, tso); - lao[0] = cos(so) / 4.0 / tco / tco / tso / tso * lao[0]; - lao[1] = cos(ro) / 4.0 / tco / tco / tso / tso * lao[1]; - if (ssst == 1 || ssst == 3 || ssst == 4) - { - lao[0] = conj(lao[0]); - lao[1] = conj(lao[1]); - } - - static bool f1 = true, f2 = true, f3 = true, f4 = true; - static bool f5 = true, f6 = true, f7 = true, f8 = true; - static bool f9 = true, f10 = true, f11 = true, f12 = true; - double hn11, hn12, hn22; - double ho11, ho12, ho22; - if (f1 && tsst == 0 && ssst == 2) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "x+ -> z+; g -> x+; g -> z+" << endl; - double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f1 = false; - } - else if (f2 && tsst == 0 && ssst == 3) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "x- -> z+; g -> x-; g -> z+" << endl; - double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f2 = false; - } - else if (f3 && tsst == 0 && ssst == 4) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "y+ -> z+; g -> y+; g -> z+" << endl; - double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f3 = false; - } - else if (f4 && tsst == 0 && ssst == 5) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "y- -> z+; g -> y-; g -> z+" << endl; - double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f4 = false; - } - else if (f5 && tsst == 1 && ssst == 2) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "x+ -> z-; g -> x+; g -> z-" << endl; - double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f5 = false; - } - else if (f6 && tsst == 1 && ssst == 3) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "x- -> z-; g -> x-; g -> z-" << endl; - double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f6 = false; - } - else if (f7 && tsst == 1 && ssst == 4) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "y+ -> z-; g -> y+; g -> z-" << endl; - double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f7 = false; - } - else if (f8 && tsst == 1 && ssst == 5) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "y- -> z-; g -> y-; g -> z-" << endl; - double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f8 = false; - } - else if (f9 && tsst == 2 && ssst == 0) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << "z+ -> x+; g -> z+; g -> x+" << endl; - double the = atan(sqrt(tan(rn) * tan(rn) + 1) / tan(sn)), phi = rn; - if (the < 0) - the = PI + the; - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," - << complex(0, -1) / sin(the) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," - << complex(0, -1) / sin(the) / qan[0] - << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," - << complex(-cos(phi), -sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," - << complex(-cos(phi), -sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] - << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f9 = false; - } - else if (f10 && tsst == 2 && ssst == 1) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f10 = false; - } - else if (f11 && tsst == 2 && ssst == 4) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f11 = false; - } - else if (f12 && tsst == 2 && ssst == 5) - { - cout << "tsst = " << tsst << ", ssst = " << ssst << endl; - cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; - cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; - cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << endl; - cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << endl; - ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); - ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; - ho22 = cos(ro) * cos(ro) * ho11; - ho11 = cos(so) * cos(so) * ho11; - hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); - hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; - hn22 = cos(rn) * cos(rn) * hn11; - hn11 = cos(sn) * cos(sn) * hn11; - cout << ho11 << "," << ho12 << "," << ho22 << endl; - cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," - << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," - << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; - cout << "swtf = " << gont << endl; - f12 = false; - } - -#endif - - return gont; -} -#endif -// for check -// used by _dst construction, so these x,y,z must coinside with grid point -// we have considered ghost points now -void NullShellPatch::prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], - MyList *Ppi, double CDH[dim], MyList *pss) -{ - int n_dst = 0; - MyList *sPp = sPpi; - MyList *Pp = Ppi; - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz, lsst; - - if (pss->data->tsst >= 0) - { - getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, - lx, ly, lz); - if (lx != lx) - getlocalpoxsst_ss(pss->data->ssst, pss->data->lpox[0], pss->data->lpox[1], pss->data->lpox[2], - pss->data->tsst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == pss->data->tsst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - { - for (int j = 0; j < dim; j++) - { - llb[j] = Bg->bbox[j]; - uub[j] = Bg->bbox[j + dim]; - } - - if (lx > llb[0] - 0.1 * DH[0] && lx < uub[0] + 0.1 * DH[0] && - ly > llb[1] - 0.1 * DH[1] && ly < uub[1] + 0.1 * DH[1] && - lz > llb[2] - 0.1 * DH[2] && lz < uub[2] + 0.1 * DH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = 0; - for (int i = 0; i < dim; i++) - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = pss->data->ssst; - ps->data->tsst = sPp->data->sst; - ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); - ps->data->Bg = Bg; - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->swtf = get_swtf(ps->data->lpox, ps->data->tsst, ps->data->ssst); - if (psul) - psul->catList(ps); - else - psul = ps; - n_dst++; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - } - else - { - if (pss->data->tsst != -1) - cout << "somthing is wrong in NullShellPatch::prolongpointstru" << endl; - lx = pss->data->gpox[0]; - ly = pss->data->gpox[1]; - lz = pss->data->gpox[2]; - while (Pp) - { - Bgl = Pp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - { - for (int j = 0; j < dim; j++) - { - llb[j] = Bg->bbox[j]; - uub[j] = Bg->bbox[j + dim]; - } - - if (lx > llb[0] - 0.1 * CDH[0] && lx < uub[0] + 0.1 * CDH[0] && - ly > llb[1] - 0.1 * CDH[1] && ly < uub[1] + 0.1 * CDH[1] && - lz > llb[2] - 0.1 * CDH[2] && lz < uub[2] + 0.1 * CDH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = 0; - for (int i = 0; i < dim; i++) - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = pss->data->ssst; - ps->data->tsst = -1; - ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); - ps->data->Bg = Bg; - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->swtf = 1; - if (psul) - psul->catList(ps); - else - psul = ps; - n_dst++; - } - } - if (Bgl == Pp->data->ble) - break; - Bgl = Bgl->next; - } - Pp = Pp->next; - } - } - // if n_dst > 0, that's because of ghost_points then prolong source list - if (n_dst == 0) - { - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "NullShellPatch::prolongpointstru fail to find target Block for pointstru:" << endl; - check_pointstrul(pss, true); - if (Pp == Ppi) - { - getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, - lx, ly, lz); - if (myrank == 0) - cout << "sst = " << pss->data->tsst << ", lx,ly,lz = " << lx << "," << ly << "," << lz << endl; - checkBlock(pss->data->tsst); - } - else - { - Pp = Ppi; - while (Pp) - { - Pp->data->checkBlock(); - Pp = Pp->next; - } - } - if (myrank == 0) - MPI_Abort(MPI_COMM_WORLD, 1); - } - else - { - MyList *ts = 0; - for (int i = 1; i < n_dst; i++) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = (i == n_dst - 1) ? pss->next : 0; - for (int i = 0; i < dim; i++) - { - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[i] = pss->data->lpox[i]; - } - ps->data->ssst = pss->data->ssst; - ps->data->tsst = pss->data->tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->Bg = pss->data->Bg; - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->swtf = pss->data->swtf; - if (ts) - ts->catList(ps); - else - ts = ps; - } - if (ts) - pss->next = ts; - } -} -// used by _src construction, so these x,y,z do not coinside with grid point -bool NullShellPatch::prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in) -{ - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz; - - if (ssyn) - { - int sst; - getlocalpox(x, y, z, sst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == sst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < 2; j++) - { - if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) - llb[j] = -PI / 4; - else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * DH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) - uub[j] = PI / 4; - else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; - } - if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) - llb[2] = Bg->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; -#else -#ifdef Cell - else - llb[2] = Bg->bbox[2] + ghost_width * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) - uub[2] = Bg->bbox[dim + 2]; - else - uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; - if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && - ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && - lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| - // ^ - // so for ^ point may miss for vertext center, so we use 0.0001 - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = x; - ps->data->gpox[1] = y; - ps->data->gpox[2] = z; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = sPp->data->sst; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->swtf = 1; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - } - else - { - while (Pp) - { - Bgl = Pp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < dim; j++) - { - if (feq(Bg->bbox[j], Pp->data->bbox[j], CDH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * CDH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * CDH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], Pp->data->bbox[dim + j], CDH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * CDH[j]; - } - if (x > llb[0] - 0.0001 * CDH[0] && x < uub[0] + 0.0001 * CDH[0] && - y > llb[1] - 0.0001 * CDH[1] && y < uub[1] + 0.0001 * CDH[1] && - z > llb[2] - 0.0001 * CDH[2] && z < uub[2] + 0.0001 * CDH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = x; - ps->data->gpox[1] = y; - ps->data->gpox[2] = z; - ps->data->lpox[0] = x; - ps->data->lpox[1] = y; - ps->data->lpox[2] = z; - ps->data->ssst = -1; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->swtf = 1; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == Pp->data->ble) - break; - Bgl = Bgl->next; - } - Pp = Pp->next; - } - } - - return false; -} -// used by _src construction, so these x,y,z do not coinside with grid point -// specially used from shell to shell -bool NullShellPatch::prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in) -{ - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz; - - int sst; - getlocalpox_ss(tsst, x, y, z, sst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == sst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < 2; j++) - { - if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) - llb[j] = -PI / 4; - else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * DH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) - uub[j] = PI / 4; - else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; - } - if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) - llb[2] = Bg->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; -#else -#ifdef Cell - else - llb[2] = Bg->bbox[2] + ghost_width * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) - uub[2] = Bg->bbox[dim + 2]; - else - uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; - if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && - ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && - lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| - // ^ - // so for ^ point may miss for vertext center, so we use 0.0001 - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = 0; // global coordinate is not valid for r=infinity - ps->data->gpox[1] = 0; - ps->data->gpox[2] = 0; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = sPp->data->sst; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->swtf = 1; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - - return false; -} -// setup interpatch interpolation stuffs -void NullShellPatch::setupintintstuff(int cpusize, MyList *CPatL, int Symmetry) -{ - const int hCS_width = 0; // do not input data from null shell to box - const int hSC_width = 1; // do input data from box to null shell - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "NullShellPatch::setupintintstuff begines..." << endl; - - ss_src = new MyList *[cpusize]; - ss_dst = new MyList *[cpusize]; - - if (!CPatL) // if characteristic evolve alone - { - cs_src = 0; - cs_dst = 0; - } - else - { - cs_src = new MyList *[cpusize]; - cs_dst = new MyList *[cpusize]; - } - - MyList *ps, *ts; - MyList *sPp; - MyList *Bgl; - MyList *Pp; - Block *Bg; - double CDH[dim], DH[dim], llb[dim], uub[dim]; - double x, y, z; - - for (int i = 0; i < dim; i++) - { - if (CPatL) - CDH[i] = CPatL->data->getdX(i); - DH[i] = getdX(i); - } - - for (int i = 0; i < cpusize; i++) - { - ss_src[i] = 0; - ss_dst[i] = 0; - if (CPatL) - { - cs_src[i] = 0; - cs_dst[i] = 0; - } - } - - sPp = PatL; - while (sPp) - { - for (int iz = 0; iz < sPp->data->shape[2]; iz++) - for (int is = 0; is < sPp->data->shape[1]; is++) - for (int ir = 0; ir < sPp->data->shape[0]; ir++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = sPp->data->bbox[0] + ir * DH[0]; - y = sPp->data->bbox[1] + is * DH[1]; - z = sPp->data->bbox[2] + iz * DH[2]; -#else -#ifdef Cell - x = sPp->data->bbox[0] + (ir + 0.5) * DH[0]; - y = sPp->data->bbox[1] + (is + 0.5) * DH[1]; - z = sPp->data->bbox[2] + (iz + 0.5) * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (CPatL && z < sPp->data->bbox[2] + (hSC_width + 0.0001) * DH[2]) - { - double gx, gy, gz; - getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); - bool flag = false; - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(cs_src[i], false, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); - if (flag) - break; - } - if (!flag) - { - CPatL->data->checkBlock(); - if (myrank == 0) - { - cout << "ShellPatch::prolongpointstru fail to find cardisian source point for" << endl; - cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; - cout << "x,y,z = " << gx << "," << gy << "," << gz << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - if (x < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[0] || x > PI / 4 + (overghost - ghost_width - 0.0001) * DH[0] || - y < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[1] || y > PI / 4 + (overghost - ghost_width - 0.0001) * DH[1]) - { - double gx, gy, gz; - if (z < 1 - 0.0001 * DH[2]) - getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); - bool flag = true; - if (flag) - { - flag = false; - for (int i = 0; i < cpusize; i++) - { - if (z < 1 - 0.0001 * DH[2]) - flag = prolongpointstru(ss_src[i], true, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); - else - flag = prolongpointstru_ss(ss_src[i], sPp->data->sst, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i); - if (flag) - break; - } - if (!flag) - { - if (myrank == 0) - { - // if you used Vertex grid please note x=1, try 0.999999 instead - cout << "NullShellPatch::prolongpointstru fail to find shell source point for" << endl; - cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - } - sPp = sPp->next; - } - if (myrank == 0) - cout << "NullShellPatch::setupintintstuff ss_src completes" << endl; - - Pp = CPatL; - while (Pp) - { - double llb[dim], uub[dim]; - if (Symmetry > 0) - llb[2] = Pp->data->bbox[2] - 0.0001 * CDH[2]; - else - llb[2] = Pp->data->bbox[2] + (hCS_width + 0.0001) * CDH[2]; - uub[2] = Pp->data->bbox[dim + 2] - (hCS_width + 0.0001) * CDH[2]; - for (int j = 0; j < 2; j++) - { - if (Symmetry > 1) - llb[j] = Pp->data->bbox[j] - 0.0001 * CDH[j]; - else - llb[j] = Pp->data->bbox[j] + (hCS_width + 0.0001) * CDH[j]; - uub[j] = Pp->data->bbox[dim + j] - (hCS_width + 0.0001) * CDH[j]; - } - for (int iz = 0; iz < Pp->data->shape[2]; iz++) - for (int iy = 0; iy < Pp->data->shape[1]; iy++) - for (int ix = 0; ix < Pp->data->shape[0]; ix++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = Pp->data->bbox[0] + ix * CDH[0]; - y = Pp->data->bbox[1] + iy * CDH[1]; - z = Pp->data->bbox[2] + iz * CDH[2]; -#else -#ifdef Cell - x = Pp->data->bbox[0] + (ix + 0.5) * CDH[0]; - y = Pp->data->bbox[1] + (iy + 0.5) * CDH[1]; - z = Pp->data->bbox[2] + (iz + 0.5) * CDH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (x < llb[0] || x > uub[0] || - y < llb[1] || y > uub[1] || - z < llb[2] || z > uub[2]) - { - int sst; - double lx, ly, lz; - bool flag = false; - getlocalpox(x, y, z, sst, lx, ly, lz); - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(cs_src[i], true, -1, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i); - if (flag) - break; - } - if (!flag) - { - if (myrank == 0) - { - cout << "ShellPatch::prolongpointstru fail to find shell source point for" << endl; - cout << "sst = -1, x,y,z = " << x << "," << y << "," << z << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - Pp = Pp->next; - } - if (myrank == 0) - if (CPatL) - cout << "NullShellPatch::setupintintstuff cs_src completes" << endl; - else - cout << "NullShellPatch::no cs_src exists" << endl; - - for (int i = 0; i < cpusize; i++) - { - ps = ss_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(ss_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - - if (CPatL) - { - ps = cs_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(cs_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - } - } - if (myrank == 0) - cout << "NullShellPatch::setupintintstuff ss_dst and cs_dst complete" << endl; - - /* - for(int i=0;inext; - ts=ts->next; - } - } - exit(0); - */ -} -void NullShellPatch::checkPatch() -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << " belong to NullShell Patchs " << endl; - MyList *Pp = PatL; - while (Pp) - { - cout << " shape: ["; - for (int i = 0; i < dim; i++) - { - cout << Pp->data->shape[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << " range:" << "("; - for (int i = 0; i < dim; i++) - { - cout << Pp->data->bbox[i] << ":" << Pp->data->bbox[dim + i]; - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - Pp = Pp->next; - } - } -} -void NullShellPatch::checkBlock(int sst) -{ - if (myrank == 0) - { - cout << "checking shell patch sst = " << sst << endl; - MyList *Pp = PatL; - while (Pp) - { - if (Pp->data->sst == sst) - { - MyList *BP = Pp->data->blb; - while (BP) - { - BP->data->checkBlock(); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - } - Pp = Pp->next; - } - } -} -double NullShellPatch::getdX(int dir) -{ - if (dir < 0 || dir >= dim) - { - cout << "NullShellPatch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double h; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (shape[dir] == 1) - { - cout << "NullShellPatch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (dir < 2) - h = PI / 2 / (shape[dir] - 1); - else - h = (xmax - xmin) / (shape[dir] - 1); -#else -#ifdef Cell - if (dir < 2) - h = PI / 2 / shape[dir]; - else - h = (xmax - xmin) / shape[dir]; -#else -#error Not define Vertex nor Cell -#endif -#endif - return h; -} -void NullShellPatch::shellname(char *sn, int i) -{ - switch (i) - { - case 0: - sprintf(sn, "zp"); - return; - case 1: - sprintf(sn, "zm"); - return; - case 2: - sprintf(sn, "xp"); - return; - case 3: - sprintf(sn, "xm"); - return; - case 4: - sprintf(sn, "yp"); - return; - case 5: - sprintf(sn, "ym"); - return; - } -} -// Now we dump the data including overlap points -void NullShellPatch::Dump_xyz(char *tag, double time, double dT) -{ - MyList *DumpListi = 0; - DumpListi = new MyList(gx); - DumpListi->insert(gy); - DumpListi->insert(gz); - Dump_Data(DumpListi, tag, time, dT); - DumpListi->clearList(); -} -void NullShellPatch::Dump_Data(MyList *DumpListi, char *tag, double time, double dT) -{ - MyList *PP = PatL; - while (PP) - { - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); - if (!databuffer) - { - cout << "NullShellPatch::Dump_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *DumpList = DumpListi; - while (DumpList) - { - var *VP = DumpList->data; - - MyList *Bp = PP->data->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->data->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - char filename[100]; - char sn[3]; - shellname(sn, PP->data->sst); - if (tag) - sprintf(filename, "%s_LevSH-%s_%s_%05d.bin", tag, sn, VP->name, ncount); - else - sprintf(filename, "LevSH-%s_%s_%05d.bin", sn, VP->name, ncount); - - Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], - PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], - PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); - } - DumpList = DumpList->next; - } - - if (myrank == 0) - free(databuffer); - - PP = PP->next; - } -} -void NullShellPatch::intertransfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry, int *Varwt) -{ - int myrank, cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int node; - - MPI_Request *reqs; - MPI_Status *stats; - reqs = new MPI_Request[2 * cpusize]; - stats = new MPI_Status[2 * cpusize]; - int req_no = 0; - - double **send_data, **rec_data; - send_data = new double *[cpusize]; - rec_data = new double *[cpusize]; - int length; - - for (node = 0; node < cpusize; node++) - { - send_data[node] = rec_data[node] = 0; - if (node == myrank) - { - if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 1" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(rec_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt); - } - } - else - { - // send from this cpu to cpu#node - if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt)) - { - send_data[node] = new double[length]; - if (!send_data[node]) - { - cout << "out of memory when new in short transfer, place 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt); - MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - // receive from cpu#node to this cpu - if (length = interdata_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - } - } - // wait for all requests to complete - MPI_Waitall(req_no, reqs, stats); - - for (node = 0; node < cpusize; node++) - if (rec_data[node]) - interdata_packer(rec_data[node], src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt); - - for (node = 0; node < cpusize; node++) - { - if (send_data[node]) - delete[] send_data[node]; - if (rec_data[node]) - delete[] rec_data[node]; - } - - delete[] reqs; - delete[] stats; - delete[] send_data; - delete[] rec_data; -} -// PACK: prepare target data in 'data' -// UNPACK: copy target data from 'data' to corresponding numerical grids -int NullShellPatch::interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, int *Varwt) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int DIM = dim; - int ordn = 2 * ghost_width; - - if (dir != PACK && dir != UNPACK) - { - cout << "error dir " << dir << " for data_packer " << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int size_out = 0; - - if (!src || !dst) - return size_out; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - while (src && dst) - { - if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || - (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) - { - varls = VarLists; - varld = VarListd; - int vind = 0; - bool flag = true; - while (varls && varld) - { - if (data) - { - if (dir == PACK) - { - /* - f_global_interp(src->data->Bg->shape,src->data->Bg->X[0],src->data->Bg->X[1],src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn],data[size_out], - src->data->lpox[0],src->data->lpox[1],src->data->lpox[2],ordn,varls->data->SoA,Symmetry); - */ - int DIMh = (src->data->dumyd == -1) ? dim : 1; - if (src->data->coef == 0) - { - src->data->coef = new double[ordn * DIMh]; - src->data->sind = new int[dim]; - if (DIMh == 3) - { - for (int i = 0; i < DIMh; i++) - { - double dd = src->data->Bg->getdX(i); - // 0.001 instead of 0.4 makes the point locate more center - src->data->sind[i] = int((src->data->lpox[i] - src->data->Bg->X[i][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = src->data->Bg->X[i][0] + (src->data->sind[i] + j) * dd; - src->data->coef[i * ordn + j] = 1; - for (int k = 0; k < j; k++) - { - h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; - src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; - src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); - } - } - } - } - else - { - int actd = 1 - src->data->dumyd; - double dd = src->data->Bg->getdX(actd); - src->data->sind[0] = int((src->data->lpox[actd] - src->data->Bg->X[actd][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = src->data->Bg->X[actd][0] + (src->data->sind[0] + j) * dd; - src->data->coef[j] = 1; - for (int k = 0; k < j; k++) - { - h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; - src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; - src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); - } - } - src->data->sind[2] = int((src->data->lpox[2] - src->data->Bg->X[2][0]) / src->data->Bg->getdX(2) + 0.001); - if (!feq(src->data->Bg->X[2][src->data->sind[2]], src->data->lpox[2], src->data->Bg->getdX(2) / 2000)) - cout << "error in NullShellPatch::interdata_packer point = " << src->data->lpox[2] << " != grid " << src->data->Bg->X[2][src->data->sind[2]] << endl; - src->data->sind[1] = int((src->data->lpox[src->data->dumyd] - src->data->Bg->X[src->data->dumyd][0]) / - src->data->Bg->getdX(src->data->dumyd) + - 0.001); - if (!feq(src->data->Bg->X[src->data->dumyd][src->data->sind[1]], src->data->lpox[src->data->dumyd], src->data->Bg->getdX(src->data->dumyd) / 2000)) - cout << "error in NullShellPatch::interdata_packer for dumy dimension point = " - << src->data->lpox[src->data->dumyd] << " != grid " << src->data->Bg->X[src->data->dumyd][src->data->sind[1]] << endl; - } - } - // interpolate - switch (DIMh) - { - case 3: - f_global_interpind(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst); - break; - case 2: - f_global_interpind2d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst); - break; - case 1: - f_global_interpind1d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst, src->data->dumyd); - break; - default: - cout << "NullShellPatch::interdata_packer: not recognized DIM = " << DIMh << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - if (dir == UNPACK) // from target data to corresponding grid - { - if (Varwt[vind / 2] != 0) // we always assume 2 time number relation - { - if (flag) - { - complex rtp = complex(data[size_out], data[size_out + 1]); - rtp = rtp * pow(dst->data->swtf, Varwt[vind / 2]); // note we only stored the factor in dst - data[size_out] = rtp.real(); - data[size_out + 1] = rtp.imag(); - } - flag = !flag; // on-off method - } - // if(dst->data->tsst==2 && fabs(dst->data->lpox[0]+0.02617993878)<0.00001 && fabs(dst->data->lpox[2]-0.510417)<0.00001)cout<data->name<data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], - dst->data->lpox[0], dst->data->lpox[1], dst->data->lpox[2], data[size_out]); - } - } - size_out += 1; - vind += 1; - varls = varls->next; - varld = varld->next; - } - } - dst = dst->next; - src = src->next; - } - - return size_out; -} -void NullShellPatch::Synch(MyList *VarList, int Symmetry, int *Varwt) -{ - MyList *Pp = PatL; - while (Pp) - { - Pp->data->Sync(VarList, Symmetry); - Pp = Pp->next; - } - // we need this before interpolation - if (Symmetry > 0) - fill_symmetric_boundarybuffer(VarList, Varwt); - - intertransfer(ss_src, ss_dst, VarList, VarList, Symmetry, Varwt); - - // we need this here to correct conners - if (Symmetry > 0) - fill_symmetric_boundarybuffer(VarList, Varwt); -} -void NullShellPatch::check_pointstrul(MyList *pp, bool first_only) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - if (!pp) - cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; - else - cout << "checking check_pointstrul..." << endl; - while (pp) - { - if (pp->data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - if (first_only) - return; - pp = pp->next; - } - } -} -void NullShellPatch::check_pointstrul2(MyList *pp, int first_last_only) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - if (!pp) - cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; - else - cout << "checking check_pointstrul..." << endl; - while (pp) - { - if (first_last_only == 2) - { - if (pp->next == 0) - { - if (pp->data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - } - } - else - { - if (pp->data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - if (first_last_only == 1) - return; - } - pp = pp->next; - } - } -} -void NullShellPatch::matchcheck(MyList *CPatL) -{ - double cbd = CPatL->data->bbox[dim]; - for (int i = 1; i < dim; i++) - cbd = Mymin(cbd, CPatL->data->bbox[dim + i]); - cbd = cbd - xmin * Rmin / (1 - xmin); - double dr, dc; - dc = CPatL->data->getdX(0); - dr = getdX(2); - for (int i = 1; i < dim; i++) - { - dc = Mymax(dc, CPatL->data->getdX(i)); - // dr = Mymax(dr,getdX(i)); - } - - int ir, ic; - ir = int(cbd / dr); - ic = int(cbd / dc); - if (Mymin(ir, ic) < 3 * ghost_width) - { - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << "NullShell Patches insert too shallow:" << endl; - cout << "distantance between these two boundaries is " << cbd << ", spatial step is " << Mymax(dc, dr) << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -} -void NullShellPatch::Interp_Points(MyList *VarList, - int NN, double **XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[NN * num_var]; - memset(shellf, 0, sizeof(double) * NN * num_var); - - // we use weight to monitor code, later some day we can move it for optimization - int *weight; - weight = new int[NN]; - memset(weight, 0, sizeof(int) * NN); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - int sst; - getlocalpox(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); // pox[2] is x indeed - - MyList *sPp = PatL; - while (sPp->data->sst != sst) - sPp = sPp->next; - - if (myrank == 0 && ((!sPp) || pox[2] < xmin - 0.0001 * DH[2] || pox[2] > xmax + 0.0001 * DH[2])) - { - cout << "NullShellPatch::Interp_Points: point gc = ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - } - if (sPp) - { - cout << ") sst = " << sst << " lc = ("; - for (int k = 0; k < dim; k++) - { - cout << pox[k]; - if (k < dim - 1) - cout << ","; - } - } - cout << ") is out of the NullShellPatch." << endl; - cout << "xmin = " << xmin << ", xmax = " << xmax << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (!sPp) - return; - - MyList *Bp = sPp->data->blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -// -// because of getlocalpox, pox will not goes into overghost region of ss_patch -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp_ss(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry, sst); - varl = varl->next; - k++; - } - weight[j] = 1; - } - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - } - - MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - int *Weight; - Weight = new int[NN]; - MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - - for (int i = 0; i < NN; i++) - { - if (Weight[i] > 1) - { - if (myrank == 0) - cout << "WARNING: NullShellPatch::Interp_Points meets multiple weight" << endl; - for (int j = 0; j < num_var; j++) - Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; - } - else if (Weight[i] == 0 && myrank == 0) - { - cout << "ERROR: NullShellPatch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j][i]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on NullShellPatch (" << xmin << ":" << xmax << ")" << endl; - - cout << "splited domains:" << endl; - MyList *sPp = PatL; - while (sPp) - { - char sn[3]; - shellname(sn, sPp->data->sst); - cout << "ss_patch " << sn << ":" << endl; - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - delete[] shellf; - delete[] weight; - delete[] Weight; - delete[] DH; - delete[] llb; - delete[] uub; -} -void NullShellPatch::Interp_Points_2D(MyList *VarList, - int NN, double **XX, /*input fake global Cartesian coordinate*/ - double *Shellf, int Symmetry) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[NN * num_var]; - memset(shellf, 0, sizeof(double) * NN * num_var); - - // we use weight to monitor code, later some day we can move it for optimization - int *weight; - weight = new int[NN]; - memset(weight, 0, sizeof(int) * NN); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - int sst; - getlocalpox_fake(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); // pox[2] is x indeed - - int indZ = int((pox[2] - xmin) / DH[2]); - MyList *sPp = PatL; - while (sPp->data->sst != sst) - sPp = sPp->next; - - if (myrank == 0 && ((!sPp) || pox[2] < xmin - 0.0001 * DH[2] || pox[2] > xmax + 0.0001 * DH[2])) - { - cout << "NullShellPatch::Interp_Points: point gc = ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - } - if (sPp) - { - cout << ") sst = " << sst << " lc = ("; - for (int k = 0; k < dim; k++) - { - cout << pox[k]; - if (k < dim - 1) - cout << ","; - } - } - cout << ") is out of the NullShellPatch." << endl; - cout << "xmin = " << xmin << ", xmax = " << xmax << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (!sPp) - return; - - MyList *Bp = sPp->data->blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -// -// because of getlocalpox, pox will not goes into overghost region of ss_patch -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp_ss_2d(BP->shape, BP->X[0], BP->X[1], indZ, BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], - pox[0], pox[1], ordn, varl->data->SoA, Symmetry, sst); - varl = varl->next; - k++; - } - weight[j] = 1; - } - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - } - - MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - int *Weight; - Weight = new int[NN]; - MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - - for (int i = 0; i < NN; i++) - { - if (Weight[i] > 1) - { - if (myrank == 0) - cout << "WARNING: NullShellPatch::Interp_Points meets multiple weight" << endl; - for (int j = 0; j < num_var; j++) - Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; - } - else if (Weight[i] == 0 && myrank == 0) - { - cout << "ERROR: NullShellPatch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j][i]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on NullShellPatch (" << xmin << ":" << xmax << ")" << endl; - - cout << "splited domains:" << endl; - MyList *sPp = PatL; - while (sPp) - { - char sn[3]; - shellname(sn, sPp->data->sst); - cout << "ss_patch " << sn << ":" << endl; - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - delete[] shellf; - delete[] weight; - delete[] Weight; - delete[] DH; - delete[] llb; - delete[] uub; -} -void NullShellPatch::Step(double dT, double PhysTime, monitor *ErrorMonitor) -{ - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - double TT = PhysTime; - double neps = 0.05; - MyList *sPp; - - // Predictor - HyperSlice(dT, TT, ErrorMonitor, iter_count); - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - // cg->swapList(TheList,JrhsList,myrank); - if (myrank == cg->rank) - { - // rhs calculation - f_array_copy(cg->shape, cg->fgfs[RJ_rhs->sgfn], cg->fgfs[RTheta->sgfn]); - f_array_copy(cg->shape, cg->fgfs[IJ_rhs->sgfn], cg->fgfs[ITheta->sgfn]); - f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[RJ0->sgfn], cg->fgfs[RJ_rhs->sgfn], - RJ0->SoA, Symmetry, neps, sPp->data->sst); - f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[IJ0->sgfn], cg->fgfs[IJ_rhs->sgfn], - RJ0->SoA, Symmetry, neps, sPp->data->sst); - f_omega_rhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega_rhs->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[RJ0->sgfn], cg->fgfs[RJ->sgfn], cg->fgfs[RJ_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[IJ0->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[IJ_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega->sgfn], cg->fgfs[omega_rhs->sgfn], - iter_count); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - /* - { - char str[50]; - sprintf(str,"rk%d",iter_count); - Dump_Data(SynchList_pre,str,PhysTime,dT); - Dump_Data(RHSList,str,PhysTime,dT); - } - */ - // no nedd to synchronize J, because Theta has already been synchnized previously - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(omega); - DG_List->insert(FXZEO); - Varwt[0] = 0; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - - Compute_News(PhysTime, dT, false); // put here because after step J and omega are at t+dt, while other variables at t - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TT += dT / 2; - HyperSlice(dT, TT, ErrorMonitor, iter_count); - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - // cg->swapList(TheList,J1List,myrank); - if (myrank == cg->rank) - { - // rhs calculation - f_array_copy(cg->shape, cg->fgfs[RJ1->sgfn], cg->fgfs[RTheta->sgfn]); - f_array_copy(cg->shape, cg->fgfs[IJ1->sgfn], cg->fgfs[ITheta->sgfn]); - f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[RJ0->sgfn], cg->fgfs[RJ1->sgfn], - RJ0->SoA, Symmetry, neps, sPp->data->sst); - f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[IJ0->sgfn], cg->fgfs[IJ1->sgfn], - RJ0->SoA, Symmetry, neps, sPp->data->sst); - f_omega_rhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega1->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[RJ0->sgfn], cg->fgfs[RJ1->sgfn], cg->fgfs[RJ_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[IJ0->sgfn], cg->fgfs[IJ1->sgfn], cg->fgfs[IJ_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega1->sgfn], cg->fgfs[omega_rhs->sgfn], - iter_count); - } - if (iter_count < 3) - cg->swapList(SynchList_cor, SynchList_pre, myrank); - else - { - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(omega0); - DG_List->insert(FXZEO); - Varwt[0] = 0; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - - /* - { - char str[50]; - sprintf(str,"rk%d",iter_count); - Dump_Data(SynchList_cor,str,PhysTime,dT); - } - */ - } -} -void NullShellPatch::Null_Boundary(double PhysTime) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - int Varwt[3]; - MyList *DG_List; - DG_List = new MyList(RU); - DG_List->insert(IU); - Varwt[0] = 1; - DG_List->insert(RQ); - DG_List->insert(IQ); - Varwt[1] = 1; - DG_List->insert(RTheta); - DG_List->insert(ITheta); - Varwt[2] = 2; - - Synch(DG_List, Symmetry, Varwt); - // Dump_Data(DG_List,0,0,1); - DG_List->clearList(); -} -#if 1 -// real evolve -void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) -{ - int ERROR = 0; - Null_Boundary(PhysTime); - - int spin, e; - - MyList *sPp; - - // evolve beta - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - if (f_NullEvol_beta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - if (f_NullEvol_beta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(betaList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(betaList, Symmetry, betawt); - // get nu, k and B - spin = 2; - e = -1; - if (RK_count == 0) - eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); - else - eth_derivs(RJ, IJ, Rnu, Inu, spin, e); - spin = 0; - e = 1; - eth_derivs(KK, FXZEO, Rk, Ik, spin, e); - eth_derivs(beta, FXZEO, RB, IB, spin, e); - - // evolve Q and U - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of Q, we can deal with U together here - // at this stage Q has been updated already - f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], - cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of Q, we can deal with U together here - // at this stage Q has been updated already - f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], - cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(QUList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(QUList, Symmetry, QUwt); - - // evolve W and Theta - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of W, we can deal with Theta together here - // at this stage W has been updated already - f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of W, we can deal with Theta together here - // at this stage W has been updated already - f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(WTheList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(WTheList, Symmetry, WThewt); -} -#else -#if 0 -//For check, give all surface varialbes -//check J evolve only -void NullShellPatch::HyperSlice(double dT,double PhysTime,monitor *ErrorMonitor,int RK_count) -{ - int ERROR=0; - - int spin,e; - - MyList *sPp; - - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { -/* - f_get_exact_null_theta(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[RTheta->sgfn],cg->fgfs[ITheta->sgfn],sPp->data->sst,Rmin,PhysTime, - cg->fgfs[quR1->sgfn],cg->fgfs[quR2->sgfn],cg->fgfs[quI1->sgfn],cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn],cg->fgfs[qlR2->sgfn],cg->fgfs[qlI1->sgfn],cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn],cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn],cg->fgfs[dquR2->sgfn],cg->fgfs[dquI1->sgfn],cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn],cg->fgfs[bdquR2->sgfn],cg->fgfs[bdquI1->sgfn],cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn],cg->fgfs[dgI->sgfn],cg->fgfs[bdgR->sgfn],cg->fgfs[bdgI->sgfn]); -*/ - f_get_null_boundary_c(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[beta->sgfn],cg->fgfs[RQ->sgfn],cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn],cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn],cg->fgfs[RTheta->sgfn],cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn],cg->fgfs[quR2->sgfn],cg->fgfs[quI1->sgfn],cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn],cg->fgfs[qlR2->sgfn],cg->fgfs[qlI1->sgfn],cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn],cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn],cg->fgfs[dquR2->sgfn],cg->fgfs[dquI1->sgfn],cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn],cg->fgfs[bdquR2->sgfn],cg->fgfs[bdquI1->sgfn],cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn],cg->fgfs[dgI->sgfn],cg->fgfs[bdgR->sgfn],cg->fgfs[bdgI->sgfn], - PhysTime,Rmin,sPp->data->sst); - - } - if(BP==sPp->data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } -} -#elif 0 -// For check Theta calculation with given Theta_x -void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) -{ - int ERROR = 0; - - int spin, e; - - MyList *sPp; - - // calculate K - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - if (RK_count == 0) - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - else - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - if (0) - { - int Varwt[3]; - MyList *DG_List; - DG_List = new MyList(RU); - DG_List->insert(IU); - Varwt[0] = 1; - DG_List->insert(RQ); - DG_List->insert(IQ); - Varwt[1] = 1; - DG_List->insert(RTheta); - DG_List->insert(ITheta); - Varwt[2] = 2; - - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - - // get nu, k and B - spin = 2; - e = -1; - if (RK_count == 0) - eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); - else - eth_derivs(RJ, IJ, Rnu, Inu, spin, e); - spin = 0; - e = 1; - eth_derivs(KK, FXZEO, Rk, Ik, spin, e); - eth_derivs(beta, FXZEO, RB, IB, spin, e); - - // evolve Theta - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_Theta_givenx(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, sPp->data->sst)) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_Theta_givenx(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, sPp->data->sst)) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(WTheList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(WTheList, Symmetry, WThewt); -} -#elif 0 -// For check Theta calculation -void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) -{ - int ERROR = 0; - - int spin, e; - - MyList *sPp; - - // calculate K - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - if (RK_count == 0) - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - else - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - if (0) - { - int Varwt[3]; - MyList *DG_List; - DG_List = new MyList(RU); - DG_List->insert(IU); - Varwt[0] = 1; - DG_List->insert(RQ); - DG_List->insert(IQ); - Varwt[1] = 1; - DG_List->insert(RTheta); - DG_List->insert(ITheta); - Varwt[2] = 2; - - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - - // get nu, k and B - spin = 2; - e = -1; - if (RK_count == 0) - eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); - else - eth_derivs(RJ, IJ, Rnu, Inu, spin, e); - spin = 0; - e = 1; - eth_derivs(KK, FXZEO, Rk, Ik, spin, e); - eth_derivs(beta, FXZEO, RB, IB, spin, e); - - // evolve Theta - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(WTheList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(WTheList, Symmetry, WThewt); -} -#elif 0 -// For check W and Theta calculation -void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) -{ - int ERROR = 0; - - int spin, e; - - MyList *sPp; - - // calculate K - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - if (RK_count == 0) - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - else - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[3]; - MyList *DG_List; - DG_List = new MyList(RU); - DG_List->insert(IU); - Varwt[0] = 1; - DG_List->insert(RQ); - DG_List->insert(IQ); - Varwt[1] = 1; - DG_List->insert(RTheta); - DG_List->insert(ITheta); - Varwt[2] = 2; - - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - - // get nu, k and B - spin = 2; - e = -1; - if (RK_count == 0) - eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); - else - eth_derivs(RJ, IJ, Rnu, Inu, spin, e); - spin = 0; - e = 1; - eth_derivs(KK, FXZEO, Rk, Ik, spin, e); - eth_derivs(beta, FXZEO, RB, IB, spin, e); - - // evolve W and Theta - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of W, we can deal with Theta together here - // at this stage W has been updated already - f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of W, we can deal with Theta together here - // at this stage W has been updated already - f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(WTheList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(WTheList, Symmetry, WThewt); -} -#elif 1 -// For check Q, U, W and Theta calculation -void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) -{ - int ERROR = 0; - - int spin, e; - - MyList *sPp; - - // calculate K - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - if (RK_count == 0) - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - else - { - f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[3]; - MyList *DG_List; - DG_List = new MyList(RU); - DG_List->insert(IU); - Varwt[0] = 1; - DG_List->insert(RQ); - DG_List->insert(IQ); - Varwt[1] = 1; - DG_List->insert(RTheta); - DG_List->insert(ITheta); - Varwt[2] = 2; - - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - - // get nu, k and B - spin = 2; - e = -1; - if (RK_count == 0) - eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); - else - eth_derivs(RJ, IJ, Rnu, Inu, spin, e); - spin = 0; - e = 1; - eth_derivs(KK, FXZEO, Rk, Ik, spin, e); - eth_derivs(beta, FXZEO, RB, IB, spin, e); - - // evolve Q and U - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of Q, we can deal with U together here - // at this stage Q has been updated already - f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], - cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of Q, we can deal with U together here - // at this stage Q has been updated already - f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], - cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(QUList, 0, PhysTime, dT); - Dump_Data(SynchList_pre, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(QUList, Symmetry, QUwt); - - // evolve W and Theta - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of W, we can deal with Theta together here - // at this stage W has been updated already - f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || - // since we do not need derivetive of W, we can deal with Theta together here - // at this stage W has been updated already - f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(WTheList, 0, PhysTime, dT); - Dump_Data(QUList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(WTheList, Symmetry, WThewt); -} -#endif -#endif -#if 1 -// need evolve step -// 0: real L2 norm; 1: root mean squar -#define L2m 0 -double NullShellPatch::Error_Check(double PhysTime, double dT, bool dp) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ1->sgfn], cg->fgfs[IJ1->sgfn], sPp->data->sst, Rmin, PhysTime, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - if (0) - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RJ1); - DG_List->insert(IJ1); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - - if (dp) - { - DG_List->insert(RJ0); - DG_List->insert(IJ0); - Dump_Data(DG_List, 0, PhysTime, dT); - } - DG_List->clearList(); - } - - double tvf, dtvf = 0; - int tN, dtN = 0; - int BDW = ghost_width, OBDW = overghost; - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_array_subtract(cg->shape, cg->fgfs[RJ1->sgfn], cg->fgfs[RJ0->sgfn]); -#if (L2m == 0) - f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[RJ1->sgfn], tvf, BDW, OBDW, Symmetry); -#elif (L2m == 1) - f_l2normhelper_sh_rms(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[RJ1->sgfn], tvf, BDW, OBDW, Symmetry, dtN); - dtN += dtN; -#endif - - dtvf += tvf; - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); -#if (L2m == 0) - tvf = sqrt(tvf); -#elif (L2m == 1) - MPI_Allreduce(&dtN, &tN, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - tvf = sqrt(tvf / tN); -#endif -#if 0 - { - MyList * DG_List; - DG_List=new MyList(RJ1); DG_List->insert(IJ1); - - Dump_Data(DG_List,0,0,1); - DG_List->clearList(); - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } -#endif - - return tvf; -} -#else -// only check Theta calculation, do not need Evolve step -double NullShellPatch::Error_Check(double PhysTime, double dT, bool dp) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RJ0); - DG_List->insert(IJ0); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - - HyperSlice(dT, PhysTime, 0, 0); - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RJ1->sgfn], cg->fgfs[IJ1->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RJ1); - DG_List->insert(IJ1); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - - if (dp) - { - DG_List->insert(RTheta); - DG_List->insert(ITheta); - Dump_Data(DG_List, 0, PhysTime, dT); - } - DG_List->clearList(); - } - - double tvf, dtvf = 0; - int BDW = ghost_width, OBDW = overghost; - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_array_subtract(cg->shape, cg->fgfs[RJ1->sgfn], cg->fgfs[RTheta->sgfn]); - - f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[RJ1->sgfn], tvf, BDW, OBDW, Symmetry); - dtvf += tvf; - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - tvf = sqrt(tvf); - - return tvf; -} -#endif -double NullShellPatch::EqTheta_Check(double PhysTime, double dT, bool dp) -{ - int ERROR = 0; - - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RJ0); - DG_List->insert(IJ0); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - - HyperSlice(dT, PhysTime, 0, 0); - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RTheta); - DG_List->insert(ITheta); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - - DG_List->clearList(); - } - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (f_Eq_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) - /* if(f_Eq_Theta_2(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[RJ0->sgfn],cg->fgfs[IJ0->sgfn], - cg->fgfs[RU->sgfn],cg->fgfs[IU->sgfn], - cg->fgfs[beta->sgfn], - cg->fgfs[RB->sgfn],cg->fgfs[IB->sgfn], - cg->fgfs[Rnu->sgfn],cg->fgfs[Inu->sgfn], - cg->fgfs[Rk->sgfn],cg->fgfs[Ik->sgfn], - cg->fgfs[RTheta->sgfn],cg->fgfs[ITheta->sgfn], - cg->fgfs[W->sgfn], - Rmin, - cg->fgfs[qlR1->sgfn],cg->fgfs[qlR2->sgfn],cg->fgfs[qlI1->sgfn],cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn],cg->fgfs[quR2->sgfn],cg->fgfs[quI1->sgfn],cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn],cg->fgfs[gI->sgfn],PhysTime,sPp->data->sst)) */ - { - cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(WTheList, 0, PhysTime, dT); - if (myrank == 0) - { - cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Synch(WTheList, Symmetry, WThewt); - - if (dp) - { - MyList *DG_List; - DG_List = new MyList(RTheta); - DG_List->insert(ITheta); - Dump_Data(DG_List, 0, PhysTime, dT); - DG_List->clearList(); - } - - double tvf, dtvf = 0; - int BDW = ghost_width, OBDW = overghost; - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[RTheta->sgfn], tvf, BDW, OBDW, Symmetry); - dtvf += tvf; - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - tvf = sqrt(tvf); - - return tvf; -} -void NullShellPatch::Compute_News(double PhysTime, double dT, bool dp) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -// for check -#if 0 - f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[omega0->sgfn],sPp->data->sst,Rmin,PhysTime); -#endif -#if 1 - f_drive_null_news(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); -#else - f_drive_null_news_diff(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst, PhysTime); -#endif - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RNews); - DG_List->insert(INews); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } -} -#if 1 -// evolve omega -void NullShellPatch::Check_News(double PhysTime, double dT, bool dp) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - - f_drive_null_news(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RNews); - DG_List->insert(INews); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } - // evolve omega - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - double TT = PhysTime; - - // Predictor - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(TheList, JrhsList, myrank); - if (myrank == cg->rank) - { -#if 1 - f_get_exact_omegau(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega_rhs->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); -#if 0 - f_euler_rout(cg->shape, dT,cg->fgfs[omega0->sgfn],cg->fgfs[omega_rhs->sgfn]); - PhysTime += dT; - f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[omega->sgfn],sPp->data->sst,Rmin,PhysTime); - PhysTime -= dT; - if(sPp->data->sst==0 && cg->X[0][0] < -PI/4 && cg->X[1][0] < -PI/4) - { - int hi=cg->shape[0]/2-1,hj=cg->shape[1]/2-1,hk=cg->shape[2]-1; - int hg=hi+hj*cg->shape[0]+hk*cg->shape[0]*cg->shape[1]; - cout<fgfs[omega->sgfn][hg]-1<<","<fgfs[omega0->sgfn][hg]-1<shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega_rhs->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); -#endif - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega->sgfn], cg->fgfs[omega_rhs->sgfn], - iter_count); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TT += dT / 2; - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(TheList, J1List, myrank); - if (myrank == cg->rank) - { - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, TT, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - TT, Rmin, sPp->data->sst); -#if 1 - f_get_exact_omegau(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega1->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); -#else - f_omega_rhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega1->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); -#endif - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega1->sgfn], cg->fgfs[omega_rhs->sgfn], - iter_count); - } - if (iter_count < 3) - cg->swapList(SynchList_cor, SynchList_pre, myrank); - else - { - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(omega0); - DG_List->insert(FXZEO); - Varwt[0] = 0; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } -#if 0 - { - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - while(BP) - { - Block *cg=BP->data; - cg->swapList(TheList,J1List,myrank); - if(myrank == cg->rank) - { - PhysTime += dT; - f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[omega->sgfn],sPp->data->sst,Rmin,PhysTime); - PhysTime -= dT; - if(sPp->data->sst==0 && cg->X[0][0] < -PI/4 && cg->X[1][0] < -PI/4) - { - int hi=cg->shape[0]/2-1,hj=cg->shape[1]/2-1,hk=cg->shape[2]-1; - int hg=hi+hj*cg->shape[0]+hk*cg->shape[0]*cg->shape[1]; - cout<fgfs[omega->sgfn][hg]-1<<","<fgfs[omega0->sgfn][hg]-1<data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - } -#endif - -#if 0 -// dump omega for check -{ - MyList * DG_List; - DG_List=new MyList(omega0); - Dump_Data(DG_List,"evo",PhysTime,dT); - - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[omega0->sgfn],sPp->data->sst,Rmin,TT); - } - if(BP==sPp->data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - - Dump_Data(DG_List,"exa",PhysTime,dT); - DG_List->clearList(); - - if(TT>0.5 && myrank==0) MPI_Abort(MPI_COMM_WORLD,1); -} -#endif -} -#else -// given omega -void NullShellPatch::Check_News(double PhysTime, double dT, bool dp) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); - - f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], - cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - PhysTime, Rmin, sPp->data->sst); - - f_get_exact_omega(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega0->sgfn], sPp->data->sst, Rmin, PhysTime); - - f_drive_null_news(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], - cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], - cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], - cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], - cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], - cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], - cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], - cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], - cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], - cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - { - int Varwt[1]; - MyList *DG_List; - DG_List = new MyList(RNews); - DG_List->insert(INews); - Varwt[0] = 2; - Synch(DG_List, Symmetry, Varwt); - DG_List->clearList(); - } -} -#endif -double NullShellPatch::News_Error_Check(double PhysTime, double dT, bool dp) -{ - MyList *sPp; - - double tvf, dtvf = 0; - int BDW = ghost_width, OBDW = overghost; - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[RNews->sgfn], tvf, BDW, OBDW, Symmetry); - dtvf += tvf; - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - tvf = sqrt(tvf); - - return tvf; -} + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "NullShellPatch.h" +#include "Parallel.h" +#include "fmisc.h" +#include "misc.h" +#include "shellfunctions.h" +#include "NullEvol.h" +#include "NullNews.h" +#include "initial_null.h" +#include "rungekutta4_rout.h" +#include "kodiss.h" + +#define PI M_PI + +// x x x x x o * +// * o x x x x x +// each side contribute an overlap points +// so we need half of that +#define overghost ((ghost_width + 1) / 2 + ghost_width) + +NullShellPatch::NullShellPatch(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetryi, int myranki) : myrank(myranki), Rmin(Rmini), xmin(xmini), xmax(xmaxi), PatL(0), Symmetry(Symmetryi) +{ + for (int i = 0; i < dim; i++) + { + shape[i] = shapei[i]; +// we always assume the input parameter is in cell center style +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + shape[i] = shape[i] + 1; +#endif + } + + if (myrank == 0) + { + cout << " null shell's range: r = [" << xmin * Rmin / (1 - xmin) << ":"; + if (xmax == 1) + cout << " +Infty]" << endl; + else + cout << xmax * Rmin / (1 - xmax) << "]" << endl; + cout << " x = [" << xmin << ":" << xmax << "]" << endl + << " shape: " << shape[2] << endl + << " resolution: [" << getdX(0) << "," << getdX(1) << "," << getdX(2) << "]" << endl; + } +// in order to touch infinity, we always use vertex center in r direction +// for Cell center it is some fake as following +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + { + double ht = (xmax - xmin) / shape[2]; + xmax = xmax + ht / 2; + xmin = xmin - ht / 2; + shape[2] = shape[2] + 1; + } +#endif + + double bbox[2 * dim]; + int shape_here[dim]; + bbox[2] = xmin; + bbox[5] = xmax; + shape_here[2] = shape[2]; + + switch (Symmetry) + { + case 0: + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] + 2 * overghost; + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank); + PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new zm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + case 1: + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] + 2 * overghost; + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); + shape_here[0] = shape[0] + 2 * overghost; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + shape_here[1] = (shape[1] + 1) / 2 + overghost; +#else +#ifdef Cell + shape_here[1] = shape[1] / 2 + overghost; +#else +#error Not define Vertex nor Cell +#endif +#endif + bbox[0] = -PI / 4 - overghost * getdX(0); + shape_here[1] += ghost_width; + bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = ghost_width * getdX(1); // buffer points method to deal with boundary + PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + case 2: +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + for (int i = 0; i < 2; i++) + shape_here[i] = (shape[i] + 1) / 2 + overghost; +#else +#ifdef Cell + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] / 2 + overghost; +#else +#error Not define Vertex nor Cell +#endif +#endif + shape_here[0] += ghost_width; + shape_here[1] += ghost_width; + bbox[0] = -ghost_width * getdX(0); // buffer points method to deal with boundary + bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); + PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + default: + cout << "not recognized Symmetry type" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int ngfs = 0; + FXZEO = new var("FXZEO", ngfs++, 1, 1, 1); + gx = new var("gx", ngfs++, 1, 1, 1); + gy = new var("gy", ngfs++, 1, 1, 1); + gz = new var("gz", ngfs++, 1, 1, 1); + // every thing is taken as scalar + beta = new var("beta", ngfs++, 1, 1, 1); + W = new var("W", ngfs++, 1, 1, 1); + KK = new var("KK", ngfs++, 1, 1, 1); + HKK = new var("HKK", ngfs++, 1, 1, 1); + KKx = new var("KKx", ngfs++, 1, 1, 1); + HKKx = new var("HKKx", ngfs++, 1, 1, 1); + Rnu = new var("Rnu", ngfs++, 1, 1, 1); + Inu = new var("Inu", ngfs++, 1, 1, 1); + Rk = new var("Rk", ngfs++, 1, 1, 1); + Ik = new var("Ik", ngfs++, 1, 1, 1); + RB = new var("RB", ngfs++, 1, 1, 1); + IB = new var("IB", ngfs++, 1, 1, 1); + RQ = new var("RQ", ngfs++, 1, 1, 1); + IQ = new var("IQ", ngfs++, 1, 1, 1); + RU = new var("RU", ngfs++, 1, 1, 1); + IU = new var("IU", ngfs++, 1, 1, 1); + RTheta = new var("RTheta", ngfs++, 1, 1, 1); + ITheta = new var("ITheta", ngfs++, 1, 1, 1); + RJo = new var("RJo", ngfs++, 1, 1, 1); + IJo = new var("IJo", ngfs++, 1, 1, 1); + omegao = new var("omegao", ngfs++, 1, 1, 1); + RJ0 = new var("RJ0", ngfs++, 1, 1, 1); + IJ0 = new var("IJ0", ngfs++, 1, 1, 1); + omega0 = new var("omega0", ngfs++, 1, 1, 1); + RJ = new var("RJ", ngfs++, 1, 1, 1); + IJ = new var("IJ", ngfs++, 1, 1, 1); + omega = new var("omega", ngfs++, 1, 1, 1); + RJ1 = new var("RJ1", ngfs++, 1, 1, 1); + IJ1 = new var("IJ1", ngfs++, 1, 1, 1); + omega1 = new var("omega1", ngfs++, 1, 1, 1); + RJ_rhs = new var("RJ_rhs", ngfs++, 1, 1, 1); + IJ_rhs = new var("IJ_rhs", ngfs++, 1, 1, 1); + omega_rhs = new var("omega_rhs", ngfs++, 1, 1, 1); + + quR1 = new var("quR1", ngfs++, 1, 1, 1); + quI1 = new var("quI1", ngfs++, 1, 1, 1); + quR2 = new var("quR2", ngfs++, 1, 1, 1); + quI2 = new var("quI2", ngfs++, 1, 1, 1); + qlR1 = new var("qlR1", ngfs++, 1, 1, 1); + qlI1 = new var("qlI1", ngfs++, 1, 1, 1); + qlR2 = new var("qlR2", ngfs++, 1, 1, 1); + qlI2 = new var("qlI2", ngfs++, 1, 1, 1); + gR = new var("gR", ngfs++, 1, 1, 1); + gI = new var("gI", ngfs++, 1, 1, 1); + + dquR1 = new var("dquR1", ngfs++, 1, 1, 1); + dquI1 = new var("dquI1", ngfs++, 1, 1, 1); + dquR2 = new var("dquR2", ngfs++, 1, 1, 1); + dquI2 = new var("dquI2", ngfs++, 1, 1, 1); + bdquR1 = new var("bdquR1", ngfs++, 1, 1, 1); + bdquI1 = new var("bdquI1", ngfs++, 1, 1, 1); + bdquR2 = new var("bdquR2", ngfs++, 1, 1, 1); + bdquI2 = new var("bdquI2", ngfs++, 1, 1, 1); + dgR = new var("dgR", ngfs++, 1, 1, 1); + dgI = new var("dgI", ngfs++, 1, 1, 1); + bdgR = new var("bdgR", ngfs++, 1, 1, 1); + bdgI = new var("bdgI", ngfs++, 1, 1, 1); + + RNews = new var("RNews", ngfs++, 1, 1, 1); + INews = new var("INews", ngfs++, 1, 1, 1); + + DumpList = new MyList(RJ0); + DumpList->insert(IJ0); + + betaList = new MyList(beta); + betaList->insert(beta); + betawt[0] = 0; + QUList = new MyList(RQ); + QUList->insert(IQ); + QUList->insert(RU); + QUList->insert(IU); + QUwt[0] = QUwt[1] = 1; + WTheList = new MyList(W); + WTheList->insert(W); + WTheList->insert(RTheta); + WTheList->insert(ITheta); + WThewt[0] = 0; + WThewt[1] = 2; + + TheList = new MyList(RTheta); + TheList->insert(ITheta); + + OldStateList = new MyList(RJo); + OldStateList->insert(IJo); + OldStateList->insert(omegao); + StateList = new MyList(RJ0); + StateList->insert(IJ0); + StateList->insert(omega0); + SynchList_pre = new MyList(RJ); + SynchList_pre->insert(IJ); + SynchList_pre->insert(omega); + RHSList = new MyList(RJ_rhs); + RHSList->insert(IJ_rhs); + RHSList->insert(omega_rhs); + SynchList_cor = new MyList(RJ1); + SynchList_cor->insert(IJ1); + SynchList_cor->insert(omega1); + + JrhsList = new MyList(RJ_rhs); + JrhsList->insert(IJ_rhs); + J1List = new MyList(RJ1); + J1List->insert(IJ1); + + ingfs = 0; + fngfs = ngfs; +} +NullShellPatch::~NullShellPatch() +{ + int nprocs = 1; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + for (int node = 0; node < nprocs; node++) + { + if (ss_src[node]) + destroypsuList(ss_src[node]); + if (ss_dst[node]) + destroypsuList(ss_dst[node]); + if (cs_src) + { + if (cs_src[node]) + destroypsuList(cs_src[node]); + if (cs_dst[node]) + destroypsuList(cs_dst[node]); + } + } + + delete[] ss_src; + delete[] ss_dst; + if (cs_src) + { + delete[] cs_src; + delete[] cs_dst; + } + + while (PatL) + { + ss_patch *sPp = PatL->data; + MyList *bg; + while (sPp->blb) + { + if (sPp->blb == sPp->ble) + break; + bg = (sPp->blb->next) ? sPp->blb->next : 0; + delete sPp->blb->data; + delete sPp->blb; + sPp->blb = bg; + } + if (sPp->ble) + { + delete sPp->ble->data; + delete sPp->ble; + } + sPp->blb = sPp->ble = 0; + PatL = PatL->next; + } + PatL->destroyList(); + + StateList->clearList(); + SynchList_pre->clearList(); + SynchList_cor->clearList(); + RHSList->clearList(); + OldStateList->clearList(); + DumpList->clearList(); + CheckList->clearList(); + betaList->clearList(); + QUList->clearList(); + WTheList->clearList(); + TheList->clearList(); + JrhsList->clearList(); + J1List->clearList(); + + delete FXZEO; + delete gx; + delete gy; + delete gz; + delete beta; + delete W; + delete Rnu; + delete Inu; + delete Rk; + delete Ik; + delete RB; + delete IB; + delete RQ; + delete IQ; + delete RU; + delete IU; + delete RTheta; + delete ITheta; + delete KK; + delete HKK; + delete KKx; + delete HKKx; + + delete RJo; + delete IJo; + delete omegao; + delete RJ0; + delete IJ0; + delete omega0; + delete RJ; + delete IJ; + delete omega; + delete RJ1; + delete IJ1; + delete omega1; + delete RJ_rhs; + delete IJ_rhs; + delete omega_rhs; + + delete quR1; + delete quR2; + delete quI1; + delete quI2; + delete qlR1; + delete qlR2; + delete qlI1; + delete qlI2; + delete gR; + delete gI; + delete dquR1; + delete dquR2; + delete dquI1; + delete dquI2; + delete bdquR1; + delete bdquR2; + delete bdquI1; + delete bdquI2; + delete dgR; + delete dgI; + delete bdgR; + delete bdgI; + + delete RNews; + delete INews; +} +void NullShellPatch::destroypsuList(MyList *ct) +{ + MyList *n; + while (ct) + { + n = ct->next; + if (ct->data->coef) + { + delete[] ct->data->coef; + delete[] ct->data->sind; + } + delete ct->data; + delete ct; + ct = n; + } +} +// the number of VarList = 2* the number of Varwt +void NullShellPatch::fill_symmetric_boundarybuffer(MyList *VarList, int *Varwt) +{ + MyList *varl; + int ind; + double drho = getdX(0), dsigma = getdX(1); + + if (Symmetry == 0) + return; + else + { + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + varl = VarList; + ind = 0; + while (varl) + { + f_fill_symmetric_boundarybuffer(cg->shape, cg->X[0], cg->X[1], cg->X[2], drho, dsigma, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl->next->data->sgfn], + Symmetry, Pp->data->sst, Varwt[ind]); + varl = varl->next; + varl = varl->next; + ind++; + } + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +} +MyList *NullShellPatch::compose_sh(int cpusize) +{ + if (dim != 3) + { + cout << "distrivute: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + // checkPatch(); + + MyList *BlL = 0; + + int split_size, min_size, block_size = 0; + + int min_width = 2 * Mymax(ghost_width, buffer_width); + int nxy[2], mmin_width[2], min_shape[2]; + + MyList *PLi = PatL; + for (int i = 0; i < 2; i++) + min_shape[i] = PLi->data->shape[i]; + PLi = PLi->next; + while (PLi) + { + ss_patch *PP = PLi->data; + for (int i = 0; i < 2; i++) + min_shape[i] = Mymin(min_shape[i], PP->shape[i]); + PLi = PLi->next; + } + + for (int i = 0; i < 2; i++) + mmin_width[i] = Mymin(min_width, min_shape[i]); + + min_size = mmin_width[0]; + for (int i = 1; i < 2; i++) + min_size = min_size * mmin_width[i]; + + PLi = PatL; + while (PLi) + { + ss_patch *PP = PLi->data; + // PP->checkPatch(true); + int bs = PP->shape[0]; + for (int i = 1; i < 2; i++) + bs = bs * PP->shape[i]; + block_size = block_size + bs; + PLi = PLi->next; + } + split_size = Mymax(min_size, block_size / cpusize); + split_size = Mymax(1, split_size); + + int n_rank = 0; + PLi = PatL; + int reacpu = 0; + while (PLi) + { + ss_patch *PP = PLi->data; + + reacpu += Parallel::partition2(nxy, split_size, mmin_width, cpusize, PP->shape); // r direction can not be splitted!! It's ode! + + Block *ng; + int shape_here[3], ibbox_here[2 * 2]; + double bbox_here[2 * 3], dd; + + // ibbox : 0,...N-1 + for (int i = 0; i < nxy[0]; i++) + for (int j = 0; j < nxy[1]; j++) + { + ibbox_here[0] = (PP->shape[0] * i) / nxy[0]; + ibbox_here[2] = (PP->shape[0] * (i + 1)) / nxy[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxy[1]; + ibbox_here[3] = (PP->shape[1] * (j + 1)) / nxy[1] - 1; + + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[2] = Mymin(PP->shape[0] - 1, ibbox_here[2] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[1] - 1, ibbox_here[3] + ghost_width); + + shape_here[0] = ibbox_here[2] - ibbox_here[0] + 1; + shape_here[1] = ibbox_here[3] - ibbox_here[1] + 1; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[2] * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[3] * dd; +#else +#ifdef Cell + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[2] + 1) * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[3] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + shape_here[2] = PP->shape[2]; + bbox_here[2] = PP->bbox[2]; + bbox_here[5] = PP->bbox[5]; + ng = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs, 0); // delete through KillBlocks + // ng->checkBlock(); + if (n_rank == cpusize) + n_rank = 0; + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks + + // set PP->blb + if (i == 0 && j == 0) + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; + PP->blb = Bp; + } + } + // set PP->ble + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; + PP->ble = Bp; + } + PLi = PLi->next; + } + if (reacpu < cpusize * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "NullShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << cpusize << " cpus run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} +int NullShellPatch::getdumydimension(int acsst, int posst) // -1 means no dumy dimension +{ + int dms; + if (acsst == -1 || posst == -1) + return -1; + switch (acsst) + { + case 0: + case 1: + switch (posst) + { + case 0: + case 1: + cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + case 2: + case 3: + return 0; + case 4: + case 5: + return 1; + default: + cout << "error in NullShellPatch::getdumydimension: posst = " << posst << endl; + return -1; + } + case 2: + case 3: + switch (posst) + { + case 0: + case 1: + return 1; + case 2: + case 3: + cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + case 4: + case 5: + return 0; + default: + cout << "error in NullShellPatch::getdumydimension: posst = " << posst << endl; + return -1; + } + case 4: + case 5: + switch (posst) + { + case 0: + case 1: + return 1; + case 2: + case 3: + return 0; + case 4: + case 5: + cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + default: + cout << "error in NullShellPatch::getdumydimension: posst = " << posst << endl; + return -1; + } + default: + cout << "error in NullShellPatch::getdumydimension: acsst = " << acsst << endl; + return -1; + } +} +void NullShellPatch::Setup_dyad() +{ + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_setup_dyad(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + cg->fgfs[gx->sgfn], cg->fgfs[gy->sgfn], cg->fgfs[gz->sgfn], + Pp->data->sst, Rmin); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +} +void NullShellPatch::Setup_Initial_Data(bool checkrun, double PhysTime) +{ + if (checkrun) + { + } + else + { + double one = 1.0; + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], Pp->data->sst, Rmin, PhysTime, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + // f_get_initial_null(cg->shape,cg->X[0],cg->X[1],cg->X[2], + // cg->fgfs[RJ0->sgfn],cg->fgfs[IJ0->sgfn],Pp->data->sst,Rmin); + // f_set_value(cg->shape,cg->fgfs[omega0->sgfn],one); + f_get_exact_omega(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega0->sgfn], Pp->data->sst, Rmin, PhysTime); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + int Varwt[1]; + MyList *DG_List; +#if 0 + eth_derivs(RJ0,IJ0,RJ1,IJ1,0,1); + Varwt[0]=1; + DG_List=new MyList(RJ1); DG_List->insert(IJ1); + Synch(DG_List,Symmetry,Varwt); + eth_derivs(RJ1,IJ1,RJ0,IJ0,1,1); + DG_List->clearList(); // after this DG_List = 0 +#elif 0 + eth_dderivs(RJ1, IJ1, RJ0, IJ0, 0, 1, 1); +#endif + DG_List = new MyList(RJ0); + DG_List->insert(IJ0); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + + Dump_Data(DG_List, 0, 0, 1); + DG_List->clearList(); + } +} +void NullShellPatch::eth_derivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e) +{ + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_eth_derivs(cg->shape, cg->X[0], cg->X[1], cg->fgfs[Rv->sgfn], cg->fgfs[Iv->sgfn], + cg->fgfs[ethRv->sgfn], cg->fgfs[ethIv->sgfn], s, e, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(ethRv); + DG_List->insert(ethIv); + Varwt[0] = s + e; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); +} +void NullShellPatch::eth_dderivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e1, int e2) +{ + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_eth_dderivs(cg->shape, cg->X[0], cg->X[1], cg->fgfs[Rv->sgfn], cg->fgfs[Iv->sgfn], + cg->fgfs[ethRv->sgfn], cg->fgfs[ethIv->sgfn], s, e1, e2, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(ethRv); + DG_List->insert(ethIv); + Varwt[0] = s + e1 + e2; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); +} +// lz is x instead of r +void NullShellPatch::getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) +{ + double r; + r = sqrt(x * x + y * y + z * z); + lz = r / (r + Rmin); + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "NullShellPatch::getlocalpox should not come here, something wrong" << endl; + } +} +// lz is x instead of r +// using fake global coordinates to get local coordinate +void NullShellPatch::getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) +{ + double r; + r = sqrt(x * x + y * y + z * z); + lz = r; + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "NullShellPatch::getlocalpox should not come here, something wrong" << endl; + } +} +// lz is x instead of r +// specially for usage from shell to shell +void NullShellPatch::getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz) +{ + // fake global coordinate + double r = 1, x, y, z; + switch (isst) + { + case 0: + x = tan(ix); + y = tan(iy); + z = r / sqrt(1 + x * x + y * y); + x = z * x; + y = z * y; + break; + case 1: + x = tan(ix); + y = tan(iy); + z = -r / sqrt(1 + x * x + y * y); + x = z * x; + y = z * y; + break; + case 2: + y = tan(ix); + z = tan(iy); + x = r / sqrt(1 + z * z + y * y); + y = x * y; + z = x * z; + break; + case 3: + y = tan(ix); + z = tan(iy); + x = -r / sqrt(1 + z * z + y * y); + y = x * y; + z = x * z; + break; + case 4: + x = tan(ix); + z = tan(iy); + y = r / sqrt(1 + x * x + z * z); + x = y * x; + z = y * z; + break; + case 5: + x = tan(ix); + z = tan(iy); + y = -r / sqrt(1 + x * x + z * z); + x = y * x; + z = y * z; + break; + } + + // map with fake global coordinate + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "NullShellPatch::getlocalpox should not come here, something wrong" << endl; + } + + lz = iz; + + // if(lx != lx) cout< NullShellPatch::get_swtf(double *pox, int tsst, int ssst) +{ + double rn = pox[0], sn = pox[1], ro, so; + double tcn, tsn, tco, tso; + tcn = sqrt((1 - sin(rn) * sin(sn)) / 2); + tsn = sqrt((1 + sin(rn) * sin(sn)) / 2); + // upper a + complex qan[2]; + qan[0] = complex(tsn, tcn); + qan[1] = complex(tsn, -tcn); + qan[0] = 2.0 * tcn * tsn / cos(sn) * qan[0]; + qan[1] = 2.0 * tcn * tsn / cos(rn) * qan[1]; + if (tsst == 1 || tsst == 3 || tsst == 4) + { + qan[0] = conj(qan[0]); + qan[1] = conj(qan[1]); + } + + complex qao[2]; + complex gont; + + double J[2][2]; + double cosro, sinro, cosso, sinso; + if (tsst == 0 || tsst == 1) // z + { + if (ssst == 2 || ssst == 3) // x + { + ro = atan(tan(sn) / tan(rn)); + so = atan(1 / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + // upper a + qao[1] = complex(tso, -tco); + qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[1] = conj(qao[1]); + } + gont = -qan[0] / qao[1]; + } + else if (ssst == 4 || ssst == 5) // y + { + ro = atan(tan(rn) / tan(sn)); + so = atan(1 / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + // upper a + qao[1] = complex(tso, -tco); + qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[1] = conj(qao[1]); + } + gont = -qan[1] / qao[1]; + } + else + cout << "Error in NullShellPatch::get_swtf 1" << endl; + } + else if (tsst == 2 || tsst == 3) + { + if (ssst == 0 || ssst == 1) + { + ro = atan(1 / tan(sn)); + so = atan(tan(rn) / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + // upper a + qao[0] = complex(tso, tco); + qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[0] = conj(qao[0]); + } + gont = -qan[1] / qao[0]; + } + else if (ssst == 4 || ssst == 5) + { + ro = atan(1 / tan(rn)); + so = atan(tan(sn) / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + // upper a + qao[0] = complex(tso, tco); + qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[0] = conj(qao[0]); + } + gont = -qan[0] / qao[0]; + } + else + cout << "Error in NullShellPatch::get_swtf 2" << endl; + } + else if (tsst == 4 || tsst == 5) + { + if (ssst == 0 || ssst == 1) + { + ro = atan(tan(rn) / tan(sn)); + so = atan(1 / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + // upper a + qao[1] = complex(tso, -tco); + qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[1] = conj(qao[1]); + } + gont = -qan[1] / qao[1]; + } + else if (ssst == 2 || ssst == 3) + { + ro = atan(1 / tan(rn)); + so = atan(tan(sn) / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + // upper a + qao[0] = complex(tso, tco); + qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[0] = conj(qao[0]); + } + gont = -qan[0] / qao[0]; + } + else + cout << "Error in NullShellPatch::get_swtf 3" << endl; + } + + return gont; +} +#else +// #define DEBUG +complex NullShellPatch::get_swtf(double *pox, int tsst, int ssst) +{ + double rn = pox[0], sn = pox[1], ro, so; + double tcn, tsn, tco, tso; + tcn = sqrt((1 - sin(rn) * sin(sn)) / 2); + tsn = sqrt((1 + sin(rn) * sin(sn)) / 2); +#ifdef DEBUG + // upper a + complex qan[2]; + qan[0] = complex(tsn, tcn); + qan[1] = complex(tsn, -tcn); + qan[0] = 2.0 * tcn * tsn / cos(sn) * qan[0]; + qan[1] = 2.0 * tcn * tsn / cos(rn) * qan[1]; + if (tsst == 1 || tsst == 3 || tsst == 4) + { + qan[0] = conj(qan[0]); + qan[1] = conj(qan[1]); + } +#endif + // lower bar a + complex lan[2]; + lan[0] = complex(tcn, -tsn); + lan[1] = complex(tcn, tsn); + lan[0] = cos(sn) / 4.0 / tcn / tcn / tsn / tsn * lan[0]; + lan[1] = cos(rn) / 4.0 / tcn / tcn / tsn / tsn * lan[1]; + + if (tsst == 1 || tsst == 3 || tsst == 4) + { + lan[0] = conj(lan[0]); + lan[1] = conj(lan[1]); + } + + complex gont = complex(2, 0); + + double J[2][2]; + double cosro, sinro, cosso, sinso; + if (tsst == 0 || tsst == 1) // z + { + if (ssst == 2 || ssst == 3) // x + { + ro = atan(tan(sn) / tan(rn)); + so = atan(1 / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = 0; + J[0][1] = -1; + J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[1][1] = -cosro * sinro / J[1][0]; + J[1][0] = cosso * sinso / J[1][0]; + } + else if (ssst == 4 || ssst == 5) // y + { + ro = atan(tan(rn) / tan(sn)); + so = atan(1 / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[0][1] = -cosro * sinro / J[0][0]; + J[0][0] = cosso * sinso / J[0][0]; + J[1][0] = 0; + J[1][1] = -1; + } + else + cout << "Error in NullShellPatch::get_swtf 1" << endl; + } + else if (tsst == 2 || tsst == 3) + { + if (ssst == 0 || ssst == 1) + { + ro = atan(1 / tan(sn)); + so = atan(tan(rn) / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[0][1] = cosro * sinro / J[0][0]; + J[0][0] = -cosso * sinso / J[0][0]; + J[1][0] = -1; + J[1][1] = 0; + } + else if (ssst == 4 || ssst == 5) + { + ro = atan(1 / tan(rn)); + so = atan(tan(sn) / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = -1; + J[0][1] = 0; + J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[1][1] = cosro * sinro / J[1][0]; + J[1][0] = -cosso * sinso / J[1][0]; + } + else + cout << "Error in NullShellPatch::get_swtf 2" << endl; + } + else if (tsst == 4 || tsst == 5) + { + if (ssst == 0 || ssst == 1) + { + ro = atan(tan(rn) / tan(sn)); + so = atan(1 / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[0][1] = -cosro * sinro / J[0][0]; + J[0][0] = cosso * sinso / J[0][0]; + J[1][0] = 0; + J[1][1] = -1; + } + else if (ssst == 2 || ssst == 3) + { + ro = atan(1 / tan(rn)); + so = atan(tan(sn) / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = -1; + J[0][1] = 0; + J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[1][1] = cosro * sinro / J[1][0]; + J[1][0] = -cosso * sinso / J[1][0]; + } + else + cout << "Error in NullShellPatch::get_swtf 3" << endl; + } + tco = sqrt((1 - sin(ro) * sin(so)) / 2); + tso = sqrt((1 + sin(ro) * sin(so)) / 2); + + complex qao[2]; + // upper a + qao[0] = complex(tso, tco); + qao[1] = complex(tso, -tco); + qao[0] = 2.0 * tco * tso / cos(so) * qao[0]; + qao[1] = 2.0 * tco * tso / cos(ro) * qao[1]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + qao[0] = conj(qao[0]); + qao[1] = conj(qao[1]); + } + + gont /= J[0][0] * lan[0] * qao[0] + J[0][1] * lan[0] * qao[1] + J[1][0] * lan[1] * qao[0] + J[1][1] * lan[1] * qao[1]; + +#ifdef DEBUG + + complex lao[2]; + // lower bar a + lao[0] = complex(tco, -tso); + lao[1] = complex(tco, tso); + lao[0] = cos(so) / 4.0 / tco / tco / tso / tso * lao[0]; + lao[1] = cos(ro) / 4.0 / tco / tco / tso / tso * lao[1]; + if (ssst == 1 || ssst == 3 || ssst == 4) + { + lao[0] = conj(lao[0]); + lao[1] = conj(lao[1]); + } + + static bool f1 = true, f2 = true, f3 = true, f4 = true; + static bool f5 = true, f6 = true, f7 = true, f8 = true; + static bool f9 = true, f10 = true, f11 = true, f12 = true; + double hn11, hn12, hn22; + double ho11, ho12, ho22; + if (f1 && tsst == 0 && ssst == 2) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "x+ -> z+; g -> x+; g -> z+" << endl; + double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f1 = false; + } + else if (f2 && tsst == 0 && ssst == 3) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "x- -> z+; g -> x-; g -> z+" << endl; + double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f2 = false; + } + else if (f3 && tsst == 0 && ssst == 4) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "y+ -> z+; g -> y+; g -> z+" << endl; + double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f3 = false; + } + else if (f4 && tsst == 0 && ssst == 5) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "y- -> z+; g -> y-; g -> z+" << endl; + double the = atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f4 = false; + } + else if (f5 && tsst == 1 && ssst == 2) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "x+ -> z-; g -> x+; g -> z-" << endl; + double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f5 = false; + } + else if (f6 && tsst == 1 && ssst == 3) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "x- -> z-; g -> x-; g -> z-" << endl; + double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f6 = false; + } + else if (f7 && tsst == 1 && ssst == 4) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "y+ -> z-; g -> y+; g -> z-" << endl; + double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f7 = false; + } + else if (f8 && tsst == 1 && ssst == 5) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "y- -> z-; g -> y-; g -> z-" << endl; + double the = PI - atan(sqrt(tan(rn) * tan(rn) + tan(sn) * tan(sn))), phi = atan2(tan(sn), tan(rn)); + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(cos(phi), sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(sin(phi), -cos(phi) * cos(the)) / (sin(phi) * sin(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f8 = false; + } + else if (f9 && tsst == 2 && ssst == 0) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << "z+ -> x+; g -> z+; g -> x+" << endl; + double the = atan(sqrt(tan(rn) * tan(rn) + 1) / tan(sn)), phi = rn; + if (the < 0) + the = PI + the; + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << "," + << complex(0, -1) / sin(the) / (J[0][0] * qao[0] + J[0][1] * qao[1]) << "," + << complex(0, -1) / sin(the) / qan[0] + << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << "," + << complex(-cos(phi), -sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / (J[1][0] * qao[0] + J[1][1] * qao[1]) << "," + << complex(-cos(phi), -sin(phi) * cos(the)) / (cos(phi) * cos(phi) * sin(the) * sin(the) + cos(the) * cos(the)) / qan[1] + << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f9 = false; + } + else if (f10 && tsst == 2 && ssst == 1) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f10 = false; + } + else if (f11 && tsst == 2 && ssst == 4) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f11 = false; + } + else if (f12 && tsst == 2 && ssst == 5) + { + cout << "tsst = " << tsst << ", ssst = " << ssst << endl; + cout << tan(rn) << "," << tan(sn) << "," << lan[0] * qan[0] + lan[1] * qan[1] << endl; + cout << tan(ro) << "," << tan(so) << "," << lao[0] * qao[0] + lao[1] * qao[1] << endl; + cout << (J[0][0] * qao[0] + J[0][1] * qao[1]) / qan[0] << endl; + cout << (J[1][0] * qao[0] + J[1][1] * qao[1]) / qan[1] << endl; + ho11 = pow(1 - sin(ro) * sin(ro) * sin(so) * sin(so), -2); + ho12 = -0.25 * sin(2 * ro) * sin(2 * so) * ho11; + ho22 = cos(ro) * cos(ro) * ho11; + ho11 = cos(so) * cos(so) * ho11; + hn11 = pow(1 - sin(rn) * sin(rn) * sin(sn) * sin(sn), -2); + hn12 = -0.25 * sin(2 * rn) * sin(2 * sn) * hn11; + hn22 = cos(rn) * cos(rn) * hn11; + hn11 = cos(sn) * cos(sn) * hn11; + cout << ho11 << "," << ho12 << "," << ho22 << endl; + cout << hn11 * J[0][0] * J[0][0] + hn12 * J[0][0] * J[1][0] + hn12 * J[1][0] * J[0][0] + hn22 * J[1][0] * J[1][0] << "," + << hn11 * J[0][0] * J[0][1] + hn12 * J[0][0] * J[1][1] + hn12 * J[1][0] * J[0][1] + hn22 * J[1][0] * J[1][1] << "," + << hn11 * J[0][1] * J[0][1] + hn12 * J[0][1] * J[1][1] + hn12 * J[1][1] * J[0][1] + hn22 * J[1][1] * J[1][1] << endl; + cout << "swtf = " << gont << endl; + f12 = false; + } + +#endif + + return gont; +} +#endif +// for check +// used by _dst construction, so these x,y,z must coinside with grid point +// we have considered ghost points now +void NullShellPatch::prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], + MyList *Ppi, double CDH[dim], MyList *pss) +{ + int n_dst = 0; + MyList *sPp = sPpi; + MyList *Pp = Ppi; + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz, lsst; + + if (pss->data->tsst >= 0) + { + getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, + lx, ly, lz); + if (lx != lx) + getlocalpoxsst_ss(pss->data->ssst, pss->data->lpox[0], pss->data->lpox[1], pss->data->lpox[2], + pss->data->tsst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == pss->data->tsst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + { + for (int j = 0; j < dim; j++) + { + llb[j] = Bg->bbox[j]; + uub[j] = Bg->bbox[j + dim]; + } + + if (lx > llb[0] - 0.1 * DH[0] && lx < uub[0] + 0.1 * DH[0] && + ly > llb[1] - 0.1 * DH[1] && ly < uub[1] + 0.1 * DH[1] && + lz > llb[2] - 0.1 * DH[2] && lz < uub[2] + 0.1 * DH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = 0; + for (int i = 0; i < dim; i++) + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = pss->data->ssst; + ps->data->tsst = sPp->data->sst; + ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); + ps->data->Bg = Bg; + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->swtf = get_swtf(ps->data->lpox, ps->data->tsst, ps->data->ssst); + if (psul) + psul->catList(ps); + else + psul = ps; + n_dst++; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + } + else + { + if (pss->data->tsst != -1) + cout << "somthing is wrong in NullShellPatch::prolongpointstru" << endl; + lx = pss->data->gpox[0]; + ly = pss->data->gpox[1]; + lz = pss->data->gpox[2]; + while (Pp) + { + Bgl = Pp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + { + for (int j = 0; j < dim; j++) + { + llb[j] = Bg->bbox[j]; + uub[j] = Bg->bbox[j + dim]; + } + + if (lx > llb[0] - 0.1 * CDH[0] && lx < uub[0] + 0.1 * CDH[0] && + ly > llb[1] - 0.1 * CDH[1] && ly < uub[1] + 0.1 * CDH[1] && + lz > llb[2] - 0.1 * CDH[2] && lz < uub[2] + 0.1 * CDH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = 0; + for (int i = 0; i < dim; i++) + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = pss->data->ssst; + ps->data->tsst = -1; + ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); + ps->data->Bg = Bg; + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->swtf = 1; + if (psul) + psul->catList(ps); + else + psul = ps; + n_dst++; + } + } + if (Bgl == Pp->data->ble) + break; + Bgl = Bgl->next; + } + Pp = Pp->next; + } + } + // if n_dst > 0, that's because of ghost_points then prolong source list + if (n_dst == 0) + { + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "NullShellPatch::prolongpointstru fail to find target Block for pointstru:" << endl; + check_pointstrul(pss, true); + if (Pp == Ppi) + { + getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, + lx, ly, lz); + if (myrank == 0) + cout << "sst = " << pss->data->tsst << ", lx,ly,lz = " << lx << "," << ly << "," << lz << endl; + checkBlock(pss->data->tsst); + } + else + { + Pp = Ppi; + while (Pp) + { + Pp->data->checkBlock(); + Pp = Pp->next; + } + } + if (myrank == 0) + MPI_Abort(MPI_COMM_WORLD, 1); + } + else + { + MyList *ts = 0; + for (int i = 1; i < n_dst; i++) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = (i == n_dst - 1) ? pss->next : 0; + for (int i = 0; i < dim; i++) + { + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[i] = pss->data->lpox[i]; + } + ps->data->ssst = pss->data->ssst; + ps->data->tsst = pss->data->tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->Bg = pss->data->Bg; + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->swtf = pss->data->swtf; + if (ts) + ts->catList(ps); + else + ts = ps; + } + if (ts) + pss->next = ts; + } +} +// used by _src construction, so these x,y,z do not coinside with grid point +bool NullShellPatch::prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in) +{ + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz; + + if (ssyn) + { + int sst; + getlocalpox(x, y, z, sst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == sst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < 2; j++) + { + if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) + llb[j] = -PI / 4; + else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * DH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) + uub[j] = PI / 4; + else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; + } + if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) + llb[2] = Bg->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; +#else +#ifdef Cell + else + llb[2] = Bg->bbox[2] + ghost_width * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) + uub[2] = Bg->bbox[dim + 2]; + else + uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; + if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && + ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && + lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| + // ^ + // so for ^ point may miss for vertext center, so we use 0.0001 + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = x; + ps->data->gpox[1] = y; + ps->data->gpox[2] = z; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = sPp->data->sst; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->swtf = 1; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + } + else + { + while (Pp) + { + Bgl = Pp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < dim; j++) + { + if (feq(Bg->bbox[j], Pp->data->bbox[j], CDH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * CDH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * CDH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], Pp->data->bbox[dim + j], CDH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * CDH[j]; + } + if (x > llb[0] - 0.0001 * CDH[0] && x < uub[0] + 0.0001 * CDH[0] && + y > llb[1] - 0.0001 * CDH[1] && y < uub[1] + 0.0001 * CDH[1] && + z > llb[2] - 0.0001 * CDH[2] && z < uub[2] + 0.0001 * CDH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = x; + ps->data->gpox[1] = y; + ps->data->gpox[2] = z; + ps->data->lpox[0] = x; + ps->data->lpox[1] = y; + ps->data->lpox[2] = z; + ps->data->ssst = -1; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->swtf = 1; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == Pp->data->ble) + break; + Bgl = Bgl->next; + } + Pp = Pp->next; + } + } + + return false; +} +// used by _src construction, so these x,y,z do not coinside with grid point +// specially used from shell to shell +bool NullShellPatch::prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in) +{ + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz; + + int sst; + getlocalpox_ss(tsst, x, y, z, sst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == sst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < 2; j++) + { + if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) + llb[j] = -PI / 4; + else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * DH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) + uub[j] = PI / 4; + else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; + } + if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) + llb[2] = Bg->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; +#else +#ifdef Cell + else + llb[2] = Bg->bbox[2] + ghost_width * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) + uub[2] = Bg->bbox[dim + 2]; + else + uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; + if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && + ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && + lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| + // ^ + // so for ^ point may miss for vertext center, so we use 0.0001 + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = 0; // global coordinate is not valid for r=infinity + ps->data->gpox[1] = 0; + ps->data->gpox[2] = 0; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = sPp->data->sst; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->swtf = 1; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + + return false; +} +// setup interpatch interpolation stuffs +void NullShellPatch::setupintintstuff(int cpusize, MyList *CPatL, int Symmetry) +{ + const int hCS_width = 0; // do not input data from null shell to box + const int hSC_width = 1; // do input data from box to null shell + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "NullShellPatch::setupintintstuff begines..." << endl; + + ss_src = new MyList *[cpusize]; + ss_dst = new MyList *[cpusize]; + + if (!CPatL) // if characteristic evolve alone + { + cs_src = 0; + cs_dst = 0; + } + else + { + cs_src = new MyList *[cpusize]; + cs_dst = new MyList *[cpusize]; + } + + MyList *ps, *ts; + MyList *sPp; + MyList *Bgl; + MyList *Pp; + Block *Bg; + double CDH[dim], DH[dim], llb[dim], uub[dim]; + double x, y, z; + + for (int i = 0; i < dim; i++) + { + if (CPatL) + CDH[i] = CPatL->data->getdX(i); + DH[i] = getdX(i); + } + + for (int i = 0; i < cpusize; i++) + { + ss_src[i] = 0; + ss_dst[i] = 0; + if (CPatL) + { + cs_src[i] = 0; + cs_dst[i] = 0; + } + } + + sPp = PatL; + while (sPp) + { + for (int iz = 0; iz < sPp->data->shape[2]; iz++) + for (int is = 0; is < sPp->data->shape[1]; is++) + for (int ir = 0; ir < sPp->data->shape[0]; ir++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = sPp->data->bbox[0] + ir * DH[0]; + y = sPp->data->bbox[1] + is * DH[1]; + z = sPp->data->bbox[2] + iz * DH[2]; +#else +#ifdef Cell + x = sPp->data->bbox[0] + (ir + 0.5) * DH[0]; + y = sPp->data->bbox[1] + (is + 0.5) * DH[1]; + z = sPp->data->bbox[2] + (iz + 0.5) * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (CPatL && z < sPp->data->bbox[2] + (hSC_width + 0.0001) * DH[2]) + { + double gx, gy, gz; + getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); + bool flag = false; + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(cs_src[i], false, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); + if (flag) + break; + } + if (!flag) + { + CPatL->data->checkBlock(); + if (myrank == 0) + { + cout << "ShellPatch::prolongpointstru fail to find cardisian source point for" << endl; + cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; + cout << "x,y,z = " << gx << "," << gy << "," << gz << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + if (x < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[0] || x > PI / 4 + (overghost - ghost_width - 0.0001) * DH[0] || + y < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[1] || y > PI / 4 + (overghost - ghost_width - 0.0001) * DH[1]) + { + double gx, gy, gz; + if (z < 1 - 0.0001 * DH[2]) + getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); + bool flag = true; + if (flag) + { + flag = false; + for (int i = 0; i < cpusize; i++) + { + if (z < 1 - 0.0001 * DH[2]) + flag = prolongpointstru(ss_src[i], true, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); + else + flag = prolongpointstru_ss(ss_src[i], sPp->data->sst, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i); + if (flag) + break; + } + if (!flag) + { + if (myrank == 0) + { + // if you used Vertex grid please note x=1, try 0.999999 instead + cout << "NullShellPatch::prolongpointstru fail to find shell source point for" << endl; + cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + } + sPp = sPp->next; + } + if (myrank == 0) + cout << "NullShellPatch::setupintintstuff ss_src completes" << endl; + + Pp = CPatL; + while (Pp) + { + double llb[dim], uub[dim]; + if (Symmetry > 0) + llb[2] = Pp->data->bbox[2] - 0.0001 * CDH[2]; + else + llb[2] = Pp->data->bbox[2] + (hCS_width + 0.0001) * CDH[2]; + uub[2] = Pp->data->bbox[dim + 2] - (hCS_width + 0.0001) * CDH[2]; + for (int j = 0; j < 2; j++) + { + if (Symmetry > 1) + llb[j] = Pp->data->bbox[j] - 0.0001 * CDH[j]; + else + llb[j] = Pp->data->bbox[j] + (hCS_width + 0.0001) * CDH[j]; + uub[j] = Pp->data->bbox[dim + j] - (hCS_width + 0.0001) * CDH[j]; + } + for (int iz = 0; iz < Pp->data->shape[2]; iz++) + for (int iy = 0; iy < Pp->data->shape[1]; iy++) + for (int ix = 0; ix < Pp->data->shape[0]; ix++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = Pp->data->bbox[0] + ix * CDH[0]; + y = Pp->data->bbox[1] + iy * CDH[1]; + z = Pp->data->bbox[2] + iz * CDH[2]; +#else +#ifdef Cell + x = Pp->data->bbox[0] + (ix + 0.5) * CDH[0]; + y = Pp->data->bbox[1] + (iy + 0.5) * CDH[1]; + z = Pp->data->bbox[2] + (iz + 0.5) * CDH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (x < llb[0] || x > uub[0] || + y < llb[1] || y > uub[1] || + z < llb[2] || z > uub[2]) + { + int sst; + double lx, ly, lz; + bool flag = false; + getlocalpox(x, y, z, sst, lx, ly, lz); + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(cs_src[i], true, -1, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i); + if (flag) + break; + } + if (!flag) + { + if (myrank == 0) + { + cout << "ShellPatch::prolongpointstru fail to find shell source point for" << endl; + cout << "sst = -1, x,y,z = " << x << "," << y << "," << z << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + Pp = Pp->next; + } + if (myrank == 0) + if (CPatL) + cout << "NullShellPatch::setupintintstuff cs_src completes" << endl; + else + cout << "NullShellPatch::no cs_src exists" << endl; + + for (int i = 0; i < cpusize; i++) + { + ps = ss_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(ss_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + + if (CPatL) + { + ps = cs_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(cs_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + } + } + if (myrank == 0) + cout << "NullShellPatch::setupintintstuff ss_dst and cs_dst complete" << endl; + + /* + for(int i=0;inext; + ts=ts->next; + } + } + exit(0); + */ +} +void NullShellPatch::checkPatch() +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << " belong to NullShell Patchs " << endl; + MyList *Pp = PatL; + while (Pp) + { + cout << " shape: ["; + for (int i = 0; i < dim; i++) + { + cout << Pp->data->shape[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << " range:" << "("; + for (int i = 0; i < dim; i++) + { + cout << Pp->data->bbox[i] << ":" << Pp->data->bbox[dim + i]; + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + Pp = Pp->next; + } + } +} +void NullShellPatch::checkBlock(int sst) +{ + if (myrank == 0) + { + cout << "checking shell patch sst = " << sst << endl; + MyList *Pp = PatL; + while (Pp) + { + if (Pp->data->sst == sst) + { + MyList *BP = Pp->data->blb; + while (BP) + { + BP->data->checkBlock(); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + } + Pp = Pp->next; + } + } +} +double NullShellPatch::getdX(int dir) +{ + if (dir < 0 || dir >= dim) + { + cout << "NullShellPatch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double h; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (shape[dir] == 1) + { + cout << "NullShellPatch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (dir < 2) + h = PI / 2 / (shape[dir] - 1); + else + h = (xmax - xmin) / (shape[dir] - 1); +#else +#ifdef Cell + if (dir < 2) + h = PI / 2 / shape[dir]; + else + h = (xmax - xmin) / shape[dir]; +#else +#error Not define Vertex nor Cell +#endif +#endif + return h; +} +void NullShellPatch::shellname(char *sn, int i) +{ + switch (i) + { + case 0: + sprintf(sn, "zp"); + return; + case 1: + sprintf(sn, "zm"); + return; + case 2: + sprintf(sn, "xp"); + return; + case 3: + sprintf(sn, "xm"); + return; + case 4: + sprintf(sn, "yp"); + return; + case 5: + sprintf(sn, "ym"); + return; + } +} +// Now we dump the data including overlap points +void NullShellPatch::Dump_xyz(char *tag, double time, double dT) +{ + MyList *DumpListi = 0; + DumpListi = new MyList(gx); + DumpListi->insert(gy); + DumpListi->insert(gz); + Dump_Data(DumpListi, tag, time, dT); + DumpListi->clearList(); +} +void NullShellPatch::Dump_Data(MyList *DumpListi, char *tag, double time, double dT) +{ + MyList *PP = PatL; + while (PP) + { + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); + if (!databuffer) + { + cout << "NullShellPatch::Dump_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *DumpList = DumpListi; + while (DumpList) + { + var *VP = DumpList->data; + + MyList *Bp = PP->data->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->data->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + char filename[100]; + char sn[3]; + shellname(sn, PP->data->sst); + if (tag) + sprintf(filename, "%s_LevSH-%s_%s_%05d.bin", tag, sn, VP->name, ncount); + else + sprintf(filename, "LevSH-%s_%s_%05d.bin", sn, VP->name, ncount); + + Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], + PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], + PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); + } + DumpList = DumpList->next; + } + + if (myrank == 0) + free(databuffer); + + PP = PP->next; + } +} +void NullShellPatch::intertransfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry, int *Varwt) +{ + int myrank, cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int node; + + MPI_Request *reqs; + MPI_Status *stats; + reqs = new MPI_Request[2 * cpusize]; + stats = new MPI_Status[2 * cpusize]; + int req_no = 0; + + double **send_data, **rec_data; + send_data = new double *[cpusize]; + rec_data = new double *[cpusize]; + int length; + + for (node = 0; node < cpusize; node++) + { + send_data[node] = rec_data[node] = 0; + if (node == myrank) + { + if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 1" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(rec_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt); + } + } + else + { + // send from this cpu to cpu#node + if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt)) + { + send_data[node] = new double[length]; + if (!send_data[node]) + { + cout << "out of memory when new in short transfer, place 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt); + MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + // receive from cpu#node to this cpu + if (length = interdata_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + } + } + // wait for all requests to complete + MPI_Waitall(req_no, reqs, stats); + + for (node = 0; node < cpusize; node++) + if (rec_data[node]) + interdata_packer(rec_data[node], src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt); + + for (node = 0; node < cpusize; node++) + { + if (send_data[node]) + delete[] send_data[node]; + if (rec_data[node]) + delete[] rec_data[node]; + } + + delete[] reqs; + delete[] stats; + delete[] send_data; + delete[] rec_data; +} +// PACK: prepare target data in 'data' +// UNPACK: copy target data from 'data' to corresponding numerical grids +int NullShellPatch::interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, int *Varwt) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int DIM = dim; + int ordn = 2 * ghost_width; + + if (dir != PACK && dir != UNPACK) + { + cout << "error dir " << dir << " for data_packer " << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int size_out = 0; + + if (!src || !dst) + return size_out; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + while (src && dst) + { + if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || + (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) + { + varls = VarLists; + varld = VarListd; + int vind = 0; + bool flag = true; + while (varls && varld) + { + if (data) + { + if (dir == PACK) + { + /* + f_global_interp(src->data->Bg->shape,src->data->Bg->X[0],src->data->Bg->X[1],src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn],data[size_out], + src->data->lpox[0],src->data->lpox[1],src->data->lpox[2],ordn,varls->data->SoA,Symmetry); + */ + int DIMh = (src->data->dumyd == -1) ? dim : 1; + if (src->data->coef == 0) + { + src->data->coef = new double[ordn * DIMh]; + src->data->sind = new int[dim]; + if (DIMh == 3) + { + for (int i = 0; i < DIMh; i++) + { + double dd = src->data->Bg->getdX(i); + // 0.001 instead of 0.4 makes the point locate more center + src->data->sind[i] = int((src->data->lpox[i] - src->data->Bg->X[i][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = src->data->Bg->X[i][0] + (src->data->sind[i] + j) * dd; + src->data->coef[i * ordn + j] = 1; + for (int k = 0; k < j; k++) + { + h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; + src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; + src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); + } + } + } + } + else + { + int actd = 1 - src->data->dumyd; + double dd = src->data->Bg->getdX(actd); + src->data->sind[0] = int((src->data->lpox[actd] - src->data->Bg->X[actd][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = src->data->Bg->X[actd][0] + (src->data->sind[0] + j) * dd; + src->data->coef[j] = 1; + for (int k = 0; k < j; k++) + { + h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; + src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; + src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); + } + } + src->data->sind[2] = int((src->data->lpox[2] - src->data->Bg->X[2][0]) / src->data->Bg->getdX(2) + 0.001); + if (!feq(src->data->Bg->X[2][src->data->sind[2]], src->data->lpox[2], src->data->Bg->getdX(2) / 2000)) + cout << "error in NullShellPatch::interdata_packer point = " << src->data->lpox[2] << " != grid " << src->data->Bg->X[2][src->data->sind[2]] << endl; + src->data->sind[1] = int((src->data->lpox[src->data->dumyd] - src->data->Bg->X[src->data->dumyd][0]) / + src->data->Bg->getdX(src->data->dumyd) + + 0.001); + if (!feq(src->data->Bg->X[src->data->dumyd][src->data->sind[1]], src->data->lpox[src->data->dumyd], src->data->Bg->getdX(src->data->dumyd) / 2000)) + cout << "error in NullShellPatch::interdata_packer for dumy dimension point = " + << src->data->lpox[src->data->dumyd] << " != grid " << src->data->Bg->X[src->data->dumyd][src->data->sind[1]] << endl; + } + } + // interpolate + switch (DIMh) + { + case 3: + f_global_interpind(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst); + break; + case 2: + f_global_interpind2d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst); + break; + case 1: + f_global_interpind1d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst, src->data->dumyd); + break; + default: + cout << "NullShellPatch::interdata_packer: not recognized DIM = " << DIMh << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + if (dir == UNPACK) // from target data to corresponding grid + { + if (Varwt[vind / 2] != 0) // we always assume 2 time number relation + { + if (flag) + { + complex rtp = complex(data[size_out], data[size_out + 1]); + rtp = rtp * pow(dst->data->swtf, Varwt[vind / 2]); // note we only stored the factor in dst + data[size_out] = rtp.real(); + data[size_out + 1] = rtp.imag(); + } + flag = !flag; // on-off method + } + // if(dst->data->tsst==2 && fabs(dst->data->lpox[0]+0.02617993878)<0.00001 && fabs(dst->data->lpox[2]-0.510417)<0.00001)cout<data->name<data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], + dst->data->lpox[0], dst->data->lpox[1], dst->data->lpox[2], data[size_out]); + } + } + size_out += 1; + vind += 1; + varls = varls->next; + varld = varld->next; + } + } + dst = dst->next; + src = src->next; + } + + return size_out; +} +void NullShellPatch::Synch(MyList *VarList, int Symmetry, int *Varwt) +{ + MyList *Pp = PatL; + while (Pp) + { + Pp->data->Sync(VarList, Symmetry); + Pp = Pp->next; + } + // we need this before interpolation + if (Symmetry > 0) + fill_symmetric_boundarybuffer(VarList, Varwt); + + intertransfer(ss_src, ss_dst, VarList, VarList, Symmetry, Varwt); + + // we need this here to correct conners + if (Symmetry > 0) + fill_symmetric_boundarybuffer(VarList, Varwt); +} +void NullShellPatch::check_pointstrul(MyList *pp, bool first_only) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + if (!pp) + cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; + else + cout << "checking check_pointstrul..." << endl; + while (pp) + { + if (pp->data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + if (first_only) + return; + pp = pp->next; + } + } +} +void NullShellPatch::check_pointstrul2(MyList *pp, int first_last_only) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + if (!pp) + cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; + else + cout << "checking check_pointstrul..." << endl; + while (pp) + { + if (first_last_only == 2) + { + if (pp->next == 0) + { + if (pp->data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + } + } + else + { + if (pp->data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + if (first_last_only == 1) + return; + } + pp = pp->next; + } + } +} +void NullShellPatch::matchcheck(MyList *CPatL) +{ + double cbd = CPatL->data->bbox[dim]; + for (int i = 1; i < dim; i++) + cbd = Mymin(cbd, CPatL->data->bbox[dim + i]); + cbd = cbd - xmin * Rmin / (1 - xmin); + double dr, dc; + dc = CPatL->data->getdX(0); + dr = getdX(2); + for (int i = 1; i < dim; i++) + { + dc = Mymax(dc, CPatL->data->getdX(i)); + // dr = Mymax(dr,getdX(i)); + } + + int ir, ic; + ir = int(cbd / dr); + ic = int(cbd / dc); + if (Mymin(ir, ic) < 3 * ghost_width) + { + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << "NullShell Patches insert too shallow:" << endl; + cout << "distantance between these two boundaries is " << cbd << ", spatial step is " << Mymax(dc, dr) << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +} +void NullShellPatch::Interp_Points(MyList *VarList, + int NN, double **XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[NN * num_var]; + memset(shellf, 0, sizeof(double) * NN * num_var); + + // we use weight to monitor code, later some day we can move it for optimization + int *weight; + weight = new int[NN]; + memset(weight, 0, sizeof(int) * NN); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + int sst; + getlocalpox(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); // pox[2] is x indeed + + MyList *sPp = PatL; + while (sPp->data->sst != sst) + sPp = sPp->next; + + if (myrank == 0 && ((!sPp) || pox[2] < xmin - 0.0001 * DH[2] || pox[2] > xmax + 0.0001 * DH[2])) + { + cout << "NullShellPatch::Interp_Points: point gc = ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + } + if (sPp) + { + cout << ") sst = " << sst << " lc = ("; + for (int k = 0; k < dim; k++) + { + cout << pox[k]; + if (k < dim - 1) + cout << ","; + } + } + cout << ") is out of the NullShellPatch." << endl; + cout << "xmin = " << xmin << ", xmax = " << xmax << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (!sPp) + return; + + MyList *Bp = sPp->data->blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +// +// because of getlocalpox, pox will not goes into overghost region of ss_patch +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp_ss(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry, sst); + varl = varl->next; + k++; + } + weight[j] = 1; + } + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + } + + MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + int *Weight; + Weight = new int[NN]; + MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + + for (int i = 0; i < NN; i++) + { + if (Weight[i] > 1) + { + if (myrank == 0) + cout << "WARNING: NullShellPatch::Interp_Points meets multiple weight" << endl; + for (int j = 0; j < num_var; j++) + Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; + } + else if (Weight[i] == 0 && myrank == 0) + { + cout << "ERROR: NullShellPatch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j][i]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on NullShellPatch (" << xmin << ":" << xmax << ")" << endl; + + cout << "splited domains:" << endl; + MyList *sPp = PatL; + while (sPp) + { + char sn[3]; + shellname(sn, sPp->data->sst); + cout << "ss_patch " << sn << ":" << endl; + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + delete[] shellf; + delete[] weight; + delete[] Weight; + delete[] DH; + delete[] llb; + delete[] uub; +} +void NullShellPatch::Interp_Points_2D(MyList *VarList, + int NN, double **XX, /*input fake global Cartesian coordinate*/ + double *Shellf, int Symmetry) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[NN * num_var]; + memset(shellf, 0, sizeof(double) * NN * num_var); + + // we use weight to monitor code, later some day we can move it for optimization + int *weight; + weight = new int[NN]; + memset(weight, 0, sizeof(int) * NN); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + int sst; + getlocalpox_fake(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); // pox[2] is x indeed + + int indZ = int((pox[2] - xmin) / DH[2]); + MyList *sPp = PatL; + while (sPp->data->sst != sst) + sPp = sPp->next; + + if (myrank == 0 && ((!sPp) || pox[2] < xmin - 0.0001 * DH[2] || pox[2] > xmax + 0.0001 * DH[2])) + { + cout << "NullShellPatch::Interp_Points: point gc = ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + } + if (sPp) + { + cout << ") sst = " << sst << " lc = ("; + for (int k = 0; k < dim; k++) + { + cout << pox[k]; + if (k < dim - 1) + cout << ","; + } + } + cout << ") is out of the NullShellPatch." << endl; + cout << "xmin = " << xmin << ", xmax = " << xmax << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (!sPp) + return; + + MyList *Bp = sPp->data->blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +// +// because of getlocalpox, pox will not goes into overghost region of ss_patch +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp_ss_2d(BP->shape, BP->X[0], BP->X[1], indZ, BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], + pox[0], pox[1], ordn, varl->data->SoA, Symmetry, sst); + varl = varl->next; + k++; + } + weight[j] = 1; + } + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + } + + MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + int *Weight; + Weight = new int[NN]; + MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + + for (int i = 0; i < NN; i++) + { + if (Weight[i] > 1) + { + if (myrank == 0) + cout << "WARNING: NullShellPatch::Interp_Points meets multiple weight" << endl; + for (int j = 0; j < num_var; j++) + Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; + } + else if (Weight[i] == 0 && myrank == 0) + { + cout << "ERROR: NullShellPatch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j][i]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on NullShellPatch (" << xmin << ":" << xmax << ")" << endl; + + cout << "splited domains:" << endl; + MyList *sPp = PatL; + while (sPp) + { + char sn[3]; + shellname(sn, sPp->data->sst); + cout << "ss_patch " << sn << ":" << endl; + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + delete[] shellf; + delete[] weight; + delete[] Weight; + delete[] DH; + delete[] llb; + delete[] uub; +} +void NullShellPatch::Step(double dT, double PhysTime, monitor *ErrorMonitor) +{ + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + double TT = PhysTime; + double neps = 0.05; + MyList *sPp; + + // Predictor + HyperSlice(dT, TT, ErrorMonitor, iter_count); + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + // cg->swapList(TheList,JrhsList,myrank); + if (myrank == cg->rank) + { + // rhs calculation + f_array_copy(cg->shape, cg->fgfs[RJ_rhs->sgfn], cg->fgfs[RTheta->sgfn]); + f_array_copy(cg->shape, cg->fgfs[IJ_rhs->sgfn], cg->fgfs[ITheta->sgfn]); + f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[RJ0->sgfn], cg->fgfs[RJ_rhs->sgfn], + RJ0->SoA, Symmetry, neps, sPp->data->sst); + f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[IJ0->sgfn], cg->fgfs[IJ_rhs->sgfn], + RJ0->SoA, Symmetry, neps, sPp->data->sst); + f_omega_rhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega_rhs->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[RJ0->sgfn], cg->fgfs[RJ->sgfn], cg->fgfs[RJ_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[IJ0->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[IJ_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega->sgfn], cg->fgfs[omega_rhs->sgfn], + iter_count); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + /* + { + char str[50]; + sprintf(str,"rk%d",iter_count); + Dump_Data(SynchList_pre,str,PhysTime,dT); + Dump_Data(RHSList,str,PhysTime,dT); + } + */ + // no nedd to synchronize J, because Theta has already been synchnized previously + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(omega); + DG_List->insert(FXZEO); + Varwt[0] = 0; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + + Compute_News(PhysTime, dT, false); // put here because after step J and omega are at t+dt, while other variables at t + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TT += dT / 2; + HyperSlice(dT, TT, ErrorMonitor, iter_count); + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + // cg->swapList(TheList,J1List,myrank); + if (myrank == cg->rank) + { + // rhs calculation + f_array_copy(cg->shape, cg->fgfs[RJ1->sgfn], cg->fgfs[RTheta->sgfn]); + f_array_copy(cg->shape, cg->fgfs[IJ1->sgfn], cg->fgfs[ITheta->sgfn]); + f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[RJ0->sgfn], cg->fgfs[RJ1->sgfn], + RJ0->SoA, Symmetry, neps, sPp->data->sst); + f_kodis_shor(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[IJ0->sgfn], cg->fgfs[IJ1->sgfn], + RJ0->SoA, Symmetry, neps, sPp->data->sst); + f_omega_rhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega1->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[RJ0->sgfn], cg->fgfs[RJ1->sgfn], cg->fgfs[RJ_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[IJ0->sgfn], cg->fgfs[IJ1->sgfn], cg->fgfs[IJ_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega1->sgfn], cg->fgfs[omega_rhs->sgfn], + iter_count); + } + if (iter_count < 3) + cg->swapList(SynchList_cor, SynchList_pre, myrank); + else + { + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(omega0); + DG_List->insert(FXZEO); + Varwt[0] = 0; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + + /* + { + char str[50]; + sprintf(str,"rk%d",iter_count); + Dump_Data(SynchList_cor,str,PhysTime,dT); + } + */ + } +} +void NullShellPatch::Null_Boundary(double PhysTime) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + int Varwt[3]; + MyList *DG_List; + DG_List = new MyList(RU); + DG_List->insert(IU); + Varwt[0] = 1; + DG_List->insert(RQ); + DG_List->insert(IQ); + Varwt[1] = 1; + DG_List->insert(RTheta); + DG_List->insert(ITheta); + Varwt[2] = 2; + + Synch(DG_List, Symmetry, Varwt); + // Dump_Data(DG_List,0,0,1); + DG_List->clearList(); +} +#if 1 +// real evolve +void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) +{ + int ERROR = 0; + Null_Boundary(PhysTime); + + int spin, e; + + MyList *sPp; + + // evolve beta + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + if (f_NullEvol_beta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + if (f_NullEvol_beta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(betaList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(betaList, Symmetry, betawt); + // get nu, k and B + spin = 2; + e = -1; + if (RK_count == 0) + eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); + else + eth_derivs(RJ, IJ, Rnu, Inu, spin, e); + spin = 0; + e = 1; + eth_derivs(KK, FXZEO, Rk, Ik, spin, e); + eth_derivs(beta, FXZEO, RB, IB, spin, e); + + // evolve Q and U + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of Q, we can deal with U together here + // at this stage Q has been updated already + f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], + cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of Q, we can deal with U together here + // at this stage Q has been updated already + f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], + cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(QUList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(QUList, Symmetry, QUwt); + + // evolve W and Theta + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of W, we can deal with Theta together here + // at this stage W has been updated already + f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of W, we can deal with Theta together here + // at this stage W has been updated already + f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(WTheList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(WTheList, Symmetry, WThewt); +} +#else +#if 0 +//For check, give all surface varialbes +//check J evolve only +void NullShellPatch::HyperSlice(double dT,double PhysTime,monitor *ErrorMonitor,int RK_count) +{ + int ERROR=0; + + int spin,e; + + MyList *sPp; + + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { +/* + f_get_exact_null_theta(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[RTheta->sgfn],cg->fgfs[ITheta->sgfn],sPp->data->sst,Rmin,PhysTime, + cg->fgfs[quR1->sgfn],cg->fgfs[quR2->sgfn],cg->fgfs[quI1->sgfn],cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn],cg->fgfs[qlR2->sgfn],cg->fgfs[qlI1->sgfn],cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn],cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn],cg->fgfs[dquR2->sgfn],cg->fgfs[dquI1->sgfn],cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn],cg->fgfs[bdquR2->sgfn],cg->fgfs[bdquI1->sgfn],cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn],cg->fgfs[dgI->sgfn],cg->fgfs[bdgR->sgfn],cg->fgfs[bdgI->sgfn]); +*/ + f_get_null_boundary_c(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[beta->sgfn],cg->fgfs[RQ->sgfn],cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn],cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn],cg->fgfs[RTheta->sgfn],cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn],cg->fgfs[quR2->sgfn],cg->fgfs[quI1->sgfn],cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn],cg->fgfs[qlR2->sgfn],cg->fgfs[qlI1->sgfn],cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn],cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn],cg->fgfs[dquR2->sgfn],cg->fgfs[dquI1->sgfn],cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn],cg->fgfs[bdquR2->sgfn],cg->fgfs[bdquI1->sgfn],cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn],cg->fgfs[dgI->sgfn],cg->fgfs[bdgR->sgfn],cg->fgfs[bdgI->sgfn], + PhysTime,Rmin,sPp->data->sst); + + } + if(BP==sPp->data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } +} +#elif 0 +// For check Theta calculation with given Theta_x +void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) +{ + int ERROR = 0; + + int spin, e; + + MyList *sPp; + + // calculate K + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + if (RK_count == 0) + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + else + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + if (0) + { + int Varwt[3]; + MyList *DG_List; + DG_List = new MyList(RU); + DG_List->insert(IU); + Varwt[0] = 1; + DG_List->insert(RQ); + DG_List->insert(IQ); + Varwt[1] = 1; + DG_List->insert(RTheta); + DG_List->insert(ITheta); + Varwt[2] = 2; + + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + + // get nu, k and B + spin = 2; + e = -1; + if (RK_count == 0) + eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); + else + eth_derivs(RJ, IJ, Rnu, Inu, spin, e); + spin = 0; + e = 1; + eth_derivs(KK, FXZEO, Rk, Ik, spin, e); + eth_derivs(beta, FXZEO, RB, IB, spin, e); + + // evolve Theta + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_Theta_givenx(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, sPp->data->sst)) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_Theta_givenx(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, sPp->data->sst)) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(WTheList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(WTheList, Symmetry, WThewt); +} +#elif 0 +// For check Theta calculation +void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) +{ + int ERROR = 0; + + int spin, e; + + MyList *sPp; + + // calculate K + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + if (RK_count == 0) + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + else + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + if (0) + { + int Varwt[3]; + MyList *DG_List; + DG_List = new MyList(RU); + DG_List->insert(IU); + Varwt[0] = 1; + DG_List->insert(RQ); + DG_List->insert(IQ); + Varwt[1] = 1; + DG_List->insert(RTheta); + DG_List->insert(ITheta); + Varwt[2] = 2; + + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + + // get nu, k and B + spin = 2; + e = -1; + if (RK_count == 0) + eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); + else + eth_derivs(RJ, IJ, Rnu, Inu, spin, e); + spin = 0; + e = 1; + eth_derivs(KK, FXZEO, Rk, Ik, spin, e); + eth_derivs(beta, FXZEO, RB, IB, spin, e); + + // evolve Theta + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(WTheList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(WTheList, Symmetry, WThewt); +} +#elif 0 +// For check W and Theta calculation +void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) +{ + int ERROR = 0; + + int spin, e; + + MyList *sPp; + + // calculate K + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + if (RK_count == 0) + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + else + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[3]; + MyList *DG_List; + DG_List = new MyList(RU); + DG_List->insert(IU); + Varwt[0] = 1; + DG_List->insert(RQ); + DG_List->insert(IQ); + Varwt[1] = 1; + DG_List->insert(RTheta); + DG_List->insert(ITheta); + Varwt[2] = 2; + + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + + // get nu, k and B + spin = 2; + e = -1; + if (RK_count == 0) + eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); + else + eth_derivs(RJ, IJ, Rnu, Inu, spin, e); + spin = 0; + e = 1; + eth_derivs(KK, FXZEO, Rk, Ik, spin, e); + eth_derivs(beta, FXZEO, RB, IB, spin, e); + + // evolve W and Theta + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of W, we can deal with Theta together here + // at this stage W has been updated already + f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of W, we can deal with Theta together here + // at this stage W has been updated already + f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(WTheList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(WTheList, Symmetry, WThewt); +} +#elif 1 +// For check Q, U, W and Theta calculation +void NullShellPatch::HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count) +{ + int ERROR = 0; + + int spin, e; + + MyList *sPp; + + // calculate K + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + if (RK_count == 0) + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + else + { + f_calculate_K(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn]); + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[3]; + MyList *DG_List; + DG_List = new MyList(RU); + DG_List->insert(IU); + Varwt[0] = 1; + DG_List->insert(RQ); + DG_List->insert(IQ); + Varwt[1] = 1; + DG_List->insert(RTheta); + DG_List->insert(ITheta); + Varwt[2] = 2; + + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + + // get nu, k and B + spin = 2; + e = -1; + if (RK_count == 0) + eth_derivs(RJ0, IJ0, Rnu, Inu, spin, e); + else + eth_derivs(RJ, IJ, Rnu, Inu, spin, e); + spin = 0; + e = 1; + eth_derivs(KK, FXZEO, Rk, Ik, spin, e); + eth_derivs(beta, FXZEO, RB, IB, spin, e); + + // evolve Q and U + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of Q, we can deal with U together here + // at this stage Q has been updated already + f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], + cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_Q(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of Q, we can deal with U together here + // at this stage Q has been updated already + f_NullEvol_U(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], + cg->fgfs[beta->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], Rmin)) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(QUList, 0, PhysTime, dT); + Dump_Data(SynchList_pre, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in Q and/or U on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(QUList, Symmetry, QUwt); + + // evolve W and Theta + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of W, we can deal with Theta together here + // at this stage W has been updated already + f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_W(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[beta->sgfn], cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]) || + // since we do not need derivetive of W, we can deal with Theta together here + // at this stage W has been updated already + f_NullEvol_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ->sgfn], cg->fgfs[IJ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + cg->fgfs[KK->sgfn], cg->fgfs[HKK->sgfn], cg->fgfs[KKx->sgfn], cg->fgfs[HKKx->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(WTheList, 0, PhysTime, dT); + Dump_Data(QUList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(WTheList, Symmetry, WThewt); +} +#endif +#endif +#if 1 +// need evolve step +// 0: real L2 norm; 1: root mean squar +#define L2m 0 +double NullShellPatch::Error_Check(double PhysTime, double dT, bool dp) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ1->sgfn], cg->fgfs[IJ1->sgfn], sPp->data->sst, Rmin, PhysTime, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + if (0) + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RJ1); + DG_List->insert(IJ1); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + + if (dp) + { + DG_List->insert(RJ0); + DG_List->insert(IJ0); + Dump_Data(DG_List, 0, PhysTime, dT); + } + DG_List->clearList(); + } + + double tvf, dtvf = 0; + int tN, dtN = 0; + int BDW = ghost_width, OBDW = overghost; + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_array_subtract(cg->shape, cg->fgfs[RJ1->sgfn], cg->fgfs[RJ0->sgfn]); +#if (L2m == 0) + f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[RJ1->sgfn], tvf, BDW, OBDW, Symmetry); +#elif (L2m == 1) + f_l2normhelper_sh_rms(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[RJ1->sgfn], tvf, BDW, OBDW, Symmetry, dtN); + dtN += dtN; +#endif + + dtvf += tvf; + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); +#if (L2m == 0) + tvf = sqrt(tvf); +#elif (L2m == 1) + MPI_Allreduce(&dtN, &tN, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + tvf = sqrt(tvf / tN); +#endif +#if 0 + { + MyList * DG_List; + DG_List=new MyList(RJ1); DG_List->insert(IJ1); + + Dump_Data(DG_List,0,0,1); + DG_List->clearList(); + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } +#endif + + return tvf; +} +#else +// only check Theta calculation, do not need Evolve step +double NullShellPatch::Error_Check(double PhysTime, double dT, bool dp) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RJ0); + DG_List->insert(IJ0); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + + HyperSlice(dT, PhysTime, 0, 0); + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RJ1->sgfn], cg->fgfs[IJ1->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RJ1); + DG_List->insert(IJ1); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + + if (dp) + { + DG_List->insert(RTheta); + DG_List->insert(ITheta); + Dump_Data(DG_List, 0, PhysTime, dT); + } + DG_List->clearList(); + } + + double tvf, dtvf = 0; + int BDW = ghost_width, OBDW = overghost; + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_array_subtract(cg->shape, cg->fgfs[RJ1->sgfn], cg->fgfs[RTheta->sgfn]); + + f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[RJ1->sgfn], tvf, BDW, OBDW, Symmetry); + dtvf += tvf; + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + tvf = sqrt(tvf); + + return tvf; +} +#endif +double NullShellPatch::EqTheta_Check(double PhysTime, double dT, bool dp) +{ + int ERROR = 0; + + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RJ0); + DG_List->insert(IJ0); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + + HyperSlice(dT, PhysTime, 0, 0); + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RTheta); + DG_List->insert(ITheta); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + + DG_List->clearList(); + } + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (f_Eq_Theta(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn], cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn], cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn], cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn])) + /* if(f_Eq_Theta_2(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[RJ0->sgfn],cg->fgfs[IJ0->sgfn], + cg->fgfs[RU->sgfn],cg->fgfs[IU->sgfn], + cg->fgfs[beta->sgfn], + cg->fgfs[RB->sgfn],cg->fgfs[IB->sgfn], + cg->fgfs[Rnu->sgfn],cg->fgfs[Inu->sgfn], + cg->fgfs[Rk->sgfn],cg->fgfs[Ik->sgfn], + cg->fgfs[RTheta->sgfn],cg->fgfs[ITheta->sgfn], + cg->fgfs[W->sgfn], + Rmin, + cg->fgfs[qlR1->sgfn],cg->fgfs[qlR2->sgfn],cg->fgfs[qlI1->sgfn],cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn],cg->fgfs[quR2->sgfn],cg->fgfs[quI1->sgfn],cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn],cg->fgfs[gI->sgfn],PhysTime,sPp->data->sst)) */ + { + cout << "find NaN in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(WTheList, 0, PhysTime, dT); + if (myrank == 0) + { + cout << "find NaN in W and/or Theta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Synch(WTheList, Symmetry, WThewt); + + if (dp) + { + MyList *DG_List; + DG_List = new MyList(RTheta); + DG_List->insert(ITheta); + Dump_Data(DG_List, 0, PhysTime, dT); + DG_List->clearList(); + } + + double tvf, dtvf = 0; + int BDW = ghost_width, OBDW = overghost; + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[RTheta->sgfn], tvf, BDW, OBDW, Symmetry); + dtvf += tvf; + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + tvf = sqrt(tvf); + + return tvf; +} +void NullShellPatch::Compute_News(double PhysTime, double dT, bool dp) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +// for check +#if 0 + f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[omega0->sgfn],sPp->data->sst,Rmin,PhysTime); +#endif +#if 1 + f_drive_null_news(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); +#else + f_drive_null_news_diff(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst, PhysTime); +#endif + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RNews); + DG_List->insert(INews); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } +} +#if 1 +// evolve omega +void NullShellPatch::Check_News(double PhysTime, double dT, bool dp) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + + f_drive_null_news(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RNews); + DG_List->insert(INews); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } + // evolve omega + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + double TT = PhysTime; + + // Predictor + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(TheList, JrhsList, myrank); + if (myrank == cg->rank) + { +#if 1 + f_get_exact_omegau(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega_rhs->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); +#if 0 + f_euler_rout(cg->shape, dT,cg->fgfs[omega0->sgfn],cg->fgfs[omega_rhs->sgfn]); + PhysTime += dT; + f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[omega->sgfn],sPp->data->sst,Rmin,PhysTime); + PhysTime -= dT; + if(sPp->data->sst==0 && cg->X[0][0] < -PI/4 && cg->X[1][0] < -PI/4) + { + int hi=cg->shape[0]/2-1,hj=cg->shape[1]/2-1,hk=cg->shape[2]-1; + int hg=hi+hj*cg->shape[0]+hk*cg->shape[0]*cg->shape[1]; + cout<fgfs[omega->sgfn][hg]-1<<","<fgfs[omega0->sgfn][hg]-1<shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega_rhs->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); +#endif + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega->sgfn], cg->fgfs[omega_rhs->sgfn], + iter_count); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TT += dT / 2; + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(TheList, J1List, myrank); + if (myrank == cg->rank) + { + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, TT, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + TT, Rmin, sPp->data->sst); +#if 1 + f_get_exact_omegau(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega1->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); +#else + f_omega_rhs(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], cg->fgfs[omega1->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn]); +#endif + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[omega0->sgfn], cg->fgfs[omega1->sgfn], cg->fgfs[omega_rhs->sgfn], + iter_count); + } + if (iter_count < 3) + cg->swapList(SynchList_cor, SynchList_pre, myrank); + else + { + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(omega0); + DG_List->insert(FXZEO); + Varwt[0] = 0; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } +#if 0 + { + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + while(BP) + { + Block *cg=BP->data; + cg->swapList(TheList,J1List,myrank); + if(myrank == cg->rank) + { + PhysTime += dT; + f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[omega->sgfn],sPp->data->sst,Rmin,PhysTime); + PhysTime -= dT; + if(sPp->data->sst==0 && cg->X[0][0] < -PI/4 && cg->X[1][0] < -PI/4) + { + int hi=cg->shape[0]/2-1,hj=cg->shape[1]/2-1,hk=cg->shape[2]-1; + int hg=hi+hj*cg->shape[0]+hk*cg->shape[0]*cg->shape[1]; + cout<fgfs[omega->sgfn][hg]-1<<","<fgfs[omega0->sgfn][hg]-1<data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + } +#endif + +#if 0 +// dump omega for check +{ + MyList * DG_List; + DG_List=new MyList(omega0); + Dump_Data(DG_List,"evo",PhysTime,dT); + + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + f_get_exact_omega(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[omega0->sgfn],sPp->data->sst,Rmin,TT); + } + if(BP==sPp->data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + + Dump_Data(DG_List,"exa",PhysTime,dT); + DG_List->clearList(); + + if(TT>0.5 && myrank==0) MPI_Abort(MPI_COMM_WORLD,1); +} +#endif +} +#else +// given omega +void NullShellPatch::Check_News(double PhysTime, double dT, bool dp) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_exact_null(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], sPp->data->sst, Rmin, PhysTime, + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn]); + + f_get_null_boundary_c(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[beta->sgfn], cg->fgfs[RQ->sgfn], cg->fgfs[IQ->sgfn], + cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[W->sgfn], cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + PhysTime, Rmin, sPp->data->sst); + + f_get_exact_omega(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega0->sgfn], sPp->data->sst, Rmin, PhysTime); + + f_drive_null_news(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[RJ0->sgfn], cg->fgfs[IJ0->sgfn], cg->fgfs[RU->sgfn], cg->fgfs[IU->sgfn], + cg->fgfs[RTheta->sgfn], cg->fgfs[ITheta->sgfn], + cg->fgfs[omega0->sgfn], cg->fgfs[beta->sgfn], + cg->fgfs[qlR1->sgfn], cg->fgfs[qlR2->sgfn], cg->fgfs[qlI1->sgfn], cg->fgfs[qlI2->sgfn], + cg->fgfs[quR1->sgfn], cg->fgfs[quR2->sgfn], cg->fgfs[quI1->sgfn], cg->fgfs[quI2->sgfn], + cg->fgfs[gR->sgfn], cg->fgfs[gI->sgfn], + cg->fgfs[dquR1->sgfn], cg->fgfs[dquR2->sgfn], cg->fgfs[dquI1->sgfn], cg->fgfs[dquI2->sgfn], + cg->fgfs[bdquR1->sgfn], cg->fgfs[bdquR2->sgfn], cg->fgfs[bdquI1->sgfn], cg->fgfs[bdquI2->sgfn], + cg->fgfs[dgR->sgfn], cg->fgfs[dgI->sgfn], cg->fgfs[bdgR->sgfn], cg->fgfs[bdgI->sgfn], + cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + { + int Varwt[1]; + MyList *DG_List; + DG_List = new MyList(RNews); + DG_List->insert(INews); + Varwt[0] = 2; + Synch(DG_List, Symmetry, Varwt); + DG_List->clearList(); + } +} +#endif +double NullShellPatch::News_Error_Check(double PhysTime, double dT, bool dp) +{ + MyList *sPp; + + double tvf, dtvf = 0; + int BDW = ghost_width, OBDW = overghost; + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[RNews->sgfn], tvf, BDW, OBDW, Symmetry); + dtvf += tvf; + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + tvf = sqrt(tvf); + + return tvf; +} diff --git a/AMSS_NCKU_source/NullShellPatch.h b/AMSS_NCKU_source/Null_Evolve/NullShellPatch.h similarity index 97% rename from AMSS_NCKU_source/NullShellPatch.h rename to AMSS_NCKU_source/Null_Evolve/NullShellPatch.h index 26ff030..6853211 100644 --- a/AMSS_NCKU_source/NullShellPatch.h +++ b/AMSS_NCKU_source/Null_Evolve/NullShellPatch.h @@ -1,189 +1,189 @@ - -#ifndef NULLSHELLPATCH_H -#define NULLSHELLPATCH_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#include -#endif - -#include -#include "MyList.h" -#include "Block.h" -#include "Parallel.h" -#include "ShellPatch.h" -#include "var.h" -#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width - -#if (dim != 3) -#error NullShellPatch only supports 3 dimensional stuff yet -#endif - -class xp_npatch : public ss_patch -{ -public: - xp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 2; }; -}; - -class xm_npatch : public ss_patch -{ -public: - xm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 3; }; -}; -class yp_npatch : public ss_patch -{ -public: - yp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 4; }; -}; - -class ym_npatch : public ss_patch -{ -public: - ym_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 5; }; -}; -class zp_npatch : public ss_patch -{ -public: - zp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 0; }; -}; - -class zm_npatch : public ss_patch -{ -public: - zm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 1; }; -}; - -class NullShellPatch -{ - -public: - struct pointstru - { - double gpox[dim]; // global cordinate - double lpox[dim]; // local cordinate - Block *Bg; - int ssst; //-1: cardisian, others as sst of ss_patch source sst - int tsst; //-1: cardisian, others as sst of ss_patch target sst - double *coef; - int *sind; - int dumyd; // the dimension which has common lines, only useful in interdata_packer - complex swtf; // exp(i gamma) of Eq.(26) of CQG 24 S327 - }; - - var *FXZEO; - var *gx, *gy, *gz; - // we always assume the number of VarList = 2* the number of Varwt - // so VarList must apear with pairs, either components of complex number or a fake pair - var *beta, *W; - var *Rnu, *Inu, *Rk, *Ik, *RB, *IB; - var *RQ, *IQ, *RU, *IU, *RTheta, *ITheta; - var *KK, *HKK, *KKx, *HKKx; - var *RJo, *IJo, *omegao; - var *RJ0, *IJ0, *omega0; - var *RJ, *IJ, *omega; - var *RJ1, *IJ1, *omega1; - var *RJ_rhs, *IJ_rhs, *omega_rhs; - - var *quR1, *quR2, *quI1, *quI2; - var *qlR1, *qlR2, *qlI1, *qlI2; - var *gR, *gI; - var *dquR1, *dquR2, *dquI1, *dquI2; - var *bdquR1, *bdquR2, *bdquI1, *bdquI2; - var *dgR, *dgI; - var *bdgR, *bdgI; - - var *RNews, *INews; - - MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; - MyList *OldStateList, *DumpList, *CheckList; - - MyList *betaList, *QUList, *WTheList, *TheList, *JrhsList, *J1List; - int betawt[1], QUwt[2], WThewt[2]; - - int myrank; - int shape[dim]; // for (rho, sigma, X), for rho and sigma means number of points for every pi/2 - double Rmin, xmin, xmax; - int Symmetry; - int ingfs, fngfs; - - MyList *PatL; - - MyList **ss_src, **ss_dst; - MyList **cs_src, **cs_dst; - -public: - NullShellPatch(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetry, int myranki); - - ~NullShellPatch(); - - void destroypsuList(MyList *ct); - void fill_symmetric_boundarybuffer(MyList *VarList, int *Varwt); - MyList *compose_sh(int cpusize); - int getdumydimension(int acsst, int posst); - void Setup_dyad(); - void Setup_Initial_Data(bool checkrun, double PhysTime); - void eth_derivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e); - void eth_dderivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e1, int e2); - void getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz); - void getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); - void getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); - void getlocalpoxsst_ss(int isst, double ix, double iy, double iz, int lsst, double &lx, double &ly, double &lz); - void getlocalpoxsst(double x, double y, double z, int sst, double &lx, double &ly, double &lz); - void getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz); - complex get_swtf(double *pox, int tsst, int ssst); - void prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], - MyList *Ppi, double CDH[dim], MyList *pss); - bool prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in); - bool prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in); - void setupintintstuff(int cpusize, MyList *CPatL, int Symmetry); - void checkPatch(); - void checkBlock(int sst); - double getdX(int dir); - void shellname(char *sn, int i); - void Dump_xyz(char *tag, double time, double dT); - void Dump_Data(MyList *DumpListi, char *tag, double time, double dT); - void intertransfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry, int *Varwt); - int interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, int *Varwt); - void Synch(MyList *VarList, int Symmetry, int *Varwt); - void CS_Inter(MyList *VarList, int Symmetry, int *Varwt); - void check_pointstrul(MyList *pp, bool first_only); - void check_pointstrul2(MyList *pp, int first_last_only); - void matchcheck(MyList *CPatL); - void Interp_Points(MyList *VarList, - int NN, double **XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry); - void Interp_Points_2D(MyList *VarList, - int NN, double **XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry); - void Step(double dT, double PhysTime, monitor *ErrorMonitor); - void Null_Boundary(double PhysTime); - void HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count); - double News_Error_Check(double PhysTime, double dT, bool dp); - double Error_Check(double PhysTime, double dT, bool dp); - double EqTheta_Check(double PhysTime, double dT, bool dp); - void Compute_News(double PhysTime, double dT, bool dp); - void Check_News(double PhysTime, double dT, bool dp); -}; - -#endif /* NULLSHELLPATCH_H */ + +#ifndef NULLSHELLPATCH_H +#define NULLSHELLPATCH_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#include +#include "MyList.h" +#include "Block.h" +#include "Parallel.h" +#include "ShellPatch.h" +#include "var.h" +#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width + +#if (dim != 3) +#error NullShellPatch only supports 3 dimensional stuff yet +#endif + +class xp_npatch : public ss_patch +{ +public: + xp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 2; }; +}; + +class xm_npatch : public ss_patch +{ +public: + xm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 3; }; +}; +class yp_npatch : public ss_patch +{ +public: + yp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 4; }; +}; + +class ym_npatch : public ss_patch +{ +public: + ym_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 5; }; +}; +class zp_npatch : public ss_patch +{ +public: + zp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 0; }; +}; + +class zm_npatch : public ss_patch +{ +public: + zm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 1; }; +}; + +class NullShellPatch +{ + +public: + struct pointstru + { + double gpox[dim]; // global cordinate + double lpox[dim]; // local cordinate + Block *Bg; + int ssst; //-1: cardisian, others as sst of ss_patch source sst + int tsst; //-1: cardisian, others as sst of ss_patch target sst + double *coef; + int *sind; + int dumyd; // the dimension which has common lines, only useful in interdata_packer + complex swtf; // exp(i gamma) of Eq.(26) of CQG 24 S327 + }; + + var *FXZEO; + var *gx, *gy, *gz; + // we always assume the number of VarList = 2* the number of Varwt + // so VarList must apear with pairs, either components of complex number or a fake pair + var *beta, *W; + var *Rnu, *Inu, *Rk, *Ik, *RB, *IB; + var *RQ, *IQ, *RU, *IU, *RTheta, *ITheta; + var *KK, *HKK, *KKx, *HKKx; + var *RJo, *IJo, *omegao; + var *RJ0, *IJ0, *omega0; + var *RJ, *IJ, *omega; + var *RJ1, *IJ1, *omega1; + var *RJ_rhs, *IJ_rhs, *omega_rhs; + + var *quR1, *quR2, *quI1, *quI2; + var *qlR1, *qlR2, *qlI1, *qlI2; + var *gR, *gI; + var *dquR1, *dquR2, *dquI1, *dquI2; + var *bdquR1, *bdquR2, *bdquI1, *bdquI2; + var *dgR, *dgI; + var *bdgR, *bdgI; + + var *RNews, *INews; + + MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; + MyList *OldStateList, *DumpList, *CheckList; + + MyList *betaList, *QUList, *WTheList, *TheList, *JrhsList, *J1List; + int betawt[1], QUwt[2], WThewt[2]; + + int myrank; + int shape[dim]; // for (rho, sigma, X), for rho and sigma means number of points for every pi/2 + double Rmin, xmin, xmax; + int Symmetry; + int ingfs, fngfs; + + MyList *PatL; + + MyList **ss_src, **ss_dst; + MyList **cs_src, **cs_dst; + +public: + NullShellPatch(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetry, int myranki); + + ~NullShellPatch(); + + void destroypsuList(MyList *ct); + void fill_symmetric_boundarybuffer(MyList *VarList, int *Varwt); + MyList *compose_sh(int cpusize); + int getdumydimension(int acsst, int posst); + void Setup_dyad(); + void Setup_Initial_Data(bool checkrun, double PhysTime); + void eth_derivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e); + void eth_dderivs(var *Rv, var *Iv, var *ethRv, var *ethIv, int s, int e1, int e2); + void getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz); + void getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); + void getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); + void getlocalpoxsst_ss(int isst, double ix, double iy, double iz, int lsst, double &lx, double &ly, double &lz); + void getlocalpoxsst(double x, double y, double z, int sst, double &lx, double &ly, double &lz); + void getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz); + complex get_swtf(double *pox, int tsst, int ssst); + void prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], + MyList *Ppi, double CDH[dim], MyList *pss); + bool prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in); + bool prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in); + void setupintintstuff(int cpusize, MyList *CPatL, int Symmetry); + void checkPatch(); + void checkBlock(int sst); + double getdX(int dir); + void shellname(char *sn, int i); + void Dump_xyz(char *tag, double time, double dT); + void Dump_Data(MyList *DumpListi, char *tag, double time, double dT); + void intertransfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry, int *Varwt); + int interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, int *Varwt); + void Synch(MyList *VarList, int Symmetry, int *Varwt); + void CS_Inter(MyList *VarList, int Symmetry, int *Varwt); + void check_pointstrul(MyList *pp, bool first_only); + void check_pointstrul2(MyList *pp, int first_last_only); + void matchcheck(MyList *CPatL); + void Interp_Points(MyList *VarList, + int NN, double **XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry); + void Interp_Points_2D(MyList *VarList, + int NN, double **XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry); + void Step(double dT, double PhysTime, monitor *ErrorMonitor); + void Null_Boundary(double PhysTime); + void HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count); + double News_Error_Check(double PhysTime, double dT, bool dp); + double Error_Check(double PhysTime, double dT, bool dp); + double EqTheta_Check(double PhysTime, double dT, bool dp); + void Compute_News(double PhysTime, double dT, bool dp); + void Check_News(double PhysTime, double dT, bool dp); +}; + +#endif /* NULLSHELLPATCH_H */ diff --git a/AMSS_NCKU_source/NullShellPatch2.C b/AMSS_NCKU_source/Null_Evolve/NullShellPatch2.C similarity index 96% rename from AMSS_NCKU_source/NullShellPatch2.C rename to AMSS_NCKU_source/Null_Evolve/NullShellPatch2.C index e946bd0..83692b6 100644 --- a/AMSS_NCKU_source/NullShellPatch2.C +++ b/AMSS_NCKU_source/Null_Evolve/NullShellPatch2.C @@ -1,2684 +1,2684 @@ - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "NullShellPatch2.h" -#include "Parallel.h" -#include "fmisc.h" -#include "misc.h" -#include "shellfunctions.h" -#include "NullEvol.h" -#include "NullNews.h" -#include "initial_null2.h" -#include "rungekutta4_rout.h" -#include "kodiss.h" - -#define PI M_PI - -NullShellPatch2::NullShellPatch2(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetryi, int myranki) : myrank(myranki), Rmin(Rmini), xmin(xmini), xmax(xmaxi), PatL(0), Symmetry(Symmetryi) -{ - for (int i = 0; i < dim; i++) - { - shape[i] = shapei[i]; -// we always assume the input parameter is in cell center style -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - shape[i] = shape[i] + 1; -#endif - } - - if (myrank == 0) - { - cout << "null shell's range: r = [" << xmin * Rmin / (1 - xmin) << ":"; - if (xmax == 1) - cout << "+Infty]" << endl; - else - cout << xmax * Rmin / (1 - xmax) << "]" << endl; - cout << " x = [" << xmin << ":" << xmax << "]" << endl - << "shape: " << shape[2] << endl - << "resolution: [" << getdX(0) << "," << getdX(1) << "," << getdX(2) << "]" << endl; - } -// in order to touch infinity, we always use vertex center in r direction -// for Cell center it is some fake as following -#ifdef Cell -#ifdef Vertex -#error Both Cell and Vertex are defined -#endif - { - double ht = (xmax - xmin) / shape[2]; - xmax = xmax + ht / 2; - xmin = xmin - ht / 2; - shape[2] = shape[2] + 1; - } -#endif - - double bbox[2 * dim]; - int shape_here[dim]; - bbox[2] = xmin; - bbox[5] = xmax; - shape_here[2] = shape[2]; - - switch (Symmetry) - { - case 0: - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] + 2 * overghost; - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank); - PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new zm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - case 1: - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] + 2 * overghost; - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); - shape_here[0] = shape[0] + 2 * overghost; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - shape_here[1] = (shape[1] + 1) / 2 + overghost; -#else -#ifdef Cell - shape_here[1] = shape[1] / 2 + overghost; -#else -#error Not define Vertex nor Cell -#endif -#endif - bbox[0] = -PI / 4 - overghost * getdX(0); - shape_here[1] += ghost_width; - bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = ghost_width * getdX(1); // buffer points method to deal with boundary - PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - case 2: -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - for (int i = 0; i < 2; i++) - shape_here[i] = (shape[i] + 1) / 2 + overghost; -#else -#ifdef Cell - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] / 2 + overghost; -#else -#error Not define Vertex nor Cell -#endif -#endif - shape_here[0] += ghost_width; - shape_here[1] += ghost_width; - bbox[0] = -ghost_width * getdX(0); // buffer points method to deal with boundary - bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); - PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - default: - cout << "not recognized Symmetry type" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int ngfs = 0; - gx = new var("gx", ngfs++, 1, 1, 1); - gy = new var("gy", ngfs++, 1, 1, 1); - gz = new var("gz", ngfs++, 1, 1, 1); - - g00 = new var("g00", ngfs++, 1, 1, 1); - g01 = new var("g01", ngfs++, -1, 1, 1); - p02 = new var("p02", ngfs++, 1, -1, 1); - p03 = new var("p03", ngfs++, 1, 1, -1); - g02 = new var("g02", ngfs++, 1, -1, 1); - g03 = new var("g03", ngfs++, 1, 1, -1); - Theta22 = new var("Theta22", ngfs++, 1, 1, 1); - Theta23 = new var("Theta23", ngfs++, 1, -1, -1); - Theta33 = new var("Theta33", ngfs++, 1, 1, 1); - - g22o = new var("g22o", ngfs++, 1, 1, 1); - g23o = new var("g23o", ngfs++, 1, -1, -1); - g33o = new var("g33o", ngfs++, 1, 1, 1); - g220 = new var("g220", ngfs++, 1, 1, 1); - g230 = new var("g230", ngfs++, 1, -1, -1); - g330 = new var("g330", ngfs++, 1, 1, 1); - g22 = new var("g22", ngfs++, 1, 1, 1); - g23 = new var("g23", ngfs++, 1, -1, -1); - g33 = new var("g33", ngfs++, 1, 1, 1); - g221 = new var("g221", ngfs++, 1, 1, 1); - g231 = new var("g231", ngfs++, 1, -1, -1); - g331 = new var("g331", ngfs++, 1, 1, 1); - g22_rhs = new var("g22_rhs", ngfs++, 1, 1, 1); - g23_rhs = new var("g23_rhs", ngfs++, 1, -1, -1); - g33_rhs = new var("g33_rhs", ngfs++, 1, 1, 1); - - RNews = new var("RNews", ngfs++, 1, 1, 1); - INews = new var("INews", ngfs++, 1, 1, 1); - omega = new var("omega", ngfs++, 1, 1, 1); - dtomega = new var("dtomega", ngfs++, 1, 1, 1); - - DumpList = new MyList(g220); - DumpList->insert(g230); - DumpList->insert(g330); - - OldStateList = new MyList(g22o); - OldStateList->insert(g23o); - OldStateList->insert(g33o); - StateList = new MyList(g220); - StateList->insert(g230); - StateList->insert(g330); - SynchList_pre = new MyList(g22); - SynchList_pre->insert(g23); - SynchList_pre->insert(g33); - RHSList = new MyList(g22_rhs); - RHSList->insert(g23_rhs); - RHSList->insert(g33_rhs); - SynchList_cor = new MyList(g221); - SynchList_cor->insert(g231); - SynchList_cor->insert(g331); - - NewsList = new MyList(RNews); - NewsList->insert(INews); - - g01List = new MyList(g01); - g01wt = new double *[1]; - for (int ii = 0; ii < 1; ii++) - { - g01wt[ii] = new double[3]; - g01wt[ii][0] = g01wt[ii][1] = g01wt[ii][2] = 1; - } - - pg0AList = new MyList(p02); - pg0AList->insert(p03); - pg0AList->insert(g02); - pg0AList->insert(g03); - pg0Awt = new double *[4]; - for (int ii = 0; ii < 4; ii++) - { - pg0Awt[ii] = new double[3]; - pg0Awt[ii][0] = pg0Awt[ii][1] = pg0Awt[ii][2] = 1; - } - pg0Awt[0][0] = pg0Awt[1][1] = pg0Awt[2][0] = pg0Awt[3][1] = -1; - - g00List = new MyList(g00); - g00wt = new double *[1]; - for (int ii = 0; ii < 1; ii++) - { - g00wt[ii] = new double[3]; - g00wt[ii][0] = g00wt[ii][1] = g00wt[ii][2] = 1; - } - - ThetaList = new MyList(Theta22); - ThetaList->insert(Theta23); - ThetaList->insert(Theta33); - Thetawt = new double *[3]; - for (int ii = 0; ii < 3; ii++) - { - Thetawt[ii] = new double[3]; - Thetawt[ii][0] = Thetawt[ii][1] = Thetawt[ii][2] = 1; - } - Thetawt[1][0] = Thetawt[1][1] = -1; - - ingfs = 0; - fngfs = ngfs; -} -NullShellPatch2::~NullShellPatch2() -{ - int nprocs = 1; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - for (int node = 0; node < nprocs; node++) - { - if (ss_src[node]) - destroypsuList(ss_src[node]); - if (ss_dst[node]) - destroypsuList(ss_dst[node]); - if (cs_src) - { - if (cs_src[node]) - destroypsuList(cs_src[node]); - if (cs_dst[node]) - destroypsuList(cs_dst[node]); - } - } - - delete[] ss_src; - delete[] ss_dst; - if (cs_src) - { - delete[] cs_src; - delete[] cs_dst; - } - - while (PatL) - { - ss_patch *sPp = PatL->data; - MyList *bg; - while (sPp->blb) - { - if (sPp->blb == sPp->ble) - break; - bg = (sPp->blb->next) ? sPp->blb->next : 0; - delete sPp->blb->data; - delete sPp->blb; - sPp->blb = bg; - } - if (sPp->ble) - { - delete sPp->ble->data; - delete sPp->ble; - } - sPp->blb = sPp->ble = 0; - PatL = PatL->next; - } - PatL->destroyList(); - - StateList->clearList(); - SynchList_pre->clearList(); - SynchList_cor->clearList(); - RHSList->clearList(); - OldStateList->clearList(); - DumpList->clearList(); - CheckList->clearList(); - - NewsList->clearList(); - - g01List->clearList(); - g00List->clearList(); - pg0AList->clearList(); - ThetaList->clearList(); - - delete gx; - delete gy; - delete gz; - - delete g00; - delete g01; - delete p02; - delete p03; - delete g02; - delete g03; - delete Theta22; - delete Theta23; - delete Theta33; - - delete g22o; - delete g23o; - delete g33o; - delete g220; - delete g230; - delete g330; - delete g22; - delete g23; - delete g33; - delete g221; - delete g231; - delete g331; - delete g22_rhs; - delete g23_rhs; - delete g33_rhs; - - delete RNews; - delete INews; - delete omega; - delete dtomega; - - for (int ii = 0; ii < 1; ii++) - delete[] g01wt[ii]; - delete[] g01wt; - for (int ii = 0; ii < 4; ii++) - delete[] pg0Awt[ii]; - delete[] pg0Awt; - for (int ii = 0; ii < 1; ii++) - delete[] g00wt[ii]; - delete[] g00wt; - for (int ii = 0; ii < 3; ii++) - delete[] Thetawt[ii]; - delete[] Thetawt; -} -double NullShellPatch2::getdX(int dir) -{ - if (dir < 0 || dir >= dim) - { - cout << "NullShellPatch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double h; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (shape[dir] == 1) - { - cout << "NullShellPatch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (dir < 2) - h = PI / 2 / (shape[dir] - 1); - else - h = (xmax - xmin) / (shape[dir] - 1); -#else -#ifdef Cell - if (dir < 2) - h = PI / 2 / shape[dir]; - else - h = (xmax - xmin) / shape[dir]; -#else -#error Not define Vertex nor Cell -#endif -#endif - return h; -} -void NullShellPatch2::destroypsuList(MyList *ct) -{ - MyList *n; - while (ct) - { - n = ct->next; - if (ct->data->coef) - { - delete[] ct->data->coef; - delete[] ct->data->sind; - } - delete ct->data; - delete ct; - ct = n; - } -} -void NullShellPatch2::shellname(char *sn, int i) -{ - switch (i) - { - case 0: - sprintf(sn, "zp"); - return; - case 1: - sprintf(sn, "zm"); - return; - case 2: - sprintf(sn, "xp"); - return; - case 3: - sprintf(sn, "xm"); - return; - case 4: - sprintf(sn, "yp"); - return; - case 5: - sprintf(sn, "ym"); - return; - } -} -MyList *NullShellPatch2::compose_sh(int cpusize) -{ - if (dim != 3) - { - cout << "distrivute: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - // checkPatch(); - - MyList *BlL = 0; - - int split_size, min_size, block_size = 0; - - int min_width = 2 * Mymax(ghost_width, buffer_width); - int nxy[2], mmin_width[2], min_shape[2]; - - MyList *PLi = PatL; - for (int i = 0; i < 2; i++) - min_shape[i] = PLi->data->shape[i]; - PLi = PLi->next; - while (PLi) - { - ss_patch *PP = PLi->data; - for (int i = 0; i < 2; i++) - min_shape[i] = Mymin(min_shape[i], PP->shape[i]); - PLi = PLi->next; - } - - for (int i = 0; i < 2; i++) - mmin_width[i] = Mymin(min_width, min_shape[i]); - - min_size = mmin_width[0]; - for (int i = 1; i < 2; i++) - min_size = min_size * mmin_width[i]; - - PLi = PatL; - while (PLi) - { - ss_patch *PP = PLi->data; - // PP->checkPatch(true); - int bs = PP->shape[0]; - for (int i = 1; i < 2; i++) - bs = bs * PP->shape[i]; - block_size = block_size + bs; - PLi = PLi->next; - } - split_size = Mymax(min_size, block_size / cpusize); - split_size = Mymax(1, split_size); - - int n_rank = 0; - PLi = PatL; - int reacpu = 0; - while (PLi) - { - ss_patch *PP = PLi->data; - - reacpu += Parallel::partition2(nxy, split_size, mmin_width, cpusize, PP->shape); // r direction can not be splitted!! It's ode! - - Block *ng; - int shape_here[3], ibbox_here[2 * 2]; - double bbox_here[2 * 3], dd; - - // ibbox : 0,...N-1 - for (int i = 0; i < nxy[0]; i++) - for (int j = 0; j < nxy[1]; j++) - { - ibbox_here[0] = (PP->shape[0] * i) / nxy[0]; - ibbox_here[2] = (PP->shape[0] * (i + 1)) / nxy[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxy[1]; - ibbox_here[3] = (PP->shape[1] * (j + 1)) / nxy[1] - 1; - - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[2] = Mymin(PP->shape[0] - 1, ibbox_here[2] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[1] - 1, ibbox_here[3] + ghost_width); - - shape_here[0] = ibbox_here[2] - ibbox_here[0] + 1; - shape_here[1] = ibbox_here[3] - ibbox_here[1] + 1; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[2] * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[3] * dd; -#else -#ifdef Cell - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[2] + 1) * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[3] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - shape_here[2] = PP->shape[2]; - bbox_here[2] = PP->bbox[2]; - bbox_here[5] = PP->bbox[5]; - ng = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs, 0); // delete through KillBlocks - // ng->checkBlock(); - if (n_rank == cpusize) - n_rank = 0; - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks - - // set PP->blb - if (i == 0 && j == 0) - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; - PP->blb = Bp; - } - } - // set PP->ble - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; - PP->ble = Bp; - } - PLi = PLi->next; - } - if (reacpu < cpusize * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "NullShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << cpusize << " cpus run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} -void NullShellPatch2::Dump_Data(MyList *DumpListi, char *tag, double time, double dT) -{ - MyList *PP = PatL; - while (PP) - { - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); - if (!databuffer) - { - cout << "NullShellPatch::Dump_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *DumpList = DumpListi; - while (DumpList) - { - var *VP = DumpList->data; - - MyList *Bp = PP->data->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->data->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - char filename[100]; - char sn[3]; - shellname(sn, PP->data->sst); - if (tag) - sprintf(filename, "%s_LevSH-%s_%s_%05d.bin", tag, sn, VP->name, ncount); - else - sprintf(filename, "LevSH-%s_%s_%05d.bin", sn, VP->name, ncount); - - Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], - PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], - PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); - } - DumpList = DumpList->next; - } - - if (myrank == 0) - free(databuffer); - - PP = PP->next; - } -} -// Now we dump the data including overlap points -void NullShellPatch2::Dump_xyz(char *tag, double time, double dT) -{ - MyList *DumpListi = 0; - DumpListi = new MyList(gx); - DumpListi->insert(gy); - DumpListi->insert(gz); - Dump_Data(DumpListi, tag, time, dT); - DumpListi->clearList(); -} -// setup interpatch interpolation stuffs -void NullShellPatch2::setupintintstuff(int cpusize, MyList *CPatL, int Symmetry) -{ - const int hCS_width = 0; // do not input data from null shell to box - const int hSC_width = 1; // do input data from box to null shell - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "NullShellPatch2::setupintintstuff begines..." << endl; - - ss_src = new MyList *[cpusize]; - ss_dst = new MyList *[cpusize]; - - if (!CPatL) // if characteristic evolve alone - { - cs_src = 0; - cs_dst = 0; - } - else - { - cs_src = new MyList *[cpusize]; - cs_dst = new MyList *[cpusize]; - } - - MyList *ps, *ts; - MyList *sPp; - MyList *Bgl; - MyList *Pp; - Block *Bg; - double CDH[dim], DH[dim], llb[dim], uub[dim]; - double x, y, z; - - for (int i = 0; i < dim; i++) - { - if (CPatL) - CDH[i] = CPatL->data->getdX(i); - DH[i] = getdX(i); - } - - for (int i = 0; i < cpusize; i++) - { - ss_src[i] = 0; - ss_dst[i] = 0; - if (CPatL) - { - cs_src[i] = 0; - cs_dst[i] = 0; - } - } - - sPp = PatL; - while (sPp) - { - for (int iz = 0; iz < sPp->data->shape[2]; iz++) - for (int is = 0; is < sPp->data->shape[1]; is++) - for (int ir = 0; ir < sPp->data->shape[0]; ir++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = sPp->data->bbox[0] + ir * DH[0]; - y = sPp->data->bbox[1] + is * DH[1]; - z = sPp->data->bbox[2] + iz * DH[2]; -#else -#ifdef Cell - x = sPp->data->bbox[0] + (ir + 0.5) * DH[0]; - y = sPp->data->bbox[1] + (is + 0.5) * DH[1]; - z = sPp->data->bbox[2] + (iz + 0.5) * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (CPatL && z < sPp->data->bbox[2] + (hSC_width + 0.0001) * DH[2]) - { - double gx, gy, gz; - getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); - bool flag = false; - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(cs_src[i], false, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i, iz); - if (flag) - break; - } - if (!flag) - { - CPatL->data->checkBlock(); - if (myrank == 0) - { - cout << "ShellPatch2::prolongpointstru fail to find cardisian source point for" << endl; - cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; - cout << "x,y,z = " << gx << "," << gy << "," << gz << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - if (x < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[0] || x > PI / 4 + (overghost - ghost_width - 0.0001) * DH[0] || - y < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[1] || y > PI / 4 + (overghost - ghost_width - 0.0001) * DH[1]) - { - double gx, gy, gz; - if (z < 1 - 0.0001 * DH[2]) - getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); - bool flag = true; - if (flag) - { - flag = false; - for (int i = 0; i < cpusize; i++) - { - if (z < 1 - 0.0001 * DH[2]) - flag = prolongpointstru(ss_src[i], true, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i, iz); - else - flag = prolongpointstru_ss(ss_src[i], sPp->data->sst, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i, iz); - if (flag) - break; - } - if (!flag) - { - if (myrank == 0) - { - // if you used Vertex grid please note x=1, try 0.999999 instead - cout << "NullShellPatch2::prolongpointstru fail to find shell source point for" << endl; - cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - } - sPp = sPp->next; - } - if (myrank == 0) - cout << "NullShellPatch2::setupintintstuff ss_src completes" << endl; - - Pp = CPatL; - while (Pp) - { - double llb[dim], uub[dim]; - if (Symmetry > 0) - llb[2] = Pp->data->bbox[2] - 0.0001 * CDH[2]; - else - llb[2] = Pp->data->bbox[2] + (hCS_width + 0.0001) * CDH[2]; - uub[2] = Pp->data->bbox[dim + 2] - (hCS_width + 0.0001) * CDH[2]; - for (int j = 0; j < 2; j++) - { - if (Symmetry > 1) - llb[j] = Pp->data->bbox[j] - 0.0001 * CDH[j]; - else - llb[j] = Pp->data->bbox[j] + (hCS_width + 0.0001) * CDH[j]; - uub[j] = Pp->data->bbox[dim + j] - (hCS_width + 0.0001) * CDH[j]; - } - for (int iz = 0; iz < Pp->data->shape[2]; iz++) - for (int iy = 0; iy < Pp->data->shape[1]; iy++) - for (int ix = 0; ix < Pp->data->shape[0]; ix++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = Pp->data->bbox[0] + ix * CDH[0]; - y = Pp->data->bbox[1] + iy * CDH[1]; - z = Pp->data->bbox[2] + iz * CDH[2]; -#else -#ifdef Cell - x = Pp->data->bbox[0] + (ix + 0.5) * CDH[0]; - y = Pp->data->bbox[1] + (iy + 0.5) * CDH[1]; - z = Pp->data->bbox[2] + (iz + 0.5) * CDH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (x < llb[0] || x > uub[0] || - y < llb[1] || y > uub[1] || - z < llb[2] || z > uub[2]) - { - int sst; - double lx, ly, lz; - bool flag = false; - getlocalpox(x, y, z, sst, lx, ly, lz); - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(cs_src[i], true, -1, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i, -1); - if (flag) - break; - } - if (!flag) - { - if (myrank == 0) - { - cout << "ShellPatch2::prolongpointstru fail to find shell source point for" << endl; - cout << "sst = -1, x,y,z = " << x << "," << y << "," << z << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - Pp = Pp->next; - } - if (myrank == 0) - if (CPatL) - cout << "NullShellPatch2::setupintintstuff cs_src completes" << endl; - else - cout << "NullShellPatch2::no cs_src exists" << endl; - - for (int i = 0; i < cpusize; i++) - { - ps = ss_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(ss_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - - if (CPatL) - { - ps = cs_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(cs_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - } - } - if (myrank == 0) - cout << "NullShellPatch2::setupintintstuff ss_dst and cs_dst complete" << endl; - - /* - for(int i=0;inext; - ts=ts->next; - } - } - exit(0); - */ -} -// lz is x instead of r -void NullShellPatch2::getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) -{ - double r; - r = sqrt(x * x + y * y + z * z); - lz = r / (r + Rmin); - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "NullShellPatch2::getlocalpox should not come here, something wrong" << endl; - } -} -// lz is x instead of r -// using fake global coordinates to get local coordinate -void NullShellPatch2::getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) -{ - double r; - r = sqrt(x * x + y * y + z * z); - lz = r; - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "NullShellPatch2::getlocalpox should not come here, something wrong" << endl; - } -} -// lz is x instead of r -// specially for usage from shell to shell -void NullShellPatch2::getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz) -{ - // fake global coordinate - double r = 1, x, y, z; - switch (isst) - { - case 0: - x = tan(ix); - y = tan(iy); - z = r / sqrt(1 + x * x + y * y); - x = z * x; - y = z * y; - break; - case 1: - x = tan(ix); - y = tan(iy); - z = -r / sqrt(1 + x * x + y * y); - x = z * x; - y = z * y; - break; - case 2: - y = tan(ix); - z = tan(iy); - x = r / sqrt(1 + z * z + y * y); - y = x * y; - z = x * z; - break; - case 3: - y = tan(ix); - z = tan(iy); - x = -r / sqrt(1 + z * z + y * y); - y = x * y; - z = x * z; - break; - case 4: - x = tan(ix); - z = tan(iy); - y = r / sqrt(1 + x * x + z * z); - x = y * x; - z = y * z; - break; - case 5: - x = tan(ix); - z = tan(iy); - y = -r / sqrt(1 + x * x + z * z); - x = y * x; - z = y * z; - break; - } - - // map with fake global coordinate - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "NullShellPatch2::getlocalpox should not come here, something wrong" << endl; - } - - lz = iz; - - // if(lx != lx) cout<data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - if (first_only) - return; - pp = pp->next; - } - } -} -// for check -// used by _dst construction, so these x,y,z must coinside with grid point -// we have considered ghost points now -void NullShellPatch2::prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], - MyList *Ppi, double CDH[dim], MyList *pss) -{ - int n_dst = 0; - MyList *sPp = sPpi; - MyList *Pp = Ppi; - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz, lsst; - - if (pss->data->tsst >= 0) - { - getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, - lx, ly, lz); - if (lx != lx) - getlocalpoxsst_ss(pss->data->ssst, pss->data->lpox[0], pss->data->lpox[1], pss->data->lpox[2], - pss->data->tsst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == pss->data->tsst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - { - for (int j = 0; j < dim; j++) - { - llb[j] = Bg->bbox[j]; - uub[j] = Bg->bbox[j + dim]; - } - - if (lx > llb[0] - 0.1 * DH[0] && lx < uub[0] + 0.1 * DH[0] && - ly > llb[1] - 0.1 * DH[1] && ly < uub[1] + 0.1 * DH[1] && - lz > llb[2] - 0.1 * DH[2] && lz < uub[2] + 0.1 * DH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = 0; - for (int i = 0; i < dim; i++) - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = pss->data->ssst; - ps->data->tsst = sPp->data->sst; - ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); - ps->data->Bg = Bg; - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->indz = pss->data->indz; - get_Jacob(ps->data->lpox, ps->data->tsst, ps->data->ssst, ps->data->Jacob); - if (psul) - psul->catList(ps); - else - psul = ps; - n_dst++; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - } - else - { - if (pss->data->tsst != -1) - cout << "somthing is wrong in NullShellPatch2::prolongpointstru" << endl; - lx = pss->data->gpox[0]; - ly = pss->data->gpox[1]; - lz = pss->data->gpox[2]; - while (Pp) - { - Bgl = Pp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - { - for (int j = 0; j < dim; j++) - { - llb[j] = Bg->bbox[j]; - uub[j] = Bg->bbox[j + dim]; - } - - if (lx > llb[0] - 0.1 * CDH[0] && lx < uub[0] + 0.1 * CDH[0] && - ly > llb[1] - 0.1 * CDH[1] && ly < uub[1] + 0.1 * CDH[1] && - lz > llb[2] - 0.1 * CDH[2] && lz < uub[2] + 0.1 * CDH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = 0; - for (int i = 0; i < dim; i++) - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = pss->data->ssst; - ps->data->tsst = -1; - ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); - ps->data->Bg = Bg; - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->indz = pss->data->indz; - for (int i = 0; i < 2; i++) - for (int j = 0; j < 2; j++) - ps->data->Jacob[i][j] = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - n_dst++; - } - } - if (Bgl == Pp->data->ble) - break; - Bgl = Bgl->next; - } - Pp = Pp->next; - } - } - // if n_dst > 0, that's because of ghost_points then prolong source list - if (n_dst == 0) - { - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "NullShellPatch2::prolongpointstru fail to find target Block for pointstru:" << endl; - check_pointstrul(pss, true); - if (Pp == Ppi) - { - getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, - lx, ly, lz); - if (myrank == 0) - cout << "sst = " << pss->data->tsst << ", lx,ly,lz = " << lx << "," << ly << "," << lz << endl; - checkBlock(pss->data->tsst); - } - else - { - Pp = Ppi; - while (Pp) - { - Pp->data->checkBlock(); - Pp = Pp->next; - } - } - if (myrank == 0) - MPI_Abort(MPI_COMM_WORLD, 1); - } - else - { - MyList *ts = 0; - for (int i = 1; i < n_dst; i++) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = (i == n_dst - 1) ? pss->next : 0; - for (int i = 0; i < dim; i++) - { - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[i] = pss->data->lpox[i]; - } - ps->data->ssst = pss->data->ssst; - ps->data->tsst = pss->data->tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->Bg = pss->data->Bg; - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->indz = pss->data->indz; - for (int i = 0; i < 2; i++) - for (int j = 0; j < 2; j++) - ps->data->Jacob[i][j] = pss->data->Jacob[i][j]; - if (ts) - ts->catList(ps); - else - ts = ps; - } - if (ts) - pss->next = ts; - } -} -// used by _src construction, so these x,y,z do not coinside with grid point -bool NullShellPatch2::prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, - const int iz) -{ - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz; - - if (ssyn) - { - int sst; - getlocalpox(x, y, z, sst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == sst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < 2; j++) - { - if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) - llb[j] = -PI / 4; - else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * DH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) - uub[j] = PI / 4; - else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; - } - if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) - llb[2] = Bg->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; -#else -#ifdef Cell - else - llb[2] = Bg->bbox[2] + ghost_width * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) - uub[2] = Bg->bbox[dim + 2]; - else - uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; - if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && - ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && - lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| - // ^ - // so for ^ point may miss for vertext center, so we use 0.0001 - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = x; - ps->data->gpox[1] = y; - ps->data->gpox[2] = z; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = sPp->data->sst; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->indz = iz; - for (int i = 0; i < 2; i++) - for (int j = 0; j < 2; j++) - ps->data->Jacob[i][j] = 0; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - } - else - { - while (Pp) - { - Bgl = Pp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < dim; j++) - { - if (feq(Bg->bbox[j], Pp->data->bbox[j], CDH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * CDH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * CDH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], Pp->data->bbox[dim + j], CDH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * CDH[j]; - } - if (x > llb[0] - 0.0001 * CDH[0] && x < uub[0] + 0.0001 * CDH[0] && - y > llb[1] - 0.0001 * CDH[1] && y < uub[1] + 0.0001 * CDH[1] && - z > llb[2] - 0.0001 * CDH[2] && z < uub[2] + 0.0001 * CDH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = x; - ps->data->gpox[1] = y; - ps->data->gpox[2] = z; - ps->data->lpox[0] = x; - ps->data->lpox[1] = y; - ps->data->lpox[2] = z; - ps->data->ssst = -1; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->indz = -1; - for (int i = 0; i < 2; i++) - for (int j = 0; j < 2; j++) - ps->data->Jacob[i][j] = 0; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == Pp->data->ble) - break; - Bgl = Bgl->next; - } - Pp = Pp->next; - } - } - - return false; -} -// used by _src construction, so these x,y,z do not coinside with grid point -// specially used from shell to shell -bool NullShellPatch2::prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, const int iz) -{ - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz; - - int sst; - getlocalpox_ss(tsst, x, y, z, sst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == sst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < 2; j++) - { - if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) - llb[j] = -PI / 4; - else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * DH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) - uub[j] = PI / 4; - else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; - } - if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) - llb[2] = Bg->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; -#else -#ifdef Cell - else - llb[2] = Bg->bbox[2] + ghost_width * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) - uub[2] = Bg->bbox[dim + 2]; - else - uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; - if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && - ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && - lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| - // ^ - // so for ^ point may miss for vertext center, so we use 0.0001 - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = 0; // global coordinate is not valid for r=infinity - ps->data->gpox[1] = 0; - ps->data->gpox[2] = 0; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = sPp->data->sst; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->data->indz = iz; - for (int i = 0; i < 2; i++) - for (int j = 0; j < 2; j++) - ps->data->Jacob[i][j] = 0; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - - return false; -} -// J[new][old] = d x_new/d x_old -void NullShellPatch2::get_Jacob(double *pox, int tsst, int ssst, double J[2][2]) -{ - double rn = pox[0], sn = pox[1], ro, so; - - double cosro, sinro, cosso, sinso; - if (tsst == 0 || tsst == 1) // z - { - if (ssst == 2 || ssst == 3) // x - { - ro = atan(tan(sn) / tan(rn)); - so = atan(1 / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = 0; - J[0][1] = -1; - J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[1][1] = -cosro * sinro / J[1][0]; - J[1][0] = cosso * sinso / J[1][0]; - } - else if (ssst == 4 || ssst == 5) // y - { - ro = atan(tan(rn) / tan(sn)); - so = atan(1 / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[0][1] = -cosro * sinro / J[0][0]; - J[0][0] = cosso * sinso / J[0][0]; - J[1][0] = 0; - J[1][1] = -1; - } - else - cout << "Error in NullShellPatch2::get_Jacob 1" << endl; - } - else if (tsst == 2 || tsst == 3) - { - if (ssst == 0 || ssst == 1) - { - ro = atan(1 / tan(sn)); - so = atan(tan(rn) / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[0][1] = cosro * sinro / J[0][0]; - J[0][0] = -cosso * sinso / J[0][0]; - J[1][0] = -1; - J[1][1] = 0; - } - else if (ssst == 4 || ssst == 5) - { - ro = atan(1 / tan(rn)); - so = atan(tan(sn) / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = -1; - J[0][1] = 0; - J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[1][1] = cosro * sinro / J[1][0]; - J[1][0] = -cosso * sinso / J[1][0]; - } - else - cout << "Error in NullShellPatch2::get_Jacob 2" << endl; - } - else if (tsst == 4 || tsst == 5) - { - if (ssst == 0 || ssst == 1) - { - ro = atan(tan(rn) / tan(sn)); - so = atan(1 / tan(sn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[0][1] = -cosro * sinro / J[0][0]; - J[0][0] = cosso * sinso / J[0][0]; - J[1][0] = 0; - J[1][1] = -1; - } - else if (ssst == 2 || ssst == 3) - { - ro = atan(1 / tan(rn)); - so = atan(tan(sn) / tan(rn)); - cosro = cos(ro); - sinro = sin(ro); - cosso = cos(so); - sinso = sin(so); - J[0][0] = -1; - J[0][1] = 0; - J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; - J[1][1] = cosro * sinro / J[1][0]; - J[1][0] = -cosso * sinso / J[1][0]; - } - else - cout << "Error in NullShellPatch2::get_Jacob 3" << endl; - } -} -int NullShellPatch2::getdumydimension(int acsst, int posst) // -1 means no dumy dimension -{ - int dms; - if (acsst == -1 || posst == -1) - return -1; - switch (acsst) - { - case 0: - case 1: - switch (posst) - { - case 0: - case 1: - cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - case 2: - case 3: - return 0; - case 4: - case 5: - return 1; - default: - cout << "error in NullShellPatch2::getdumydimension: posst = " << posst << endl; - return -1; - } - case 2: - case 3: - switch (posst) - { - case 0: - case 1: - return 1; - case 2: - case 3: - cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - case 4: - case 5: - return 0; - default: - cout << "error in NullShellPatch2::getdumydimension: posst = " << posst << endl; - return -1; - } - case 4: - case 5: - switch (posst) - { - case 0: - case 1: - return 1; - case 2: - case 3: - return 0; - case 4: - case 5: - cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - default: - cout << "error in NullShellPatch2::getdumydimension: posst = " << posst << endl; - return -1; - } - default: - cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << endl; - return -1; - } -} -void NullShellPatch2::Synch(MyList *VarList, int Symmetry, double **Varwt, const short int svt) -{ - MyList *Pp = PatL; - while (Pp) - { - Pp->data->Sync(VarList, Symmetry); - Pp = Pp->next; - } - - // we need this before interpolation - if (Symmetry > 0) - fill_symmetric_boundarybuffer(VarList, Varwt); - - intertransfer(ss_src, ss_dst, VarList, VarList, Symmetry, Varwt, svt); - - // we need this here to correct conners - if (Symmetry > 0) - fill_symmetric_boundarybuffer(VarList, Varwt); -} -// Varwt: AoS of rho, sigma, x -void NullShellPatch2::fill_symmetric_boundarybuffer(MyList *VarList, double **Varwt) -{ - MyList *varl; - int ind; - double drho = getdX(0), dsigma = getdX(1); - - if (Symmetry == 0) - return; - else - { - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - varl = VarList; - ind = 0; - while (varl) - { - f_fill_symmetric_boundarybuffer2(cg->shape, cg->X[0], cg->X[1], cg->X[2], drho, dsigma, - cg->fgfs[varl->data->sgfn], - Symmetry, Pp->data->sst, Varwt[ind]); // defined in NullEvol2.f90 - varl = varl->next; - ind++; - } - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -} -void NullShellPatch2::intertransfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry, double **Varwt, const short int svt) -{ - int myrank, cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int node; - - MPI_Request *reqs; - MPI_Status *stats; - reqs = new MPI_Request[2 * cpusize]; - stats = new MPI_Status[2 * cpusize]; - int req_no = 0; - - double **send_data, **rec_data; - send_data = new double *[cpusize]; - rec_data = new double *[cpusize]; - int length; - - for (node = 0; node < cpusize; node++) - { - send_data[node] = rec_data[node] = 0; - if (node == myrank) - { - if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 1" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(rec_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt); - } - } - else - { - // send from this cpu to cpu#node - if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt)) - { - send_data[node] = new double[length]; - if (!send_data[node]) - { - cout << "out of memory when new in short transfer, place 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt); - MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - // receive from cpu#node to this cpu - if (length = interdata_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt, svt)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - } - } - // wait for all requests to complete - MPI_Waitall(req_no, reqs, stats); - - for (node = 0; node < cpusize; node++) - if (rec_data[node]) - interdata_packer(rec_data[node], src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt, svt); - - for (node = 0; node < cpusize; node++) - { - if (send_data[node]) - delete[] send_data[node]; - if (rec_data[node]) - delete[] rec_data[node]; - } - - delete[] reqs; - delete[] stats; - delete[] send_data; - delete[] rec_data; -} -// PACK: prepare target data in 'data' -// UNPACK: copy target data from 'data' to corresponding numerical grids -int NullShellPatch2::interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, - const short int svt) -{ - int rev; - rev = interdata_packer_pre(data, src, dst, rank_in, dir, VarLists, VarListd, Symmetry, Varwt, svt); - if (dir == PACK) - return rev; - rev = interdata_packer_pot(data, src, dst, rank_in, dir, VarLists, VarListd, Symmetry, Varwt, svt); - return rev; -} -int NullShellPatch2::interdata_packer_pre(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, - const short int svt) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int DIM = dim; - int ordn = 2 * ghost_width; - - if (dir != PACK && dir != UNPACK) - { - cout << "error dir " << dir << " for data_packer " << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int size_out = 0; - - if (!src || !dst) - return size_out; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - while (src && dst) - { - if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || - (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) - { - varls = VarLists; - varld = VarListd; - int vind = 1; - bool flag = true; - while (varls && varld) - { - if (data) - { - if (dir == PACK) - { - int DIMh = (src->data->dumyd == -1) ? dim : 1; - if (src->data->coef == 0) - { - src->data->coef = new double[ordn * DIMh]; - src->data->sind = new int[dim]; - if (DIMh == 3) - { - for (int i = 0; i < DIMh; i++) - { - double dd = src->data->Bg->getdX(i); - // 0.001 instead of 0.4 makes the point locate more center - src->data->sind[i] = int((src->data->lpox[i] - src->data->Bg->X[i][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = src->data->Bg->X[i][0] + (src->data->sind[i] + j) * dd; - src->data->coef[i * ordn + j] = 1; - for (int k = 0; k < j; k++) - { - h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; - src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; - src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); - } - } - } - } - else - { - int actd = 1 - src->data->dumyd; - double dd = src->data->Bg->getdX(actd); - src->data->sind[0] = int((src->data->lpox[actd] - src->data->Bg->X[actd][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = src->data->Bg->X[actd][0] + (src->data->sind[0] + j) * dd; - src->data->coef[j] = 1; - for (int k = 0; k < j; k++) - { - h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; - src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; - src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); - } - } - src->data->sind[2] = int((src->data->lpox[2] - src->data->Bg->X[2][0]) / src->data->Bg->getdX(2) + 0.001); - if (!feq(src->data->Bg->X[2][src->data->sind[2]], src->data->lpox[2], src->data->Bg->getdX(2) / 2000)) - cout << "error in NullShellPatch::interdata_packer point = " << src->data->lpox[2] << " != grid " << src->data->Bg->X[2][src->data->sind[2]] << endl; - src->data->sind[1] = int((src->data->lpox[src->data->dumyd] - src->data->Bg->X[src->data->dumyd][0]) / - src->data->Bg->getdX(src->data->dumyd) + - 0.001); - if (!feq(src->data->Bg->X[src->data->dumyd][src->data->sind[1]], src->data->lpox[src->data->dumyd], src->data->Bg->getdX(src->data->dumyd) / 2000)) - cout << "error in NullShellPatch::interdata_packer for dumy dimension point = " - << src->data->lpox[src->data->dumyd] << " != grid " << src->data->Bg->X[src->data->dumyd][src->data->sind[1]] << endl; - } - } - // interpolate - switch (DIMh) - { - case 3: - f_global_interpind(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst); - break; - case 2: - f_global_interpind2d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst); - break; - case 1: - f_global_interpind1d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst, src->data->dumyd); - break; - default: - cout << "NullShellPatch2::interdata_packer: not recognized DIM = " << DIMh << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - if (dir == UNPACK) // from target data to corresponding grid - { - switch (svt) - { - case 1: // type(0,0) - vind = 0; - break; - case 2: // type(0,1) - { - if (vind / 2 * 2 == vind) - { - double tmp[2]; - double Jon[2][2]; - Jon[0][0] = dst->data->Jacob[0][0]; - Jon[0][1] = dst->data->Jacob[0][1]; - Jon[1][0] = dst->data->Jacob[1][0]; - Jon[1][1] = dst->data->Jacob[1][1]; - - tmp[0] = Jon[0][0] * Jon[1][1] - Jon[0][1] * Jon[1][0]; - tmp[1] = Jon[1][1] / tmp[0]; - Jon[0][1] = -Jon[0][1] / tmp[0]; - Jon[1][0] = -Jon[1][0] / tmp[0]; - Jon[1][1] = Jon[0][0] / tmp[0]; - Jon[0][0] = tmp[1]; - - tmp[0] = data[size_out - 1]; - tmp[1] = data[size_out]; - data[size_out - 1] = Jon[0][0] * tmp[0] + Jon[1][0] * tmp[1]; - data[size_out] = Jon[0][1] * tmp[0] + Jon[1][1] * tmp[1]; - - vind = 0; - } - break; - } - case 3: // symmetric type(0,2) - { - if (vind / 3 * 3 == vind) - { - double tmp[3]; - double Jon[2][2]; - Jon[0][0] = dst->data->Jacob[0][0]; - Jon[0][1] = dst->data->Jacob[0][1]; - Jon[1][0] = dst->data->Jacob[1][0]; - Jon[1][1] = dst->data->Jacob[1][1]; - tmp[0] = Jon[0][0] * Jon[1][1] - Jon[0][1] * Jon[1][0]; - tmp[1] = Jon[1][1] / tmp[0]; - Jon[0][1] = -Jon[0][1] / tmp[0]; - Jon[1][0] = -Jon[1][0] / tmp[0]; - Jon[1][1] = Jon[0][0] / tmp[0]; - Jon[0][0] = tmp[1]; - - tmp[0] = data[size_out - 2]; - tmp[1] = data[size_out - 1]; - tmp[2] = data[size_out]; - data[size_out - 2] = Jon[0][0] * Jon[0][0] * tmp[0] + 2 * Jon[1][0] * Jon[0][0] * tmp[1] + Jon[1][0] * Jon[1][0] * tmp[2]; - data[size_out - 1] = Jon[0][0] * Jon[0][1] * tmp[0] + (Jon[1][0] * Jon[0][1] + Jon[0][0] * Jon[1][1]) * tmp[1] + Jon[1][0] * Jon[1][1] * tmp[2]; - data[size_out] = Jon[0][1] * Jon[0][1] * tmp[0] + 2 * Jon[1][1] * Jon[0][1] * tmp[1] + Jon[1][1] * Jon[1][1] * tmp[2]; - - vind = 0; - } - break; - } - default: - { - cout << "NullShellPatch2::interdata_packer: not recognized svt = " << svt << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - size_out += 1; - vind += 1; - varls = varls->next; - varld = varld->next; - } - } - dst = dst->next; - src = src->next; - } - - return size_out; -} -int NullShellPatch2::interdata_packer_pot(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, - const short int svt) -{ - if (dir != UNPACK) - return 0; - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int DIM = dim; - int ordn = 2 * ghost_width; - - int size_out = 0; - - if (!src || !dst) - return size_out; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - while (src && dst) - { - if ((dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) - { - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - if (data) - { - if (dir == UNPACK) // from target data to corresponding grid - { - f_pointcopy(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], - dst->data->lpox[0], dst->data->lpox[1], dst->data->lpox[2], data[size_out]); - } - } - size_out += 1; - varls = varls->next; - varld = varld->next; - } - } - dst = dst->next; - src = src->next; - } - - return size_out; -} -void NullShellPatch2::Interp_Points_2D(MyList *VarList, - int NN, double **XX, /*input fake global Cartesian coordinate*/ - double *Shellf, int Symmetry) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[NN * num_var]; - memset(shellf, 0, sizeof(double) * NN * num_var); - - // we use weight to monitor code, later some day we can move it for optimization - int *weight; - weight = new int[NN]; - memset(weight, 0, sizeof(int) * NN); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - int sst; - getlocalpox_fake(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); // pox[2] is x indeed - - // int indZ=int((pox[2]-xmin)/DH[2]); - int indZ = shape[2]; // note we use index for Fortran - MyList *sPp = PatL; - while (sPp->data->sst != sst) - sPp = sPp->next; - - if (myrank == 0 && ((!sPp) || pox[2] < xmin - 0.0001 * DH[2] || pox[2] > xmax + 0.0001 * DH[2])) - { - cout << "NullShellPatch::Interp_Points: point gc = ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - } - if (sPp) - { - cout << ") sst = " << sst << " lc = ("; - for (int k = 0; k < dim; k++) - { - cout << pox[k]; - if (k < dim - 1) - cout << ","; - } - } - cout << ") is out of the NullShellPatch." << endl; - cout << "xmin = " << xmin << ", xmax = " << xmax << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (!sPp) - return; - - MyList *Bp = sPp->data->blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -// -// because of getlocalpox, pox will not goes into overghost region of ss_patch -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp_ss_2d(BP->shape, BP->X[0], BP->X[1], indZ, BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], - pox[0], pox[1], ordn, varl->data->SoA, Symmetry, sst); - varl = varl->next; - k++; - } - weight[j] = 1; - } - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - } - - MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - int *Weight; - Weight = new int[NN]; - MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - - for (int i = 0; i < NN; i++) - { - if (Weight[i] > 1) - { - if (myrank == 0) - cout << "WARNING: NullShellPatch::Interp_Points meets multiple weight" << endl; - for (int j = 0; j < num_var; j++) - Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; - } - else if (Weight[i] == 0 && myrank == 0) - { - cout << "ERROR: NullShellPatch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j][i]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on NullShellPatch (" << xmin << ":" << xmax << ")" << endl; - - cout << "splited domains:" << endl; - MyList *sPp = PatL; - while (sPp) - { - char sn[3]; - shellname(sn, sPp->data->sst); - cout << "ss_patch " << sn << ":" << endl; - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - delete[] shellf; - delete[] weight; - delete[] Weight; - delete[] DH; - delete[] llb; - delete[] uub; -} + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "NullShellPatch2.h" +#include "Parallel.h" +#include "fmisc.h" +#include "misc.h" +#include "shellfunctions.h" +#include "NullEvol.h" +#include "NullNews.h" +#include "initial_null2.h" +#include "rungekutta4_rout.h" +#include "kodiss.h" + +#define PI M_PI + +NullShellPatch2::NullShellPatch2(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetryi, int myranki) : myrank(myranki), Rmin(Rmini), xmin(xmini), xmax(xmaxi), PatL(0), Symmetry(Symmetryi) +{ + for (int i = 0; i < dim; i++) + { + shape[i] = shapei[i]; +// we always assume the input parameter is in cell center style +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + shape[i] = shape[i] + 1; +#endif + } + + if (myrank == 0) + { + cout << "null shell's range: r = [" << xmin * Rmin / (1 - xmin) << ":"; + if (xmax == 1) + cout << "+Infty]" << endl; + else + cout << xmax * Rmin / (1 - xmax) << "]" << endl; + cout << " x = [" << xmin << ":" << xmax << "]" << endl + << "shape: " << shape[2] << endl + << "resolution: [" << getdX(0) << "," << getdX(1) << "," << getdX(2) << "]" << endl; + } +// in order to touch infinity, we always use vertex center in r direction +// for Cell center it is some fake as following +#ifdef Cell +#ifdef Vertex +#error Both Cell and Vertex are defined +#endif + { + double ht = (xmax - xmin) / shape[2]; + xmax = xmax + ht / 2; + xmin = xmin - ht / 2; + shape[2] = shape[2] + 1; + } +#endif + + double bbox[2 * dim]; + int shape_here[dim]; + bbox[2] = xmin; + bbox[5] = xmax; + shape_here[2] = shape[2]; + + switch (Symmetry) + { + case 0: + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] + 2 * overghost; + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank); + PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new zm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + case 1: + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] + 2 * overghost; + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); + shape_here[0] = shape[0] + 2 * overghost; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + shape_here[1] = (shape[1] + 1) / 2 + overghost; +#else +#ifdef Cell + shape_here[1] = shape[1] / 2 + overghost; +#else +#error Not define Vertex nor Cell +#endif +#endif + bbox[0] = -PI / 4 - overghost * getdX(0); + shape_here[1] += ghost_width; + bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = ghost_width * getdX(1); // buffer points method to deal with boundary + PatL->insert(new xm_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new ym_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + case 2: +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + for (int i = 0; i < 2; i++) + shape_here[i] = (shape[i] + 1) / 2 + overghost; +#else +#ifdef Cell + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] / 2 + overghost; +#else +#error Not define Vertex nor Cell +#endif +#endif + shape_here[0] += ghost_width; + shape_here[1] += ghost_width; + bbox[0] = -ghost_width * getdX(0); // buffer points method to deal with boundary + bbox[1] = -ghost_width * getdX(1); // buffer points method to deal with boundary + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new zp_npatch(ingfs, fngfs, shape_here, bbox, myrank); + PatL->insert(new xp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_npatch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + default: + cout << "not recognized Symmetry type" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int ngfs = 0; + gx = new var("gx", ngfs++, 1, 1, 1); + gy = new var("gy", ngfs++, 1, 1, 1); + gz = new var("gz", ngfs++, 1, 1, 1); + + g00 = new var("g00", ngfs++, 1, 1, 1); + g01 = new var("g01", ngfs++, -1, 1, 1); + p02 = new var("p02", ngfs++, 1, -1, 1); + p03 = new var("p03", ngfs++, 1, 1, -1); + g02 = new var("g02", ngfs++, 1, -1, 1); + g03 = new var("g03", ngfs++, 1, 1, -1); + Theta22 = new var("Theta22", ngfs++, 1, 1, 1); + Theta23 = new var("Theta23", ngfs++, 1, -1, -1); + Theta33 = new var("Theta33", ngfs++, 1, 1, 1); + + g22o = new var("g22o", ngfs++, 1, 1, 1); + g23o = new var("g23o", ngfs++, 1, -1, -1); + g33o = new var("g33o", ngfs++, 1, 1, 1); + g220 = new var("g220", ngfs++, 1, 1, 1); + g230 = new var("g230", ngfs++, 1, -1, -1); + g330 = new var("g330", ngfs++, 1, 1, 1); + g22 = new var("g22", ngfs++, 1, 1, 1); + g23 = new var("g23", ngfs++, 1, -1, -1); + g33 = new var("g33", ngfs++, 1, 1, 1); + g221 = new var("g221", ngfs++, 1, 1, 1); + g231 = new var("g231", ngfs++, 1, -1, -1); + g331 = new var("g331", ngfs++, 1, 1, 1); + g22_rhs = new var("g22_rhs", ngfs++, 1, 1, 1); + g23_rhs = new var("g23_rhs", ngfs++, 1, -1, -1); + g33_rhs = new var("g33_rhs", ngfs++, 1, 1, 1); + + RNews = new var("RNews", ngfs++, 1, 1, 1); + INews = new var("INews", ngfs++, 1, 1, 1); + omega = new var("omega", ngfs++, 1, 1, 1); + dtomega = new var("dtomega", ngfs++, 1, 1, 1); + + DumpList = new MyList(g220); + DumpList->insert(g230); + DumpList->insert(g330); + + OldStateList = new MyList(g22o); + OldStateList->insert(g23o); + OldStateList->insert(g33o); + StateList = new MyList(g220); + StateList->insert(g230); + StateList->insert(g330); + SynchList_pre = new MyList(g22); + SynchList_pre->insert(g23); + SynchList_pre->insert(g33); + RHSList = new MyList(g22_rhs); + RHSList->insert(g23_rhs); + RHSList->insert(g33_rhs); + SynchList_cor = new MyList(g221); + SynchList_cor->insert(g231); + SynchList_cor->insert(g331); + + NewsList = new MyList(RNews); + NewsList->insert(INews); + + g01List = new MyList(g01); + g01wt = new double *[1]; + for (int ii = 0; ii < 1; ii++) + { + g01wt[ii] = new double[3]; + g01wt[ii][0] = g01wt[ii][1] = g01wt[ii][2] = 1; + } + + pg0AList = new MyList(p02); + pg0AList->insert(p03); + pg0AList->insert(g02); + pg0AList->insert(g03); + pg0Awt = new double *[4]; + for (int ii = 0; ii < 4; ii++) + { + pg0Awt[ii] = new double[3]; + pg0Awt[ii][0] = pg0Awt[ii][1] = pg0Awt[ii][2] = 1; + } + pg0Awt[0][0] = pg0Awt[1][1] = pg0Awt[2][0] = pg0Awt[3][1] = -1; + + g00List = new MyList(g00); + g00wt = new double *[1]; + for (int ii = 0; ii < 1; ii++) + { + g00wt[ii] = new double[3]; + g00wt[ii][0] = g00wt[ii][1] = g00wt[ii][2] = 1; + } + + ThetaList = new MyList(Theta22); + ThetaList->insert(Theta23); + ThetaList->insert(Theta33); + Thetawt = new double *[3]; + for (int ii = 0; ii < 3; ii++) + { + Thetawt[ii] = new double[3]; + Thetawt[ii][0] = Thetawt[ii][1] = Thetawt[ii][2] = 1; + } + Thetawt[1][0] = Thetawt[1][1] = -1; + + ingfs = 0; + fngfs = ngfs; +} +NullShellPatch2::~NullShellPatch2() +{ + int nprocs = 1; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + for (int node = 0; node < nprocs; node++) + { + if (ss_src[node]) + destroypsuList(ss_src[node]); + if (ss_dst[node]) + destroypsuList(ss_dst[node]); + if (cs_src) + { + if (cs_src[node]) + destroypsuList(cs_src[node]); + if (cs_dst[node]) + destroypsuList(cs_dst[node]); + } + } + + delete[] ss_src; + delete[] ss_dst; + if (cs_src) + { + delete[] cs_src; + delete[] cs_dst; + } + + while (PatL) + { + ss_patch *sPp = PatL->data; + MyList *bg; + while (sPp->blb) + { + if (sPp->blb == sPp->ble) + break; + bg = (sPp->blb->next) ? sPp->blb->next : 0; + delete sPp->blb->data; + delete sPp->blb; + sPp->blb = bg; + } + if (sPp->ble) + { + delete sPp->ble->data; + delete sPp->ble; + } + sPp->blb = sPp->ble = 0; + PatL = PatL->next; + } + PatL->destroyList(); + + StateList->clearList(); + SynchList_pre->clearList(); + SynchList_cor->clearList(); + RHSList->clearList(); + OldStateList->clearList(); + DumpList->clearList(); + CheckList->clearList(); + + NewsList->clearList(); + + g01List->clearList(); + g00List->clearList(); + pg0AList->clearList(); + ThetaList->clearList(); + + delete gx; + delete gy; + delete gz; + + delete g00; + delete g01; + delete p02; + delete p03; + delete g02; + delete g03; + delete Theta22; + delete Theta23; + delete Theta33; + + delete g22o; + delete g23o; + delete g33o; + delete g220; + delete g230; + delete g330; + delete g22; + delete g23; + delete g33; + delete g221; + delete g231; + delete g331; + delete g22_rhs; + delete g23_rhs; + delete g33_rhs; + + delete RNews; + delete INews; + delete omega; + delete dtomega; + + for (int ii = 0; ii < 1; ii++) + delete[] g01wt[ii]; + delete[] g01wt; + for (int ii = 0; ii < 4; ii++) + delete[] pg0Awt[ii]; + delete[] pg0Awt; + for (int ii = 0; ii < 1; ii++) + delete[] g00wt[ii]; + delete[] g00wt; + for (int ii = 0; ii < 3; ii++) + delete[] Thetawt[ii]; + delete[] Thetawt; +} +double NullShellPatch2::getdX(int dir) +{ + if (dir < 0 || dir >= dim) + { + cout << "NullShellPatch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double h; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (shape[dir] == 1) + { + cout << "NullShellPatch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (dir < 2) + h = PI / 2 / (shape[dir] - 1); + else + h = (xmax - xmin) / (shape[dir] - 1); +#else +#ifdef Cell + if (dir < 2) + h = PI / 2 / shape[dir]; + else + h = (xmax - xmin) / shape[dir]; +#else +#error Not define Vertex nor Cell +#endif +#endif + return h; +} +void NullShellPatch2::destroypsuList(MyList *ct) +{ + MyList *n; + while (ct) + { + n = ct->next; + if (ct->data->coef) + { + delete[] ct->data->coef; + delete[] ct->data->sind; + } + delete ct->data; + delete ct; + ct = n; + } +} +void NullShellPatch2::shellname(char *sn, int i) +{ + switch (i) + { + case 0: + sprintf(sn, "zp"); + return; + case 1: + sprintf(sn, "zm"); + return; + case 2: + sprintf(sn, "xp"); + return; + case 3: + sprintf(sn, "xm"); + return; + case 4: + sprintf(sn, "yp"); + return; + case 5: + sprintf(sn, "ym"); + return; + } +} +MyList *NullShellPatch2::compose_sh(int cpusize) +{ + if (dim != 3) + { + cout << "distrivute: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + // checkPatch(); + + MyList *BlL = 0; + + int split_size, min_size, block_size = 0; + + int min_width = 2 * Mymax(ghost_width, buffer_width); + int nxy[2], mmin_width[2], min_shape[2]; + + MyList *PLi = PatL; + for (int i = 0; i < 2; i++) + min_shape[i] = PLi->data->shape[i]; + PLi = PLi->next; + while (PLi) + { + ss_patch *PP = PLi->data; + for (int i = 0; i < 2; i++) + min_shape[i] = Mymin(min_shape[i], PP->shape[i]); + PLi = PLi->next; + } + + for (int i = 0; i < 2; i++) + mmin_width[i] = Mymin(min_width, min_shape[i]); + + min_size = mmin_width[0]; + for (int i = 1; i < 2; i++) + min_size = min_size * mmin_width[i]; + + PLi = PatL; + while (PLi) + { + ss_patch *PP = PLi->data; + // PP->checkPatch(true); + int bs = PP->shape[0]; + for (int i = 1; i < 2; i++) + bs = bs * PP->shape[i]; + block_size = block_size + bs; + PLi = PLi->next; + } + split_size = Mymax(min_size, block_size / cpusize); + split_size = Mymax(1, split_size); + + int n_rank = 0; + PLi = PatL; + int reacpu = 0; + while (PLi) + { + ss_patch *PP = PLi->data; + + reacpu += Parallel::partition2(nxy, split_size, mmin_width, cpusize, PP->shape); // r direction can not be splitted!! It's ode! + + Block *ng; + int shape_here[3], ibbox_here[2 * 2]; + double bbox_here[2 * 3], dd; + + // ibbox : 0,...N-1 + for (int i = 0; i < nxy[0]; i++) + for (int j = 0; j < nxy[1]; j++) + { + ibbox_here[0] = (PP->shape[0] * i) / nxy[0]; + ibbox_here[2] = (PP->shape[0] * (i + 1)) / nxy[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxy[1]; + ibbox_here[3] = (PP->shape[1] * (j + 1)) / nxy[1] - 1; + + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[2] = Mymin(PP->shape[0] - 1, ibbox_here[2] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[1] - 1, ibbox_here[3] + ghost_width); + + shape_here[0] = ibbox_here[2] - ibbox_here[0] + 1; + shape_here[1] = ibbox_here[3] - ibbox_here[1] + 1; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[2] * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[3] * dd; +#else +#ifdef Cell + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[2] + 1) * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[3] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + shape_here[2] = PP->shape[2]; + bbox_here[2] = PP->bbox[2]; + bbox_here[5] = PP->bbox[5]; + ng = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs, 0); // delete through KillBlocks + // ng->checkBlock(); + if (n_rank == cpusize) + n_rank = 0; + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks + + // set PP->blb + if (i == 0 && j == 0) + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; + PP->blb = Bp; + } + } + // set PP->ble + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; + PP->ble = Bp; + } + PLi = PLi->next; + } + if (reacpu < cpusize * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "NullShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << cpusize << " cpus run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} +void NullShellPatch2::Dump_Data(MyList *DumpListi, char *tag, double time, double dT) +{ + MyList *PP = PatL; + while (PP) + { + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); + if (!databuffer) + { + cout << "NullShellPatch::Dump_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *DumpList = DumpListi; + while (DumpList) + { + var *VP = DumpList->data; + + MyList *Bp = PP->data->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->data->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + char filename[100]; + char sn[3]; + shellname(sn, PP->data->sst); + if (tag) + sprintf(filename, "%s_LevSH-%s_%s_%05d.bin", tag, sn, VP->name, ncount); + else + sprintf(filename, "LevSH-%s_%s_%05d.bin", sn, VP->name, ncount); + + Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], + PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], + PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); + } + DumpList = DumpList->next; + } + + if (myrank == 0) + free(databuffer); + + PP = PP->next; + } +} +// Now we dump the data including overlap points +void NullShellPatch2::Dump_xyz(char *tag, double time, double dT) +{ + MyList *DumpListi = 0; + DumpListi = new MyList(gx); + DumpListi->insert(gy); + DumpListi->insert(gz); + Dump_Data(DumpListi, tag, time, dT); + DumpListi->clearList(); +} +// setup interpatch interpolation stuffs +void NullShellPatch2::setupintintstuff(int cpusize, MyList *CPatL, int Symmetry) +{ + const int hCS_width = 0; // do not input data from null shell to box + const int hSC_width = 1; // do input data from box to null shell + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "NullShellPatch2::setupintintstuff begines..." << endl; + + ss_src = new MyList *[cpusize]; + ss_dst = new MyList *[cpusize]; + + if (!CPatL) // if characteristic evolve alone + { + cs_src = 0; + cs_dst = 0; + } + else + { + cs_src = new MyList *[cpusize]; + cs_dst = new MyList *[cpusize]; + } + + MyList *ps, *ts; + MyList *sPp; + MyList *Bgl; + MyList *Pp; + Block *Bg; + double CDH[dim], DH[dim], llb[dim], uub[dim]; + double x, y, z; + + for (int i = 0; i < dim; i++) + { + if (CPatL) + CDH[i] = CPatL->data->getdX(i); + DH[i] = getdX(i); + } + + for (int i = 0; i < cpusize; i++) + { + ss_src[i] = 0; + ss_dst[i] = 0; + if (CPatL) + { + cs_src[i] = 0; + cs_dst[i] = 0; + } + } + + sPp = PatL; + while (sPp) + { + for (int iz = 0; iz < sPp->data->shape[2]; iz++) + for (int is = 0; is < sPp->data->shape[1]; is++) + for (int ir = 0; ir < sPp->data->shape[0]; ir++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = sPp->data->bbox[0] + ir * DH[0]; + y = sPp->data->bbox[1] + is * DH[1]; + z = sPp->data->bbox[2] + iz * DH[2]; +#else +#ifdef Cell + x = sPp->data->bbox[0] + (ir + 0.5) * DH[0]; + y = sPp->data->bbox[1] + (is + 0.5) * DH[1]; + z = sPp->data->bbox[2] + (iz + 0.5) * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (CPatL && z < sPp->data->bbox[2] + (hSC_width + 0.0001) * DH[2]) + { + double gx, gy, gz; + getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); + bool flag = false; + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(cs_src[i], false, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i, iz); + if (flag) + break; + } + if (!flag) + { + CPatL->data->checkBlock(); + if (myrank == 0) + { + cout << "ShellPatch2::prolongpointstru fail to find cardisian source point for" << endl; + cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; + cout << "x,y,z = " << gx << "," << gy << "," << gz << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + if (x < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[0] || x > PI / 4 + (overghost - ghost_width - 0.0001) * DH[0] || + y < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[1] || y > PI / 4 + (overghost - ghost_width - 0.0001) * DH[1]) + { + double gx, gy, gz; + if (z < 1 - 0.0001 * DH[2]) + getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); + bool flag = true; + if (flag) + { + flag = false; + for (int i = 0; i < cpusize; i++) + { + if (z < 1 - 0.0001 * DH[2]) + flag = prolongpointstru(ss_src[i], true, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i, iz); + else + flag = prolongpointstru_ss(ss_src[i], sPp->data->sst, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i, iz); + if (flag) + break; + } + if (!flag) + { + if (myrank == 0) + { + // if you used Vertex grid please note x=1, try 0.999999 instead + cout << "NullShellPatch2::prolongpointstru fail to find shell source point for" << endl; + cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + } + sPp = sPp->next; + } + if (myrank == 0) + cout << "NullShellPatch2::setupintintstuff ss_src completes" << endl; + + Pp = CPatL; + while (Pp) + { + double llb[dim], uub[dim]; + if (Symmetry > 0) + llb[2] = Pp->data->bbox[2] - 0.0001 * CDH[2]; + else + llb[2] = Pp->data->bbox[2] + (hCS_width + 0.0001) * CDH[2]; + uub[2] = Pp->data->bbox[dim + 2] - (hCS_width + 0.0001) * CDH[2]; + for (int j = 0; j < 2; j++) + { + if (Symmetry > 1) + llb[j] = Pp->data->bbox[j] - 0.0001 * CDH[j]; + else + llb[j] = Pp->data->bbox[j] + (hCS_width + 0.0001) * CDH[j]; + uub[j] = Pp->data->bbox[dim + j] - (hCS_width + 0.0001) * CDH[j]; + } + for (int iz = 0; iz < Pp->data->shape[2]; iz++) + for (int iy = 0; iy < Pp->data->shape[1]; iy++) + for (int ix = 0; ix < Pp->data->shape[0]; ix++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = Pp->data->bbox[0] + ix * CDH[0]; + y = Pp->data->bbox[1] + iy * CDH[1]; + z = Pp->data->bbox[2] + iz * CDH[2]; +#else +#ifdef Cell + x = Pp->data->bbox[0] + (ix + 0.5) * CDH[0]; + y = Pp->data->bbox[1] + (iy + 0.5) * CDH[1]; + z = Pp->data->bbox[2] + (iz + 0.5) * CDH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (x < llb[0] || x > uub[0] || + y < llb[1] || y > uub[1] || + z < llb[2] || z > uub[2]) + { + int sst; + double lx, ly, lz; + bool flag = false; + getlocalpox(x, y, z, sst, lx, ly, lz); + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(cs_src[i], true, -1, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i, -1); + if (flag) + break; + } + if (!flag) + { + if (myrank == 0) + { + cout << "ShellPatch2::prolongpointstru fail to find shell source point for" << endl; + cout << "sst = -1, x,y,z = " << x << "," << y << "," << z << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + Pp = Pp->next; + } + if (myrank == 0) + if (CPatL) + cout << "NullShellPatch2::setupintintstuff cs_src completes" << endl; + else + cout << "NullShellPatch2::no cs_src exists" << endl; + + for (int i = 0; i < cpusize; i++) + { + ps = ss_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(ss_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + + if (CPatL) + { + ps = cs_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(cs_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + } + } + if (myrank == 0) + cout << "NullShellPatch2::setupintintstuff ss_dst and cs_dst complete" << endl; + + /* + for(int i=0;inext; + ts=ts->next; + } + } + exit(0); + */ +} +// lz is x instead of r +void NullShellPatch2::getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) +{ + double r; + r = sqrt(x * x + y * y + z * z); + lz = r / (r + Rmin); + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "NullShellPatch2::getlocalpox should not come here, something wrong" << endl; + } +} +// lz is x instead of r +// using fake global coordinates to get local coordinate +void NullShellPatch2::getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) +{ + double r; + r = sqrt(x * x + y * y + z * z); + lz = r; + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "NullShellPatch2::getlocalpox should not come here, something wrong" << endl; + } +} +// lz is x instead of r +// specially for usage from shell to shell +void NullShellPatch2::getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz) +{ + // fake global coordinate + double r = 1, x, y, z; + switch (isst) + { + case 0: + x = tan(ix); + y = tan(iy); + z = r / sqrt(1 + x * x + y * y); + x = z * x; + y = z * y; + break; + case 1: + x = tan(ix); + y = tan(iy); + z = -r / sqrt(1 + x * x + y * y); + x = z * x; + y = z * y; + break; + case 2: + y = tan(ix); + z = tan(iy); + x = r / sqrt(1 + z * z + y * y); + y = x * y; + z = x * z; + break; + case 3: + y = tan(ix); + z = tan(iy); + x = -r / sqrt(1 + z * z + y * y); + y = x * y; + z = x * z; + break; + case 4: + x = tan(ix); + z = tan(iy); + y = r / sqrt(1 + x * x + z * z); + x = y * x; + z = y * z; + break; + case 5: + x = tan(ix); + z = tan(iy); + y = -r / sqrt(1 + x * x + z * z); + x = y * x; + z = y * z; + break; + } + + // map with fake global coordinate + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "NullShellPatch2::getlocalpox should not come here, something wrong" << endl; + } + + lz = iz; + + // if(lx != lx) cout<data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + if (first_only) + return; + pp = pp->next; + } + } +} +// for check +// used by _dst construction, so these x,y,z must coinside with grid point +// we have considered ghost points now +void NullShellPatch2::prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], + MyList *Ppi, double CDH[dim], MyList *pss) +{ + int n_dst = 0; + MyList *sPp = sPpi; + MyList *Pp = Ppi; + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz, lsst; + + if (pss->data->tsst >= 0) + { + getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, + lx, ly, lz); + if (lx != lx) + getlocalpoxsst_ss(pss->data->ssst, pss->data->lpox[0], pss->data->lpox[1], pss->data->lpox[2], + pss->data->tsst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == pss->data->tsst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + { + for (int j = 0; j < dim; j++) + { + llb[j] = Bg->bbox[j]; + uub[j] = Bg->bbox[j + dim]; + } + + if (lx > llb[0] - 0.1 * DH[0] && lx < uub[0] + 0.1 * DH[0] && + ly > llb[1] - 0.1 * DH[1] && ly < uub[1] + 0.1 * DH[1] && + lz > llb[2] - 0.1 * DH[2] && lz < uub[2] + 0.1 * DH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = 0; + for (int i = 0; i < dim; i++) + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = pss->data->ssst; + ps->data->tsst = sPp->data->sst; + ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); + ps->data->Bg = Bg; + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->indz = pss->data->indz; + get_Jacob(ps->data->lpox, ps->data->tsst, ps->data->ssst, ps->data->Jacob); + if (psul) + psul->catList(ps); + else + psul = ps; + n_dst++; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + } + else + { + if (pss->data->tsst != -1) + cout << "somthing is wrong in NullShellPatch2::prolongpointstru" << endl; + lx = pss->data->gpox[0]; + ly = pss->data->gpox[1]; + lz = pss->data->gpox[2]; + while (Pp) + { + Bgl = Pp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + { + for (int j = 0; j < dim; j++) + { + llb[j] = Bg->bbox[j]; + uub[j] = Bg->bbox[j + dim]; + } + + if (lx > llb[0] - 0.1 * CDH[0] && lx < uub[0] + 0.1 * CDH[0] && + ly > llb[1] - 0.1 * CDH[1] && ly < uub[1] + 0.1 * CDH[1] && + lz > llb[2] - 0.1 * CDH[2] && lz < uub[2] + 0.1 * CDH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = 0; + for (int i = 0; i < dim; i++) + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = pss->data->ssst; + ps->data->tsst = -1; + ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); + ps->data->Bg = Bg; + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->indz = pss->data->indz; + for (int i = 0; i < 2; i++) + for (int j = 0; j < 2; j++) + ps->data->Jacob[i][j] = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + n_dst++; + } + } + if (Bgl == Pp->data->ble) + break; + Bgl = Bgl->next; + } + Pp = Pp->next; + } + } + // if n_dst > 0, that's because of ghost_points then prolong source list + if (n_dst == 0) + { + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "NullShellPatch2::prolongpointstru fail to find target Block for pointstru:" << endl; + check_pointstrul(pss, true); + if (Pp == Ppi) + { + getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, + lx, ly, lz); + if (myrank == 0) + cout << "sst = " << pss->data->tsst << ", lx,ly,lz = " << lx << "," << ly << "," << lz << endl; + checkBlock(pss->data->tsst); + } + else + { + Pp = Ppi; + while (Pp) + { + Pp->data->checkBlock(); + Pp = Pp->next; + } + } + if (myrank == 0) + MPI_Abort(MPI_COMM_WORLD, 1); + } + else + { + MyList *ts = 0; + for (int i = 1; i < n_dst; i++) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = (i == n_dst - 1) ? pss->next : 0; + for (int i = 0; i < dim; i++) + { + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[i] = pss->data->lpox[i]; + } + ps->data->ssst = pss->data->ssst; + ps->data->tsst = pss->data->tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->Bg = pss->data->Bg; + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->indz = pss->data->indz; + for (int i = 0; i < 2; i++) + for (int j = 0; j < 2; j++) + ps->data->Jacob[i][j] = pss->data->Jacob[i][j]; + if (ts) + ts->catList(ps); + else + ts = ps; + } + if (ts) + pss->next = ts; + } +} +// used by _src construction, so these x,y,z do not coinside with grid point +bool NullShellPatch2::prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, + const int iz) +{ + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz; + + if (ssyn) + { + int sst; + getlocalpox(x, y, z, sst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == sst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < 2; j++) + { + if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) + llb[j] = -PI / 4; + else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * DH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) + uub[j] = PI / 4; + else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; + } + if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) + llb[2] = Bg->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; +#else +#ifdef Cell + else + llb[2] = Bg->bbox[2] + ghost_width * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) + uub[2] = Bg->bbox[dim + 2]; + else + uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; + if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && + ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && + lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| + // ^ + // so for ^ point may miss for vertext center, so we use 0.0001 + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = x; + ps->data->gpox[1] = y; + ps->data->gpox[2] = z; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = sPp->data->sst; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->indz = iz; + for (int i = 0; i < 2; i++) + for (int j = 0; j < 2; j++) + ps->data->Jacob[i][j] = 0; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + } + else + { + while (Pp) + { + Bgl = Pp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < dim; j++) + { + if (feq(Bg->bbox[j], Pp->data->bbox[j], CDH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * CDH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * CDH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], Pp->data->bbox[dim + j], CDH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * CDH[j]; + } + if (x > llb[0] - 0.0001 * CDH[0] && x < uub[0] + 0.0001 * CDH[0] && + y > llb[1] - 0.0001 * CDH[1] && y < uub[1] + 0.0001 * CDH[1] && + z > llb[2] - 0.0001 * CDH[2] && z < uub[2] + 0.0001 * CDH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = x; + ps->data->gpox[1] = y; + ps->data->gpox[2] = z; + ps->data->lpox[0] = x; + ps->data->lpox[1] = y; + ps->data->lpox[2] = z; + ps->data->ssst = -1; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->indz = -1; + for (int i = 0; i < 2; i++) + for (int j = 0; j < 2; j++) + ps->data->Jacob[i][j] = 0; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == Pp->data->ble) + break; + Bgl = Bgl->next; + } + Pp = Pp->next; + } + } + + return false; +} +// used by _src construction, so these x,y,z do not coinside with grid point +// specially used from shell to shell +bool NullShellPatch2::prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, const int iz) +{ + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz; + + int sst; + getlocalpox_ss(tsst, x, y, z, sst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == sst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < 2; j++) + { + if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) + llb[j] = -PI / 4; + else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * DH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) + uub[j] = PI / 4; + else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; + } + if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) + llb[2] = Bg->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; +#else +#ifdef Cell + else + llb[2] = Bg->bbox[2] + ghost_width * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) + uub[2] = Bg->bbox[dim + 2]; + else + uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; + if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && + ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && + lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| + // ^ + // so for ^ point may miss for vertext center, so we use 0.0001 + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = 0; // global coordinate is not valid for r=infinity + ps->data->gpox[1] = 0; + ps->data->gpox[2] = 0; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = sPp->data->sst; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->data->indz = iz; + for (int i = 0; i < 2; i++) + for (int j = 0; j < 2; j++) + ps->data->Jacob[i][j] = 0; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + + return false; +} +// J[new][old] = d x_new/d x_old +void NullShellPatch2::get_Jacob(double *pox, int tsst, int ssst, double J[2][2]) +{ + double rn = pox[0], sn = pox[1], ro, so; + + double cosro, sinro, cosso, sinso; + if (tsst == 0 || tsst == 1) // z + { + if (ssst == 2 || ssst == 3) // x + { + ro = atan(tan(sn) / tan(rn)); + so = atan(1 / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = 0; + J[0][1] = -1; + J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[1][1] = -cosro * sinro / J[1][0]; + J[1][0] = cosso * sinso / J[1][0]; + } + else if (ssst == 4 || ssst == 5) // y + { + ro = atan(tan(rn) / tan(sn)); + so = atan(1 / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[0][1] = -cosro * sinro / J[0][0]; + J[0][0] = cosso * sinso / J[0][0]; + J[1][0] = 0; + J[1][1] = -1; + } + else + cout << "Error in NullShellPatch2::get_Jacob 1" << endl; + } + else if (tsst == 2 || tsst == 3) + { + if (ssst == 0 || ssst == 1) + { + ro = atan(1 / tan(sn)); + so = atan(tan(rn) / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[0][1] = cosro * sinro / J[0][0]; + J[0][0] = -cosso * sinso / J[0][0]; + J[1][0] = -1; + J[1][1] = 0; + } + else if (ssst == 4 || ssst == 5) + { + ro = atan(1 / tan(rn)); + so = atan(tan(sn) / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = -1; + J[0][1] = 0; + J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[1][1] = cosro * sinro / J[1][0]; + J[1][0] = -cosso * sinso / J[1][0]; + } + else + cout << "Error in NullShellPatch2::get_Jacob 2" << endl; + } + else if (tsst == 4 || tsst == 5) + { + if (ssst == 0 || ssst == 1) + { + ro = atan(tan(rn) / tan(sn)); + so = atan(1 / tan(sn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[0][1] = -cosro * sinro / J[0][0]; + J[0][0] = cosso * sinso / J[0][0]; + J[1][0] = 0; + J[1][1] = -1; + } + else if (ssst == 2 || ssst == 3) + { + ro = atan(1 / tan(rn)); + so = atan(tan(sn) / tan(rn)); + cosro = cos(ro); + sinro = sin(ro); + cosso = cos(so); + sinso = sin(so); + J[0][0] = -1; + J[0][1] = 0; + J[1][0] = cosso * cosso * sinro * sinro + cosro * cosro * sinso * sinso; + J[1][1] = cosro * sinro / J[1][0]; + J[1][0] = -cosso * sinso / J[1][0]; + } + else + cout << "Error in NullShellPatch2::get_Jacob 3" << endl; + } +} +int NullShellPatch2::getdumydimension(int acsst, int posst) // -1 means no dumy dimension +{ + int dms; + if (acsst == -1 || posst == -1) + return -1; + switch (acsst) + { + case 0: + case 1: + switch (posst) + { + case 0: + case 1: + cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + case 2: + case 3: + return 0; + case 4: + case 5: + return 1; + default: + cout << "error in NullShellPatch2::getdumydimension: posst = " << posst << endl; + return -1; + } + case 2: + case 3: + switch (posst) + { + case 0: + case 1: + return 1; + case 2: + case 3: + cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + case 4: + case 5: + return 0; + default: + cout << "error in NullShellPatch2::getdumydimension: posst = " << posst << endl; + return -1; + } + case 4: + case 5: + switch (posst) + { + case 0: + case 1: + return 1; + case 2: + case 3: + return 0; + case 4: + case 5: + cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + default: + cout << "error in NullShellPatch2::getdumydimension: posst = " << posst << endl; + return -1; + } + default: + cout << "error in NullShellPatch2::getdumydimension: acsst = " << acsst << endl; + return -1; + } +} +void NullShellPatch2::Synch(MyList *VarList, int Symmetry, double **Varwt, const short int svt) +{ + MyList *Pp = PatL; + while (Pp) + { + Pp->data->Sync(VarList, Symmetry); + Pp = Pp->next; + } + + // we need this before interpolation + if (Symmetry > 0) + fill_symmetric_boundarybuffer(VarList, Varwt); + + intertransfer(ss_src, ss_dst, VarList, VarList, Symmetry, Varwt, svt); + + // we need this here to correct conners + if (Symmetry > 0) + fill_symmetric_boundarybuffer(VarList, Varwt); +} +// Varwt: AoS of rho, sigma, x +void NullShellPatch2::fill_symmetric_boundarybuffer(MyList *VarList, double **Varwt) +{ + MyList *varl; + int ind; + double drho = getdX(0), dsigma = getdX(1); + + if (Symmetry == 0) + return; + else + { + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + varl = VarList; + ind = 0; + while (varl) + { + f_fill_symmetric_boundarybuffer2(cg->shape, cg->X[0], cg->X[1], cg->X[2], drho, dsigma, + cg->fgfs[varl->data->sgfn], + Symmetry, Pp->data->sst, Varwt[ind]); // defined in NullEvol2.f90 + varl = varl->next; + ind++; + } + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +} +void NullShellPatch2::intertransfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry, double **Varwt, const short int svt) +{ + int myrank, cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int node; + + MPI_Request *reqs; + MPI_Status *stats; + reqs = new MPI_Request[2 * cpusize]; + stats = new MPI_Status[2 * cpusize]; + int req_no = 0; + + double **send_data, **rec_data; + send_data = new double *[cpusize]; + rec_data = new double *[cpusize]; + int length; + + for (node = 0; node < cpusize; node++) + { + send_data[node] = rec_data[node] = 0; + if (node == myrank) + { + if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 1" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(rec_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt); + } + } + else + { + // send from this cpu to cpu#node + if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt)) + { + send_data[node] = new double[length]; + if (!send_data[node]) + { + cout << "out of memory when new in short transfer, place 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry, Varwt, svt); + MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + // receive from cpu#node to this cpu + if (length = interdata_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt, svt)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + } + } + // wait for all requests to complete + MPI_Waitall(req_no, reqs, stats); + + for (node = 0; node < cpusize; node++) + if (rec_data[node]) + interdata_packer(rec_data[node], src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry, Varwt, svt); + + for (node = 0; node < cpusize; node++) + { + if (send_data[node]) + delete[] send_data[node]; + if (rec_data[node]) + delete[] rec_data[node]; + } + + delete[] reqs; + delete[] stats; + delete[] send_data; + delete[] rec_data; +} +// PACK: prepare target data in 'data' +// UNPACK: copy target data from 'data' to corresponding numerical grids +int NullShellPatch2::interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, + const short int svt) +{ + int rev; + rev = interdata_packer_pre(data, src, dst, rank_in, dir, VarLists, VarListd, Symmetry, Varwt, svt); + if (dir == PACK) + return rev; + rev = interdata_packer_pot(data, src, dst, rank_in, dir, VarLists, VarListd, Symmetry, Varwt, svt); + return rev; +} +int NullShellPatch2::interdata_packer_pre(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, + const short int svt) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int DIM = dim; + int ordn = 2 * ghost_width; + + if (dir != PACK && dir != UNPACK) + { + cout << "error dir " << dir << " for data_packer " << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int size_out = 0; + + if (!src || !dst) + return size_out; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + while (src && dst) + { + if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || + (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) + { + varls = VarLists; + varld = VarListd; + int vind = 1; + bool flag = true; + while (varls && varld) + { + if (data) + { + if (dir == PACK) + { + int DIMh = (src->data->dumyd == -1) ? dim : 1; + if (src->data->coef == 0) + { + src->data->coef = new double[ordn * DIMh]; + src->data->sind = new int[dim]; + if (DIMh == 3) + { + for (int i = 0; i < DIMh; i++) + { + double dd = src->data->Bg->getdX(i); + // 0.001 instead of 0.4 makes the point locate more center + src->data->sind[i] = int((src->data->lpox[i] - src->data->Bg->X[i][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = src->data->Bg->X[i][0] + (src->data->sind[i] + j) * dd; + src->data->coef[i * ordn + j] = 1; + for (int k = 0; k < j; k++) + { + h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; + src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; + src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); + } + } + } + } + else + { + int actd = 1 - src->data->dumyd; + double dd = src->data->Bg->getdX(actd); + src->data->sind[0] = int((src->data->lpox[actd] - src->data->Bg->X[actd][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = src->data->Bg->X[actd][0] + (src->data->sind[0] + j) * dd; + src->data->coef[j] = 1; + for (int k = 0; k < j; k++) + { + h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; + src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; + src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); + } + } + src->data->sind[2] = int((src->data->lpox[2] - src->data->Bg->X[2][0]) / src->data->Bg->getdX(2) + 0.001); + if (!feq(src->data->Bg->X[2][src->data->sind[2]], src->data->lpox[2], src->data->Bg->getdX(2) / 2000)) + cout << "error in NullShellPatch::interdata_packer point = " << src->data->lpox[2] << " != grid " << src->data->Bg->X[2][src->data->sind[2]] << endl; + src->data->sind[1] = int((src->data->lpox[src->data->dumyd] - src->data->Bg->X[src->data->dumyd][0]) / + src->data->Bg->getdX(src->data->dumyd) + + 0.001); + if (!feq(src->data->Bg->X[src->data->dumyd][src->data->sind[1]], src->data->lpox[src->data->dumyd], src->data->Bg->getdX(src->data->dumyd) / 2000)) + cout << "error in NullShellPatch::interdata_packer for dumy dimension point = " + << src->data->lpox[src->data->dumyd] << " != grid " << src->data->Bg->X[src->data->dumyd][src->data->sind[1]] << endl; + } + } + // interpolate + switch (DIMh) + { + case 3: + f_global_interpind(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst); + break; + case 2: + f_global_interpind2d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst); + break; + case 1: + f_global_interpind1d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst, src->data->dumyd); + break; + default: + cout << "NullShellPatch2::interdata_packer: not recognized DIM = " << DIMh << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + if (dir == UNPACK) // from target data to corresponding grid + { + switch (svt) + { + case 1: // type(0,0) + vind = 0; + break; + case 2: // type(0,1) + { + if (vind / 2 * 2 == vind) + { + double tmp[2]; + double Jon[2][2]; + Jon[0][0] = dst->data->Jacob[0][0]; + Jon[0][1] = dst->data->Jacob[0][1]; + Jon[1][0] = dst->data->Jacob[1][0]; + Jon[1][1] = dst->data->Jacob[1][1]; + + tmp[0] = Jon[0][0] * Jon[1][1] - Jon[0][1] * Jon[1][0]; + tmp[1] = Jon[1][1] / tmp[0]; + Jon[0][1] = -Jon[0][1] / tmp[0]; + Jon[1][0] = -Jon[1][0] / tmp[0]; + Jon[1][1] = Jon[0][0] / tmp[0]; + Jon[0][0] = tmp[1]; + + tmp[0] = data[size_out - 1]; + tmp[1] = data[size_out]; + data[size_out - 1] = Jon[0][0] * tmp[0] + Jon[1][0] * tmp[1]; + data[size_out] = Jon[0][1] * tmp[0] + Jon[1][1] * tmp[1]; + + vind = 0; + } + break; + } + case 3: // symmetric type(0,2) + { + if (vind / 3 * 3 == vind) + { + double tmp[3]; + double Jon[2][2]; + Jon[0][0] = dst->data->Jacob[0][0]; + Jon[0][1] = dst->data->Jacob[0][1]; + Jon[1][0] = dst->data->Jacob[1][0]; + Jon[1][1] = dst->data->Jacob[1][1]; + tmp[0] = Jon[0][0] * Jon[1][1] - Jon[0][1] * Jon[1][0]; + tmp[1] = Jon[1][1] / tmp[0]; + Jon[0][1] = -Jon[0][1] / tmp[0]; + Jon[1][0] = -Jon[1][0] / tmp[0]; + Jon[1][1] = Jon[0][0] / tmp[0]; + Jon[0][0] = tmp[1]; + + tmp[0] = data[size_out - 2]; + tmp[1] = data[size_out - 1]; + tmp[2] = data[size_out]; + data[size_out - 2] = Jon[0][0] * Jon[0][0] * tmp[0] + 2 * Jon[1][0] * Jon[0][0] * tmp[1] + Jon[1][0] * Jon[1][0] * tmp[2]; + data[size_out - 1] = Jon[0][0] * Jon[0][1] * tmp[0] + (Jon[1][0] * Jon[0][1] + Jon[0][0] * Jon[1][1]) * tmp[1] + Jon[1][0] * Jon[1][1] * tmp[2]; + data[size_out] = Jon[0][1] * Jon[0][1] * tmp[0] + 2 * Jon[1][1] * Jon[0][1] * tmp[1] + Jon[1][1] * Jon[1][1] * tmp[2]; + + vind = 0; + } + break; + } + default: + { + cout << "NullShellPatch2::interdata_packer: not recognized svt = " << svt << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + size_out += 1; + vind += 1; + varls = varls->next; + varld = varld->next; + } + } + dst = dst->next; + src = src->next; + } + + return size_out; +} +int NullShellPatch2::interdata_packer_pot(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, + const short int svt) +{ + if (dir != UNPACK) + return 0; + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int DIM = dim; + int ordn = 2 * ghost_width; + + int size_out = 0; + + if (!src || !dst) + return size_out; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + while (src && dst) + { + if ((dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) + { + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + if (data) + { + if (dir == UNPACK) // from target data to corresponding grid + { + f_pointcopy(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], + dst->data->lpox[0], dst->data->lpox[1], dst->data->lpox[2], data[size_out]); + } + } + size_out += 1; + varls = varls->next; + varld = varld->next; + } + } + dst = dst->next; + src = src->next; + } + + return size_out; +} +void NullShellPatch2::Interp_Points_2D(MyList *VarList, + int NN, double **XX, /*input fake global Cartesian coordinate*/ + double *Shellf, int Symmetry) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[NN * num_var]; + memset(shellf, 0, sizeof(double) * NN * num_var); + + // we use weight to monitor code, later some day we can move it for optimization + int *weight; + weight = new int[NN]; + memset(weight, 0, sizeof(int) * NN); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + int sst; + getlocalpox_fake(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); // pox[2] is x indeed + + // int indZ=int((pox[2]-xmin)/DH[2]); + int indZ = shape[2]; // note we use index for Fortran + MyList *sPp = PatL; + while (sPp->data->sst != sst) + sPp = sPp->next; + + if (myrank == 0 && ((!sPp) || pox[2] < xmin - 0.0001 * DH[2] || pox[2] > xmax + 0.0001 * DH[2])) + { + cout << "NullShellPatch::Interp_Points: point gc = ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + } + if (sPp) + { + cout << ") sst = " << sst << " lc = ("; + for (int k = 0; k < dim; k++) + { + cout << pox[k]; + if (k < dim - 1) + cout << ","; + } + } + cout << ") is out of the NullShellPatch." << endl; + cout << "xmin = " << xmin << ", xmax = " << xmax << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (!sPp) + return; + + MyList *Bp = sPp->data->blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +// +// because of getlocalpox, pox will not goes into overghost region of ss_patch +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp_ss_2d(BP->shape, BP->X[0], BP->X[1], indZ, BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], + pox[0], pox[1], ordn, varl->data->SoA, Symmetry, sst); + varl = varl->next; + k++; + } + weight[j] = 1; + } + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + } + + MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + int *Weight; + Weight = new int[NN]; + MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + + for (int i = 0; i < NN; i++) + { + if (Weight[i] > 1) + { + if (myrank == 0) + cout << "WARNING: NullShellPatch::Interp_Points meets multiple weight" << endl; + for (int j = 0; j < num_var; j++) + Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; + } + else if (Weight[i] == 0 && myrank == 0) + { + cout << "ERROR: NullShellPatch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j][i]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on NullShellPatch (" << xmin << ":" << xmax << ")" << endl; + + cout << "splited domains:" << endl; + MyList *sPp = PatL; + while (sPp) + { + char sn[3]; + shellname(sn, sPp->data->sst); + cout << "ss_patch " << sn << ":" << endl; + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + delete[] shellf; + delete[] weight; + delete[] Weight; + delete[] DH; + delete[] llb; + delete[] uub; +} diff --git a/AMSS_NCKU_source/NullShellPatch2.h b/AMSS_NCKU_source/Null_Evolve/NullShellPatch2.h similarity index 97% rename from AMSS_NCKU_source/NullShellPatch2.h rename to AMSS_NCKU_source/Null_Evolve/NullShellPatch2.h index df132ff..04c09c8 100644 --- a/AMSS_NCKU_source/NullShellPatch2.h +++ b/AMSS_NCKU_source/Null_Evolve/NullShellPatch2.h @@ -1,183 +1,183 @@ - -#ifndef NULLSHELLPATCH2_H -#define NULLSHELLPATCH2_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#include -#endif - -#include -#include "MyList.h" -#include "Block.h" -#include "Parallel.h" -#include "ShellPatch.h" -#include "var.h" -#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width - -#if (dim != 3) -#error NullShellPatch2 only supports 3 dimensional stuff yet -#endif - -// x x x x x o * -// * o x x x x x -// each side contribute an overlap points -// so we need half of that -#define overghost ((ghost_width + 1) / 2 + ghost_width) - -class NullShellPatch2 -{ - - class xp_npatch : public ss_patch - { - public: - xp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 2; }; - }; - - class xm_npatch : public ss_patch - { - public: - xm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 3; }; - }; - class yp_npatch : public ss_patch - { - public: - yp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 4; }; - }; - - class ym_npatch : public ss_patch - { - public: - ym_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 5; }; - }; - class zp_npatch : public ss_patch - { - public: - zp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 0; }; - }; - - class zm_npatch : public ss_patch - { - public: - zm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 1; }; - }; - -public: - struct pointstru - { - double gpox[dim]; // global cordinate - double lpox[dim]; // local cordinate - Block *Bg; - int ssst; //-1: cardisian, others as sst of ss_patch source sst - int tsst; //-1: cardisian, others as sst of ss_patch target sst - double *coef; - int *sind; // index position, considered dummy dimension already - int dumyd; // the dimension which has common lines, only useful in interdata_packer - double Jacob[2][2]; - int indz; // index position of r direction - }; - - var *gx, *gy, *gz; - // surface variable - var *g00, *g01, *p02, *p03, *g02, *g03; - var *Theta22, *Theta23, *Theta33; - - // evolution variables - var *g22o, *g23o, *g33o; - var *g220, *g230, *g330; - var *g22, *g23, *g33; - var *g221, *g231, *g331; - var *g22_rhs, *g23_rhs, *g33_rhs; - - var *RNews, *INews; - var *omega, *dtomega; - - MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; - MyList *OldStateList, *DumpList, *CheckList; - MyList *NewsList; - - MyList *g01List, *pg0AList, *g00List, *ThetaList; - - double **g01wt, **pg0Awt, **g00wt, **Thetawt; - - int myrank; - int shape[dim]; // for (rho, sigma, X), for rho and sigma means number of points for every pi/2 - double Rmin, xmin, xmax; - int Symmetry; - int ingfs, fngfs; - - MyList *PatL; - - MyList **ss_src, **ss_dst; - MyList **cs_src, **cs_dst; - -public: - NullShellPatch2(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetry, int myranki); - - ~NullShellPatch2(); - - double getdX(int dir); - void shellname(char *sn, int i); - void destroypsuList(MyList *ct); - MyList *compose_sh(int cpusize); - void Dump_xyz(char *tag, double time, double dT); - void Dump_Data(MyList *DumpListi, char *tag, double time, double dT); - void setupintintstuff(int cpusize, MyList *CPatL, int Symmetry); - void getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz); - void getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); - void getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); - void getlocalpoxsst_ss(int isst, double ix, double iy, double iz, int lsst, double &lx, double &ly, double &lz); - void getlocalpoxsst(double x, double y, double z, int sst, double &lx, double &ly, double &lz); - void getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz); - int getdumydimension(int acsst, int posst); - void get_Jacob(double *pox, int tsst, int ssst, double J[2][2]); - void prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], - MyList *Ppi, double CDH[dim], MyList *pss); - bool prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, const int iz); - bool prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, const int iz); - void Setup_Initial_Data(bool checkrun, double PhysTime); - void Step(double dT, double PhysTime, monitor *ErrorMonitor); - void HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count); - void Synch(MyList *VarList, int Symmetry, double **Varwt, const short int svt); - void fill_symmetric_boundarybuffer(MyList *VarList, double **Varwt); - void intertransfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry, double **Varwt, const short int svt); - int interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, - const short int svt); - int interdata_packer_pre(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, - const short int svt); - int interdata_packer_pot(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, - const short int svt); - void check_pointstrul(MyList *pp, bool first_only); - void checkBlock(int sst); - void Null_Boundary(double PhysTime); - void Compute_News(double PhysTime); - void Interp_Points_2D(MyList *VarList, - int NN, double **XX, /*input fake global Cartesian coordinate*/ - double *Shellf, int Symmetry); - double Error_Check(double PhysTime); -}; - -#endif /* NULLSHELLPATCH2_H */ + +#ifndef NULLSHELLPATCH2_H +#define NULLSHELLPATCH2_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#include +#include "MyList.h" +#include "Block.h" +#include "Parallel.h" +#include "ShellPatch.h" +#include "var.h" +#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width + +#if (dim != 3) +#error NullShellPatch2 only supports 3 dimensional stuff yet +#endif + +// x x x x x o * +// * o x x x x x +// each side contribute an overlap points +// so we need half of that +#define overghost ((ghost_width + 1) / 2 + ghost_width) + +class NullShellPatch2 +{ + + class xp_npatch : public ss_patch + { + public: + xp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 2; }; + }; + + class xm_npatch : public ss_patch + { + public: + xm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 3; }; + }; + class yp_npatch : public ss_patch + { + public: + yp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 4; }; + }; + + class ym_npatch : public ss_patch + { + public: + ym_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 5; }; + }; + class zp_npatch : public ss_patch + { + public: + zp_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 0; }; + }; + + class zm_npatch : public ss_patch + { + public: + zm_npatch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 1; }; + }; + +public: + struct pointstru + { + double gpox[dim]; // global cordinate + double lpox[dim]; // local cordinate + Block *Bg; + int ssst; //-1: cardisian, others as sst of ss_patch source sst + int tsst; //-1: cardisian, others as sst of ss_patch target sst + double *coef; + int *sind; // index position, considered dummy dimension already + int dumyd; // the dimension which has common lines, only useful in interdata_packer + double Jacob[2][2]; + int indz; // index position of r direction + }; + + var *gx, *gy, *gz; + // surface variable + var *g00, *g01, *p02, *p03, *g02, *g03; + var *Theta22, *Theta23, *Theta33; + + // evolution variables + var *g22o, *g23o, *g33o; + var *g220, *g230, *g330; + var *g22, *g23, *g33; + var *g221, *g231, *g331; + var *g22_rhs, *g23_rhs, *g33_rhs; + + var *RNews, *INews; + var *omega, *dtomega; + + MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; + MyList *OldStateList, *DumpList, *CheckList; + MyList *NewsList; + + MyList *g01List, *pg0AList, *g00List, *ThetaList; + + double **g01wt, **pg0Awt, **g00wt, **Thetawt; + + int myrank; + int shape[dim]; // for (rho, sigma, X), for rho and sigma means number of points for every pi/2 + double Rmin, xmin, xmax; + int Symmetry; + int ingfs, fngfs; + + MyList *PatL; + + MyList **ss_src, **ss_dst; + MyList **cs_src, **cs_dst; + +public: + NullShellPatch2(int *shapei, double Rmini, double xmini, double xmaxi, int Symmetry, int myranki); + + ~NullShellPatch2(); + + double getdX(int dir); + void shellname(char *sn, int i); + void destroypsuList(MyList *ct); + MyList *compose_sh(int cpusize); + void Dump_xyz(char *tag, double time, double dT); + void Dump_Data(MyList *DumpListi, char *tag, double time, double dT); + void setupintintstuff(int cpusize, MyList *CPatL, int Symmetry); + void getlocalpox_ss(int isst, double ix, double iy, double iz, int &sst, double &lx, double &ly, double &lz); + void getlocalpox_fake(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); + void getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz); + void getlocalpoxsst_ss(int isst, double ix, double iy, double iz, int lsst, double &lx, double &ly, double &lz); + void getlocalpoxsst(double x, double y, double z, int sst, double &lx, double &ly, double &lz); + void getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz); + int getdumydimension(int acsst, int posst); + void get_Jacob(double *pox, int tsst, int ssst, double J[2][2]); + void prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], + MyList *Ppi, double CDH[dim], MyList *pss); + bool prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, const int iz); + bool prolongpointstru_ss(MyList *&psul, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in, const int iz); + void Setup_Initial_Data(bool checkrun, double PhysTime); + void Step(double dT, double PhysTime, monitor *ErrorMonitor); + void HyperSlice(double dT, double PhysTime, monitor *ErrorMonitor, int RK_count); + void Synch(MyList *VarList, int Symmetry, double **Varwt, const short int svt); + void fill_symmetric_boundarybuffer(MyList *VarList, double **Varwt); + void intertransfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry, double **Varwt, const short int svt); + int interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, + const short int svt); + int interdata_packer_pre(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, + const short int svt); + int interdata_packer_pot(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry, double **Varwt, + const short int svt); + void check_pointstrul(MyList *pp, bool first_only); + void checkBlock(int sst); + void Null_Boundary(double PhysTime); + void Compute_News(double PhysTime); + void Interp_Points_2D(MyList *VarList, + int NN, double **XX, /*input fake global Cartesian coordinate*/ + double *Shellf, int Symmetry); + double Error_Check(double PhysTime); +}; + +#endif /* NULLSHELLPATCH2_H */ diff --git a/AMSS_NCKU_source/NullShellPatch2_Evo.C b/AMSS_NCKU_source/Null_Evolve/NullShellPatch2_Evo.C similarity index 96% rename from AMSS_NCKU_source/NullShellPatch2_Evo.C rename to AMSS_NCKU_source/Null_Evolve/NullShellPatch2_Evo.C index adf7818..e07b52b 100644 --- a/AMSS_NCKU_source/NullShellPatch2_Evo.C +++ b/AMSS_NCKU_source/Null_Evolve/NullShellPatch2_Evo.C @@ -1,1036 +1,1036 @@ - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "NullShellPatch2.h" -#include "Parallel.h" -#include "fmisc.h" -#include "misc.h" -#include "shellfunctions.h" -#include "NullEvol.h" -#include "NullNews.h" -#include "initial_null2.h" -#include "rungekutta4_rout.h" -#include "kodiss.h" - -#define PI M_PI - -#if 0 -// for RT -void NullShellPatch2::Setup_Initial_Data(bool checkrun,double PhysTime) -{ - if(checkrun) - { - } - else - { - MyList *Pp=PatL; - while(Pp) - { - MyList *BL=Pp->data->blb; - while(BL) - { - Block *cg=BL->data; - if(myrank == cg->rank) - { - f_get_initial_null2(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - Pp->data->sst,Rmin); -// for Theta_AB - f_get_gauge_g00_K(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], - cg->fgfs[g00->sgfn],Rmin); - } - if(BL == Pp->data->ble) break; - BL=BL->next; - } - Pp=Pp->next; - } -//Synchronize K - Synch(g00List,Symmetry,g00wt,1); - Pp=PatL; - int IONE=1; - while(Pp) - { - MyList *BP=Pp->data->blb; - int fngfs = Pp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - f_get_gauge_g00(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], - cg->fgfs[g00->sgfn],Rmin,IONE); - } - if(BP==Pp->data->ble) break; - BP=BP->next; - } - Pp=Pp->next; - } - Synch(ThetaList,Symmetry,Thetawt,3); - } -} -#else -void NullShellPatch2::Setup_Initial_Data(bool checkrun, double PhysTime) -{ - if (checkrun) - { - } - else - { - MyList *Pp = PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_null3(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], - Pp->data->sst, Rmin); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -} -#endif -void NullShellPatch2::Step(double dT, double PhysTime, monitor *ErrorMonitor) -{ - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - double TT = PhysTime; - double neps = -0.05; - MyList *sPp; - - // Predictor - HyperSlice(dT, TT, ErrorMonitor, iter_count); - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - // rhs calculation - f_array_copy(cg->shape, cg->fgfs[g22_rhs->sgfn], cg->fgfs[Theta22->sgfn]); - f_array_copy(cg->shape, cg->fgfs[g23_rhs->sgfn], cg->fgfs[Theta23->sgfn]); - f_array_copy(cg->shape, cg->fgfs[g33_rhs->sgfn], cg->fgfs[Theta33->sgfn]); - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g220->sgfn], cg->fgfs[g22_rhs->sgfn], - Thetawt[0], Symmetry, neps, sPp->data->sst); - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g230->sgfn], cg->fgfs[g23_rhs->sgfn], - Thetawt[1], Symmetry, neps, sPp->data->sst); - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g330->sgfn], cg->fgfs[g33_rhs->sgfn], - Thetawt[2], Symmetry, neps, sPp->data->sst); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g220->sgfn], cg->fgfs[g22->sgfn], cg->fgfs[g22_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g230->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g23_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g330->sgfn], cg->fgfs[g33->sgfn], cg->fgfs[g33_rhs->sgfn], - iter_count); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - Synch(SynchList_pre, Symmetry, Thetawt, 3); - // Synch(SynchList_pre,Symmetry,g00wt,1); - - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TT += dT / 2; - HyperSlice(dT, TT, ErrorMonitor, iter_count); - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - // rhs calculation - f_array_copy(cg->shape, cg->fgfs[g221->sgfn], cg->fgfs[Theta22->sgfn]); - f_array_copy(cg->shape, cg->fgfs[g231->sgfn], cg->fgfs[Theta23->sgfn]); - f_array_copy(cg->shape, cg->fgfs[g331->sgfn], cg->fgfs[Theta33->sgfn]); - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g22->sgfn], cg->fgfs[g221->sgfn], - Thetawt[0], Symmetry, neps, sPp->data->sst); - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g23->sgfn], cg->fgfs[g231->sgfn], - Thetawt[1], Symmetry, neps, sPp->data->sst); - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g33->sgfn], cg->fgfs[g331->sgfn], - Thetawt[2], Symmetry, neps, sPp->data->sst); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g220->sgfn], cg->fgfs[g221->sgfn], cg->fgfs[g22_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g230->sgfn], cg->fgfs[g231->sgfn], cg->fgfs[g23_rhs->sgfn], - iter_count); - f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g330->sgfn], cg->fgfs[g331->sgfn], cg->fgfs[g33_rhs->sgfn], - iter_count); - } - if (iter_count < 3) - cg->swapList(SynchList_cor, SynchList_pre, myrank); - else - { - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - if (iter_count < 3) - Synch(SynchList_pre, Symmetry, Thetawt, 3); - else - Synch(StateList, Symmetry, Thetawt, 3); - // if( iter_count < 3 ) Synch(SynchList_pre,Symmetry,g00wt,1); - // else Synch(StateList,Symmetry,g00wt,1); - } -} -// really ODEs, so we do not need Synch in this routine at all -#if 0 -void NullShellPatch2::HyperSlice(double dT,double PhysTime,monitor *ErrorMonitor,int RK_count) -{ - int ERROR=0; - Null_Boundary(PhysTime); -#if 1 - MyList *sPp; - -// evolve g01 - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - if(RK_count==0) - { - if(f_NullEvol_g01(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[g01->sgfn],Rmin)) - { - cout<<"find NaN of g01 in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], - cg->fgfs[g01->sgfn],Rmin)) - { - cout<<"find NaN of g01 in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - Synch(g01List,Symmetry,g01wt,1); - if(RK_count==3) Dump_Data(g01List,0,PhysTime,dT); -//check error information - {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } - if(ERROR) - { - if(RK_count==0) Dump_Data(StateList,0,PhysTime,dT); - else Dump_Data(SynchList_pre,0,PhysTime,dT); - if(myrank == 0) - { - if(ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], - cg->fgfs[g01->sgfn], - cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], - cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn],Rmin)) - { - cout<<"find NaN of pg0A in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - Synch(pg0AList,Symmetry,pg0Awt,2); - if(RK_count==3) Dump_Data(pg0AList,0,PhysTime,dT); -//check error information - {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } - if(ERROR) - { - Dump_Data(g01List,0,PhysTime,dT); - if(myrank == 0) - { - if(ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], - cg->fgfs[g00->sgfn],cg->fgfs[g01->sgfn], - cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn], - cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn],Rmin)) - { - cout<<"find NaN of ThetaAB in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - Synch(ThetaList,Symmetry,Thetawt,3); - if(RK_count==3) Dump_Data(ThetaList,0,PhysTime,dT); -//check error information - {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } - if(ERROR) - { - Dump_Data(pg0AList,0,PhysTime,dT); - if(myrank == 0) - { - if(ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], - cg->fgfs[g00->sgfn],cg->fgfs[g01->sgfn], - cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn], - cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn],Rmin)) - { - cout<<"find NaN of ThetaAB in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," - <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - Synch(ThetaList,Symmetry,Thetawt,3); - if(RK_count==3) Dump_Data(ThetaList,0,PhysTime,dT); - Synch(g00List,Symmetry,g00wt,1); - if(RK_count==3) Dump_Data(g00List,0,PhysTime,dT); -//check error information - {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } - if(ERROR) - { - Dump_Data(pg0AList,0,PhysTime,dT); - if(myrank == 0) - { - if(ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_g01(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], - cg->fgfs[g01->sgfn], Rmin)) - { - cout << "find NaN of g01 in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - Synch(g01List, Symmetry, g01wt, 1); - // if(RK_count==3) Dump_Data(g01List,0,PhysTime,dT); - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - if (RK_count == 0) - Dump_Data(StateList, 0, PhysTime, dT); - else - Dump_Data(SynchList_pre, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // evolve p02, p03, g02 and g03 - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_pg0A(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], - cg->fgfs[g01->sgfn], - cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], - cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], Rmin)) - { - cout << "find NaN of pg0A in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_pg0A(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], - cg->fgfs[g01->sgfn], - cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], - cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], Rmin)) - { - cout << "find NaN of pg0A in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - Synch(pg0AList, Symmetry, pg0Awt, 2); - // if(RK_count==3) Dump_Data(pg0AList,0,PhysTime,dT); - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(g01List, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - // for gauge variable g00 - { - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_g00_with_t(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g00->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // if(RK_count==3) Dump_Data(g00List,0,PhysTime,dT); - } - // evolve ThetaAB - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (RK_count == 0) - { - if (f_NullEvol_Theta2(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], - cg->fgfs[g00->sgfn], cg->fgfs[g01->sgfn], - cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], - cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], - cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin)) - { - cout << "find NaN of ThetaAB in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - else - { - if (f_NullEvol_Theta2(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], - cg->fgfs[g00->sgfn], cg->fgfs[g01->sgfn], - cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], - cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], - cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin)) - { - cout << "find NaN of ThetaAB in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - Synch(ThetaList, Symmetry, Thetawt, 3); - // if(RK_count==3) Dump_Data(ThetaList,0,PhysTime,dT); - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Dump_Data(pg0AList, 0, PhysTime, dT); - if (myrank == 0) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - else - cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -} -#endif -#if 0 -void NullShellPatch2::Null_Boundary(double PhysTime) -{ - MyList *sPp; - - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - f_get_null_boundary2(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], - cg->fgfs[g01->sgfn], - cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], - cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn],Rmin); -// for Theta_AB - f_get_gauge_g00_K(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], - cg->fgfs[g00->sgfn],Rmin); - } - if(BP==sPp->data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } -// boundary for Theta_AB -//Synchronize K - Synch(g00List,Symmetry,g00wt,1); - sPp=PatL; - int IZEO=1; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - f_get_gauge_g00(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], - cg->fgfs[g00->sgfn],Rmin,IZEO); - } - if(BP==sPp->data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } - Synch(ThetaList,Symmetry,Thetawt,3); - //Synch(ThetaList,Symmetry,g00wt,1); -// boundary condition is independent of angular direction, do not need synch -// Synch(pg0AList,Symmetry,pg0Awt,2,-1); -// Synch(g00List,Symmetry,g00wt,1,-1); -// Synch(ThetaList,Symmetry,Thetawt,3,-1); -} -#else -void NullShellPatch2::Null_Boundary(double PhysTime) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary3(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], - cg->fgfs[g01->sgfn], - cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], - cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], - cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - /* - // check Synch - Synch(g01List,Symmetry,g01wt,1); - Dump_Data(g01List,0,PhysTime,1); - Synch(pg0AList,Symmetry,pg0Awt,2); - Dump_Data(pg0AList,0,PhysTime,1); - Synch(StateList,Symmetry,Thetawt,3); - Dump_Data(StateList,0,PhysTime,1); - Synch(ThetaList,Symmetry,Thetawt,3); - Dump_Data(ThetaList,0,PhysTime,1); - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - */ -} -// 0: real L2 norm; 1: root mean squar -#define L2m 0 -double NullShellPatch2::Error_Check(double PhysTime) -{ - MyList *sPp; - - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_boundary3(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[g221->sgfn], cg->fgfs[g231->sgfn], cg->fgfs[g331->sgfn], - cg->fgfs[g01->sgfn], - cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], - cg->fgfs[g22_rhs->sgfn], cg->fgfs[g03->sgfn], - cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - double tvf, dtvf = 0; - int tN, dtN = 0; - int BDW = ghost_width, OBDW = overghost; - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_array_subtract(cg->shape, cg->fgfs[g22_rhs->sgfn], cg->fgfs[g02->sgfn]); -#if (L2m == 0) - f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[g22_rhs->sgfn], tvf, BDW, OBDW, Symmetry); -#elif (L2m == 1) - f_l2normhelper_sh_rms(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[g22_rhs->sgfn], tvf, BDW, OBDW, Symmetry, dtN); - dtN += dtN; -#endif - - dtvf += tvf; - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - // Dump_Data(RHSList,0,PhysTime,1); - // Dump_Data(ThetaList,0,PhysTime,1); - // if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); -#if (L2m == 0) - tvf = sqrt(tvf); -#elif (L2m == 1) - MPI_Allreduce(&dtN, &tN, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - tvf = sqrt(tvf / tN); -#endif - - return tvf; -} -#undef L2m -#endif - -void NullShellPatch2::Compute_News(double PhysTime) -{ - MyList *sPp; - -// get omega and dtomega -// for RT -#if 0 - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - f_get_omega_and_dtomega_pre(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[omega->sgfn],cg->fgfs[dtomega->sgfn],Rmin); - } - if(BP==sPp->data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } -// Synch - { - MyList * DG_List; - DG_List=new MyList(omega); - Synch(DG_List,Symmetry,g00wt,1); - DG_List->clearList(); - DG_List=new MyList(dtomega); - Synch(DG_List,Symmetry,g00wt,1); - DG_List->clearList(); - } -// get dtomega - sPp=PatL; - while(sPp) - { - MyList *BP=sPp->data->blb; - int fngfs = sPp->data->fngfs; - while(BP) - { - Block *cg=BP->data; - if(myrank == cg->rank) - { - f_get_dtomega(cg->shape,cg->X[0],cg->X[1],cg->X[2], - cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], - cg->fgfs[omega->sgfn],cg->fgfs[dtomega->sgfn],Rmin); - } - if(BP==sPp->data->ble) break; - BP=BP->next; - } - sPp=sPp->next; - } -// Synch - { - MyList * DG_List; - DG_List=new MyList(dtomega); - Synch(DG_List,Symmetry,g00wt,1); - DG_List->clearList(); - } -#else - // for linear wave - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_omega_and_dtomega_LN(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega->sgfn], cg->fgfs[dtomega->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - // Synch - { - MyList *DG_List; - DG_List = new MyList(omega); - Synch(DG_List, Symmetry, g00wt, 1); - DG_List->clearList(); - DG_List = new MyList(dtomega); - Synch(DG_List, Symmetry, g00wt, 1); - DG_List->clearList(); - } -#endif - // calculate News - sPp = PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_get_null_news2(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[omega->sgfn], cg->fgfs[dtomega->sgfn], - cg->fgfs[g00->sgfn], cg->fgfs[g01->sgfn], - cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], - cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], - cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], - cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -} + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "NullShellPatch2.h" +#include "Parallel.h" +#include "fmisc.h" +#include "misc.h" +#include "shellfunctions.h" +#include "NullEvol.h" +#include "NullNews.h" +#include "initial_null2.h" +#include "rungekutta4_rout.h" +#include "kodiss.h" + +#define PI M_PI + +#if 0 +// for RT +void NullShellPatch2::Setup_Initial_Data(bool checkrun,double PhysTime) +{ + if(checkrun) + { + } + else + { + MyList *Pp=PatL; + while(Pp) + { + MyList *BL=Pp->data->blb; + while(BL) + { + Block *cg=BL->data; + if(myrank == cg->rank) + { + f_get_initial_null2(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + Pp->data->sst,Rmin); +// for Theta_AB + f_get_gauge_g00_K(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], + cg->fgfs[g00->sgfn],Rmin); + } + if(BL == Pp->data->ble) break; + BL=BL->next; + } + Pp=Pp->next; + } +//Synchronize K + Synch(g00List,Symmetry,g00wt,1); + Pp=PatL; + int IONE=1; + while(Pp) + { + MyList *BP=Pp->data->blb; + int fngfs = Pp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + f_get_gauge_g00(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], + cg->fgfs[g00->sgfn],Rmin,IONE); + } + if(BP==Pp->data->ble) break; + BP=BP->next; + } + Pp=Pp->next; + } + Synch(ThetaList,Symmetry,Thetawt,3); + } +} +#else +void NullShellPatch2::Setup_Initial_Data(bool checkrun, double PhysTime) +{ + if (checkrun) + { + } + else + { + MyList *Pp = PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_null3(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], + Pp->data->sst, Rmin); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +} +#endif +void NullShellPatch2::Step(double dT, double PhysTime, monitor *ErrorMonitor) +{ + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + double TT = PhysTime; + double neps = -0.05; + MyList *sPp; + + // Predictor + HyperSlice(dT, TT, ErrorMonitor, iter_count); + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + // rhs calculation + f_array_copy(cg->shape, cg->fgfs[g22_rhs->sgfn], cg->fgfs[Theta22->sgfn]); + f_array_copy(cg->shape, cg->fgfs[g23_rhs->sgfn], cg->fgfs[Theta23->sgfn]); + f_array_copy(cg->shape, cg->fgfs[g33_rhs->sgfn], cg->fgfs[Theta33->sgfn]); + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g220->sgfn], cg->fgfs[g22_rhs->sgfn], + Thetawt[0], Symmetry, neps, sPp->data->sst); + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g230->sgfn], cg->fgfs[g23_rhs->sgfn], + Thetawt[1], Symmetry, neps, sPp->data->sst); + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g330->sgfn], cg->fgfs[g33_rhs->sgfn], + Thetawt[2], Symmetry, neps, sPp->data->sst); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g220->sgfn], cg->fgfs[g22->sgfn], cg->fgfs[g22_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g230->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g23_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g330->sgfn], cg->fgfs[g33->sgfn], cg->fgfs[g33_rhs->sgfn], + iter_count); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + Synch(SynchList_pre, Symmetry, Thetawt, 3); + // Synch(SynchList_pre,Symmetry,g00wt,1); + + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TT += dT / 2; + HyperSlice(dT, TT, ErrorMonitor, iter_count); + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + // rhs calculation + f_array_copy(cg->shape, cg->fgfs[g221->sgfn], cg->fgfs[Theta22->sgfn]); + f_array_copy(cg->shape, cg->fgfs[g231->sgfn], cg->fgfs[Theta23->sgfn]); + f_array_copy(cg->shape, cg->fgfs[g331->sgfn], cg->fgfs[Theta33->sgfn]); + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g22->sgfn], cg->fgfs[g221->sgfn], + Thetawt[0], Symmetry, neps, sPp->data->sst); + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g23->sgfn], cg->fgfs[g231->sgfn], + Thetawt[1], Symmetry, neps, sPp->data->sst); + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[g33->sgfn], cg->fgfs[g331->sgfn], + Thetawt[2], Symmetry, neps, sPp->data->sst); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g220->sgfn], cg->fgfs[g221->sgfn], cg->fgfs[g22_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g230->sgfn], cg->fgfs[g231->sgfn], cg->fgfs[g23_rhs->sgfn], + iter_count); + f_rungekutta4_rout(cg->shape, dT, cg->fgfs[g330->sgfn], cg->fgfs[g331->sgfn], cg->fgfs[g33_rhs->sgfn], + iter_count); + } + if (iter_count < 3) + cg->swapList(SynchList_cor, SynchList_pre, myrank); + else + { + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + if (iter_count < 3) + Synch(SynchList_pre, Symmetry, Thetawt, 3); + else + Synch(StateList, Symmetry, Thetawt, 3); + // if( iter_count < 3 ) Synch(SynchList_pre,Symmetry,g00wt,1); + // else Synch(StateList,Symmetry,g00wt,1); + } +} +// really ODEs, so we do not need Synch in this routine at all +#if 0 +void NullShellPatch2::HyperSlice(double dT,double PhysTime,monitor *ErrorMonitor,int RK_count) +{ + int ERROR=0; + Null_Boundary(PhysTime); +#if 1 + MyList *sPp; + +// evolve g01 + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + if(RK_count==0) + { + if(f_NullEvol_g01(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[g01->sgfn],Rmin)) + { + cout<<"find NaN of g01 in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], + cg->fgfs[g01->sgfn],Rmin)) + { + cout<<"find NaN of g01 in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + Synch(g01List,Symmetry,g01wt,1); + if(RK_count==3) Dump_Data(g01List,0,PhysTime,dT); +//check error information + {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } + if(ERROR) + { + if(RK_count==0) Dump_Data(StateList,0,PhysTime,dT); + else Dump_Data(SynchList_pre,0,PhysTime,dT); + if(myrank == 0) + { + if(ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], + cg->fgfs[g01->sgfn], + cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], + cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn],Rmin)) + { + cout<<"find NaN of pg0A in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + Synch(pg0AList,Symmetry,pg0Awt,2); + if(RK_count==3) Dump_Data(pg0AList,0,PhysTime,dT); +//check error information + {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } + if(ERROR) + { + Dump_Data(g01List,0,PhysTime,dT); + if(myrank == 0) + { + if(ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], + cg->fgfs[g00->sgfn],cg->fgfs[g01->sgfn], + cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn], + cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn],Rmin)) + { + cout<<"find NaN of ThetaAB in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + Synch(ThetaList,Symmetry,Thetawt,3); + if(RK_count==3) Dump_Data(ThetaList,0,PhysTime,dT); +//check error information + {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } + if(ERROR) + { + Dump_Data(pg0AList,0,PhysTime,dT); + if(myrank == 0) + { + if(ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], + cg->fgfs[g00->sgfn],cg->fgfs[g01->sgfn], + cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn], + cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn],Rmin)) + { + cout<<"find NaN of ThetaAB in NullShell domain: sst = "<data->sst<<", ("<bbox[0]<<":"<bbox[3]<<"," + <bbox[1]<<":"<bbox[4]<<","<bbox[2]<<":"<bbox[5]<<")"<data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + Synch(ThetaList,Symmetry,Thetawt,3); + if(RK_count==3) Dump_Data(ThetaList,0,PhysTime,dT); + Synch(g00List,Symmetry,g00wt,1); + if(RK_count==3) Dump_Data(g00List,0,PhysTime,dT); +//check error information + {int erh=ERROR;MPI_Allreduce(&erh,&ERROR,1,MPI_INT,MPI_SUM,MPI_COMM_WORLD); } + if(ERROR) + { + Dump_Data(pg0AList,0,PhysTime,dT); + if(myrank == 0) + { + if(ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile<<"find NaN in beta on NullShell Patches at t = "<bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_g01(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], + cg->fgfs[g01->sgfn], Rmin)) + { + cout << "find NaN of g01 in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + Synch(g01List, Symmetry, g01wt, 1); + // if(RK_count==3) Dump_Data(g01List,0,PhysTime,dT); + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + if (RK_count == 0) + Dump_Data(StateList, 0, PhysTime, dT); + else + Dump_Data(SynchList_pre, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // evolve p02, p03, g02 and g03 + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_pg0A(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], + cg->fgfs[g01->sgfn], + cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], + cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], Rmin)) + { + cout << "find NaN of pg0A in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_pg0A(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], + cg->fgfs[g01->sgfn], + cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], + cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], Rmin)) + { + cout << "find NaN of pg0A in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + Synch(pg0AList, Symmetry, pg0Awt, 2); + // if(RK_count==3) Dump_Data(pg0AList,0,PhysTime,dT); + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(g01List, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + // for gauge variable g00 + { + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_g00_with_t(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g00->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // if(RK_count==3) Dump_Data(g00List,0,PhysTime,dT); + } + // evolve ThetaAB + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (RK_count == 0) + { + if (f_NullEvol_Theta2(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], + cg->fgfs[g00->sgfn], cg->fgfs[g01->sgfn], + cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], + cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], + cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin)) + { + cout << "find NaN of ThetaAB in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + else + { + if (f_NullEvol_Theta2(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], + cg->fgfs[g00->sgfn], cg->fgfs[g01->sgfn], + cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], + cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], + cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin)) + { + cout << "find NaN of ThetaAB in NullShell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + Synch(ThetaList, Symmetry, Thetawt, 3); + // if(RK_count==3) Dump_Data(ThetaList,0,PhysTime,dT); + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Dump_Data(pg0AList, 0, PhysTime, dT); + if (myrank == 0) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + else + cout << "find NaN in beta on NullShell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +} +#endif +#if 0 +void NullShellPatch2::Null_Boundary(double PhysTime) +{ + MyList *sPp; + + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + f_get_null_boundary2(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g22->sgfn],cg->fgfs[g23->sgfn],cg->fgfs[g33->sgfn], + cg->fgfs[g01->sgfn], + cg->fgfs[p02->sgfn],cg->fgfs[p03->sgfn], + cg->fgfs[g02->sgfn],cg->fgfs[g03->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn],Rmin); +// for Theta_AB + f_get_gauge_g00_K(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], + cg->fgfs[g00->sgfn],Rmin); + } + if(BP==sPp->data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } +// boundary for Theta_AB +//Synchronize K + Synch(g00List,Symmetry,g00wt,1); + sPp=PatL; + int IZEO=1; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + f_get_gauge_g00(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[Theta22->sgfn],cg->fgfs[Theta23->sgfn],cg->fgfs[Theta33->sgfn], + cg->fgfs[g00->sgfn],Rmin,IZEO); + } + if(BP==sPp->data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } + Synch(ThetaList,Symmetry,Thetawt,3); + //Synch(ThetaList,Symmetry,g00wt,1); +// boundary condition is independent of angular direction, do not need synch +// Synch(pg0AList,Symmetry,pg0Awt,2,-1); +// Synch(g00List,Symmetry,g00wt,1,-1); +// Synch(ThetaList,Symmetry,Thetawt,3,-1); +} +#else +void NullShellPatch2::Null_Boundary(double PhysTime) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary3(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g22->sgfn], cg->fgfs[g23->sgfn], cg->fgfs[g33->sgfn], + cg->fgfs[g01->sgfn], + cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], + cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], + cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + /* + // check Synch + Synch(g01List,Symmetry,g01wt,1); + Dump_Data(g01List,0,PhysTime,1); + Synch(pg0AList,Symmetry,pg0Awt,2); + Dump_Data(pg0AList,0,PhysTime,1); + Synch(StateList,Symmetry,Thetawt,3); + Dump_Data(StateList,0,PhysTime,1); + Synch(ThetaList,Symmetry,Thetawt,3); + Dump_Data(ThetaList,0,PhysTime,1); + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + */ +} +// 0: real L2 norm; 1: root mean squar +#define L2m 0 +double NullShellPatch2::Error_Check(double PhysTime) +{ + MyList *sPp; + + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_boundary3(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[g221->sgfn], cg->fgfs[g231->sgfn], cg->fgfs[g331->sgfn], + cg->fgfs[g01->sgfn], + cg->fgfs[p02->sgfn], cg->fgfs[p03->sgfn], + cg->fgfs[g22_rhs->sgfn], cg->fgfs[g03->sgfn], + cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + double tvf, dtvf = 0; + int tN, dtN = 0; + int BDW = ghost_width, OBDW = overghost; + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_array_subtract(cg->shape, cg->fgfs[g22_rhs->sgfn], cg->fgfs[g02->sgfn]); +#if (L2m == 0) + f_l2normhelper_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[g22_rhs->sgfn], tvf, BDW, OBDW, Symmetry); +#elif (L2m == 1) + f_l2normhelper_sh_rms(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[g22_rhs->sgfn], tvf, BDW, OBDW, Symmetry, dtN); + dtN += dtN; +#endif + + dtvf += tvf; + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + // Dump_Data(RHSList,0,PhysTime,1); + // Dump_Data(ThetaList,0,PhysTime,1); + // if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); +#if (L2m == 0) + tvf = sqrt(tvf); +#elif (L2m == 1) + MPI_Allreduce(&dtN, &tN, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + tvf = sqrt(tvf / tN); +#endif + + return tvf; +} +#undef L2m +#endif + +void NullShellPatch2::Compute_News(double PhysTime) +{ + MyList *sPp; + +// get omega and dtomega +// for RT +#if 0 + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + f_get_omega_and_dtomega_pre(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[omega->sgfn],cg->fgfs[dtomega->sgfn],Rmin); + } + if(BP==sPp->data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } +// Synch + { + MyList * DG_List; + DG_List=new MyList(omega); + Synch(DG_List,Symmetry,g00wt,1); + DG_List->clearList(); + DG_List=new MyList(dtomega); + Synch(DG_List,Symmetry,g00wt,1); + DG_List->clearList(); + } +// get dtomega + sPp=PatL; + while(sPp) + { + MyList *BP=sPp->data->blb; + int fngfs = sPp->data->fngfs; + while(BP) + { + Block *cg=BP->data; + if(myrank == cg->rank) + { + f_get_dtomega(cg->shape,cg->X[0],cg->X[1],cg->X[2], + cg->fgfs[g220->sgfn],cg->fgfs[g230->sgfn],cg->fgfs[g330->sgfn], + cg->fgfs[omega->sgfn],cg->fgfs[dtomega->sgfn],Rmin); + } + if(BP==sPp->data->ble) break; + BP=BP->next; + } + sPp=sPp->next; + } +// Synch + { + MyList * DG_List; + DG_List=new MyList(dtomega); + Synch(DG_List,Symmetry,g00wt,1); + DG_List->clearList(); + } +#else + // for linear wave + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_omega_and_dtomega_LN(PhysTime, cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega->sgfn], cg->fgfs[dtomega->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + // Synch + { + MyList *DG_List; + DG_List = new MyList(omega); + Synch(DG_List, Symmetry, g00wt, 1); + DG_List->clearList(); + DG_List = new MyList(dtomega); + Synch(DG_List, Symmetry, g00wt, 1); + DG_List->clearList(); + } +#endif + // calculate News + sPp = PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_get_null_news2(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[omega->sgfn], cg->fgfs[dtomega->sgfn], + cg->fgfs[g00->sgfn], cg->fgfs[g01->sgfn], + cg->fgfs[g02->sgfn], cg->fgfs[g03->sgfn], + cg->fgfs[g220->sgfn], cg->fgfs[g230->sgfn], cg->fgfs[g330->sgfn], + cg->fgfs[Theta22->sgfn], cg->fgfs[Theta23->sgfn], cg->fgfs[Theta33->sgfn], + cg->fgfs[RNews->sgfn], cg->fgfs[INews->sgfn], Rmin, sPp->data->sst); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +} diff --git a/AMSS_NCKU_source/testNull.C b/AMSS_NCKU_source/Null_Evolve/testNull.C similarity index 96% rename from AMSS_NCKU_source/testNull.C rename to AMSS_NCKU_source/Null_Evolve/testNull.C index d09293e..56f4746 100644 --- a/AMSS_NCKU_source/testNull.C +++ b/AMSS_NCKU_source/Null_Evolve/testNull.C @@ -1,216 +1,216 @@ -// $Id: testNull.C,v 1.8 2013/03/06 04:16:04 zjcao Exp $ -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "misc.h" -#include "macrodef.h" -#include "NullShellPatch.h" -#include "monitor.h" -#include "surface_integral.h" - -#define PI M_PI -//======================================= -int main(int argc, char *argv[]) -{ - int myrank = 0, nprocs = 1; - MPI_Init(&argc, &argv); - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int checkrun; - char checkfilename[50]; - int Steps; - double StartTime, TotalTime; - double AnasTime, DumpTime, CheckTime; - double Courant; - double numepss, numepsb; - int Symmetry; - int a_lev, maxl, decn; - double maxrex, drex; - - int shapei[dim]; - double Rmin, xmin, xmax; - - // double RJerror[2]; - double RJerror; - // read parameter from file - { - char filename[100] = "input.par"; - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << filename - << " for inputing information of Shell patches" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN") - { - if (skey == "Shell shape") - shapei[sind] = atof(sval.c_str()); - else if (skey == "Rmin") - Rmin = atof(sval.c_str()); - else if (skey == "xmin") - xmin = atof(sval.c_str()); - else if (skey == "xmax") - xmax = atof(sval.c_str()); - } - if (sgrp == "ABE") - { - if (skey == "Symmetry") - Symmetry = atoi(sval.c_str()); - else if (skey == "Courant") - Courant = atof(sval.c_str()); - else if (skey == "DumpTime") - DumpTime = atof(sval.c_str()); - else if (skey == "TotalTime") - TotalTime = atof(sval.c_str()); - else if (skey == "AnalysisTime") - AnasTime = atof(sval.c_str()); - else if (skey == "Max mode l") - maxl = atoi(sval.c_str()); - } - } - inf.close(); - } - - monitor *ECmonitor, *NewsMonitor; - // setup Monitors - { - stringstream a_stream; - a_stream.setf(ios::left); - a_stream << "# time L2norm_of_error"; - ECmonitor = new monitor("error.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - char str[50]; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - sprintf(str, "R%02dm%03d", pl, pm); - a_stream << setw(16) << str; - sprintf(str, "I%02dm%03d", pl, pm); - a_stream << setw(16) << str; - } - NewsMonitor = new monitor("null_news.dat", myrank, a_stream.str()); - } - //===========================the computation body==================================================== - NullShellPatch *ADM; - surface_integral *Waveshell; - // setup sphere integration engine - Waveshell = new surface_integral(Symmetry); - - ADM = new NullShellPatch(shapei, Rmin, xmin, xmax, Symmetry, myrank); - ADM->compose_sh(nprocs); - ADM->Setup_dyad(); - ADM->Dump_xyz(0, 0, 1); - ADM->setupintintstuff(nprocs, 0, Symmetry); - - double PhysTime = 0, dT = Courant * PI / 4 / shapei[0]; - double LastDump = 0, LastAnas = 0; - - ADM->Setup_Initial_Data(false, PhysTime); - while (PhysTime < TotalTime) - { - if (LastAnas >= AnasTime) - { - double *RP, *IP; - int NN = 0; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - NN++; - RP = new double[NN]; - IP = new double[NN]; -// ADM->Check_News(PhysTime,dT,false); -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - Waveshell->surf_Wave(ADM->xmax, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); -#else -#ifdef Cell - Waveshell->surf_Wave(ADM->xmax - (ADM->getdX(2)) / 2.0, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); -#else -#error Not define Vertex nor Cell -#endif -#endif - NewsMonitor->writefile(PhysTime, NN, RP, IP); - delete[] RP; - delete[] IP; - - RJerror = ADM->Error_Check(PhysTime, dT, (LastDump >= DumpTime)); - // RJerror[1]=ADM->News_Error_Check(PhysTime,dT,(LastDump >= DumpTime)); - // RJerror[0]=ADM->EqTheta_Check(PhysTime,dT,(LastDump >= DumpTime)); - - ECmonitor->writefile(PhysTime, 1, &RJerror); - - LastAnas = 0; - } - - if (LastDump >= DumpTime) - { - ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); - LastDump = 0; - } - - ADM->Step(dT, PhysTime, 0); - PhysTime += dT; - LastDump += dT; - LastAnas += dT; - if (myrank == 0) - cout << "Time = " << PhysTime << endl; - // ADM->Dump_Data(ADM->StateList,0,PhysTime,dT); - } - - ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); - delete ADM; - delete ECmonitor; - delete NewsMonitor; - delete Waveshell; - //=======================caculation done============================================================= - if (myrank == 0) - cout << "===============================================================" << endl; - if (myrank == 0) - cout << "Simulation is successfully done!!" << endl; - MPI_Finalize(); - - exit(0); -} +// $Id: testNull.C,v 1.8 2013/03/06 04:16:04 zjcao Exp $ +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "misc.h" +#include "macrodef.h" +#include "NullShellPatch.h" +#include "monitor.h" +#include "surface_integral.h" + +#define PI M_PI +//======================================= +int main(int argc, char *argv[]) +{ + int myrank = 0, nprocs = 1; + MPI_Init(&argc, &argv); + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int checkrun; + char checkfilename[50]; + int Steps; + double StartTime, TotalTime; + double AnasTime, DumpTime, CheckTime; + double Courant; + double numepss, numepsb; + int Symmetry; + int a_lev, maxl, decn; + double maxrex, drex; + + int shapei[dim]; + double Rmin, xmin, xmax; + + // double RJerror[2]; + double RJerror; + // read parameter from file + { + char filename[100] = "input.par"; + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << filename + << " for inputing information of Shell patches" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN") + { + if (skey == "Shell shape") + shapei[sind] = atof(sval.c_str()); + else if (skey == "Rmin") + Rmin = atof(sval.c_str()); + else if (skey == "xmin") + xmin = atof(sval.c_str()); + else if (skey == "xmax") + xmax = atof(sval.c_str()); + } + if (sgrp == "ABE") + { + if (skey == "Symmetry") + Symmetry = atoi(sval.c_str()); + else if (skey == "Courant") + Courant = atof(sval.c_str()); + else if (skey == "DumpTime") + DumpTime = atof(sval.c_str()); + else if (skey == "TotalTime") + TotalTime = atof(sval.c_str()); + else if (skey == "AnalysisTime") + AnasTime = atof(sval.c_str()); + else if (skey == "Max mode l") + maxl = atoi(sval.c_str()); + } + } + inf.close(); + } + + monitor *ECmonitor, *NewsMonitor; + // setup Monitors + { + stringstream a_stream; + a_stream.setf(ios::left); + a_stream << "# time L2norm_of_error"; + ECmonitor = new monitor("error.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + char str[50]; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + sprintf(str, "R%02dm%03d", pl, pm); + a_stream << setw(16) << str; + sprintf(str, "I%02dm%03d", pl, pm); + a_stream << setw(16) << str; + } + NewsMonitor = new monitor("null_news.dat", myrank, a_stream.str()); + } + //===========================the computation body==================================================== + NullShellPatch *ADM; + surface_integral *Waveshell; + // setup sphere integration engine + Waveshell = new surface_integral(Symmetry); + + ADM = new NullShellPatch(shapei, Rmin, xmin, xmax, Symmetry, myrank); + ADM->compose_sh(nprocs); + ADM->Setup_dyad(); + ADM->Dump_xyz(0, 0, 1); + ADM->setupintintstuff(nprocs, 0, Symmetry); + + double PhysTime = 0, dT = Courant * PI / 4 / shapei[0]; + double LastDump = 0, LastAnas = 0; + + ADM->Setup_Initial_Data(false, PhysTime); + while (PhysTime < TotalTime) + { + if (LastAnas >= AnasTime) + { + double *RP, *IP; + int NN = 0; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + NN++; + RP = new double[NN]; + IP = new double[NN]; +// ADM->Check_News(PhysTime,dT,false); +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + Waveshell->surf_Wave(ADM->xmax, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); +#else +#ifdef Cell + Waveshell->surf_Wave(ADM->xmax - (ADM->getdX(2)) / 2.0, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); +#else +#error Not define Vertex nor Cell +#endif +#endif + NewsMonitor->writefile(PhysTime, NN, RP, IP); + delete[] RP; + delete[] IP; + + RJerror = ADM->Error_Check(PhysTime, dT, (LastDump >= DumpTime)); + // RJerror[1]=ADM->News_Error_Check(PhysTime,dT,(LastDump >= DumpTime)); + // RJerror[0]=ADM->EqTheta_Check(PhysTime,dT,(LastDump >= DumpTime)); + + ECmonitor->writefile(PhysTime, 1, &RJerror); + + LastAnas = 0; + } + + if (LastDump >= DumpTime) + { + ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); + LastDump = 0; + } + + ADM->Step(dT, PhysTime, 0); + PhysTime += dT; + LastDump += dT; + LastAnas += dT; + if (myrank == 0) + cout << "Time = " << PhysTime << endl; + // ADM->Dump_Data(ADM->StateList,0,PhysTime,dT); + } + + ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); + delete ADM; + delete ECmonitor; + delete NewsMonitor; + delete Waveshell; + //=======================caculation done============================================================= + if (myrank == 0) + cout << "===============================================================" << endl; + if (myrank == 0) + cout << "Simulation is successfully done!!" << endl; + MPI_Finalize(); + + exit(0); +} diff --git a/AMSS_NCKU_source/testNull2.C b/AMSS_NCKU_source/Null_Evolve/testNull2.C similarity index 96% rename from AMSS_NCKU_source/testNull2.C rename to AMSS_NCKU_source/Null_Evolve/testNull2.C index ef5697c..846b351 100644 --- a/AMSS_NCKU_source/testNull2.C +++ b/AMSS_NCKU_source/Null_Evolve/testNull2.C @@ -1,274 +1,274 @@ -// $Id: testNull2.C,v 1.1 2013/08/20 11:49:05 zjcao Exp $ -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "misc.h" -#include "macrodef.h" -#include "NullShellPatch2.h" -#include "monitor.h" -#include "surface_integral.h" - -#define PI M_PI - -namespace parameters -{ - map int_par; - map dou_par; - map str_par; -} - -//======================================= -int main(int argc, char *argv[]) -{ - int myrank = 0, nprocs = 1; - MPI_Init(&argc, &argv); - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int checkrun; - char checkfilename[50]; - int Steps; - double StartTime, TotalTime; - double AnasTime, DumpTime, CheckTime; - double Courant; - double numepss, numepsb; - int Symmetry; - int a_lev, maxl, decn; - double maxrex, drex; - - int shapei[dim]; - double Rmin, xmin, xmax; - - if (argc > 1) - { - string sttr(argv[1]); - parameters::str_par.insert(map::value_type("inputpar", sttr)); - } - else - { - string sttr("input.par"); - parameters::str_par.insert(map::value_type("inputpar", sttr)); - } - - // read parameter from file - { - string out_dir; - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << filename - << " for inputing information of Shell patches" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN") - { - if (skey == "Shell shape") - shapei[sind] = atof(sval.c_str()); - else if (skey == "Rmin") - Rmin = atof(sval.c_str()); - else if (skey == "xmin") - xmin = atof(sval.c_str()); - else if (skey == "xmax") - xmax = atof(sval.c_str()); - } - if (sgrp == "ABE") - { - if (skey == "Symmetry") - Symmetry = atoi(sval.c_str()); - else if (skey == "Courant") - Courant = atof(sval.c_str()); - else if (skey == "DumpTime") - DumpTime = atof(sval.c_str()); - else if (skey == "TotalTime") - TotalTime = atof(sval.c_str()); - else if (skey == "AnalysisTime") - AnasTime = atof(sval.c_str()); - else if (skey == "Max mode l") - maxl = atoi(sval.c_str()); - else if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - if (myrank == 0) - { - char cmd[100]; - sprintf(cmd, "rm %s -rf", out_dir.c_str()); - system(cmd); - sprintf(cmd, "mkdir %s", out_dir.c_str()); - system(cmd); - } - } - - monitor *ECmonitor, *NewsMonitor; - // setup Monitors - { - stringstream a_stream; - a_stream.setf(ios::left); - a_stream << "# time L2norm_of_error"; - ECmonitor = new monitor("error.dat", myrank, a_stream.str()); - - a_stream.clear(); - a_stream.str(""); - a_stream << setw(15) << "# time"; - char str[50]; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - sprintf(str, "R%02dm%03d", pl, pm); - a_stream << setw(16) << str; - sprintf(str, "I%02dm%03d", pl, pm); - a_stream << setw(16) << str; - } - NewsMonitor = new monitor("null_news.dat", myrank, a_stream.str()); - } - //===========================the computation body==================================================== - NullShellPatch2 *ADM; - surface_integral *Waveshell; - // setup sphere integration engine - Waveshell = new surface_integral(Symmetry); - - ADM = new NullShellPatch2(shapei, Rmin, xmin, xmax, Symmetry, myrank); - - ADM->compose_sh(nprocs); - ADM->Dump_xyz(0, 0, 1); - ADM->setupintintstuff(nprocs, 0, Symmetry); - - double PhysTime = 0, dT = Courant * PI / 4 / shapei[0]; - double LastDump = 0, LastAnas = 0; - - ADM->Setup_Initial_Data(false, PhysTime); - - // check Synch - // ADM->Synch(ADM->StateList,Symmetry,ADM->Thetawt,3,-1); - // ADM->Dump_Data(ADM->StateList,0,PhysTime,dT); - // exit(0); - - while (PhysTime < TotalTime) - { - ADM->Step(dT, PhysTime, 0); - PhysTime += dT; - LastDump += dT; - LastAnas += dT; - if (myrank == 0) - cout << "Time = " << PhysTime << endl; - - if (LastAnas >= AnasTime) - { - double *RP, *IP; - int NN = 0; - for (int pl = 2; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - NN++; - RP = new double[NN]; - IP = new double[NN]; - ADM->Compute_News(PhysTime); -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - Waveshell->surf_Wave(ADM->xmax, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); -#else -#ifdef Cell - Waveshell->surf_Wave(ADM->xmax - (ADM->getdX(2)) / 2.0, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); -#else -#error Not define Vertex nor Cell -#endif -#endif - NewsMonitor->writefile(PhysTime, NN, RP, IP); - delete[] RP; - delete[] IP; - - double RJerror; - RJerror = ADM->Error_Check(PhysTime); - ECmonitor->writefile(PhysTime, 1, &RJerror); - - LastAnas = 0; - } - - if (LastDump >= DumpTime) - { - ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); - ADM->Dump_Data(ADM->g01List, 0, PhysTime, dT); - ADM->Dump_Data(ADM->pg0AList, 0, PhysTime, dT); - ADM->Dump_Data(ADM->g00List, 0, PhysTime, dT); - ADM->Dump_Data(ADM->ThetaList, 0, PhysTime, dT); - LastDump = 0; - } - } - - ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); - delete ADM; - //=======================caculation done============================================================= - if (myrank == 0) - cout << "===============================================================" << endl; - if (myrank == 0) - cout << "Simulation is successfully done!!" << endl; - MPI_Finalize(); - - exit(0); -} +// $Id: testNull2.C,v 1.1 2013/08/20 11:49:05 zjcao Exp $ +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "misc.h" +#include "macrodef.h" +#include "NullShellPatch2.h" +#include "monitor.h" +#include "surface_integral.h" + +#define PI M_PI + +namespace parameters +{ + map int_par; + map dou_par; + map str_par; +} + +//======================================= +int main(int argc, char *argv[]) +{ + int myrank = 0, nprocs = 1; + MPI_Init(&argc, &argv); + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int checkrun; + char checkfilename[50]; + int Steps; + double StartTime, TotalTime; + double AnasTime, DumpTime, CheckTime; + double Courant; + double numepss, numepsb; + int Symmetry; + int a_lev, maxl, decn; + double maxrex, drex; + + int shapei[dim]; + double Rmin, xmin, xmax; + + if (argc > 1) + { + string sttr(argv[1]); + parameters::str_par.insert(map::value_type("inputpar", sttr)); + } + else + { + string sttr("input.par"); + parameters::str_par.insert(map::value_type("inputpar", sttr)); + } + + // read parameter from file + { + string out_dir; + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << filename + << " for inputing information of Shell patches" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN") + { + if (skey == "Shell shape") + shapei[sind] = atof(sval.c_str()); + else if (skey == "Rmin") + Rmin = atof(sval.c_str()); + else if (skey == "xmin") + xmin = atof(sval.c_str()); + else if (skey == "xmax") + xmax = atof(sval.c_str()); + } + if (sgrp == "ABE") + { + if (skey == "Symmetry") + Symmetry = atoi(sval.c_str()); + else if (skey == "Courant") + Courant = atof(sval.c_str()); + else if (skey == "DumpTime") + DumpTime = atof(sval.c_str()); + else if (skey == "TotalTime") + TotalTime = atof(sval.c_str()); + else if (skey == "AnalysisTime") + AnasTime = atof(sval.c_str()); + else if (skey == "Max mode l") + maxl = atoi(sval.c_str()); + else if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + if (myrank == 0) + { + char cmd[100]; + sprintf(cmd, "rm %s -rf", out_dir.c_str()); + system(cmd); + sprintf(cmd, "mkdir %s", out_dir.c_str()); + system(cmd); + } + } + + monitor *ECmonitor, *NewsMonitor; + // setup Monitors + { + stringstream a_stream; + a_stream.setf(ios::left); + a_stream << "# time L2norm_of_error"; + ECmonitor = new monitor("error.dat", myrank, a_stream.str()); + + a_stream.clear(); + a_stream.str(""); + a_stream << setw(15) << "# time"; + char str[50]; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + sprintf(str, "R%02dm%03d", pl, pm); + a_stream << setw(16) << str; + sprintf(str, "I%02dm%03d", pl, pm); + a_stream << setw(16) << str; + } + NewsMonitor = new monitor("null_news.dat", myrank, a_stream.str()); + } + //===========================the computation body==================================================== + NullShellPatch2 *ADM; + surface_integral *Waveshell; + // setup sphere integration engine + Waveshell = new surface_integral(Symmetry); + + ADM = new NullShellPatch2(shapei, Rmin, xmin, xmax, Symmetry, myrank); + + ADM->compose_sh(nprocs); + ADM->Dump_xyz(0, 0, 1); + ADM->setupintintstuff(nprocs, 0, Symmetry); + + double PhysTime = 0, dT = Courant * PI / 4 / shapei[0]; + double LastDump = 0, LastAnas = 0; + + ADM->Setup_Initial_Data(false, PhysTime); + + // check Synch + // ADM->Synch(ADM->StateList,Symmetry,ADM->Thetawt,3,-1); + // ADM->Dump_Data(ADM->StateList,0,PhysTime,dT); + // exit(0); + + while (PhysTime < TotalTime) + { + ADM->Step(dT, PhysTime, 0); + PhysTime += dT; + LastDump += dT; + LastAnas += dT; + if (myrank == 0) + cout << "Time = " << PhysTime << endl; + + if (LastAnas >= AnasTime) + { + double *RP, *IP; + int NN = 0; + for (int pl = 2; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + NN++; + RP = new double[NN]; + IP = new double[NN]; + ADM->Compute_News(PhysTime); +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + Waveshell->surf_Wave(ADM->xmax, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); +#else +#ifdef Cell + Waveshell->surf_Wave(ADM->xmax - (ADM->getdX(2)) / 2.0, 0, ADM, ADM->RNews, ADM->INews, 2, maxl, NN, RP, IP, 0); +#else +#error Not define Vertex nor Cell +#endif +#endif + NewsMonitor->writefile(PhysTime, NN, RP, IP); + delete[] RP; + delete[] IP; + + double RJerror; + RJerror = ADM->Error_Check(PhysTime); + ECmonitor->writefile(PhysTime, 1, &RJerror); + + LastAnas = 0; + } + + if (LastDump >= DumpTime) + { + ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); + ADM->Dump_Data(ADM->g01List, 0, PhysTime, dT); + ADM->Dump_Data(ADM->pg0AList, 0, PhysTime, dT); + ADM->Dump_Data(ADM->g00List, 0, PhysTime, dT); + ADM->Dump_Data(ADM->ThetaList, 0, PhysTime, dT); + LastDump = 0; + } + } + + ADM->Dump_Data(ADM->StateList, 0, PhysTime, dT); + delete ADM; + //=======================caculation done============================================================= + if (myrank == 0) + cout << "===============================================================" << endl; + if (myrank == 0) + cout << "Simulation is successfully done!!" << endl; + MPI_Finalize(); + + exit(0); +} diff --git a/AMSS_NCKU_source/Parallel.C b/AMSS_NCKU_source/Parallel/Parallel.C similarity index 96% rename from AMSS_NCKU_source/Parallel.C rename to AMSS_NCKU_source/Parallel/Parallel.C index 38278ab..8a47d89 100644 --- a/AMSS_NCKU_source/Parallel.C +++ b/AMSS_NCKU_source/Parallel/Parallel.C @@ -1,5286 +1,5286 @@ - -#include "Parallel.h" -#include "fmisc.h" -#include "prolongrestrict.h" -#include "misc.h" -#include "parameters.h" - -int Parallel::partition1(int &nx, int split_size, int min_width, int cpusize, int shape) // special for 1 diemnsion -{ - nx = Mymax(1, shape / min_width); - nx = Mymin(cpusize, nx); - - return nx; -} -int Parallel::partition2(int *nxy, int split_size, int *min_width, int cpusize, int *shape) // special for 2 diemnsions -{ -#define SEARCH_SIZE 5 - int i, j, nx, ny; - int maxnx, maxny; - int mnx, mny; - int dn, hmin_width, cmin_width; - int cnx, cny; - double fx, fy; - int block_size; - int n; - - block_size = shape[0] * shape[1]; - n = Mymax(1, (block_size + split_size / 2) / split_size); - - maxnx = Mymax(1, shape[0] / min_width[0]); - maxnx = Mymin(cpusize, maxnx); - maxny = Mymax(1, shape[1] / min_width[1]); - maxny = Mymin(cpusize, maxny); - fx = (double)shape[0] / (shape[0] + shape[1]); - fy = (double)shape[1] / (shape[0] + shape[1]); - nx = mnx = Mymax(1, Mymin(maxnx, (int)(sqrt(double(n)) * fx / fy))); - ny = mny = Mymax(1, Mymin(maxny, (int)(sqrt(double(n)) * fy / fx))); - dn = abs(n - nx * ny); - hmin_width = Mymin(shape[0] / nx, shape[1] / ny); - for (cny = Mymax(1, mny - SEARCH_SIZE); cny <= (Mymin(mny + SEARCH_SIZE, maxny)); cny++) - for (cnx = Mymax(1, mnx - SEARCH_SIZE); cnx <= (Mymin(mnx + SEARCH_SIZE, maxnx)); cnx++) - { - cmin_width = Mymin(shape[0] / cnx, shape[1] / cny); - if (dn > abs(n - cnx * cny) || (dn == abs(n - cnx * cny) && cmin_width > hmin_width)) - { - dn = abs(n - cnx * cny); - nx = cnx; - ny = cny; - hmin_width = cmin_width; - } - } - - nxy[0] = nx; - nxy[1] = ny; - - return nx * ny; -#undef SEARCH_SIZE -} -int Parallel::partition3(int *nxyz, int split_size, int *min_width, int cpusize, int *shape) // special for 3 diemnsions -#if 1 // algrithsm from Pretorius -{ -// cout< abs(n - cnx * cny * cnz) || (dn == abs(n - cnx * cny * cnz) && cmin_width > hmin_width)) - { - dn = abs(n - cnx * cny * cnz); - nx = cnx; - ny = cny; - nz = cnz; - hmin_width = cmin_width; - } - } - - nxyz[0] = nx; - nxyz[1] = ny; - nxyz[2] = nz; - - return nx * ny * nz; -#undef SEARCH_SIZE -} -#elif 1 // Zhihui's idea one on 2013-09-25 -{ - int nx, ny, nz; - int hmin_width; - hmin_width = Mymin(min_width[0], min_width[1]); - hmin_width = Mymin(hmin_width, min_width[2]); - nx = shape[0] / hmin_width; - if (nx * hmin_width < shape[0]) - nx++; - ny = shape[1] / hmin_width; - if (ny * hmin_width < shape[1]) - ny++; - nz = shape[2] / hmin_width; - if (nz * hmin_width < shape[2]) - nz++; - while (nx * ny * nz > cpusize) - { - hmin_width++; - nx = shape[0] / hmin_width; - if (nx * hmin_width < shape[0]) - nx++; - ny = shape[1] / hmin_width; - if (ny * hmin_width < shape[1]) - ny++; - nz = shape[2] / hmin_width; - if (nz * hmin_width < shape[2]) - nz++; - } - - nxyz[0] = nx; - nxyz[1] = ny; - nxyz[2] = nz; - - return nx * ny * nz; -} -#elif 1 // Zhihui's idea two on 2013-09-25 -{ - int nx, ny, nz; - const int hmin_width = 8; // for example we use 8 - nx = shape[0] / hmin_width; - if (nx * hmin_width < shape[0]) - nx++; - ny = shape[1] / hmin_width; - if (ny * hmin_width < shape[1]) - ny++; - nz = shape[2] / hmin_width; - if (nz * hmin_width < shape[2]) - nz++; - - nxyz[0] = nx; - nxyz[1] = ny; - nxyz[2] = nz; - - return nx * ny * nz; -} -#endif -// distribute the data to cprocessors -#if (PSTR == 0) -MyList *Parallel::distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, - bool periodic, int nodes) -{ -#ifdef USE_GPU_DIVIDE - double cpu_part, gpu_part; - map::iterator iter; - iter = parameters::dou_par.find("cpu part"); - if (iter != parameters::dou_par.end()) - { - cpu_part = iter->second; - } - else - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "cpu part") - cpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); - } - iter = parameters::dou_par.find("gpu part"); - if (iter != parameters::dou_par.end()) - { - gpu_part = iter->second; - } - else - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "gpu part") - gpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); - } - - if (nodes == 0) - nodes = cpusize / 2; -#else - if (nodes == 0) - nodes = cpusize; -#endif - - if (dim != 3) - { - cout << "distrivute: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - MyList *BlL = 0; - - int split_size, min_size, block_size = 0; - - int min_width = 2 * Mymax(ghost_width, buffer_width); - int nxyz[dim], mmin_width[dim], min_shape[dim]; - - MyList *PLi = PatchLIST; - for (int i = 0; i < dim; i++) - min_shape[i] = PLi->data->shape[i]; - int lev = PLi->data->lev; - PLi = PLi->next; - while (PLi) - { - Patch *PP = PLi->data; - for (int i = 0; i < dim; i++) - min_shape[i] = Mymin(min_shape[i], PP->shape[i]); - if (lev != PLi->data->lev) - cout << "Parallel::distribute CAUSTION: meet Patches for different level: " << lev << " and " << PLi->data->lev << endl; - PLi = PLi->next; - } - - for (int i = 0; i < dim; i++) - mmin_width[i] = Mymin(min_width, min_shape[i]); - - min_size = mmin_width[0]; - for (int i = 1; i < dim; i++) - min_size = min_size * mmin_width[i]; - - PLi = PatchLIST; - while (PLi) - { - Patch *PP = PLi->data; - // PP->checkPatch(true); - int bs = PP->shape[0]; - for (int i = 1; i < dim; i++) - bs = bs * PP->shape[i]; - block_size = block_size + bs; - PLi = PLi->next; - } - split_size = Mymax(min_size, block_size / nodes); - split_size = Mymax(1, split_size); - - int n_rank = 0; - PLi = PatchLIST; - int reacpu = 0; - while (PLi) - { - Patch *PP = PLi->data; - - reacpu += partition3(nxyz, split_size, mmin_width, nodes, PP->shape); - - Block *ng0, *ng; - int shape_here[dim], ibbox_here[2 * dim]; - double bbox_here[2 * dim], dd; - - // ibbox : 0,...N-1 - for (int i = 0; i < nxyz[0]; i++) - for (int j = 0; j < nxyz[1]; j++) - for (int k = 0; k < nxyz[2]; k++) - { - ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; - ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; - ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; - ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; - ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; - - if (periodic) - { - ibbox_here[0] = ibbox_here[0] - ghost_width; - ibbox_here[3] = ibbox_here[3] + ghost_width; - ibbox_here[1] = ibbox_here[1] - ghost_width; - ibbox_here[4] = ibbox_here[4] + ghost_width; - ibbox_here[2] = ibbox_here[2] - ghost_width; - ibbox_here[5] = ibbox_here[5] + ghost_width; - } - else - { - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); - ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); - ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); - } - - shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; - shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; - shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // 0--4, 5--10 - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); - bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; - bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; -#else -#ifdef Cell - // 0--5, 5--10 - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; - bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; - bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - -#ifdef USE_GPU_DIVIDE - { - const int pices = 2; - double picef[pices]; - picef[0] = cpu_part; - picef[1] = gpu_part; - int shape_res[dim * pices]; - double bbox_res[2 * dim * pices]; - misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_width); - ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfsi, fngfsi, PP->lev, 0); // delete through KillBlocks - - // if(n_rank==cpusize) {n_rank=0; cerr<<"place one!!"<checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks - - for (int i = 1; i < pices; i++) - { - ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfsi, fngfsi, PP->lev, i); // delete through KillBlocks - // if(n_rank==cpusize) {n_rank=0; cerr<<"place two!! "<checkBlock(); - BlL->insert(ng); - } - } -#else - ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfsi, fngfsi, PP->lev); - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks -#endif - if (n_rank == cpusize) - n_rank = 0; - - // set PP->blb - if (i == 0 && j == 0 && k == 0) - { - MyList *Bp = BlL; - while (Bp->data != ng0) - Bp = Bp->next; // ng0 is the first of the pices list - PP->blb = Bp; - } - } - // set PP->ble - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; // ng is the last of the pices list - PP->ble = Bp; - } - PLi = PLi->next; - } - if (reacpu < nodes * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "Parallel::distribute CAUSTION: level#" << lev << " uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} - -#ifdef INTERP_LB_OPTIMIZE -#include "interp_lb_profile_data.h" - -MyList *Parallel::distribute_optimize(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, - bool periodic, int nodes) -{ -#ifdef USE_GPU_DIVIDE - double cpu_part, gpu_part; - map::iterator iter; - iter = parameters::dou_par.find("cpu part"); - if (iter != parameters::dou_par.end()) - { - cpu_part = iter->second; - } - else - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - strcpy(pname, (iter->second).c_str()); - else { cout << "Error inputpar" << endl; exit(0); } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { cout << "Can not open parameter file " << pname << endl; MPI_Abort(MPI_COMM_WORLD, 1); } - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); str = pline; - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) { cout << "error reading parameter file " << pname << " in line " << i << endl; MPI_Abort(MPI_COMM_WORLD, 1); } - else if (status == 0) continue; - if (sgrp == "ABE") { if (skey == "cpu part") cpu_part = atof(sval.c_str()); } - } - inf.close(); - parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); - } - iter = parameters::dou_par.find("gpu part"); - if (iter != parameters::dou_par.end()) - { - gpu_part = iter->second; - } - else - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - strcpy(pname, (iter->second).c_str()); - else { cout << "Error inputpar" << endl; exit(0); } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { cout << "Can not open parameter file " << pname << endl; MPI_Abort(MPI_COMM_WORLD, 1); } - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); str = pline; - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) { cout << "error reading parameter file " << pname << " in line " << i << endl; MPI_Abort(MPI_COMM_WORLD, 1); } - else if (status == 0) continue; - if (sgrp == "ABE") { if (skey == "gpu part") gpu_part = atof(sval.c_str()); } - } - inf.close(); - parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); - } - if (nodes == 0) nodes = cpusize / 2; -#else - if (nodes == 0) nodes = cpusize; -#endif - - if (dim != 3) - { - cout << "distrivute: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - MyList *BlL = 0; - int split_size, min_size, block_size = 0; - int min_width = 2 * Mymax(ghost_width, buffer_width); - int nxyz[dim], mmin_width[dim], min_shape[dim]; - - MyList *PLi = PatchLIST; - for (int i = 0; i < dim; i++) - min_shape[i] = PLi->data->shape[i]; - int lev = PLi->data->lev; - PLi = PLi->next; - while (PLi) - { - Patch *PP = PLi->data; - for (int i = 0; i < dim; i++) - min_shape[i] = Mymin(min_shape[i], PP->shape[i]); - if (lev != PLi->data->lev) - cout << "Parallel::distribute CAUSTION: meet Patches for different level: " << lev << " and " << PLi->data->lev << endl; - PLi = PLi->next; - } - - for (int i = 0; i < dim; i++) - mmin_width[i] = Mymin(min_width, min_shape[i]); - min_size = mmin_width[0]; - for (int i = 1; i < dim; i++) - min_size = min_size * mmin_width[i]; - - PLi = PatchLIST; - while (PLi) - { - Patch *PP = PLi->data; - int bs = PP->shape[0]; - for (int i = 1; i < dim; i++) - bs = bs * PP->shape[i]; - block_size = block_size + bs; - PLi = PLi->next; - } - split_size = Mymax(min_size, block_size / nodes); - split_size = Mymax(1, split_size); - - int n_rank = 0; - PLi = PatchLIST; - int reacpu = 0; - int current_block_id = 0; - while (PLi) { - Block *ng0, *ng; - bool first_block_in_patch = true; - Patch *PP = PLi->data; - reacpu += partition3(nxyz, split_size, mmin_width, nodes, PP->shape); - - for (int i = 0; i < nxyz[0]; i++) - for (int j = 0; j < nxyz[1]; j++) - for (int k = 0; k < nxyz[2]; k++) - { - int ibbox_here[6], shape_here[3]; - double bbox_here[6], dd; - Block *current_ng_start = nullptr; - - bool is_heavy = false; - int r_l = -1, r_r = -1; - if (cpusize == INTERP_LB_NPROCS) { - for (int si = 0; si < INTERP_LB_NUM_HEAVY; si++) { - if (current_block_id == interp_lb_splits[si][0]) { - is_heavy = true; - r_l = interp_lb_splits[si][1]; - r_r = interp_lb_splits[si][2]; - break; - } - } - } - - if (is_heavy) - { - int ib0 = (PP->shape[0] * i) / nxyz[0]; - int ib3 = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; - int jb1 = (PP->shape[1] * j) / nxyz[1]; - int jb4 = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; - int kb2 = (PP->shape[2] * k) / nxyz[2]; - int kb5 = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; - - Block *split_first_block = nullptr; - Block *split_last_block = nullptr; - splitHotspotBlock(BlL, dim, ib0, ib3, jb1, jb4, kb2, kb5, - PP, r_l, r_r, ingfsi, fngfsi, periodic, - split_first_block, split_last_block); - - current_ng_start = split_first_block; - ng = split_last_block; - } - else - { - ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; - ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; - ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; - ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; - ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; - - if (periodic) { - for(int d=0; d<3; d++) { - ibbox_here[d] -= ghost_width; - ibbox_here[d+3] += ghost_width; - } - } else { - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); - ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); - ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); - } - - for(int d=0; d<3; d++) shape_here[d] = ibbox_here[d+3] - ibbox_here[d] + 1; - -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; - dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); - bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; - bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; -#else -#ifdef Cell - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; - dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; - bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; - bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - ng = createMappedBlock(BlL, dim, shape_here, bbox_here, - current_block_id, ingfsi, fngfsi, PP->lev); - current_ng_start = ng; - } - - if (first_block_in_patch) { - ng0 = current_ng_start; - MyList *Bp_start = BlL; - while (Bp_start && Bp_start->data != ng0) Bp_start = Bp_start->next; - PP->blb = Bp_start; - first_block_in_patch = false; - } - - current_block_id++; - } - - { - MyList *Bp_end = BlL; - while (Bp_end && Bp_end->data != ng) Bp_end = Bp_end->next; - PP->ble = Bp_end; - } - - PLi = PLi->next; - } - if (reacpu < nodes * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "Parallel::distribute CAUSTION: level#" << lev << " uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} - -Block* Parallel::splitHotspotBlock(MyList* &BlL, int _dim, - int ib0_orig, int ib3_orig, - int jb1_orig, int jb4_orig, - int kb2_orig, int kb5_orig, - Patch* PP, int r_left, int r_right, - int ingfsi, int fngfsi, bool periodic, - Block* &split_first_block, Block* &split_last_block) -{ - int mid = (ib0_orig + ib3_orig) / 2; - - int indices_L[6] = {ib0_orig, jb1_orig, kb2_orig, mid, jb4_orig, kb5_orig}; - int indices_R[6] = {mid + 1, jb1_orig, kb2_orig, ib3_orig, jb4_orig, kb5_orig}; - - auto createSubBlock = [&](int* ib_raw, int target_rank) { - int ib_final[6]; - int sh_here[3]; - double bb_here[6], dd; - - if (periodic) { - ib_final[0] = ib_raw[0] - ghost_width; - ib_final[3] = ib_raw[3] + ghost_width; - ib_final[1] = ib_raw[1] - ghost_width; - ib_final[4] = ib_raw[4] + ghost_width; - ib_final[2] = ib_raw[2] - ghost_width; - ib_final[5] = ib_raw[5] + ghost_width; - } else { - ib_final[0] = Mymax(0, ib_raw[0] - ghost_width); - ib_final[3] = Mymin(PP->shape[0] - 1, ib_raw[3] + ghost_width); - ib_final[1] = Mymax(0, ib_raw[1] - ghost_width); - ib_final[4] = Mymin(PP->shape[1] - 1, ib_raw[4] + ghost_width); - ib_final[2] = Mymax(0, ib_raw[2] - ghost_width); - ib_final[5] = Mymin(PP->shape[2] - 1, ib_raw[5] + ghost_width); - } - - sh_here[0] = ib_final[3] - ib_final[0] + 1; - sh_here[1] = ib_final[4] - ib_final[1] + 1; - sh_here[2] = ib_final[5] - ib_final[2] + 1; - -#ifdef Vertex - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bb_here[0] = PP->bbox[0] + ib_final[0] * dd; - bb_here[3] = PP->bbox[0] + ib_final[3] * dd; - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bb_here[1] = PP->bbox[1] + ib_final[1] * dd; - bb_here[4] = PP->bbox[1] + ib_final[4] * dd; - dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); - bb_here[2] = PP->bbox[2] + ib_final[2] * dd; - bb_here[5] = PP->bbox[2] + ib_final[5] * dd; -#else -#ifdef Cell - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bb_here[0] = PP->bbox[0] + ib_final[0] * dd; - bb_here[3] = PP->bbox[0] + (ib_final[3] + 1) * dd; - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bb_here[1] = PP->bbox[1] + ib_final[1] * dd; - bb_here[4] = PP->bbox[1] + (ib_final[4] + 1) * dd; - dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; - bb_here[2] = PP->bbox[2] + ib_final[2] * dd; - bb_here[5] = PP->bbox[2] + (ib_final[5] + 1) * dd; -#endif -#endif - - Block* Bg = new Block(dim, sh_here, bb_here, target_rank, ingfsi, fngfsi, PP->lev); - if (BlL) BlL->insert(Bg); - else BlL = new MyList(Bg); - - return Bg; - }; - - split_first_block = createSubBlock(indices_L, r_left); - split_last_block = createSubBlock(indices_R, r_right); - return split_last_block; -} - -Block* Parallel::createMappedBlock(MyList* &BlL, int _dim, int* shape, double* bbox, - int block_id, int ingfsi, int fngfsi, int lev) -{ - int target_rank = block_id; - if (INTERP_LB_NPROCS > 0) { - for (int ri = 0; ri < interp_lb_num_remaps; ri++) { - if (block_id == interp_lb_remaps[ri][0]) { - target_rank = interp_lb_remaps[ri][1]; - break; - } - } - } - - Block* ng = new Block(dim, shape, bbox, target_rank, ingfsi, fngfsi, lev); - if (BlL) BlL->insert(ng); - else BlL = new MyList(ng); - - return ng; -} -#else -// When INTERP_LB_OPTIMIZE is not defined, distribute_optimize falls back to distribute -MyList *Parallel::distribute_optimize(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, - bool periodic, int nodes) -{ - return distribute(PatchLIST, cpusize, ingfsi, fngfsi, periodic, nodes); -} -Block* Parallel::splitHotspotBlock(MyList* &BlL, int _dim, - int ib0_orig, int ib3_orig, - int jb1_orig, int jb4_orig, - int kb2_orig, int kb5_orig, - Patch* PP, int r_left, int r_right, - int ingfsi, int fngfsi, bool periodic, - Block* &split_first_block, Block* &split_last_block) -{ return nullptr; } -Block* Parallel::createMappedBlock(MyList* &BlL, int _dim, int* shape, double* bbox, - int block_id, int ingfsi, int fngfsi, int lev) -{ return nullptr; } -#endif - -#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) -MyList *Parallel::distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, - bool periodic, int start_rank, int end_rank, int nodes) -{ -#ifdef USE_GPU_DIVIDE - double cpu_part, gpu_part; - map::iterator iter; - iter = parameters::dou_par.find("cpu part"); - if (iter != parameters::dou_par.end()) - { - cpu_part = iter->second; - } - else - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "cpu part") - cpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); - } - iter = parameters::dou_par.find("gpu part"); - if (iter != parameters::dou_par.end()) - { - gpu_part = iter->second; - } - else - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "gpu part") - gpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); - } - - if (nodes == 0) - nodes = cpusize / 2; -#else - if (nodes == 0) - nodes = cpusize; -#endif - - if (dim != 3) - { - cout << "distrivute: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - MyList *BlL = 0; - - int split_size, min_size, block_size = 0; - - int min_width = 2 * Mymax(ghost_width, buffer_width); - int nxyz[dim], mmin_width[dim], min_shape[dim]; - - MyList *PLi = PatchLIST; - for (int i = 0; i < dim; i++) - min_shape[i] = PLi->data->shape[i]; - int lev = PLi->data->lev; - PLi = PLi->next; - while (PLi) - { - Patch *PP = PLi->data; - for (int i = 0; i < dim; i++) - min_shape[i] = Mymin(min_shape[i], PP->shape[i]); - if (lev != PLi->data->lev) - cout << "Parallel::distribute CAUSTION: meet Patches for different level: " << lev << " and " << PLi->data->lev << endl; - PLi = PLi->next; - } - - for (int i = 0; i < dim; i++) - mmin_width[i] = Mymin(min_width, min_shape[i]); - - min_size = mmin_width[0]; - for (int i = 1; i < dim; i++) - min_size = min_size * mmin_width[i]; - - PLi = PatchLIST; - while (PLi) - { - Patch *PP = PLi->data; - // PP->checkPatch(true); - int bs = PP->shape[0]; - for (int i = 1; i < dim; i++) - bs = bs * PP->shape[i]; - block_size = block_size + bs; - PLi = PLi->next; - } - split_size = Mymax(min_size, block_size / cpusize); - split_size = Mymax(1, split_size); - - int n_rank = start_rank; - PLi = PatchLIST; - int reacpu = 0; - while (PLi) - { - Patch *PP = PLi->data; - - reacpu += partition3(nxyz, split_size, mmin_width, cpusize, PP->shape); - - Block *ng, *ng0; - int shape_here[dim], ibbox_here[2 * dim]; - double bbox_here[2 * dim], dd; - - // ibbox : 0,...N-1 - for (int i = 0; i < nxyz[0]; i++) - for (int j = 0; j < nxyz[1]; j++) - for (int k = 0; k < nxyz[2]; k++) - { - ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; - ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; - ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; - ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; - ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; - - if (periodic) - { - ibbox_here[0] = ibbox_here[0] - ghost_width; - ibbox_here[3] = ibbox_here[3] + ghost_width; - ibbox_here[1] = ibbox_here[1] - ghost_width; - ibbox_here[4] = ibbox_here[4] + ghost_width; - ibbox_here[2] = ibbox_here[2] - ghost_width; - ibbox_here[5] = ibbox_here[5] + ghost_width; - } - else - { - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); - ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); - ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); - } - - shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; - shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; - shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // 0--4, 5--10 - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); - bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; - bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; -#else -#ifdef Cell - // 0--5, 5--10 - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; - bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; - bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - -#ifdef USE_GPU_DIVIDE - { - const int pices = 2; - double picef[pices]; - picef[0] = cpu_part; - picef[1] = gpu_part; - int shape_res[dim * pices]; - double bbox_res[2 * dim * pices]; - misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_width); - ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfsi, fngfsi, PP->lev, 0); // delete through KillBlocks - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks - - for (int i = 1; i < pices; i++) - { - ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfsi, fngfsi, PP->lev, i); // delete through KillBlocks - // ng->checkBlock(); - BlL->insert(ng); - } - } -#else - ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfsi, fngfsi, PP->lev); // delete through KillBlocks - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks -#endif - - if (n_rank == end_rank + 1) - n_rank = start_rank; - - // set PP->blb - if (i == 0 && j == 0 && k == 0) - { - MyList *Bp = BlL; - while (Bp->data != ng0) - Bp = Bp->next; // ng0 is the first of the pices list - PP->blb = Bp; - } - } - // set PP->ble - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; // ng is the last of the pices list - PP->ble = Bp; - } - PLi = PLi->next; - } - if (reacpu < nodes * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == start_rank) - cout << "Parallel::distribute CAUSTION: level#" << lev << " uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} -#endif -void Parallel::setfunction(MyList *BlL, var *vn, double func(double x, double y, double z)) -{ - while (BlL) - { - if (BlL->data->X[0]) - { - int nn = BlL->data->shape[0] * BlL->data->shape[1] * BlL->data->shape[2]; - double *p = BlL->data->fgfs[vn->sgfn]; - for (int i = 0; i < nn; i++) - { - int ind[3]; - getarrayindex(3, BlL->data->shape, ind, i); - p[i] = func(BlL->data->X[0][ind[0]], BlL->data->X[1][ind[1]], BlL->data->X[2][ind[2]]); - } - } - BlL = BlL->next; - } -} -// set function only for cpu rank -void Parallel::setfunction(int rank, MyList *BlL, var *vn, double func(double x, double y, double z)) -{ - while (BlL) - { - if (BlL->data->X[0] && BlL->data->rank == rank) - { - int nn = BlL->data->shape[0] * BlL->data->shape[1] * BlL->data->shape[2]; - double *p = BlL->data->fgfs[vn->sgfn]; - for (int i = 0; i < nn; i++) - { - int ind[3]; - getarrayindex(3, BlL->data->shape, ind, i); - p[i] = func(BlL->data->X[0][ind[0]], BlL->data->X[1][ind[1]], BlL->data->X[2][ind[2]]); - } - } - BlL = BlL->next; - } -} -void Parallel::getarrayindex(int DIM, int *shape, int *index, int n) -{ - // we assume index has already memory space - int *mu; - mu = new int[DIM]; - mu[0] = 1; - for (int i = 1; i < DIM; i++) - mu[i] = mu[i - 1] * shape[i - 1]; - for (int i = DIM - 1; i >= 0; i--) - { - index[i] = n / mu[i]; - n = n - index[i] * mu[i]; - } - - delete[] mu; -} -int Parallel::getarraylocation(int DIM, int *shape, int *index) -{ - int n, mu; - mu = shape[0]; - n = index[0]; - for (int i = 1; i < DIM; i++) - { - n = n + index[i] * mu; - mu = mu * shape[i]; - } - - return n; -} -void Parallel::copy(int DIM, double *llbout, double *uubout, int *Dshape, double *DD, double *llbin, double *uubin, - int *shape, double *datain, double *llb, double *uub) -{ - // for 3 dimensional case, based on simple test, I found this is half slower than f90 code - int *illi, *iuui; - int *illo, *iuuo; - int *indi, *indo; - illi = new int[DIM]; - iuui = new int[DIM]; - illo = new int[DIM]; - iuuo = new int[DIM]; - indi = new int[DIM]; - indo = new int[DIM]; - - int ial = 1; - for (int i = 0; i < DIM; i++) - { - double ho, hi; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - ho = (uubout[i] - llbout[i]) / (Dshape[i] - 1); - hi = (uubin[i] - llbin[i]) / (shape[i] - 1); -#else -#ifdef Cell - ho = (uubout[i] - llbout[i]) / Dshape[i]; - hi = (uubin[i] - llbin[i]) / shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - illo[i] = int((llb[i] - llbout[i]) / ho); - iuuo[i] = Dshape[i] - 1 - int((uubout[i] - uub[i]) / ho); - illi[i] = int((llb[i] - llbin[i]) / hi); - iuui[i] = shape[i] - 1 - int((uubin[i] - uub[i]) / hi); - - if (illo[i] > iuuo[i] || illi[i] > iuui[i] || illo[i] < 0 || illi[i] < 0 || - iuui[i] >= shape[i] || iuuo[i] >= Dshape[i]) - { - cout << "Parallel copy: in direction " << i << ":" << endl; - cout << "llb = " << llb[i] << ", uub = " << uub[i] << endl; - cout << " in data : il = " << illi[i] << ", iu = " << iuui[i] << endl; - cout << "bbox = (" << llbin[i] << "," << uubin[i] << ")" << endl; - cout << "shape = " << shape[i] << endl; - cout << "out data : il = " << illo[i] << ", iu = " << iuuo[i] << endl; - cout << "bbox = (" << llbout[i] << "," << uubout[i] << ")" << endl; - cout << "shape = " << Dshape[i] << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - int ihi = iuui[i] - illi[i] + 1, iho = iuuo[i] - illo[i] + 1; - if (!(feq(ho, hi, ho / 2)) || ihi != iho) - { - cout << "Parallel copy: in direction " << i << ":" << endl; - cout << "Parallel copy: not the same grid structure." << endl; - cout << "hi = " << hi << ", bbox = (" << llbin[i] << "," << uubin[i] << "), shape = " << shape[i] << endl; - cout << "ho = " << ho << ", bbox = (" << llbout[i] << "," << uubout[i] << "), shape = " << Dshape[i] << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - ial = ial * ihi; - } - - for (int i = 0; i < DIM; i++) - { - indi[i] = illi[i]; - indo[i] = illo[i]; - } - /* - //check start index - for(int i=0;i NNi) - { - cout << "Parallel copy: ni = " << ni << " is out of array range (0," << NNi << ")." << endl; - cout << "shape = ("; - for (int j = 0; j < DIM; j++) - { - cout << shape[j]; - if (j < DIM - 1) - cout << ","; - else - cout << ")" << endl; - } - cout << "ind = ("; - for (int j = 0; j < DIM; j++) - { - cout << indi[j]; - if (j < DIM - 1) - cout << ","; - else - cout << ")" << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - DD[no] = datain[ni]; - - indi[0]++; - for (int j = 1; j < DIM; j++) - { - if (indi[j - 1] == iuui[j - 1] + 1) - { - indi[j - 1] = illi[j - 1]; - indi[j]++; - } // carry 1 to next digital - else - break; - } - indo[0]++; - for (int j = 1; j < DIM; j++) - { - if (indo[j - 1] == iuuo[j - 1] + 1) - { - indo[j - 1] = illo[j - 1]; - indo[j]++; - } - else - break; - } - } - /* - //check final index - for(int i=0;i *BlL, MyList *DumpList, char *tag, double time, double dT) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MyList *Bp; - while (DumpList) - { - Bp = BlL; - int Bi = 0; - while (Bp) - { - Block *BP = Bp->data; - var *VP = DumpList->data; - if (BP->rank == myrank) - { - - string out_dir; - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - char filename[100]; - if (tag) - sprintf(filename, "%s/%s_Lev%02d-%02d_%02d_%s_%05d.bin", out_dir.c_str(), tag, BP->lev, Bi, myrank, VP->name, ncount); - else - sprintf(filename, "%s/Lev%02d-%02d_%02d_%s_%05d.bin", out_dir.c_str(), BP->lev, Bi, myrank, VP->name, ncount); - writefile(time, BP->shape[0], BP->shape[1], BP->shape[2], BP->bbox[0], BP->bbox[3], BP->bbox[1], BP->bbox[4], - BP->bbox[2], BP->bbox[5], filename, BP->fgfs[VP->sgfn]); - cout << "end of dump " << VP->name << " at time " << time << ", on node " << myrank << endl; - } - Bp = Bp->next; - Bi++; - } - DumpList = DumpList->next; - } -} -// Now we dump the data including buffer points -void Parallel::Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); - if (!databuffer) - { - cout << "Parallel::Dump_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - while (DumpList) - { - var *VP = DumpList->data; - - MyList *Bp = PP->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - - string out_dir; - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - char filename[100]; - if (tag) - sprintf(filename, "%s/%s_Lev%02d-%02d_%s_%05d.bin", out_dir.c_str(), tag, PP->lev, grd, VP->name, ncount); - else - sprintf(filename, "%s/Lev%02d-%02d_%s_%05d.bin", out_dir.c_str(), PP->lev, grd, VP->name, ncount); - - writefile(time, PP->shape[0], PP->shape[1], PP->shape[2], PP->bbox[0], PP->bbox[3], PP->bbox[1], PP->bbox[4], - PP->bbox[2], PP->bbox[5], filename, databuffer); - } - DumpList = DumpList->next; - } - - if (myrank == 0) - free(databuffer); -} -void Parallel::Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT) -{ - MyList *Pp; - Pp = PL; - int grd = 0; - while (Pp) - { - Patch *PP = Pp->data; - Dump_Data(PP, DumpList, tag, time, dT, grd); - grd++; - Pp = Pp->next; - } -} -// collect the data including buffer points -double *Parallel::Collect_Data(Patch *PP, var *VP) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); - if (!databuffer) - { - cout << "Parallel::Collect_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *Bp = PP->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->ble) - break; - Bp = Bp->next; - } - - return databuffer; -} -// Now we dump the data including buffer points -// dump z = 0 plane -void Parallel::d2Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0, *databuffer2 = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); - databuffer2 = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1]); - if (!databuffer || !databuffer2) - { - cout << "Parallel::d2Dump_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - while (DumpList) - { - var *VP = DumpList->data; - - MyList *Bp = PP->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - - string out_dir; - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - char filename[100]; - if (tag) - sprintf(filename, "%s/%s_2d_Lev%02d-%02d_%s_%05d.dat", out_dir.c_str(), tag, PP->lev, grd, VP->name, ncount); - else - sprintf(filename, "%s/2d_Lev%02d-%02d_%s_%05d.dat", out_dir.c_str(), PP->lev, grd, VP->name, ncount); - - int gord = ghost_width; - f_d2dump(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, databuffer2, gord, VP->SoA); - writefile(time, PP->shape[0], PP->shape[1], PP->bbox[0], PP->bbox[3], PP->bbox[1], PP->bbox[4], - filename, databuffer2); - } - DumpList = DumpList->next; - } - - if (myrank == 0) - { - free(databuffer); - free(databuffer2); - } -} -void Parallel::d2Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT) -{ - MyList *Pp; - Pp = PL; - int grd = 0; - while (Pp) - { - Patch *PP = Pp->data; - d2Dump_Data(PP, DumpList, tag, time, dT, grd); - grd++; - Pp = Pp->next; - } -} -// Now we dump the data including buffer points and ghost points of the given patch -void Parallel::Dump_Data0(Patch *PP, MyList *DumpList, char *tag, double time, double dT) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3], tllb[3], tuub[3]; - int tshape[3]; - double DX, DY, DZ; - - for (int i = 0; i < 3; i++) - { - double DX = PP->blb->data->getdX(i); - tshape[i] = PP->shape[i] + 2 * ghost_width; - tllb[i] = PP->bbox[i] - ghost_width * DX; - tuub[i] = PP->bbox[i + dim] + ghost_width * DX; - } - - int NN = tshape[0] * tshape[1] * tshape[2]; - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * NN); - if (!databuffer) - { - cout << "on node# " << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - while (DumpList) - { - var *VP = DumpList->data; - MyList *Bp = PP->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], tllb[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], tllb[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], tllb[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], tuub[0], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], tuub[1], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], tuub[2], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, tllb, tuub, tshape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - if (myrank == 0) - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], tllb[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], tllb[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], tllb[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], tuub[0], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], tuub[1], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], tuub[2], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, tllb, tuub, tshape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - - string out_dir; - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - char filename[100]; - if (tag) - sprintf(filename, "%s/%s_Lev%02d_%s_%05d.bin", out_dir.c_str(), tag, PP->lev, VP->name, ncount); - else - sprintf(filename, "%s/Lev%02d_%s_%05d.bin", out_dir.c_str(), PP->lev, VP->name, ncount); - - writefile(time, tshape[0], tshape[1], tshape[2], tllb[0], tuub[0], tllb[1], tuub[2], - tllb[2], tuub[2], filename, databuffer); - } - DumpList = DumpList->next; - } - - if (myrank == 0) - free(databuffer); -} -// Map point is much easier than maping data itself -// But the main problem is about the points near the boundary -// worst case is -ghost -ghost+1 .... 0 * ...... -double Parallel::global_interp(int DIM, int *ext, double **CoX, double *datain, - double *poXb, int ordn, double *SoA, int Symmetry) -{ - if (DIM != 3) - { - cout << "Parallel::global_interp does not suport DIM = " << DIM << " for Symmetry." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double resu; - double poX[3]; - double asgn = 1; - - for (int i = 0; i < 3; i++) - poX[i] = poXb[i]; - - switch (Symmetry) - { - case 2: - for (int i = 0; i < 3; i++) - if (poX[i] < 0) - { - poX[i] = -poX[i]; - asgn = asgn * SoA[i]; - } - break; - case 1: - if (poX[2] < 0) - { - poX[2] = -poX[2]; - asgn = asgn * SoA[2]; - } - } - - int extb[3]; - - for (int i = 0; i < 3; i++) - extb[i] = ext[i]; - - switch (Symmetry) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - case 2: - if (poX[0] < (ghost_width - 1) * (CoX[0][1] - CoX[0][0])) - extb[0] = extb[0] + ghost_width - 1; - if (poX[1] < (ghost_width - 1) * (CoX[1][1] - CoX[1][0])) - extb[1] = extb[1] + ghost_width - 1; - case 1: - if (poX[2] < (ghost_width - 1) * (CoX[2][1] - CoX[2][0])) - extb[2] = extb[2] + ghost_width - 1; -#else -#ifdef Cell - case 2: - if (poX[0] < (ghost_width - 0.5) * (CoX[0][1] - CoX[0][0])) - extb[0] = extb[0] + ghost_width; - if (poX[1] < (ghost_width - 0.5) * (CoX[1][1] - CoX[1][0])) - extb[1] = extb[1] + ghost_width; - case 1: - if (poX[2] < (ghost_width - 0.5) * (CoX[2][1] - CoX[2][0])) - extb[2] = extb[2] + ghost_width; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - - if (extb[0] > ext[0] || extb[1] > ext[1] || extb[2] > ext[2]) - { - double *CoXb[3]; - int Nb = extb[0] * extb[1] * extb[2]; - double *datab; - datab = new double[Nb]; - for (int i = 0; i < 3; i++) - { - CoXb[i] = new double[extb[i]]; - double DH = CoX[i][1] - CoX[i][0]; - if (extb[i] > ext[i]) - { - if (CoX[i][0] > DH) - { - cout << "lower boundary[" << i << "] = " << CoX[i][0] << ", but SYmmetry = " << Symmetry << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - for (int j = 0; j < ghost_width - 1; j++) - CoXb[i][j] = -CoX[i][ghost_width - 1 - j]; - for (int j = ghost_width - 1; j < extb[i]; j++) - CoXb[i][j] = CoX[i][j - ghost_width + 1]; -#else -#ifdef Cell - for (int j = 0; j < ghost_width; j++) - CoXb[i][j] = -CoX[i][ghost_width - 1 - j]; - for (int j = ghost_width; j < extb[i]; j++) - CoXb[i][j] = CoX[i][j - ghost_width]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else - { - for (int j = 0; j < extb[i]; j++) - CoXb[i][j] = CoX[i][j]; - } - } - - for (int i = 0; i < Nb; i++) - { - int ind[3], indb[3]; - getarrayindex(3, extb, indb, i); - double sgn = 1; - for (int j = 0; j < 3; j++) - { - if (extb[j] > ext[j]) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (indb[j] < ghost_width - 1) - { - ind[j] = ghost_width - 1 - indb[j]; - sgn = sgn * SoA[j]; - } - else - { - ind[j] = 1 + indb[j] - ghost_width; - } -#else -#ifdef Cell - if (indb[j] < ghost_width) - { - ind[j] = ghost_width - 1 - indb[j]; - sgn = sgn * SoA[j]; - } - else - { - ind[j] = indb[j] - ghost_width; - } -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else - ind[j] = indb[j]; - } - int lon = getarraylocation(3, ext, ind); - datab[i] = datain[lon] * sgn; - } - - resu = global_interp(DIM, extb, CoXb, datab, poX, ordn); - - for (int i = 0; i < 3; i++) - delete[] CoXb[i]; - delete[] datab; - } - else - { - resu = global_interp(DIM, ext, CoX, datain, poX, ordn); - } - - return resu * asgn; -} -double Parallel::global_interp(int DIM, int *ext, double **CoX, double *datain, - double *poX, int ordn) -{ - if (ordn > 2 * ghost_width) - { - cout << "Parallel::global_interp can not handle ordn = " << ordn << " > 2*ghost_width = " << 2 * ghost_width << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - double *bbox, *datainbbox; - bbox = new double[2 * DIM]; - datainbbox = new double[2 * DIM]; - - int *NN, *ind, *shape; - NN = new int[DIM]; - ind = new int[DIM]; - shape = new int[DIM]; - - for (int i = 0; i < DIM; i++) - { - ind[i] = int((poX[i] - CoX[i][0]) / (CoX[i][1] - CoX[i][0])) - ordn / 2 + 1; - // poX may exactly locate on the boundary (exclude ghost) - if (ind[i] == -1 && feq(poX[i], CoX[i][0], (CoX[i][1] - CoX[i][0]) / 2)) - ind[i] = 0; - /* - if(ind[i] < 0) - { - cout<<"Parallel::global_interp error ind["< ext = "<= 0; i--) - NN[i] = NN[i + 1] * ordn; - - double *xpts, *funcvals; - xpts = new double[ordn]; - funcvals = new double[ordn]; - double *DDd, *DDd1, rr; - - DDd = new double[NN[0]]; - - copy(DIM, bbox, bbox + DIM, shape, DDd, datainbbox, datainbbox + DIM, ext, datain, bbox, bbox + DIM); - - for (int i = 0; i < DIM; i++) - { - for (int j = ind[i]; j < ind[i] + ordn; j++) - { - xpts[j - ind[i]] = CoX[i][j]; - } - - if (i < DIM - 1) - { - DDd1 = new double[NN[i + 1]]; - for (int j = 0; j < NN[i + 1]; j++) - { - for (int k = 0; k < ordn; k++) - funcvals[k] = DDd[k + j * ordn]; - DDd1[j] = Lagrangian_Int(poX[i], ordn, xpts, funcvals); - } - delete[] DDd; - DDd = DDd1; - } - else - { - for (int j = 0; j < ordn; j++) - funcvals[j] = DDd[j]; - rr = Lagrangian_Int(poX[i], ordn, xpts, funcvals); - delete[] DDd1; // since DDd and DDd1 now point to the same stuff, we need delete after above int - } - } - - delete[] NN; - delete[] ind; - delete[] xpts; - delete[] funcvals; - delete[] bbox; - delete[] datainbbox; - delete[] shape; - - return rr; -} -double Parallel::Lagrangian_Int(double x, int npts, double *xpts, double *funcvals) -{ - double sum = 0; - for (int i = 0; i < npts; i++) - { - sum = sum + funcvals[i] * LagrangePoly(x, i, npts, xpts); - } - return sum; -} -double Parallel::LagrangePoly(double x, int pt, int npts, double *xpts) -{ - double h = 1; - int i; - - for (i = 0; i < pt; i++) - h = h * (x - xpts[i]) / (xpts[pt] - xpts[i]); - - for (i = pt + 1; i < npts; i++) - h = h * (x - xpts[i]) / (xpts[pt] - xpts[i]); - - return h; -} -// collect all grid segments or blocks including ghost and buffer for given patch -MyList *Parallel::build_complete_gsl(Patch *Pat) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - if (!cgsl) - { - cgsl = gs = new MyList; // delete through destroyList(); - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - gs->data->llb[i] = BP->data->bbox[i]; - gs->data->uub[i] = BP->data->bbox[dim + i]; - gs->data->shape[i] = BP->data->shape[i]; - } - gs->data->Bg = BP->data; - gs->next = 0; - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks including ghost and buffer for given patch list -MyList *Parallel::build_complete_gsl(MyList *PatL) -{ - MyList *cgsl = 0, *gs; - while (PatL) - { - if (!cgsl) - { - cgsl = build_complete_gsl(PatL->data); - gs = cgsl; - while (gs->next) - gs = gs->next; - } - else - { - gs->next = build_complete_gsl(PatL->data); - gs = gs->next; - while (gs->next) - gs = gs->next; - } - PatL = PatL->next; - } - - return cgsl; -} -// cellect the information of Patch list -MyList *Parallel::build_complete_gsl_virtual(MyList *PatL) -{ - MyList *cgsl = 0, *gs; - while (PatL) - { - if (cgsl) - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - else - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - gs->data->llb[i] = PatL->data->bbox[i]; - gs->data->uub[i] = PatL->data->bbox[dim + i]; - gs->data->shape[i] = PatL->data->shape[i]; - } - gs->data->Bg = 0; - gs->next = 0; - - PatL = PatL->next; - } - - return cgsl; -} -// cellect the information of Patch list without buffer points -MyList *Parallel::build_complete_gsl_virtual2(MyList *PatL) // - buffer -{ - MyList *cgsl = 0, *gs; - while (PatL) - { - if (cgsl) - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - else - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = PatL->data->getdX(i); - gs->data->llb[i] = PatL->data->bbox[i] + PatL->data->lli[i] * DH; - gs->data->uub[i] = PatL->data->bbox[dim + i] - PatL->data->uui[i] * DH; - gs->data->shape[i] = PatL->data->shape[i] - PatL->data->lli[i] - PatL->data->uui[i]; - } - gs->data->Bg = 0; - gs->next = 0; - - PatL = PatL->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost for given patch, without extension -MyList *Parallel::build_bulk_gsl(Patch *Pat) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = BP->data; - gs->next = 0; - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// bulk part for given Block within given patch, without extension -MyList *Parallel::build_bulk_gsl(Block *bp, Patch *Pat) -{ - MyList *gs = 0; - - gs = new MyList; - gs->data = new Parallel::gridseg; - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = bp; - gs->next = 0; - - return gs; -} -MyList *Parallel::clone_gsl(MyList *p, bool first_only) -{ - MyList *np = 0, *q = 0, *pq = 0; - - while (p) - { - q = new MyList; - q->data = new Parallel::gridseg; - q->data->Bg = p->data->Bg; - for (int i = 0; i < dim; i++) - { - q->data->llb[i] = p->data->llb[i]; - q->data->uub[i] = p->data->uub[i]; - q->data->shape[i] = p->data->shape[i]; - } - if (pq) - pq->next = q; - else - np = q; - if (first_only) - { - np->next = 0; - return np; - } - pq = q; - p = p->next; - } - return np; -} -MyList *Parallel::gs_subtract(MyList *A, MyList *B) -{ - if (!A) - return 0; - if (!B) - return clone_gsl(A, true); - - double cut_plane[2 * dim], DH[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = A->data->Bg->getdX(i); - if (B->data->Bg && !feq(DH[i], B->data->Bg->getdX(i), DH[i] / 2)) - { - cout << "Parallel::gs_subtract meets different grid segment " << DH[i] << " vs " << B->data->Bg->getdX(i) << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *C = 0, *q; - for (int i = 0; i < dim; i++) - { - if (B->data->llb[i] > A->data->uub[i] || B->data->uub[i] < A->data->llb[i]) - return clone_gsl(A, true); - cut_plane[i] = A->data->llb[i]; - cut_plane[i + dim] = A->data->uub[i]; - } - - for (int i = 0; i < dim; i++) - { - cut_plane[i] = Mymax(A->data->llb[i], B->data->llb[i]); - if (cut_plane[i] - A->data->llb[i] > DH[i] / 2) - { - q = clone_gsl(A, true); - // prolong the list from head - if (C) - q->next = C; - C = q; - for (int j = 0; j < dim; j++) - { - if (i == j) - { - C->data->llb[i] = A->data->llb[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->uub[i] = Mymax(C->data->llb[i], cut_plane[i] - DH[i]); -#else -#ifdef Cell - C->data->uub[i] = Mymax(C->data->llb[i], cut_plane[i]); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else - { - C->data->llb[j] = cut_plane[j]; - C->data->uub[j] = cut_plane[j + dim]; - } -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - } - - cut_plane[i + dim] = Mymin(A->data->uub[i], B->data->uub[i]); - if (A->data->uub[i] - cut_plane[i + dim] > DH[i] / 2) - { - q = clone_gsl(A, true); - if (C) - q->next = C; - C = q; - for (int j = 0; j < dim; j++) - { - if (i == j) - { - C->data->uub[i] = A->data->uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->llb[i] = Mymin(C->data->uub[i], cut_plane[i + dim] + DH[i]); -#else -#ifdef Cell - C->data->llb[i] = Mymin(C->data->uub[i], cut_plane[i + dim]); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else - { - C->data->llb[j] = cut_plane[j]; - C->data->uub[j] = cut_plane[j + dim]; - } -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - } - } - return C; -} -// stupid method -/* -MyList *Parallel::gsl_subtract(MyList *A,MyList *B) //A subtract B but with A's information -{ -// always make return and A, B distinct - if(!A) return 0; - - if(!B) return clone_gsl(A,0); - - MyList *C=0,*C0,*C1,*Cc,*CC0,*gs; - - while(A) - { - C0=gs_subtract(A,B); // note C0 becomes a list after subtraction - C1=B->next; - while(C1) - { - CC0=C0; - Cc=0; - while(CC0) - { - gs=gs_subtract(CC0,C1); - if(Cc) Cc->catList(gs); - else Cc=gs; - CC0=CC0->next; - } - if(C0) C0->destroyList(); - C0=Cc; - C1=C1->next; - } - if(C) C->catList(C0); - else C=C0; - A=A->next; - } - - return C; -} -*/ -// more clever method -MyList *Parallel::gsl_subtract(MyList *A, MyList *B) // A subtract B but with A's information -{ - // always make return and A, B distinct - if (!A) - return 0; - - MyList *C = 0, *C0, *C1; - - C = clone_gsl(A, 0); - - while (B) - { - C0 = 0; - C1 = C; - while (C1) - { - if (C0) - C0->catList(gs_subtract(C1, B)); - else - C0 = gs_subtract(C1, B); - C1 = C1->next; - } - if (C) - C->destroyList(); - else - { - if (C0) - C0->destroyList(); - return 0; - } - - C = C0; - B = B->next; - } - - return C; -} -MyList *Parallel::gs_and(MyList *A, MyList *B) -{ - if (!A || !B) - return 0; - - double llb[dim], uub[dim]; - bool flag = false; - for (int i = 0; i < dim; i++) - { - llb[i] = Mymax(A->data->llb[i], B->data->llb[i]); - uub[i] = Mymin(A->data->uub[i], B->data->uub[i]); - if (llb[i] > uub[i]) - { - flag = true; - break; - } - } - if (flag) - return 0; - - MyList *C; - C = clone_gsl(A, true); - for (int i = 0; i < dim; i++) - { - C->data->llb[i] = llb[i]; - C->data->uub[i] = uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / C->data->Bg->getdX(i) + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / C->data->Bg->getdX(i) + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - - return C; -} -// overlap of A_i and (union of all j of B_j) -MyList *Parallel::gsl_and(MyList *A, MyList *B) // A and B but with A's information -{ - MyList *C = 0, *C1; - - while (A) - { - C1 = B; - while (C1) - { - if (C) - C->catList(gs_and(A, C1)); - else - C = gs_and(A, C1); - C1 = C1->next; - } - A = A->next; - } - return C; -} -// collect all ghost grid segments or blocks for given patch -MyList *Parallel::build_ghost_gsl(Patch *Pat) -{ - MyList *cgsl = 0, *gs, *gsb; - MyList *BP = Pat->blb; - while (BP) - { - gs = new MyList; - gs->data = new Parallel::gridseg; - - for (int i = 0; i < dim; i++) - { - gs->data->llb[i] = BP->data->bbox[i]; - gs->data->uub[i] = BP->data->bbox[dim + i]; - gs->data->shape[i] = BP->data->shape[i]; - } - gs->data->Bg = BP->data; - gs->next = 0; - - gsb = build_bulk_gsl(BP->data, Pat); - - if (!cgsl) - cgsl = gs_subtract(gs, gsb); - else - cgsl->catList(gs_subtract(gs, gsb)); - - gsb->destroyList(); - gs->destroyList(); - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all ghost grid segments or blocks for given patch list -MyList *Parallel::build_ghost_gsl(MyList *PatL) -{ - MyList *cgsl = 0, *gs; - while (PatL) - { - if (!cgsl) - { - cgsl = build_ghost_gsl(PatL->data); - gs = cgsl; - while (gs->next) - gs = gs->next; - } - else - { - gs->next = build_ghost_gsl(PatL->data); - gs = gs->next; - while (gs->next) - gs = gs->next; - } - PatL = PatL->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost for given patch -// special for Sync usage, so we do not need consider missing points -MyList *Parallel::build_owned_gsl0(Patch *Pat, int rank_in) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost for given patch -MyList *Parallel::build_owned_gsl1(Patch *Pat, int rank_in) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // NOTE: our dividing structure is (exclude ghost) - // -1 0 - // 1 2 - // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to - // the fortran routine where we always take floor to get index - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + (ghost_width - 1) * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost nor buffer for given patch -MyList *Parallel::build_owned_gsl2(Patch *Pat, int rank_in) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] - Pat->uui[i] * DH : bp->bbox[dim + i] - ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // NOTE: our dividing structure is (exclude ghost) - // -1 0 - // 1 2 - // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to - // the fortran routine where we always take floor to get index - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i] + (ghost_width - 1) * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i] + ghost_width * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost for given patch, and delete the ghost_width for interpolation consideration on the patch boundary -MyList *Parallel::build_owned_gsl3(Patch *Pat, int rank_in, int Symmetry) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = bp->bbox[dim + i] - ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // NOTE: our dividing structure is (exclude ghost) - // -1 0 - // 1 2 - // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to - // the fortran routine where we always take floor to get index - gs->data->llb[i] = bp->bbox[i] + (ghost_width - 1) * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->llb[i] = bp->bbox[i] + ghost_width * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - // Symmetry consideration - if (Symmetry > 0) - { - double DH = bp->getdX(2); - if (feq(bp->bbox[2], 0, DH / 2)) - { - gs->data->llb[2] = bp->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - if (Symmetry > 1) - { - for (int i = 0; i < 2; i++) - { - DH = bp->getdX(i); - if (feq(bp->bbox[i], 0, DH / 2)) - { - gs->data->llb[i] = bp->bbox[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - } - } - } - - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost nor buffer for given patch, -// and delete the ghost_width for interpolation consideration on the patch boundary -MyList *Parallel::build_owned_gsl4(Patch *Pat, int rank_in, int Symmetry) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] - Pat->uui[i] * DH : bp->bbox[dim + i]; - gs->data->uub[i] -= ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // NOTE: our dividing structure is (exclude ghost) - // -1 0 - // 1 2 - // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to - // the fortran routine where we always take floor to get index - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i]; - gs->data->llb[i] += (ghost_width - 1) * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i]; - gs->data->llb[i] += ghost_width * DH; - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - // Symmetry consideration - if (Symmetry > 0) - { - double DH = bp->getdX(2); - if (feq(bp->bbox[2], 0, DH / 2)) - { - gs->data->llb[2] = bp->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - if (Symmetry > 1) - { - for (int i = 0; i < 2; i++) - { - DH = bp->getdX(i); - if (feq(bp->bbox[i], 0, DH / 2)) - { - gs->data->llb[i] = bp->bbox[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - } - } - } - - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost nor buffer for given patch, no extention -MyList *Parallel::build_owned_gsl5(Patch *Pat, int rank_in) -{ - MyList *cgsl = 0, *gs; - MyList *BP = Pat->blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] - Pat->uui[i] * DH : bp->bbox[dim + i] - ghost_width * DH; - gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i] + ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == Pat->ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost for given patch list -// stupid method -/* -MyList *Parallel::build_owned_gsl(MyList *PatL,int rank_in,int type,int Symmetry) -{ - MyList *cgsl=0,*gs; - while(PatL) - { - if(!cgsl) - { - switch(type) - { - case 0: - cgsl = build_owned_gsl0(PatL->data,rank_in); - break; - case 1: - cgsl = build_owned_gsl1(PatL->data,rank_in); - break; - case 2: - cgsl = build_owned_gsl2(PatL->data,rank_in); - break; - case 3: - cgsl = build_owned_gsl3(PatL->data,rank_in,Symmetry); - break; - case 4: - cgsl = build_owned_gsl4(PatL->data,rank_in,Symmetry); - break; - case 5: - cgsl = build_owned_gsl5(PatL->data,rank_in); - break; - default: - cout<<"Parallel::build_owned_gsl : unknown type = "<next) gs = gs->next; - } - else - { - switch(type) - { - case 0: - gs->next = build_owned_gsl0(PatL->data,rank_in); - break; - case 1: - gs->next = build_owned_gsl1(PatL->data,rank_in); - break; - case 2: - gs->next = build_owned_gsl2(PatL->data,rank_in); - break; - case 3: - gs->next = build_owned_gsl3(PatL->data,rank_in,Symmetry); - break; - case 4: - gs->next = build_owned_gsl4(PatL->data,rank_in,Symmetry); - break; - case 5: - gs->next = build_owned_gsl5(PatL->data,rank_in); - break; - default: - cout<<"Parallel::build_owned_gsl : unknown type = "<next) gs = gs->next; - } - PatL = PatL->next; - } - - return cgsl; -} -*/ -// more clever method -MyList *Parallel::build_owned_gsl(MyList *PatL, int rank_in, int type, int Symmetry) -{ - MyList *cgsl = 0, *gs; - while (PatL) - { - switch (type) - { - case 0: - gs = build_owned_gsl0(PatL->data, rank_in); - break; - case 1: - gs = build_owned_gsl1(PatL->data, rank_in); - break; - case 2: - gs = build_owned_gsl2(PatL->data, rank_in); - break; - case 3: - gs = build_owned_gsl3(PatL->data, rank_in, Symmetry); - break; - case 4: - gs = build_owned_gsl4(PatL->data, rank_in, Symmetry); - break; - case 5: - gs = build_owned_gsl5(PatL->data, rank_in); - break; - default: - cout << "Parallel::build_owned_gsl : unknown type = " << type << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (cgsl) - cgsl->catList(gs); - else - cgsl = gs; - PatL = PatL->next; - } - - return cgsl; -} -// according to overlape to determine real grid segments -void Parallel::build_gstl(MyList *srci, MyList *dsti, - MyList **out_src, MyList **out_dst) -{ - *out_src = *out_dst = 0; - - if (!srci || !dsti) - return; - - MyList *s, *d; - MyList *s2, *d2; - - double llb[dim], uub[dim]; - - s = srci; - while (s) - { - Parallel::gridseg *sd = s->data; - d = dsti; - while (d) - { - Parallel::gridseg *dd = d->data; - bool flag = true; - for (int i = 0; i < dim; i++) - { - double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); - llb[i] = Mymax(sd->llb[i], dd->llb[i]); - uub[i] = Mymin(sd->uub[i], dd->uub[i]); - // make sure the region boundary is consistent to the grids - // here we only judge if the domain is empty, so do not need to adjust the align - double lb = llb[i], ub = uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // ---*--- - // x-------x - // if (int(2*(sd->uub[i]-uub[i])/SH+0.4)%2 == 1) ub = uub[i]-SH/2; - // else if(int(2*(dd->uub[i]-uub[i])/DH+0.4)%2 == 1) ub = uub[i]-DH/2; - // if (int(2*(llb[i]-sd->llb[i])/SH+0.4)%2 == 1) lb = llb[i]+SH/2; - // else if(int(2*(llb[i]-dd->llb[i])/DH+0.4)%2 == 1) lb = llb[i]+DH/2; - if (lb > ub + Mymin(SH, DH) / 2) - { - flag = false; - break; - } // special for isolated point -#else -#ifdef Cell - // |------| - // |-------------| - // if (int(2*(sd->uub[i]-uub[i])/SH+0.4)%2 == 1) ub = uub[i]+SH/2; - // else if(int(2*(dd->uub[i]-uub[i])/DH+0.4)%2 == 1) ub = uub[i]+DH/2; - // |------| - // |-------------| - // if (int(2*(llb[i]-sd->llb[i])/SH+0.4)%2 == 1) lb = llb[i]-SH/2; - // else if(int(2*(llb[i]-dd->llb[i])/DH+0.4)%2 == 1) lb = llb[i]-DH/2; - if (ub - lb < Mymin(SH, DH) / 2) - { - flag = false; - break; - } // even for isolated point, it has a cell belong to it -#else -#error Not define Vertex nor Cell -#endif -#endif - } - - if (flag) - { - if (!(*out_src)) - { - *out_src = s2 = new MyList; - *out_dst = d2 = new MyList; - s2->data = new Parallel::gridseg; - d2->data = new Parallel::gridseg; - } - else - { - s2->next = new MyList; - s2 = s2->next; - d2->next = new MyList; - d2 = d2->next; - s2->data = new Parallel::gridseg; - d2->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); - s2->data->llb[i] = d2->data->llb[i] = llb[i]; - s2->data->uub[i] = d2->data->uub[i] = uub[i]; -// using float method to count point, we do not need following consideration (2012 nov 17) -#if 1 - -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - // old code distuinguish vertex and cell - // if (int(2*(sd->uub[i]-uub[i])/SH+0.4)%2 == 1) s2->data->uub[i] = uub[i]-SH/2; - // else if(int(2*(dd->uub[i]-uub[i])/DH+0.4)%2 == 1) d2->data->uub[i] = uub[i]-DH/2; - // if (int(2*(llb[i]-sd->llb[i])/SH+0.4)%2 == 1) s2->data->llb[i] = llb[i]+SH/2; - // else if(int(2*(llb[i]-dd->llb[i])/DH+0.4)%2 == 1) d2->data->llb[i] = llb[i]+DH/2; - // new code: here we concern much more about missing point, because overlaping domain has been gaureented above - if (int(2 * (sd->uub[i] - uub[i]) / SH + 0.4) % 2 == 1) - s2->data->uub[i] = uub[i] + SH / 2; - else if (int(2 * (dd->uub[i] - uub[i]) / DH + 0.4) % 2 == 1) - d2->data->uub[i] = uub[i] + DH / 2; - if (int(2 * (llb[i] - sd->llb[i]) / SH + 0.4) % 2 == 1) - s2->data->llb[i] = llb[i] - SH / 2; - else if (int(2 * (llb[i] - dd->llb[i]) / DH + 0.4) % 2 == 1) - d2->data->llb[i] = llb[i] - DH / 2; - s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4) + 1; - d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - if (int(2 * (sd->uub[i] - uub[i]) / SH + 0.4) % 2 == 1) - s2->data->uub[i] = uub[i] + SH / 2; - else if (int(2 * (dd->uub[i] - uub[i]) / DH + 0.4) % 2 == 1) - d2->data->uub[i] = uub[i] + DH / 2; - if (int(2 * (llb[i] - sd->llb[i]) / SH + 0.4) % 2 == 1) - s2->data->llb[i] = llb[i] - SH / 2; - else if (int(2 * (llb[i] - dd->llb[i]) / DH + 0.4) % 2 == 1) - d2->data->llb[i] = llb[i] - DH / 2; - s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4); - d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - -#endif - s2->data->illb[i] = sd->illb[i]; - d2->data->illb[i] = dd->illb[i]; - s2->data->iuub[i] = sd->iuub[i]; - d2->data->iuub[i] = dd->iuub[i]; - } - s2->data->Bg = sd->Bg; - s2->next = 0; - d2->data->Bg = dd->Bg; - d2->next = 0; - } - d = d->next; - } - s = s->next; - } -} -// PACK: prepare target data in 'data' -// UNPACK: copy target data from 'data' to corresponding numerical grids -int Parallel::data_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int DIM = dim; - - if (dir != PACK && dir != UNPACK) - { - cout << "error dir " << dir << " for data_packer " << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int size_out = 0; - - if (!src || !dst) - return size_out; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int type; /* 1 copy, 2 restrict, 3 prolong */ - if (src->data->Bg->lev == dst->data->Bg->lev) - type = 1; - else if (src->data->Bg->lev > dst->data->Bg->lev) - type = 2; - else - type = 3; - - while (src && dst) - { - if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || - (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) - { - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - if (data) - { - if (dir == PACK) - switch (type) - { - // attention must be paied to the difference between src's llb,uub and dst's llb,uub - case 1: - f_copy(DIM, dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, - src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], - dst->data->llb, dst->data->uub); - break; - case 2: - f_restrict3(DIM, dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, - src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], - dst->data->llb, dst->data->uub, varls->data->SoA, Symmetry); - break; - case 3: - f_prolong3(DIM, src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], - dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, - dst->data->llb, dst->data->uub, varls->data->SoA, Symmetry); - } - if (dir == UNPACK) // from target data to corresponding grid - f_copy(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], - dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, - dst->data->llb, dst->data->uub); - } - size_out += dst->data->shape[0] * dst->data->shape[1] * dst->data->shape[2]; - varls = varls->next; - varld = varld->next; - } - } - dst = dst->next; - src = src->next; - } - - return size_out; -} -int Parallel::data_packermix(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int DIM = dim; - - if (dir != PACK && dir != UNPACK) - { - cout << "Parallel::data_packermix: error dir " << dir << " for data_packermix." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int size_out = 0; - - if (!src || !dst) - return size_out; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int type; /* 1 copy, 2 restrict, 3 prolong */ - if (src->data->Bg->lev == dst->data->Bg->lev) - type = 1; - else if (src->data->Bg->lev > dst->data->Bg->lev) - type = 2; - else - type = 3; - - if (type != 3) - { - cout << "Parallel::data_packermix: error type " << type << " for data_packermix." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - while (src && dst) - { - if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || - (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) - { - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - if (data) - { - if (dir == PACK) - f_prolongcopy3(DIM, src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], - dst->data->llb, dst->data->uub, src->data->shape, data + size_out, - src->data->llb, src->data->uub, varls->data->SoA, Symmetry); - if (dir == UNPACK) // from target data to corresponding grid - f_prolongmix3(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], - src->data->llb, src->data->uub, src->data->shape, data + size_out, - dst->data->llb, dst->data->uub, varls->data->SoA, Symmetry, dst->data->illb, dst->data->iuub); - } - // the symmetry problem should be dealt in prolongcopy3, - // so we always have ghost_width for both sides - size_out += (src->data->shape[0] + 2 * ghost_width) * (src->data->shape[1] + 2 * ghost_width) * (src->data->shape[2] + 2 * ghost_width); - varls = varls->next; - varld = varld->next; - } - } - dst = dst->next; - src = src->next; - } - - return size_out; -} -// -void Parallel::transfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry) -{ - int myrank, cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int node; - - MPI_Request *reqs = new MPI_Request[2 * cpusize]; - MPI_Status *stats = new MPI_Status[2 * cpusize]; - int *req_node = new int[2 * cpusize]; - int *req_is_recv = new int[2 * cpusize]; - int *completed = new int[2 * cpusize]; - int req_no = 0; - int pending_recv = 0; - - double **send_data = new double *[cpusize]; - double **rec_data = new double *[cpusize]; - int *send_lengths = new int[cpusize]; - int *recv_lengths = new int[cpusize]; - - for (node = 0; node < cpusize; node++) - { - send_data[node] = rec_data[node] = 0; - send_lengths[node] = recv_lengths[node] = 0; - } - - // Post receives first so peers can progress rendezvous early. - for (node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - recv_lengths[node] = data_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); - if (recv_lengths[node] > 0) - { - rec_data[node] = new double[recv_lengths[node]]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 1" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Irecv((void *)rec_data[node], recv_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 1; - req_no++; - pending_recv++; - } - } - - // Local transfer on this rank. - recv_lengths[myrank] = data_packer(0, src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - if (recv_lengths[myrank] > 0) - { - rec_data[myrank] = new double[recv_lengths[myrank]]; - if (!rec_data[myrank]) - { - cout << "out of memory when new in short transfer, place 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - data_packer(rec_data[myrank], src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - } - - // Pack and post sends. - for (node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - send_lengths[node] = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - if (send_lengths[node] > 0) - { - send_data[node] = new double[send_lengths[node]]; - if (!send_data[node]) - { - cout << "out of memory when new in short transfer, place 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - data_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - MPI_Isend((void *)send_data[node], send_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 0; - req_no++; - } - } - - // Unpack as soon as receive completes to reduce pure wait time. - while (pending_recv > 0) - { - int outcount = 0; - MPI_Waitsome(req_no, reqs, &outcount, completed, stats); - if (outcount == MPI_UNDEFINED) break; - - for (int i = 0; i < outcount; i++) - { - int idx = completed[i]; - if (idx >= 0 && req_is_recv[idx]) - { - int recv_node = req_node[idx]; - data_packer(rec_data[recv_node], src[recv_node], dst[recv_node], recv_node, UNPACK, VarList1, VarList2, Symmetry); - pending_recv--; - } - } - } - - if (req_no > 0) MPI_Waitall(req_no, reqs, stats); - - if (rec_data[myrank]) - data_packer(rec_data[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); - - for (node = 0; node < cpusize; node++) - { - if (send_data[node]) - delete[] send_data[node]; - if (rec_data[node]) - delete[] rec_data[node]; - } - - delete[] reqs; - delete[] stats; - delete[] req_node; - delete[] req_is_recv; - delete[] completed; - delete[] send_data; - delete[] rec_data; - delete[] send_lengths; - delete[] recv_lengths; -} -// -void Parallel::transfermix(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry) -{ - int myrank, cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int node; - - MPI_Request *reqs = new MPI_Request[2 * cpusize]; - MPI_Status *stats = new MPI_Status[2 * cpusize]; - int *req_node = new int[2 * cpusize]; - int *req_is_recv = new int[2 * cpusize]; - int *completed = new int[2 * cpusize]; - int req_no = 0; - int pending_recv = 0; - - double **send_data = new double *[cpusize]; - double **rec_data = new double *[cpusize]; - int *send_lengths = new int[cpusize]; - int *recv_lengths = new int[cpusize]; - - for (node = 0; node < cpusize; node++) - { - send_data[node] = rec_data[node] = 0; - send_lengths[node] = recv_lengths[node] = 0; - } - - // Post receives first so peers can progress rendezvous early. - for (node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - recv_lengths[node] = data_packermix(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); - if (recv_lengths[node] > 0) - { - rec_data[node] = new double[recv_lengths[node]]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 1" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Irecv((void *)rec_data[node], recv_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 1; - req_no++; - pending_recv++; - } - } - - // Local transfer on this rank. - recv_lengths[myrank] = data_packermix(0, src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - if (recv_lengths[myrank] > 0) - { - rec_data[myrank] = new double[recv_lengths[myrank]]; - if (!rec_data[myrank]) - { - cout << "out of memory when new in short transfer, place 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - data_packermix(rec_data[myrank], src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - } - - // Pack and post sends. - for (node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - send_lengths[node] = data_packermix(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - if (send_lengths[node] > 0) - { - send_data[node] = new double[send_lengths[node]]; - if (!send_data[node]) - { - cout << "out of memory when new in short transfer, place 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - data_packermix(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - MPI_Isend((void *)send_data[node], send_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 0; - req_no++; - } - } - - // Unpack as soon as receive completes to reduce pure wait time. - while (pending_recv > 0) - { - int outcount = 0; - MPI_Waitsome(req_no, reqs, &outcount, completed, stats); - if (outcount == MPI_UNDEFINED) break; - - for (int i = 0; i < outcount; i++) - { - int idx = completed[i]; - if (idx >= 0 && req_is_recv[idx]) - { - int recv_node = req_node[idx]; - data_packermix(rec_data[recv_node], src[recv_node], dst[recv_node], recv_node, UNPACK, VarList1, VarList2, Symmetry); - pending_recv--; - } - } - } - - if (req_no > 0) MPI_Waitall(req_no, reqs, stats); - - if (rec_data[myrank]) - data_packermix(rec_data[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); - - for (node = 0; node < cpusize; node++) - { - if (send_data[node]) - delete[] send_data[node]; - if (rec_data[node]) - delete[] rec_data[node]; - } - - delete[] reqs; - delete[] stats; - delete[] req_node; - delete[] req_is_recv; - delete[] completed; - delete[] send_data; - delete[] rec_data; - delete[] send_lengths; - delete[] recv_lengths; -} -void Parallel::Sync(Patch *Pat, MyList *VarList, int Symmetry) -{ - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_ghost_gsl(Pat); // ghost region only - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl0(Pat, node); // for the part without ghost points and do not extend - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer_src[node], data locate on cpu#node; - // but for transfer_dst[node] the data may locate on any node - } - - transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -void Parallel::Sync(MyList *PatL, MyList *VarList, int Symmetry) -{ - // Patch inner Synch - MyList *Pp = PatL; - while (Pp) - { - Sync(Pp->data, VarList, Symmetry); - Pp = Pp->next; - } - - // Patch inter Synch - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_buffer_gsl(PatL); // buffer region only - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl(PatL, node, 5, Symmetry); // for the part without ghost nor buffer points and do not extend - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -// Merged Sync: collect all intra-patch and inter-patch grid segment lists, -// then issue a single transfer() call instead of N+1 separate ones. -void Parallel::Sync_merged(MyList *PatL, MyList *VarList, int Symmetry) -{ - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList **combined_src = new MyList *[cpusize]; - MyList **combined_dst = new MyList *[cpusize]; - for (int node = 0; node < cpusize; node++) - combined_src[node] = combined_dst[node] = 0; - - // Phase A: Intra-patch ghost exchange segments - MyList *Pp = PatL; - while (Pp) - { - Patch *Pat = Pp->data; - MyList *dst_ghost = build_ghost_gsl(Pat); - - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl0(Pat, node); - MyList *tsrc = 0, *tdst = 0; - build_gstl(src_owned, dst_ghost, &tsrc, &tdst); - - if (tsrc) - { - if (combined_src[node]) - combined_src[node]->catList(tsrc); - else - combined_src[node] = tsrc; - } - if (tdst) - { - if (combined_dst[node]) - combined_dst[node]->catList(tdst); - else - combined_dst[node] = tdst; - } - - if (src_owned) - src_owned->destroyList(); - } - - if (dst_ghost) - dst_ghost->destroyList(); - - Pp = Pp->next; - } - - // Phase B: Inter-patch buffer exchange segments - MyList *dst_buffer = build_buffer_gsl(PatL); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl(PatL, node, 5, Symmetry); - MyList *tsrc = 0, *tdst = 0; - build_gstl(src_owned, dst_buffer, &tsrc, &tdst); - - if (tsrc) - { - if (combined_src[node]) - combined_src[node]->catList(tsrc); - else - combined_src[node] = tsrc; - } - if (tdst) - { - if (combined_dst[node]) - combined_dst[node]->catList(tdst); - else - combined_dst[node] = tdst; - } - - if (src_owned) - src_owned->destroyList(); - } - if (dst_buffer) - dst_buffer->destroyList(); - - // Phase C: Single transfer - transfer(combined_src, combined_dst, VarList, VarList, Symmetry); - - // Phase D: Cleanup - for (int node = 0; node < cpusize; node++) - { - if (combined_src[node]) - combined_src[node]->destroyList(); - if (combined_dst[node]) - combined_dst[node]->destroyList(); - } - delete[] combined_src; - delete[] combined_dst; -} -// SyncCache constructor -Parallel::SyncCache::SyncCache() - : valid(false), cpusize(0), combined_src(0), combined_dst(0), - send_lengths(0), recv_lengths(0), send_bufs(0), recv_bufs(0), - send_buf_caps(0), recv_buf_caps(0), reqs(0), stats(0), max_reqs(0), - lengths_valid(false), tc_req_node(0), tc_req_is_recv(0), tc_completed(0) -{ -} -// SyncCache invalidate: free grid segment lists but keep buffers -void Parallel::SyncCache::invalidate() -{ - if (!valid) - return; - for (int i = 0; i < cpusize; i++) - { - if (combined_src[i]) - combined_src[i]->destroyList(); - if (combined_dst[i]) - combined_dst[i]->destroyList(); - combined_src[i] = combined_dst[i] = 0; - send_lengths[i] = recv_lengths[i] = 0; - } - valid = false; - lengths_valid = false; -} -// SyncCache destroy: free everything -void Parallel::SyncCache::destroy() -{ - invalidate(); - if (combined_src) delete[] combined_src; - if (combined_dst) delete[] combined_dst; - if (send_lengths) delete[] send_lengths; - if (recv_lengths) delete[] recv_lengths; - if (send_buf_caps) delete[] send_buf_caps; - if (recv_buf_caps) delete[] recv_buf_caps; - for (int i = 0; i < cpusize; i++) - { - if (send_bufs && send_bufs[i]) delete[] send_bufs[i]; - if (recv_bufs && recv_bufs[i]) delete[] recv_bufs[i]; - } - if (send_bufs) delete[] send_bufs; - if (recv_bufs) delete[] recv_bufs; - if (reqs) delete[] reqs; - if (stats) delete[] stats; - if (tc_req_node) delete[] tc_req_node; - if (tc_req_is_recv) delete[] tc_req_is_recv; - if (tc_completed) delete[] tc_completed; - combined_src = combined_dst = 0; - send_lengths = recv_lengths = 0; - send_buf_caps = recv_buf_caps = 0; - send_bufs = recv_bufs = 0; - reqs = 0; stats = 0; - tc_req_node = 0; tc_req_is_recv = 0; tc_completed = 0; - cpusize = 0; max_reqs = 0; -} -// transfer_cached: reuse pre-allocated buffers from SyncCache -void Parallel::transfer_cached(MyList **src, MyList **dst, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache) -{ - int myrank; - MPI_Comm_size(MPI_COMM_WORLD, &cache.cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - int cpusize = cache.cpusize; - - int req_no = 0; - int pending_recv = 0; - int node; - int *req_node = cache.tc_req_node; - int *req_is_recv = cache.tc_req_is_recv; - int *completed = cache.tc_completed; - - // Post receives first so peers can progress rendezvous early. - for (node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - int rlength = data_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); - cache.recv_lengths[node] = rlength; - if (rlength > 0) - { - if (rlength > cache.recv_buf_caps[node]) - { - if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; - cache.recv_bufs[node] = new double[rlength]; - cache.recv_buf_caps[node] = rlength; - } - MPI_Irecv((void *)cache.recv_bufs[node], rlength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 1; - req_no++; - pending_recv++; - } - } - - // Local transfer on this rank. - int self_len = data_packer(0, src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - cache.recv_lengths[myrank] = self_len; - if (self_len > 0) - { - if (self_len > cache.recv_buf_caps[myrank]) - { - if (cache.recv_bufs[myrank]) delete[] cache.recv_bufs[myrank]; - cache.recv_bufs[myrank] = new double[self_len]; - cache.recv_buf_caps[myrank] = self_len; - } - data_packer(cache.recv_bufs[myrank], src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - } - - // Pack and post sends. - for (node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - int slength = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - cache.send_lengths[node] = slength; - if (slength > 0) - { - if (slength > cache.send_buf_caps[node]) - { - if (cache.send_bufs[node]) delete[] cache.send_bufs[node]; - cache.send_bufs[node] = new double[slength]; - cache.send_buf_caps[node] = slength; - } - data_packer(cache.send_bufs[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - MPI_Isend((void *)cache.send_bufs[node], slength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 0; - req_no++; - } - } - - // Unpack as soon as receive completes to reduce pure wait time. - while (pending_recv > 0) - { - int outcount = 0; - MPI_Waitsome(req_no, cache.reqs, &outcount, completed, cache.stats); - if (outcount == MPI_UNDEFINED) break; - - for (int i = 0; i < outcount; i++) - { - int idx = completed[i]; - if (idx >= 0 && req_is_recv[idx]) - { - int recv_node_i = req_node[idx]; - data_packer(cache.recv_bufs[recv_node_i], src[recv_node_i], dst[recv_node_i], recv_node_i, UNPACK, VarList1, VarList2, Symmetry); - pending_recv--; - } - } - } - - if (req_no > 0) MPI_Waitall(req_no, cache.reqs, cache.stats); - - if (self_len > 0) - data_packer(cache.recv_bufs[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); -} -void Parallel::Sync_cached(MyList *PatL, MyList *VarList, int Symmetry, SyncCache &cache) -{ - if (!cache.valid) - { - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - cache.cpusize = cpusize; - - // Allocate cache arrays if needed - if (!cache.combined_src) - { - cache.combined_src = new MyList *[cpusize]; - cache.combined_dst = new MyList *[cpusize]; - cache.send_lengths = new int[cpusize]; - cache.recv_lengths = new int[cpusize]; - cache.send_bufs = new double *[cpusize]; - cache.recv_bufs = new double *[cpusize]; - cache.send_buf_caps = new int[cpusize]; - cache.recv_buf_caps = new int[cpusize]; - for (int i = 0; i < cpusize; i++) - { - cache.send_bufs[i] = cache.recv_bufs[i] = 0; - cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; - } - cache.max_reqs = 2 * cpusize; - cache.reqs = new MPI_Request[cache.max_reqs]; - cache.stats = new MPI_Status[cache.max_reqs]; - cache.tc_req_node = new int[cache.max_reqs]; - cache.tc_req_is_recv = new int[cache.max_reqs]; - cache.tc_completed = new int[cache.max_reqs]; - } - - for (int node = 0; node < cpusize; node++) - { - cache.combined_src[node] = cache.combined_dst[node] = 0; - cache.send_lengths[node] = cache.recv_lengths[node] = 0; - } - - // Build intra-patch segments (same as Sync_merged Phase A) - MyList *Pp = PatL; - while (Pp) - { - Patch *Pat = Pp->data; - MyList *dst_ghost = build_ghost_gsl(Pat); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl0(Pat, node); - MyList *tsrc = 0, *tdst = 0; - build_gstl(src_owned, dst_ghost, &tsrc, &tdst); - if (tsrc) - { - if (cache.combined_src[node]) - cache.combined_src[node]->catList(tsrc); - else - cache.combined_src[node] = tsrc; - } - if (tdst) - { - if (cache.combined_dst[node]) - cache.combined_dst[node]->catList(tdst); - else - cache.combined_dst[node] = tdst; - } - if (src_owned) src_owned->destroyList(); - } - if (dst_ghost) dst_ghost->destroyList(); - Pp = Pp->next; - } - - // Build inter-patch segments (same as Sync_merged Phase B) - MyList *dst_buffer = build_buffer_gsl(PatL); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl(PatL, node, 5, Symmetry); - MyList *tsrc = 0, *tdst = 0; - build_gstl(src_owned, dst_buffer, &tsrc, &tdst); - if (tsrc) - { - if (cache.combined_src[node]) - cache.combined_src[node]->catList(tsrc); - else - cache.combined_src[node] = tsrc; - } - if (tdst) - { - if (cache.combined_dst[node]) - cache.combined_dst[node]->catList(tdst); - else - cache.combined_dst[node] = tdst; - } - if (src_owned) src_owned->destroyList(); - } - if (dst_buffer) dst_buffer->destroyList(); - - cache.valid = true; - } - - // Use cached lists with buffer-reusing transfer - transfer_cached(cache.combined_src, cache.combined_dst, VarList, VarList, Symmetry, cache); -} -// Sync_start: pack and post MPI_Isend/Irecv, return immediately -void Parallel::Sync_start(MyList *PatL, MyList *VarList, int Symmetry, - SyncCache &cache, AsyncSyncState &state) -{ - // Ensure cache is built - if (!cache.valid) - { - // Build cache (same logic as Sync_cached) - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - cache.cpusize = cpusize; - - if (!cache.combined_src) - { - cache.combined_src = new MyList *[cpusize]; - cache.combined_dst = new MyList *[cpusize]; - cache.send_lengths = new int[cpusize]; - cache.recv_lengths = new int[cpusize]; - cache.send_bufs = new double *[cpusize]; - cache.recv_bufs = new double *[cpusize]; - cache.send_buf_caps = new int[cpusize]; - cache.recv_buf_caps = new int[cpusize]; - for (int i = 0; i < cpusize; i++) - { - cache.send_bufs[i] = cache.recv_bufs[i] = 0; - cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; - } - cache.max_reqs = 2 * cpusize; - cache.reqs = new MPI_Request[cache.max_reqs]; - cache.stats = new MPI_Status[cache.max_reqs]; - cache.tc_req_node = new int[cache.max_reqs]; - cache.tc_req_is_recv = new int[cache.max_reqs]; - cache.tc_completed = new int[cache.max_reqs]; - } - - for (int node = 0; node < cpusize; node++) - { - cache.combined_src[node] = cache.combined_dst[node] = 0; - cache.send_lengths[node] = cache.recv_lengths[node] = 0; - } - - MyList *Pp = PatL; - while (Pp) - { - Patch *Pat = Pp->data; - MyList *dst_ghost = build_ghost_gsl(Pat); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl0(Pat, node); - MyList *tsrc = 0, *tdst = 0; - build_gstl(src_owned, dst_ghost, &tsrc, &tdst); - if (tsrc) - { - if (cache.combined_src[node]) - cache.combined_src[node]->catList(tsrc); - else - cache.combined_src[node] = tsrc; - } - if (tdst) - { - if (cache.combined_dst[node]) - cache.combined_dst[node]->catList(tdst); - else - cache.combined_dst[node] = tdst; - } - if (src_owned) src_owned->destroyList(); - } - if (dst_ghost) dst_ghost->destroyList(); - Pp = Pp->next; - } - - MyList *dst_buffer = build_buffer_gsl(PatL); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl(PatL, node, 5, Symmetry); - MyList *tsrc = 0, *tdst = 0; - build_gstl(src_owned, dst_buffer, &tsrc, &tdst); - if (tsrc) - { - if (cache.combined_src[node]) - cache.combined_src[node]->catList(tsrc); - else - cache.combined_src[node] = tsrc; - } - if (tdst) - { - if (cache.combined_dst[node]) - cache.combined_dst[node]->catList(tdst); - else - cache.combined_dst[node] = tdst; - } - if (src_owned) src_owned->destroyList(); - } - if (dst_buffer) dst_buffer->destroyList(); - cache.valid = true; - } - - // Now pack and post async MPI operations - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - int cpusize = cache.cpusize; - state.req_no = 0; - state.active = true; - state.pending_recv = 0; - // Allocate tracking arrays - delete[] state.req_node; delete[] state.req_is_recv; - state.req_node = new int[cache.max_reqs]; - state.req_is_recv = new int[cache.max_reqs]; - - MyList **src = cache.combined_src; - MyList **dst = cache.combined_dst; - - for (int node = 0; node < cpusize; node++) - { - if (node == myrank) - { - int length; - if (!cache.lengths_valid) { - length = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); - cache.recv_lengths[node] = length; - } else { - length = cache.recv_lengths[node]; - } - if (length > 0) - { - if (length > cache.recv_buf_caps[node]) - { - if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; - cache.recv_bufs[node] = new double[length]; - cache.recv_buf_caps[node] = length; - } - data_packer(cache.recv_bufs[node], src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); - } - } - else - { - int slength; - if (!cache.lengths_valid) { - slength = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); - cache.send_lengths[node] = slength; - } else { - slength = cache.send_lengths[node]; - } - if (slength > 0) - { - if (slength > cache.send_buf_caps[node]) - { - if (cache.send_bufs[node]) delete[] cache.send_bufs[node]; - cache.send_bufs[node] = new double[slength]; - cache.send_buf_caps[node] = slength; - } - data_packer(cache.send_bufs[node], src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); - state.req_node[state.req_no] = node; - state.req_is_recv[state.req_no] = 0; - MPI_Isend((void *)cache.send_bufs[node], slength, MPI_DOUBLE, node, 2, MPI_COMM_WORLD, cache.reqs + state.req_no++); - } - int rlength; - if (!cache.lengths_valid) { - rlength = data_packer(0, src[node], dst[node], node, UNPACK, VarList, VarList, Symmetry); - cache.recv_lengths[node] = rlength; - } else { - rlength = cache.recv_lengths[node]; - } - if (rlength > 0) - { - if (rlength > cache.recv_buf_caps[node]) - { - if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; - cache.recv_bufs[node] = new double[rlength]; - cache.recv_buf_caps[node] = rlength; - } - state.req_node[state.req_no] = node; - state.req_is_recv[state.req_no] = 1; - state.pending_recv++; - MPI_Irecv((void *)cache.recv_bufs[node], rlength, MPI_DOUBLE, node, 2, MPI_COMM_WORLD, cache.reqs + state.req_no++); - } - } - } - cache.lengths_valid = true; -} -// Sync_finish: progressive unpack as receives complete, then wait for sends -void Parallel::Sync_finish(SyncCache &cache, AsyncSyncState &state, - MyList *VarList, int Symmetry) -{ - if (!state.active) - return; - - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - MyList **src = cache.combined_src; - MyList **dst = cache.combined_dst; - - // Unpack local data first (no MPI needed) - if (cache.recv_bufs[myrank] && cache.recv_lengths[myrank] > 0) - data_packer(cache.recv_bufs[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList, VarList, Symmetry); - - // Progressive unpack of remote receives - if (state.pending_recv > 0 && state.req_no > 0) - { - int pending = state.pending_recv; - int *completed = new int[cache.max_reqs]; - while (pending > 0) - { - int outcount = 0; - MPI_Waitsome(state.req_no, cache.reqs, &outcount, completed, cache.stats); - if (outcount == MPI_UNDEFINED) break; - for (int i = 0; i < outcount; i++) - { - int idx = completed[i]; - if (idx >= 0 && state.req_is_recv[idx]) - { - int recv_node = state.req_node[idx]; - data_packer(cache.recv_bufs[recv_node], src[recv_node], dst[recv_node], recv_node, UNPACK, VarList, VarList, Symmetry); - pending--; - } - } - } - delete[] completed; - } - - // Wait for remaining sends - if (state.req_no > 0) MPI_Waitall(state.req_no, cache.reqs, cache.stats); - - delete[] state.req_node; state.req_node = 0; - delete[] state.req_is_recv; state.req_is_recv = 0; - state.active = false; -} -// collect buffer grid segments or blocks for the periodic boundary condition of given patch -// --------------------------------------------------- -// |con | |con | -// |ner | PhysBD |ner | -// |-------------------------------------------------| -// | | | | -// |Phy | |Phy | -// |sBD | |BD | -// | | | | -// | | | | -// | | | | -// |-------------------------------------------------| -// |con | PhysBD |con | -// |ner | |ner | -// --------------------------------------------------- -// first order derivetive does not need conner information, -// but second order derivative needs! -/* the following code does not include conner part -MyList *Parallel::build_PhysBD_gsl(Patch *Pat) -{ - MyList *cgsl,*gsc,*gsb=0,*p; - gsc = build_ghost_gsl(Pat); - for(int i=0;idata->Bg->getdX(i); -// lower boundary - if(gsb) - { - p = new MyList; - p->data = new Parallel::gridseg; - p->next=gsb; - gsb=p; - } - else - { - gsb = new MyList; - gsb->data = new Parallel::gridseg; - gsb->next=0; - } - for(int j=0;jdata->llb[i] = Pat->bbox[i]-ghost_width*DH; - gsb->data->uub[i] = Pat->bbox[i]-DH; -#else -#ifdef Cell - gsb->data->llb[i] = Pat->bbox[i]-ghost_width*DH; - gsb->data->uub[i] = Pat->bbox[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - gsb->data->shape[i] = ghost_width; - } - else - { - gsb->data->llb[j] = Pat->bbox[j]; - gsb->data->uub[j] = Pat->bbox[j+dim]; - gsb->data->shape[j] = Pat->shape[j]; - } - } - gsb->data->Bg = 0; //vertual grid segment -// upper boundary - p = new MyList; - p->data = new Parallel::gridseg; - p->next=gsb; - gsb=p; - for(int j=0;jdata->llb[i] = Pat->bbox[i+dim]+DH; - gsb->data->uub[i] = Pat->bbox[i+dim]+ghost_width*DH; -#else -#ifdef Cell - gsb->data->llb[i] = Pat->bbox[i+dim]; - gsb->data->uub[i] = Pat->bbox[i+dim]+ghost_width*DH; -#else -#error Not define Vertex nor Cell -#endif -#endif - gsb->data->shape[i] = ghost_width; - } - else - { - gsb->data->llb[j] = Pat->bbox[j]; - gsb->data->uub[j] = Pat->bbox[j+dim]; - gsb->data->shape[j] = Pat->shape[j]; - } - } - gsb->data->Bg = 0; //vertual grid segment - } - - cgsl = gsl_and(gsc,gsb); - - gsc->destroyList(); - gsb->destroyList(); - - return cgsl; -} -*/ -// the following code includes conner part -MyList *Parallel::build_PhysBD_gsl(Patch *Pat) -{ - MyList *cgsl, *gsc, *gsb = 0, *p; - - gsc = build_complete_gsl(Pat); - - gsb = new MyList; - gsb->data = new Parallel::gridseg; - gsb->next = 0; - gsb->data->Bg = 0; - - for (int j = 0; j < dim; j++) - { - gsb->data->llb[j] = Pat->bbox[j]; - gsb->data->uub[j] = Pat->bbox[j + dim]; - gsb->data->shape[j] = Pat->shape[j]; - } - - p = gsl_subtract(gsc, gsb); - - gsc->destroyList(); - gsb->destroyList(); - - cgsl = divide_gsl(p, Pat); - - p->destroyList(); - - return cgsl; -} -MyList *Parallel::divide_gsl(MyList *p, Patch *Pat) -{ - MyList *cgsl = 0; - while (p) - { - if (cgsl) - cgsl->catList(divide_gs(p, Pat)); - else - cgsl = divide_gs(p, Pat); - p = p->next; - } - - return cgsl; -} -// divide the gs into pices which locate either totally outside of the given Patch coordinate range -// or totally inside it. It's usefull for periodic boundary condition -MyList *Parallel::divide_gs(MyList *p, Patch *Pat) -{ - double DH[dim]; - for (int i = 0; i < dim; i++) - { - DH[i] = p->data->Bg->getdX(i); - } - - int num[dim]; - double llb[3][dim], uub[3][dim]; - for (int i = 0; i < dim; i++) - { - if (p->data->llb[i] < Pat->bbox[i] - DH[i] / 2) - { - if (p->data->uub[i] > Pat->bbox[i + dim] + DH[i] / 2) - { - num[i] = 3; - llb[0][i] = p->data->llb[i]; - llb[1][i] = Pat->bbox[i]; - uub[1][i] = Pat->bbox[i + dim]; - uub[2][i] = p->data->uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - uub[0][i] = Pat->bbox[i] - DH[i]; - llb[2][i] = Pat->bbox[i + dim] + DH[i]; -#else -#ifdef Cell - uub[0][i] = Pat->bbox[i]; - llb[2][i] = Pat->bbox[i + dim]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else if (p->data->uub[i] > Pat->bbox[i] + DH[i] / 2) - { - num[i] = 2; - llb[0][i] = p->data->llb[i]; - llb[1][i] = Pat->bbox[i]; - uub[1][i] = p->data->uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - uub[0][i] = Pat->bbox[i] - DH[i]; -#else -#ifdef Cell - uub[0][i] = Pat->bbox[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else - { - num[i] = 1; - llb[0][i] = p->data->llb[i]; - uub[0][i] = p->data->uub[i]; - } - } - else if (p->data->llb[i] < Pat->bbox[i + dim] - DH[i] / 2) - { - if (p->data->uub[i] > Pat->bbox[i + dim] + DH[i] / 2) - { - num[i] = 2; - llb[0][i] = p->data->llb[i]; - uub[0][i] = Pat->bbox[i + dim]; - uub[1][i] = p->data->uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[1][i] = Pat->bbox[i + dim] + DH[i]; -#else -#ifdef Cell - llb[1][i] = Pat->bbox[i + dim]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - else - { - num[i] = 1; - llb[0][i] = p->data->llb[i]; - uub[0][i] = p->data->uub[i]; - } - } - else - { - num[i] = 1; - llb[0][i] = p->data->llb[i]; - uub[0][i] = p->data->uub[i]; - } - } - MyList *cgsl = 0, *gg; - int NN = 1; - for (int i = 0; i < dim; i++) - NN = NN * num[i]; - - for (int i = 0; i < NN; i++) - { - int ind[dim]; - getarrayindex(dim, num, ind, i); - gg = clone_gsl(p, true); - for (int k = 0; k < dim; k++) - { - gg->data->llb[k] = llb[ind[k]][k]; - gg->data->uub[k] = uub[ind[k]][k]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gg->data->shape[k] = int((uub[ind[k]][k] - llb[ind[k]][k]) / DH[k] + 0.4) + 1; -#else -#ifdef Cell - gg->data->shape[k] = int((uub[ind[k]][k] - llb[ind[k]][k]) / DH[k] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - - if (cgsl) - cgsl->catList(gg); - else - cgsl = gg; - } - - return cgsl; -} -// after mod operation, according to overlape to determine real grid segments -void Parallel::build_PhysBD_gstl(Patch *Pat, MyList *srci, MyList *dsti, - MyList **out_src, MyList **out_dst) -{ - *out_src = *out_dst = 0; - - if (!srci || !dsti) - return; - - MyList *s, *d; - MyList *s2, *d2; - - double llb[dim], uub[dim]; - - s = srci; - while (s) - { - Parallel::gridseg *sd = s->data; - d = dsti; - while (d) - { - Parallel::gridseg *dd = d->data; - bool flag = true; - for (int i = 0; i < dim; i++) - { - double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); - if (!feq(SH, DH, SH / 2)) - { - cout << "Parallel::build_PhysBD_gstl meets different grid space SH = " << SH << ", DH = " << DH << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - // we assume dst and src locate on the same Patch - if (dd->llb[i] < Pat->bbox[i]) - llb[i] = Mymax(sd->llb[i], dd->llb[i] + Pat->bbox[dim + i] - Pat->bbox[i]); - else if (dd->llb[i] > Pat->bbox[i + dim]) - llb[i] = Mymax(sd->llb[i], dd->llb[i] - Pat->bbox[dim + i] + Pat->bbox[i]); - else - llb[i] = Mymax(sd->llb[i], dd->llb[i]); - - if (dd->uub[i] < Pat->bbox[i]) - uub[i] = Mymin(sd->uub[i], dd->uub[i] + Pat->bbox[dim + i] - Pat->bbox[i]); - else if (dd->uub[i] > Pat->bbox[dim + i]) - uub[i] = Mymin(sd->uub[i], dd->uub[i] - Pat->bbox[dim + i] + Pat->bbox[i]); - else - uub[i] = Mymin(sd->uub[i], dd->uub[i]); -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (llb[i] > uub[i] + SH / 2) - { - flag = false; - break; - } // special for isolated point -#else -#ifdef Cell - if (llb[i] > uub[i]) - { - flag = false; - break; - } -#else -#error Not define Vertex nor Cell -#endif -#endif - } - - if (flag) - { - if (!(*out_src)) - { - *out_src = s2 = new MyList; - *out_dst = d2 = new MyList; - s2->data = new Parallel::gridseg; - d2->data = new Parallel::gridseg; - } - else - { - s2->next = new MyList; - s2 = s2->next; - d2->next = new MyList; - d2 = d2->next; - s2->data = new Parallel::gridseg; - d2->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); - s2->data->llb[i] = llb[i]; - s2->data->uub[i] = uub[i]; - - if (dd->llb[i] < Pat->bbox[i]) - d2->data->llb[i] = llb[i] - Pat->bbox[dim + i] + Pat->bbox[i]; - else if (dd->llb[i] > Pat->bbox[i + dim]) - d2->data->llb[i] = llb[i] + Pat->bbox[dim + i] - Pat->bbox[i]; - else - d2->data->llb[i] = llb[i]; - - if (dd->uub[i] < Pat->bbox[i]) - d2->data->uub[i] = uub[i] - Pat->bbox[dim + i] + Pat->bbox[i]; - else if (dd->uub[i] > Pat->bbox[dim + i]) - d2->data->uub[i] = uub[i] + Pat->bbox[dim + i] - Pat->bbox[i]; - else - d2->data->uub[i] = uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4) + 1; - d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4); - d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - s2->data->Bg = sd->Bg; - s2->next = 0; - d2->data->Bg = dd->Bg; - d2->next = 0; - } - d = d->next; - } - s = s->next; - } -} -void Parallel::PeriodicBD(Patch *Pat, MyList *VarList, int Symmetry) -{ - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_PhysBD_gsl(Pat); - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl0(Pat, node); // for the part without ghost points and do not extend - build_PhysBD_gstl(Pat, src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} + +#include "Parallel.h" +#include "fmisc.h" +#include "prolongrestrict.h" +#include "misc.h" +#include "parameters.h" + +int Parallel::partition1(int &nx, int split_size, int min_width, int cpusize, int shape) // special for 1 diemnsion +{ + nx = Mymax(1, shape / min_width); + nx = Mymin(cpusize, nx); + + return nx; +} +int Parallel::partition2(int *nxy, int split_size, int *min_width, int cpusize, int *shape) // special for 2 diemnsions +{ +#define SEARCH_SIZE 5 + int i, j, nx, ny; + int maxnx, maxny; + int mnx, mny; + int dn, hmin_width, cmin_width; + int cnx, cny; + double fx, fy; + int block_size; + int n; + + block_size = shape[0] * shape[1]; + n = Mymax(1, (block_size + split_size / 2) / split_size); + + maxnx = Mymax(1, shape[0] / min_width[0]); + maxnx = Mymin(cpusize, maxnx); + maxny = Mymax(1, shape[1] / min_width[1]); + maxny = Mymin(cpusize, maxny); + fx = (double)shape[0] / (shape[0] + shape[1]); + fy = (double)shape[1] / (shape[0] + shape[1]); + nx = mnx = Mymax(1, Mymin(maxnx, (int)(sqrt(double(n)) * fx / fy))); + ny = mny = Mymax(1, Mymin(maxny, (int)(sqrt(double(n)) * fy / fx))); + dn = abs(n - nx * ny); + hmin_width = Mymin(shape[0] / nx, shape[1] / ny); + for (cny = Mymax(1, mny - SEARCH_SIZE); cny <= (Mymin(mny + SEARCH_SIZE, maxny)); cny++) + for (cnx = Mymax(1, mnx - SEARCH_SIZE); cnx <= (Mymin(mnx + SEARCH_SIZE, maxnx)); cnx++) + { + cmin_width = Mymin(shape[0] / cnx, shape[1] / cny); + if (dn > abs(n - cnx * cny) || (dn == abs(n - cnx * cny) && cmin_width > hmin_width)) + { + dn = abs(n - cnx * cny); + nx = cnx; + ny = cny; + hmin_width = cmin_width; + } + } + + nxy[0] = nx; + nxy[1] = ny; + + return nx * ny; +#undef SEARCH_SIZE +} +int Parallel::partition3(int *nxyz, int split_size, int *min_width, int cpusize, int *shape) // special for 3 diemnsions +#if 1 // algrithsm from Pretorius +{ +// cout< abs(n - cnx * cny * cnz) || (dn == abs(n - cnx * cny * cnz) && cmin_width > hmin_width)) + { + dn = abs(n - cnx * cny * cnz); + nx = cnx; + ny = cny; + nz = cnz; + hmin_width = cmin_width; + } + } + + nxyz[0] = nx; + nxyz[1] = ny; + nxyz[2] = nz; + + return nx * ny * nz; +#undef SEARCH_SIZE +} +#elif 1 // Zhihui's idea one on 2013-09-25 +{ + int nx, ny, nz; + int hmin_width; + hmin_width = Mymin(min_width[0], min_width[1]); + hmin_width = Mymin(hmin_width, min_width[2]); + nx = shape[0] / hmin_width; + if (nx * hmin_width < shape[0]) + nx++; + ny = shape[1] / hmin_width; + if (ny * hmin_width < shape[1]) + ny++; + nz = shape[2] / hmin_width; + if (nz * hmin_width < shape[2]) + nz++; + while (nx * ny * nz > cpusize) + { + hmin_width++; + nx = shape[0] / hmin_width; + if (nx * hmin_width < shape[0]) + nx++; + ny = shape[1] / hmin_width; + if (ny * hmin_width < shape[1]) + ny++; + nz = shape[2] / hmin_width; + if (nz * hmin_width < shape[2]) + nz++; + } + + nxyz[0] = nx; + nxyz[1] = ny; + nxyz[2] = nz; + + return nx * ny * nz; +} +#elif 1 // Zhihui's idea two on 2013-09-25 +{ + int nx, ny, nz; + const int hmin_width = 8; // for example we use 8 + nx = shape[0] / hmin_width; + if (nx * hmin_width < shape[0]) + nx++; + ny = shape[1] / hmin_width; + if (ny * hmin_width < shape[1]) + ny++; + nz = shape[2] / hmin_width; + if (nz * hmin_width < shape[2]) + nz++; + + nxyz[0] = nx; + nxyz[1] = ny; + nxyz[2] = nz; + + return nx * ny * nz; +} +#endif +// distribute the data to cprocessors +#if (PSTR == 0) +MyList *Parallel::distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, + bool periodic, int nodes) +{ +#ifdef USE_GPU_DIVIDE + double cpu_part, gpu_part; + map::iterator iter; + iter = parameters::dou_par.find("cpu part"); + if (iter != parameters::dou_par.end()) + { + cpu_part = iter->second; + } + else + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "cpu part") + cpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); + } + iter = parameters::dou_par.find("gpu part"); + if (iter != parameters::dou_par.end()) + { + gpu_part = iter->second; + } + else + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "gpu part") + gpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); + } + + if (nodes == 0) + nodes = cpusize / 2; +#else + if (nodes == 0) + nodes = cpusize; +#endif + + if (dim != 3) + { + cout << "distrivute: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + MyList *BlL = 0; + + int split_size, min_size, block_size = 0; + + int min_width = 2 * Mymax(ghost_width, buffer_width); + int nxyz[dim], mmin_width[dim], min_shape[dim]; + + MyList *PLi = PatchLIST; + for (int i = 0; i < dim; i++) + min_shape[i] = PLi->data->shape[i]; + int lev = PLi->data->lev; + PLi = PLi->next; + while (PLi) + { + Patch *PP = PLi->data; + for (int i = 0; i < dim; i++) + min_shape[i] = Mymin(min_shape[i], PP->shape[i]); + if (lev != PLi->data->lev) + cout << "Parallel::distribute CAUSTION: meet Patches for different level: " << lev << " and " << PLi->data->lev << endl; + PLi = PLi->next; + } + + for (int i = 0; i < dim; i++) + mmin_width[i] = Mymin(min_width, min_shape[i]); + + min_size = mmin_width[0]; + for (int i = 1; i < dim; i++) + min_size = min_size * mmin_width[i]; + + PLi = PatchLIST; + while (PLi) + { + Patch *PP = PLi->data; + // PP->checkPatch(true); + int bs = PP->shape[0]; + for (int i = 1; i < dim; i++) + bs = bs * PP->shape[i]; + block_size = block_size + bs; + PLi = PLi->next; + } + split_size = Mymax(min_size, block_size / nodes); + split_size = Mymax(1, split_size); + + int n_rank = 0; + PLi = PatchLIST; + int reacpu = 0; + while (PLi) + { + Patch *PP = PLi->data; + + reacpu += partition3(nxyz, split_size, mmin_width, nodes, PP->shape); + + Block *ng0, *ng; + int shape_here[dim], ibbox_here[2 * dim]; + double bbox_here[2 * dim], dd; + + // ibbox : 0,...N-1 + for (int i = 0; i < nxyz[0]; i++) + for (int j = 0; j < nxyz[1]; j++) + for (int k = 0; k < nxyz[2]; k++) + { + ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; + ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; + ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; + ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; + ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; + + if (periodic) + { + ibbox_here[0] = ibbox_here[0] - ghost_width; + ibbox_here[3] = ibbox_here[3] + ghost_width; + ibbox_here[1] = ibbox_here[1] - ghost_width; + ibbox_here[4] = ibbox_here[4] + ghost_width; + ibbox_here[2] = ibbox_here[2] - ghost_width; + ibbox_here[5] = ibbox_here[5] + ghost_width; + } + else + { + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); + ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); + ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); + } + + shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; + shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; + shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // 0--4, 5--10 + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); + bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; + bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; +#else +#ifdef Cell + // 0--5, 5--10 + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; + bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; + bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + +#ifdef USE_GPU_DIVIDE + { + const int pices = 2; + double picef[pices]; + picef[0] = cpu_part; + picef[1] = gpu_part; + int shape_res[dim * pices]; + double bbox_res[2 * dim * pices]; + misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_width); + ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfsi, fngfsi, PP->lev, 0); // delete through KillBlocks + + // if(n_rank==cpusize) {n_rank=0; cerr<<"place one!!"<checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks + + for (int i = 1; i < pices; i++) + { + ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfsi, fngfsi, PP->lev, i); // delete through KillBlocks + // if(n_rank==cpusize) {n_rank=0; cerr<<"place two!! "<checkBlock(); + BlL->insert(ng); + } + } +#else + ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfsi, fngfsi, PP->lev); + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks +#endif + if (n_rank == cpusize) + n_rank = 0; + + // set PP->blb + if (i == 0 && j == 0 && k == 0) + { + MyList *Bp = BlL; + while (Bp->data != ng0) + Bp = Bp->next; // ng0 is the first of the pices list + PP->blb = Bp; + } + } + // set PP->ble + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; // ng is the last of the pices list + PP->ble = Bp; + } + PLi = PLi->next; + } + if (reacpu < nodes * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "Parallel::distribute CAUSTION: level#" << lev << " uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} + +#ifdef INTERP_LB_OPTIMIZE +#include "interp_lb_profile_data.h" + +MyList *Parallel::distribute_optimize(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, + bool periodic, int nodes) +{ +#ifdef USE_GPU_DIVIDE + double cpu_part, gpu_part; + map::iterator iter; + iter = parameters::dou_par.find("cpu part"); + if (iter != parameters::dou_par.end()) + { + cpu_part = iter->second; + } + else + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + strcpy(pname, (iter->second).c_str()); + else { cout << "Error inputpar" << endl; exit(0); } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { cout << "Can not open parameter file " << pname << endl; MPI_Abort(MPI_COMM_WORLD, 1); } + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); str = pline; + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) { cout << "error reading parameter file " << pname << " in line " << i << endl; MPI_Abort(MPI_COMM_WORLD, 1); } + else if (status == 0) continue; + if (sgrp == "ABE") { if (skey == "cpu part") cpu_part = atof(sval.c_str()); } + } + inf.close(); + parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); + } + iter = parameters::dou_par.find("gpu part"); + if (iter != parameters::dou_par.end()) + { + gpu_part = iter->second; + } + else + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + strcpy(pname, (iter->second).c_str()); + else { cout << "Error inputpar" << endl; exit(0); } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { cout << "Can not open parameter file " << pname << endl; MPI_Abort(MPI_COMM_WORLD, 1); } + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); str = pline; + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) { cout << "error reading parameter file " << pname << " in line " << i << endl; MPI_Abort(MPI_COMM_WORLD, 1); } + else if (status == 0) continue; + if (sgrp == "ABE") { if (skey == "gpu part") gpu_part = atof(sval.c_str()); } + } + inf.close(); + parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); + } + if (nodes == 0) nodes = cpusize / 2; +#else + if (nodes == 0) nodes = cpusize; +#endif + + if (dim != 3) + { + cout << "distrivute: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + MyList *BlL = 0; + int split_size, min_size, block_size = 0; + int min_width = 2 * Mymax(ghost_width, buffer_width); + int nxyz[dim], mmin_width[dim], min_shape[dim]; + + MyList *PLi = PatchLIST; + for (int i = 0; i < dim; i++) + min_shape[i] = PLi->data->shape[i]; + int lev = PLi->data->lev; + PLi = PLi->next; + while (PLi) + { + Patch *PP = PLi->data; + for (int i = 0; i < dim; i++) + min_shape[i] = Mymin(min_shape[i], PP->shape[i]); + if (lev != PLi->data->lev) + cout << "Parallel::distribute CAUSTION: meet Patches for different level: " << lev << " and " << PLi->data->lev << endl; + PLi = PLi->next; + } + + for (int i = 0; i < dim; i++) + mmin_width[i] = Mymin(min_width, min_shape[i]); + min_size = mmin_width[0]; + for (int i = 1; i < dim; i++) + min_size = min_size * mmin_width[i]; + + PLi = PatchLIST; + while (PLi) + { + Patch *PP = PLi->data; + int bs = PP->shape[0]; + for (int i = 1; i < dim; i++) + bs = bs * PP->shape[i]; + block_size = block_size + bs; + PLi = PLi->next; + } + split_size = Mymax(min_size, block_size / nodes); + split_size = Mymax(1, split_size); + + int n_rank = 0; + PLi = PatchLIST; + int reacpu = 0; + int current_block_id = 0; + while (PLi) { + Block *ng0, *ng; + bool first_block_in_patch = true; + Patch *PP = PLi->data; + reacpu += partition3(nxyz, split_size, mmin_width, nodes, PP->shape); + + for (int i = 0; i < nxyz[0]; i++) + for (int j = 0; j < nxyz[1]; j++) + for (int k = 0; k < nxyz[2]; k++) + { + int ibbox_here[6], shape_here[3]; + double bbox_here[6], dd; + Block *current_ng_start = nullptr; + + bool is_heavy = false; + int r_l = -1, r_r = -1; + if (cpusize == INTERP_LB_NPROCS) { + for (int si = 0; si < INTERP_LB_NUM_HEAVY; si++) { + if (current_block_id == interp_lb_splits[si][0]) { + is_heavy = true; + r_l = interp_lb_splits[si][1]; + r_r = interp_lb_splits[si][2]; + break; + } + } + } + + if (is_heavy) + { + int ib0 = (PP->shape[0] * i) / nxyz[0]; + int ib3 = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; + int jb1 = (PP->shape[1] * j) / nxyz[1]; + int jb4 = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; + int kb2 = (PP->shape[2] * k) / nxyz[2]; + int kb5 = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; + + Block *split_first_block = nullptr; + Block *split_last_block = nullptr; + splitHotspotBlock(BlL, dim, ib0, ib3, jb1, jb4, kb2, kb5, + PP, r_l, r_r, ingfsi, fngfsi, periodic, + split_first_block, split_last_block); + + current_ng_start = split_first_block; + ng = split_last_block; + } + else + { + ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; + ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; + ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; + ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; + ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; + + if (periodic) { + for(int d=0; d<3; d++) { + ibbox_here[d] -= ghost_width; + ibbox_here[d+3] += ghost_width; + } + } else { + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); + ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); + ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); + } + + for(int d=0; d<3; d++) shape_here[d] = ibbox_here[d+3] - ibbox_here[d] + 1; + +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; + dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); + bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; + bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; +#else +#ifdef Cell + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; + dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; + bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; + bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + ng = createMappedBlock(BlL, dim, shape_here, bbox_here, + current_block_id, ingfsi, fngfsi, PP->lev); + current_ng_start = ng; + } + + if (first_block_in_patch) { + ng0 = current_ng_start; + MyList *Bp_start = BlL; + while (Bp_start && Bp_start->data != ng0) Bp_start = Bp_start->next; + PP->blb = Bp_start; + first_block_in_patch = false; + } + + current_block_id++; + } + + { + MyList *Bp_end = BlL; + while (Bp_end && Bp_end->data != ng) Bp_end = Bp_end->next; + PP->ble = Bp_end; + } + + PLi = PLi->next; + } + if (reacpu < nodes * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "Parallel::distribute CAUSTION: level#" << lev << " uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} + +Block* Parallel::splitHotspotBlock(MyList* &BlL, int _dim, + int ib0_orig, int ib3_orig, + int jb1_orig, int jb4_orig, + int kb2_orig, int kb5_orig, + Patch* PP, int r_left, int r_right, + int ingfsi, int fngfsi, bool periodic, + Block* &split_first_block, Block* &split_last_block) +{ + int mid = (ib0_orig + ib3_orig) / 2; + + int indices_L[6] = {ib0_orig, jb1_orig, kb2_orig, mid, jb4_orig, kb5_orig}; + int indices_R[6] = {mid + 1, jb1_orig, kb2_orig, ib3_orig, jb4_orig, kb5_orig}; + + auto createSubBlock = [&](int* ib_raw, int target_rank) { + int ib_final[6]; + int sh_here[3]; + double bb_here[6], dd; + + if (periodic) { + ib_final[0] = ib_raw[0] - ghost_width; + ib_final[3] = ib_raw[3] + ghost_width; + ib_final[1] = ib_raw[1] - ghost_width; + ib_final[4] = ib_raw[4] + ghost_width; + ib_final[2] = ib_raw[2] - ghost_width; + ib_final[5] = ib_raw[5] + ghost_width; + } else { + ib_final[0] = Mymax(0, ib_raw[0] - ghost_width); + ib_final[3] = Mymin(PP->shape[0] - 1, ib_raw[3] + ghost_width); + ib_final[1] = Mymax(0, ib_raw[1] - ghost_width); + ib_final[4] = Mymin(PP->shape[1] - 1, ib_raw[4] + ghost_width); + ib_final[2] = Mymax(0, ib_raw[2] - ghost_width); + ib_final[5] = Mymin(PP->shape[2] - 1, ib_raw[5] + ghost_width); + } + + sh_here[0] = ib_final[3] - ib_final[0] + 1; + sh_here[1] = ib_final[4] - ib_final[1] + 1; + sh_here[2] = ib_final[5] - ib_final[2] + 1; + +#ifdef Vertex + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bb_here[0] = PP->bbox[0] + ib_final[0] * dd; + bb_here[3] = PP->bbox[0] + ib_final[3] * dd; + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bb_here[1] = PP->bbox[1] + ib_final[1] * dd; + bb_here[4] = PP->bbox[1] + ib_final[4] * dd; + dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); + bb_here[2] = PP->bbox[2] + ib_final[2] * dd; + bb_here[5] = PP->bbox[2] + ib_final[5] * dd; +#else +#ifdef Cell + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bb_here[0] = PP->bbox[0] + ib_final[0] * dd; + bb_here[3] = PP->bbox[0] + (ib_final[3] + 1) * dd; + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bb_here[1] = PP->bbox[1] + ib_final[1] * dd; + bb_here[4] = PP->bbox[1] + (ib_final[4] + 1) * dd; + dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; + bb_here[2] = PP->bbox[2] + ib_final[2] * dd; + bb_here[5] = PP->bbox[2] + (ib_final[5] + 1) * dd; +#endif +#endif + + Block* Bg = new Block(dim, sh_here, bb_here, target_rank, ingfsi, fngfsi, PP->lev); + if (BlL) BlL->insert(Bg); + else BlL = new MyList(Bg); + + return Bg; + }; + + split_first_block = createSubBlock(indices_L, r_left); + split_last_block = createSubBlock(indices_R, r_right); + return split_last_block; +} + +Block* Parallel::createMappedBlock(MyList* &BlL, int _dim, int* shape, double* bbox, + int block_id, int ingfsi, int fngfsi, int lev) +{ + int target_rank = block_id; + if (INTERP_LB_NPROCS > 0) { + for (int ri = 0; ri < interp_lb_num_remaps; ri++) { + if (block_id == interp_lb_remaps[ri][0]) { + target_rank = interp_lb_remaps[ri][1]; + break; + } + } + } + + Block* ng = new Block(dim, shape, bbox, target_rank, ingfsi, fngfsi, lev); + if (BlL) BlL->insert(ng); + else BlL = new MyList(ng); + + return ng; +} +#else +// When INTERP_LB_OPTIMIZE is not defined, distribute_optimize falls back to distribute +MyList *Parallel::distribute_optimize(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, + bool periodic, int nodes) +{ + return distribute(PatchLIST, cpusize, ingfsi, fngfsi, periodic, nodes); +} +Block* Parallel::splitHotspotBlock(MyList* &BlL, int _dim, + int ib0_orig, int ib3_orig, + int jb1_orig, int jb4_orig, + int kb2_orig, int kb5_orig, + Patch* PP, int r_left, int r_right, + int ingfsi, int fngfsi, bool periodic, + Block* &split_first_block, Block* &split_last_block) +{ return nullptr; } +Block* Parallel::createMappedBlock(MyList* &BlL, int _dim, int* shape, double* bbox, + int block_id, int ingfsi, int fngfsi, int lev) +{ return nullptr; } +#endif + +#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) +MyList *Parallel::distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, + bool periodic, int start_rank, int end_rank, int nodes) +{ +#ifdef USE_GPU_DIVIDE + double cpu_part, gpu_part; + map::iterator iter; + iter = parameters::dou_par.find("cpu part"); + if (iter != parameters::dou_par.end()) + { + cpu_part = iter->second; + } + else + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "cpu part") + cpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); + } + iter = parameters::dou_par.find("gpu part"); + if (iter != parameters::dou_par.end()) + { + gpu_part = iter->second; + } + else + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "gpu part") + gpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); + } + + if (nodes == 0) + nodes = cpusize / 2; +#else + if (nodes == 0) + nodes = cpusize; +#endif + + if (dim != 3) + { + cout << "distrivute: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + MyList *BlL = 0; + + int split_size, min_size, block_size = 0; + + int min_width = 2 * Mymax(ghost_width, buffer_width); + int nxyz[dim], mmin_width[dim], min_shape[dim]; + + MyList *PLi = PatchLIST; + for (int i = 0; i < dim; i++) + min_shape[i] = PLi->data->shape[i]; + int lev = PLi->data->lev; + PLi = PLi->next; + while (PLi) + { + Patch *PP = PLi->data; + for (int i = 0; i < dim; i++) + min_shape[i] = Mymin(min_shape[i], PP->shape[i]); + if (lev != PLi->data->lev) + cout << "Parallel::distribute CAUSTION: meet Patches for different level: " << lev << " and " << PLi->data->lev << endl; + PLi = PLi->next; + } + + for (int i = 0; i < dim; i++) + mmin_width[i] = Mymin(min_width, min_shape[i]); + + min_size = mmin_width[0]; + for (int i = 1; i < dim; i++) + min_size = min_size * mmin_width[i]; + + PLi = PatchLIST; + while (PLi) + { + Patch *PP = PLi->data; + // PP->checkPatch(true); + int bs = PP->shape[0]; + for (int i = 1; i < dim; i++) + bs = bs * PP->shape[i]; + block_size = block_size + bs; + PLi = PLi->next; + } + split_size = Mymax(min_size, block_size / cpusize); + split_size = Mymax(1, split_size); + + int n_rank = start_rank; + PLi = PatchLIST; + int reacpu = 0; + while (PLi) + { + Patch *PP = PLi->data; + + reacpu += partition3(nxyz, split_size, mmin_width, cpusize, PP->shape); + + Block *ng, *ng0; + int shape_here[dim], ibbox_here[2 * dim]; + double bbox_here[2 * dim], dd; + + // ibbox : 0,...N-1 + for (int i = 0; i < nxyz[0]; i++) + for (int j = 0; j < nxyz[1]; j++) + for (int k = 0; k < nxyz[2]; k++) + { + ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; + ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; + ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; + ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; + ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; + + if (periodic) + { + ibbox_here[0] = ibbox_here[0] - ghost_width; + ibbox_here[3] = ibbox_here[3] + ghost_width; + ibbox_here[1] = ibbox_here[1] - ghost_width; + ibbox_here[4] = ibbox_here[4] + ghost_width; + ibbox_here[2] = ibbox_here[2] - ghost_width; + ibbox_here[5] = ibbox_here[5] + ghost_width; + } + else + { + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); + ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); + ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); + } + + shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; + shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; + shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // 0--4, 5--10 + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); + bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; + bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; +#else +#ifdef Cell + // 0--5, 5--10 + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; + bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; + bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + +#ifdef USE_GPU_DIVIDE + { + const int pices = 2; + double picef[pices]; + picef[0] = cpu_part; + picef[1] = gpu_part; + int shape_res[dim * pices]; + double bbox_res[2 * dim * pices]; + misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_width); + ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfsi, fngfsi, PP->lev, 0); // delete through KillBlocks + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks + + for (int i = 1; i < pices; i++) + { + ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfsi, fngfsi, PP->lev, i); // delete through KillBlocks + // ng->checkBlock(); + BlL->insert(ng); + } + } +#else + ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfsi, fngfsi, PP->lev); // delete through KillBlocks + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks +#endif + + if (n_rank == end_rank + 1) + n_rank = start_rank; + + // set PP->blb + if (i == 0 && j == 0 && k == 0) + { + MyList *Bp = BlL; + while (Bp->data != ng0) + Bp = Bp->next; // ng0 is the first of the pices list + PP->blb = Bp; + } + } + // set PP->ble + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; // ng is the last of the pices list + PP->ble = Bp; + } + PLi = PLi->next; + } + if (reacpu < nodes * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == start_rank) + cout << "Parallel::distribute CAUSTION: level#" << lev << " uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} +#endif +void Parallel::setfunction(MyList *BlL, var *vn, double func(double x, double y, double z)) +{ + while (BlL) + { + if (BlL->data->X[0]) + { + int nn = BlL->data->shape[0] * BlL->data->shape[1] * BlL->data->shape[2]; + double *p = BlL->data->fgfs[vn->sgfn]; + for (int i = 0; i < nn; i++) + { + int ind[3]; + getarrayindex(3, BlL->data->shape, ind, i); + p[i] = func(BlL->data->X[0][ind[0]], BlL->data->X[1][ind[1]], BlL->data->X[2][ind[2]]); + } + } + BlL = BlL->next; + } +} +// set function only for cpu rank +void Parallel::setfunction(int rank, MyList *BlL, var *vn, double func(double x, double y, double z)) +{ + while (BlL) + { + if (BlL->data->X[0] && BlL->data->rank == rank) + { + int nn = BlL->data->shape[0] * BlL->data->shape[1] * BlL->data->shape[2]; + double *p = BlL->data->fgfs[vn->sgfn]; + for (int i = 0; i < nn; i++) + { + int ind[3]; + getarrayindex(3, BlL->data->shape, ind, i); + p[i] = func(BlL->data->X[0][ind[0]], BlL->data->X[1][ind[1]], BlL->data->X[2][ind[2]]); + } + } + BlL = BlL->next; + } +} +void Parallel::getarrayindex(int DIM, int *shape, int *index, int n) +{ + // we assume index has already memory space + int *mu; + mu = new int[DIM]; + mu[0] = 1; + for (int i = 1; i < DIM; i++) + mu[i] = mu[i - 1] * shape[i - 1]; + for (int i = DIM - 1; i >= 0; i--) + { + index[i] = n / mu[i]; + n = n - index[i] * mu[i]; + } + + delete[] mu; +} +int Parallel::getarraylocation(int DIM, int *shape, int *index) +{ + int n, mu; + mu = shape[0]; + n = index[0]; + for (int i = 1; i < DIM; i++) + { + n = n + index[i] * mu; + mu = mu * shape[i]; + } + + return n; +} +void Parallel::copy(int DIM, double *llbout, double *uubout, int *Dshape, double *DD, double *llbin, double *uubin, + int *shape, double *datain, double *llb, double *uub) +{ + // for 3 dimensional case, based on simple test, I found this is half slower than f90 code + int *illi, *iuui; + int *illo, *iuuo; + int *indi, *indo; + illi = new int[DIM]; + iuui = new int[DIM]; + illo = new int[DIM]; + iuuo = new int[DIM]; + indi = new int[DIM]; + indo = new int[DIM]; + + int ial = 1; + for (int i = 0; i < DIM; i++) + { + double ho, hi; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + ho = (uubout[i] - llbout[i]) / (Dshape[i] - 1); + hi = (uubin[i] - llbin[i]) / (shape[i] - 1); +#else +#ifdef Cell + ho = (uubout[i] - llbout[i]) / Dshape[i]; + hi = (uubin[i] - llbin[i]) / shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + illo[i] = int((llb[i] - llbout[i]) / ho); + iuuo[i] = Dshape[i] - 1 - int((uubout[i] - uub[i]) / ho); + illi[i] = int((llb[i] - llbin[i]) / hi); + iuui[i] = shape[i] - 1 - int((uubin[i] - uub[i]) / hi); + + if (illo[i] > iuuo[i] || illi[i] > iuui[i] || illo[i] < 0 || illi[i] < 0 || + iuui[i] >= shape[i] || iuuo[i] >= Dshape[i]) + { + cout << "Parallel copy: in direction " << i << ":" << endl; + cout << "llb = " << llb[i] << ", uub = " << uub[i] << endl; + cout << " in data : il = " << illi[i] << ", iu = " << iuui[i] << endl; + cout << "bbox = (" << llbin[i] << "," << uubin[i] << ")" << endl; + cout << "shape = " << shape[i] << endl; + cout << "out data : il = " << illo[i] << ", iu = " << iuuo[i] << endl; + cout << "bbox = (" << llbout[i] << "," << uubout[i] << ")" << endl; + cout << "shape = " << Dshape[i] << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + int ihi = iuui[i] - illi[i] + 1, iho = iuuo[i] - illo[i] + 1; + if (!(feq(ho, hi, ho / 2)) || ihi != iho) + { + cout << "Parallel copy: in direction " << i << ":" << endl; + cout << "Parallel copy: not the same grid structure." << endl; + cout << "hi = " << hi << ", bbox = (" << llbin[i] << "," << uubin[i] << "), shape = " << shape[i] << endl; + cout << "ho = " << ho << ", bbox = (" << llbout[i] << "," << uubout[i] << "), shape = " << Dshape[i] << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + ial = ial * ihi; + } + + for (int i = 0; i < DIM; i++) + { + indi[i] = illi[i]; + indo[i] = illo[i]; + } + /* + //check start index + for(int i=0;i NNi) + { + cout << "Parallel copy: ni = " << ni << " is out of array range (0," << NNi << ")." << endl; + cout << "shape = ("; + for (int j = 0; j < DIM; j++) + { + cout << shape[j]; + if (j < DIM - 1) + cout << ","; + else + cout << ")" << endl; + } + cout << "ind = ("; + for (int j = 0; j < DIM; j++) + { + cout << indi[j]; + if (j < DIM - 1) + cout << ","; + else + cout << ")" << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + DD[no] = datain[ni]; + + indi[0]++; + for (int j = 1; j < DIM; j++) + { + if (indi[j - 1] == iuui[j - 1] + 1) + { + indi[j - 1] = illi[j - 1]; + indi[j]++; + } // carry 1 to next digital + else + break; + } + indo[0]++; + for (int j = 1; j < DIM; j++) + { + if (indo[j - 1] == iuuo[j - 1] + 1) + { + indo[j - 1] = illo[j - 1]; + indo[j]++; + } + else + break; + } + } + /* + //check final index + for(int i=0;i *BlL, MyList *DumpList, char *tag, double time, double dT) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MyList *Bp; + while (DumpList) + { + Bp = BlL; + int Bi = 0; + while (Bp) + { + Block *BP = Bp->data; + var *VP = DumpList->data; + if (BP->rank == myrank) + { + + string out_dir; + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + char filename[100]; + if (tag) + sprintf(filename, "%s/%s_Lev%02d-%02d_%02d_%s_%05d.bin", out_dir.c_str(), tag, BP->lev, Bi, myrank, VP->name, ncount); + else + sprintf(filename, "%s/Lev%02d-%02d_%02d_%s_%05d.bin", out_dir.c_str(), BP->lev, Bi, myrank, VP->name, ncount); + writefile(time, BP->shape[0], BP->shape[1], BP->shape[2], BP->bbox[0], BP->bbox[3], BP->bbox[1], BP->bbox[4], + BP->bbox[2], BP->bbox[5], filename, BP->fgfs[VP->sgfn]); + cout << "end of dump " << VP->name << " at time " << time << ", on node " << myrank << endl; + } + Bp = Bp->next; + Bi++; + } + DumpList = DumpList->next; + } +} +// Now we dump the data including buffer points +void Parallel::Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); + if (!databuffer) + { + cout << "Parallel::Dump_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + while (DumpList) + { + var *VP = DumpList->data; + + MyList *Bp = PP->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + + string out_dir; + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + char filename[100]; + if (tag) + sprintf(filename, "%s/%s_Lev%02d-%02d_%s_%05d.bin", out_dir.c_str(), tag, PP->lev, grd, VP->name, ncount); + else + sprintf(filename, "%s/Lev%02d-%02d_%s_%05d.bin", out_dir.c_str(), PP->lev, grd, VP->name, ncount); + + writefile(time, PP->shape[0], PP->shape[1], PP->shape[2], PP->bbox[0], PP->bbox[3], PP->bbox[1], PP->bbox[4], + PP->bbox[2], PP->bbox[5], filename, databuffer); + } + DumpList = DumpList->next; + } + + if (myrank == 0) + free(databuffer); +} +void Parallel::Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT) +{ + MyList *Pp; + Pp = PL; + int grd = 0; + while (Pp) + { + Patch *PP = Pp->data; + Dump_Data(PP, DumpList, tag, time, dT, grd); + grd++; + Pp = Pp->next; + } +} +// collect the data including buffer points +double *Parallel::Collect_Data(Patch *PP, var *VP) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); + if (!databuffer) + { + cout << "Parallel::Collect_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *Bp = PP->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->ble) + break; + Bp = Bp->next; + } + + return databuffer; +} +// Now we dump the data including buffer points +// dump z = 0 plane +void Parallel::d2Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0, *databuffer2 = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); + databuffer2 = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1]); + if (!databuffer || !databuffer2) + { + cout << "Parallel::d2Dump_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + while (DumpList) + { + var *VP = DumpList->data; + + MyList *Bp = PP->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + + string out_dir; + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + char filename[100]; + if (tag) + sprintf(filename, "%s/%s_2d_Lev%02d-%02d_%s_%05d.dat", out_dir.c_str(), tag, PP->lev, grd, VP->name, ncount); + else + sprintf(filename, "%s/2d_Lev%02d-%02d_%s_%05d.dat", out_dir.c_str(), PP->lev, grd, VP->name, ncount); + + int gord = ghost_width; + f_d2dump(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, databuffer2, gord, VP->SoA); + writefile(time, PP->shape[0], PP->shape[1], PP->bbox[0], PP->bbox[3], PP->bbox[1], PP->bbox[4], + filename, databuffer2); + } + DumpList = DumpList->next; + } + + if (myrank == 0) + { + free(databuffer); + free(databuffer2); + } +} +void Parallel::d2Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT) +{ + MyList *Pp; + Pp = PL; + int grd = 0; + while (Pp) + { + Patch *PP = Pp->data; + d2Dump_Data(PP, DumpList, tag, time, dT, grd); + grd++; + Pp = Pp->next; + } +} +// Now we dump the data including buffer points and ghost points of the given patch +void Parallel::Dump_Data0(Patch *PP, MyList *DumpList, char *tag, double time, double dT) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3], tllb[3], tuub[3]; + int tshape[3]; + double DX, DY, DZ; + + for (int i = 0; i < 3; i++) + { + double DX = PP->blb->data->getdX(i); + tshape[i] = PP->shape[i] + 2 * ghost_width; + tllb[i] = PP->bbox[i] - ghost_width * DX; + tuub[i] = PP->bbox[i + dim] + ghost_width * DX; + } + + int NN = tshape[0] * tshape[1] * tshape[2]; + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * NN); + if (!databuffer) + { + cout << "on node# " << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + while (DumpList) + { + var *VP = DumpList->data; + MyList *Bp = PP->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], tllb[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], tllb[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], tllb[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], tuub[0], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], tuub[1], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], tuub[2], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, tllb, tuub, tshape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + if (myrank == 0) + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], tllb[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], tllb[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], tllb[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], tuub[0], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], tuub[1], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], tuub[2], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, tllb, tuub, tshape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + + string out_dir; + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + char filename[100]; + if (tag) + sprintf(filename, "%s/%s_Lev%02d_%s_%05d.bin", out_dir.c_str(), tag, PP->lev, VP->name, ncount); + else + sprintf(filename, "%s/Lev%02d_%s_%05d.bin", out_dir.c_str(), PP->lev, VP->name, ncount); + + writefile(time, tshape[0], tshape[1], tshape[2], tllb[0], tuub[0], tllb[1], tuub[2], + tllb[2], tuub[2], filename, databuffer); + } + DumpList = DumpList->next; + } + + if (myrank == 0) + free(databuffer); +} +// Map point is much easier than maping data itself +// But the main problem is about the points near the boundary +// worst case is -ghost -ghost+1 .... 0 * ...... +double Parallel::global_interp(int DIM, int *ext, double **CoX, double *datain, + double *poXb, int ordn, double *SoA, int Symmetry) +{ + if (DIM != 3) + { + cout << "Parallel::global_interp does not suport DIM = " << DIM << " for Symmetry." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double resu; + double poX[3]; + double asgn = 1; + + for (int i = 0; i < 3; i++) + poX[i] = poXb[i]; + + switch (Symmetry) + { + case 2: + for (int i = 0; i < 3; i++) + if (poX[i] < 0) + { + poX[i] = -poX[i]; + asgn = asgn * SoA[i]; + } + break; + case 1: + if (poX[2] < 0) + { + poX[2] = -poX[2]; + asgn = asgn * SoA[2]; + } + } + + int extb[3]; + + for (int i = 0; i < 3; i++) + extb[i] = ext[i]; + + switch (Symmetry) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + case 2: + if (poX[0] < (ghost_width - 1) * (CoX[0][1] - CoX[0][0])) + extb[0] = extb[0] + ghost_width - 1; + if (poX[1] < (ghost_width - 1) * (CoX[1][1] - CoX[1][0])) + extb[1] = extb[1] + ghost_width - 1; + case 1: + if (poX[2] < (ghost_width - 1) * (CoX[2][1] - CoX[2][0])) + extb[2] = extb[2] + ghost_width - 1; +#else +#ifdef Cell + case 2: + if (poX[0] < (ghost_width - 0.5) * (CoX[0][1] - CoX[0][0])) + extb[0] = extb[0] + ghost_width; + if (poX[1] < (ghost_width - 0.5) * (CoX[1][1] - CoX[1][0])) + extb[1] = extb[1] + ghost_width; + case 1: + if (poX[2] < (ghost_width - 0.5) * (CoX[2][1] - CoX[2][0])) + extb[2] = extb[2] + ghost_width; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + + if (extb[0] > ext[0] || extb[1] > ext[1] || extb[2] > ext[2]) + { + double *CoXb[3]; + int Nb = extb[0] * extb[1] * extb[2]; + double *datab; + datab = new double[Nb]; + for (int i = 0; i < 3; i++) + { + CoXb[i] = new double[extb[i]]; + double DH = CoX[i][1] - CoX[i][0]; + if (extb[i] > ext[i]) + { + if (CoX[i][0] > DH) + { + cout << "lower boundary[" << i << "] = " << CoX[i][0] << ", but SYmmetry = " << Symmetry << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + for (int j = 0; j < ghost_width - 1; j++) + CoXb[i][j] = -CoX[i][ghost_width - 1 - j]; + for (int j = ghost_width - 1; j < extb[i]; j++) + CoXb[i][j] = CoX[i][j - ghost_width + 1]; +#else +#ifdef Cell + for (int j = 0; j < ghost_width; j++) + CoXb[i][j] = -CoX[i][ghost_width - 1 - j]; + for (int j = ghost_width; j < extb[i]; j++) + CoXb[i][j] = CoX[i][j - ghost_width]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else + { + for (int j = 0; j < extb[i]; j++) + CoXb[i][j] = CoX[i][j]; + } + } + + for (int i = 0; i < Nb; i++) + { + int ind[3], indb[3]; + getarrayindex(3, extb, indb, i); + double sgn = 1; + for (int j = 0; j < 3; j++) + { + if (extb[j] > ext[j]) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (indb[j] < ghost_width - 1) + { + ind[j] = ghost_width - 1 - indb[j]; + sgn = sgn * SoA[j]; + } + else + { + ind[j] = 1 + indb[j] - ghost_width; + } +#else +#ifdef Cell + if (indb[j] < ghost_width) + { + ind[j] = ghost_width - 1 - indb[j]; + sgn = sgn * SoA[j]; + } + else + { + ind[j] = indb[j] - ghost_width; + } +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else + ind[j] = indb[j]; + } + int lon = getarraylocation(3, ext, ind); + datab[i] = datain[lon] * sgn; + } + + resu = global_interp(DIM, extb, CoXb, datab, poX, ordn); + + for (int i = 0; i < 3; i++) + delete[] CoXb[i]; + delete[] datab; + } + else + { + resu = global_interp(DIM, ext, CoX, datain, poX, ordn); + } + + return resu * asgn; +} +double Parallel::global_interp(int DIM, int *ext, double **CoX, double *datain, + double *poX, int ordn) +{ + if (ordn > 2 * ghost_width) + { + cout << "Parallel::global_interp can not handle ordn = " << ordn << " > 2*ghost_width = " << 2 * ghost_width << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + double *bbox, *datainbbox; + bbox = new double[2 * DIM]; + datainbbox = new double[2 * DIM]; + + int *NN, *ind, *shape; + NN = new int[DIM]; + ind = new int[DIM]; + shape = new int[DIM]; + + for (int i = 0; i < DIM; i++) + { + ind[i] = int((poX[i] - CoX[i][0]) / (CoX[i][1] - CoX[i][0])) - ordn / 2 + 1; + // poX may exactly locate on the boundary (exclude ghost) + if (ind[i] == -1 && feq(poX[i], CoX[i][0], (CoX[i][1] - CoX[i][0]) / 2)) + ind[i] = 0; + /* + if(ind[i] < 0) + { + cout<<"Parallel::global_interp error ind["< ext = "<= 0; i--) + NN[i] = NN[i + 1] * ordn; + + double *xpts, *funcvals; + xpts = new double[ordn]; + funcvals = new double[ordn]; + double *DDd, *DDd1, rr; + + DDd = new double[NN[0]]; + + copy(DIM, bbox, bbox + DIM, shape, DDd, datainbbox, datainbbox + DIM, ext, datain, bbox, bbox + DIM); + + for (int i = 0; i < DIM; i++) + { + for (int j = ind[i]; j < ind[i] + ordn; j++) + { + xpts[j - ind[i]] = CoX[i][j]; + } + + if (i < DIM - 1) + { + DDd1 = new double[NN[i + 1]]; + for (int j = 0; j < NN[i + 1]; j++) + { + for (int k = 0; k < ordn; k++) + funcvals[k] = DDd[k + j * ordn]; + DDd1[j] = Lagrangian_Int(poX[i], ordn, xpts, funcvals); + } + delete[] DDd; + DDd = DDd1; + } + else + { + for (int j = 0; j < ordn; j++) + funcvals[j] = DDd[j]; + rr = Lagrangian_Int(poX[i], ordn, xpts, funcvals); + delete[] DDd1; // since DDd and DDd1 now point to the same stuff, we need delete after above int + } + } + + delete[] NN; + delete[] ind; + delete[] xpts; + delete[] funcvals; + delete[] bbox; + delete[] datainbbox; + delete[] shape; + + return rr; +} +double Parallel::Lagrangian_Int(double x, int npts, double *xpts, double *funcvals) +{ + double sum = 0; + for (int i = 0; i < npts; i++) + { + sum = sum + funcvals[i] * LagrangePoly(x, i, npts, xpts); + } + return sum; +} +double Parallel::LagrangePoly(double x, int pt, int npts, double *xpts) +{ + double h = 1; + int i; + + for (i = 0; i < pt; i++) + h = h * (x - xpts[i]) / (xpts[pt] - xpts[i]); + + for (i = pt + 1; i < npts; i++) + h = h * (x - xpts[i]) / (xpts[pt] - xpts[i]); + + return h; +} +// collect all grid segments or blocks including ghost and buffer for given patch +MyList *Parallel::build_complete_gsl(Patch *Pat) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + if (!cgsl) + { + cgsl = gs = new MyList; // delete through destroyList(); + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + gs->data->llb[i] = BP->data->bbox[i]; + gs->data->uub[i] = BP->data->bbox[dim + i]; + gs->data->shape[i] = BP->data->shape[i]; + } + gs->data->Bg = BP->data; + gs->next = 0; + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks including ghost and buffer for given patch list +MyList *Parallel::build_complete_gsl(MyList *PatL) +{ + MyList *cgsl = 0, *gs; + while (PatL) + { + if (!cgsl) + { + cgsl = build_complete_gsl(PatL->data); + gs = cgsl; + while (gs->next) + gs = gs->next; + } + else + { + gs->next = build_complete_gsl(PatL->data); + gs = gs->next; + while (gs->next) + gs = gs->next; + } + PatL = PatL->next; + } + + return cgsl; +} +// cellect the information of Patch list +MyList *Parallel::build_complete_gsl_virtual(MyList *PatL) +{ + MyList *cgsl = 0, *gs; + while (PatL) + { + if (cgsl) + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + else + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + gs->data->llb[i] = PatL->data->bbox[i]; + gs->data->uub[i] = PatL->data->bbox[dim + i]; + gs->data->shape[i] = PatL->data->shape[i]; + } + gs->data->Bg = 0; + gs->next = 0; + + PatL = PatL->next; + } + + return cgsl; +} +// cellect the information of Patch list without buffer points +MyList *Parallel::build_complete_gsl_virtual2(MyList *PatL) // - buffer +{ + MyList *cgsl = 0, *gs; + while (PatL) + { + if (cgsl) + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + else + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = PatL->data->getdX(i); + gs->data->llb[i] = PatL->data->bbox[i] + PatL->data->lli[i] * DH; + gs->data->uub[i] = PatL->data->bbox[dim + i] - PatL->data->uui[i] * DH; + gs->data->shape[i] = PatL->data->shape[i] - PatL->data->lli[i] - PatL->data->uui[i]; + } + gs->data->Bg = 0; + gs->next = 0; + + PatL = PatL->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost for given patch, without extension +MyList *Parallel::build_bulk_gsl(Patch *Pat) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = BP->data; + gs->next = 0; + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// bulk part for given Block within given patch, without extension +MyList *Parallel::build_bulk_gsl(Block *bp, Patch *Pat) +{ + MyList *gs = 0; + + gs = new MyList; + gs->data = new Parallel::gridseg; + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = bp; + gs->next = 0; + + return gs; +} +MyList *Parallel::clone_gsl(MyList *p, bool first_only) +{ + MyList *np = 0, *q = 0, *pq = 0; + + while (p) + { + q = new MyList; + q->data = new Parallel::gridseg; + q->data->Bg = p->data->Bg; + for (int i = 0; i < dim; i++) + { + q->data->llb[i] = p->data->llb[i]; + q->data->uub[i] = p->data->uub[i]; + q->data->shape[i] = p->data->shape[i]; + } + if (pq) + pq->next = q; + else + np = q; + if (first_only) + { + np->next = 0; + return np; + } + pq = q; + p = p->next; + } + return np; +} +MyList *Parallel::gs_subtract(MyList *A, MyList *B) +{ + if (!A) + return 0; + if (!B) + return clone_gsl(A, true); + + double cut_plane[2 * dim], DH[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = A->data->Bg->getdX(i); + if (B->data->Bg && !feq(DH[i], B->data->Bg->getdX(i), DH[i] / 2)) + { + cout << "Parallel::gs_subtract meets different grid segment " << DH[i] << " vs " << B->data->Bg->getdX(i) << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *C = 0, *q; + for (int i = 0; i < dim; i++) + { + if (B->data->llb[i] > A->data->uub[i] || B->data->uub[i] < A->data->llb[i]) + return clone_gsl(A, true); + cut_plane[i] = A->data->llb[i]; + cut_plane[i + dim] = A->data->uub[i]; + } + + for (int i = 0; i < dim; i++) + { + cut_plane[i] = Mymax(A->data->llb[i], B->data->llb[i]); + if (cut_plane[i] - A->data->llb[i] > DH[i] / 2) + { + q = clone_gsl(A, true); + // prolong the list from head + if (C) + q->next = C; + C = q; + for (int j = 0; j < dim; j++) + { + if (i == j) + { + C->data->llb[i] = A->data->llb[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->uub[i] = Mymax(C->data->llb[i], cut_plane[i] - DH[i]); +#else +#ifdef Cell + C->data->uub[i] = Mymax(C->data->llb[i], cut_plane[i]); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else + { + C->data->llb[j] = cut_plane[j]; + C->data->uub[j] = cut_plane[j + dim]; + } +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + } + + cut_plane[i + dim] = Mymin(A->data->uub[i], B->data->uub[i]); + if (A->data->uub[i] - cut_plane[i + dim] > DH[i] / 2) + { + q = clone_gsl(A, true); + if (C) + q->next = C; + C = q; + for (int j = 0; j < dim; j++) + { + if (i == j) + { + C->data->uub[i] = A->data->uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->llb[i] = Mymin(C->data->uub[i], cut_plane[i + dim] + DH[i]); +#else +#ifdef Cell + C->data->llb[i] = Mymin(C->data->uub[i], cut_plane[i + dim]); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else + { + C->data->llb[j] = cut_plane[j]; + C->data->uub[j] = cut_plane[j + dim]; + } +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + } + } + return C; +} +// stupid method +/* +MyList *Parallel::gsl_subtract(MyList *A,MyList *B) //A subtract B but with A's information +{ +// always make return and A, B distinct + if(!A) return 0; + + if(!B) return clone_gsl(A,0); + + MyList *C=0,*C0,*C1,*Cc,*CC0,*gs; + + while(A) + { + C0=gs_subtract(A,B); // note C0 becomes a list after subtraction + C1=B->next; + while(C1) + { + CC0=C0; + Cc=0; + while(CC0) + { + gs=gs_subtract(CC0,C1); + if(Cc) Cc->catList(gs); + else Cc=gs; + CC0=CC0->next; + } + if(C0) C0->destroyList(); + C0=Cc; + C1=C1->next; + } + if(C) C->catList(C0); + else C=C0; + A=A->next; + } + + return C; +} +*/ +// more clever method +MyList *Parallel::gsl_subtract(MyList *A, MyList *B) // A subtract B but with A's information +{ + // always make return and A, B distinct + if (!A) + return 0; + + MyList *C = 0, *C0, *C1; + + C = clone_gsl(A, 0); + + while (B) + { + C0 = 0; + C1 = C; + while (C1) + { + if (C0) + C0->catList(gs_subtract(C1, B)); + else + C0 = gs_subtract(C1, B); + C1 = C1->next; + } + if (C) + C->destroyList(); + else + { + if (C0) + C0->destroyList(); + return 0; + } + + C = C0; + B = B->next; + } + + return C; +} +MyList *Parallel::gs_and(MyList *A, MyList *B) +{ + if (!A || !B) + return 0; + + double llb[dim], uub[dim]; + bool flag = false; + for (int i = 0; i < dim; i++) + { + llb[i] = Mymax(A->data->llb[i], B->data->llb[i]); + uub[i] = Mymin(A->data->uub[i], B->data->uub[i]); + if (llb[i] > uub[i]) + { + flag = true; + break; + } + } + if (flag) + return 0; + + MyList *C; + C = clone_gsl(A, true); + for (int i = 0; i < dim; i++) + { + C->data->llb[i] = llb[i]; + C->data->uub[i] = uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / C->data->Bg->getdX(i) + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / C->data->Bg->getdX(i) + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + + return C; +} +// overlap of A_i and (union of all j of B_j) +MyList *Parallel::gsl_and(MyList *A, MyList *B) // A and B but with A's information +{ + MyList *C = 0, *C1; + + while (A) + { + C1 = B; + while (C1) + { + if (C) + C->catList(gs_and(A, C1)); + else + C = gs_and(A, C1); + C1 = C1->next; + } + A = A->next; + } + return C; +} +// collect all ghost grid segments or blocks for given patch +MyList *Parallel::build_ghost_gsl(Patch *Pat) +{ + MyList *cgsl = 0, *gs, *gsb; + MyList *BP = Pat->blb; + while (BP) + { + gs = new MyList; + gs->data = new Parallel::gridseg; + + for (int i = 0; i < dim; i++) + { + gs->data->llb[i] = BP->data->bbox[i]; + gs->data->uub[i] = BP->data->bbox[dim + i]; + gs->data->shape[i] = BP->data->shape[i]; + } + gs->data->Bg = BP->data; + gs->next = 0; + + gsb = build_bulk_gsl(BP->data, Pat); + + if (!cgsl) + cgsl = gs_subtract(gs, gsb); + else + cgsl->catList(gs_subtract(gs, gsb)); + + gsb->destroyList(); + gs->destroyList(); + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all ghost grid segments or blocks for given patch list +MyList *Parallel::build_ghost_gsl(MyList *PatL) +{ + MyList *cgsl = 0, *gs; + while (PatL) + { + if (!cgsl) + { + cgsl = build_ghost_gsl(PatL->data); + gs = cgsl; + while (gs->next) + gs = gs->next; + } + else + { + gs->next = build_ghost_gsl(PatL->data); + gs = gs->next; + while (gs->next) + gs = gs->next; + } + PatL = PatL->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost for given patch +// special for Sync usage, so we do not need consider missing points +MyList *Parallel::build_owned_gsl0(Patch *Pat, int rank_in) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost for given patch +MyList *Parallel::build_owned_gsl1(Patch *Pat, int rank_in) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // NOTE: our dividing structure is (exclude ghost) + // -1 0 + // 1 2 + // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to + // the fortran routine where we always take floor to get index + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + (ghost_width - 1) * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost nor buffer for given patch +MyList *Parallel::build_owned_gsl2(Patch *Pat, int rank_in) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] - Pat->uui[i] * DH : bp->bbox[dim + i] - ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // NOTE: our dividing structure is (exclude ghost) + // -1 0 + // 1 2 + // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to + // the fortran routine where we always take floor to get index + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i] + (ghost_width - 1) * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i] + ghost_width * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost for given patch, and delete the ghost_width for interpolation consideration on the patch boundary +MyList *Parallel::build_owned_gsl3(Patch *Pat, int rank_in, int Symmetry) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = bp->bbox[dim + i] - ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // NOTE: our dividing structure is (exclude ghost) + // -1 0 + // 1 2 + // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to + // the fortran routine where we always take floor to get index + gs->data->llb[i] = bp->bbox[i] + (ghost_width - 1) * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->llb[i] = bp->bbox[i] + ghost_width * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + // Symmetry consideration + if (Symmetry > 0) + { + double DH = bp->getdX(2); + if (feq(bp->bbox[2], 0, DH / 2)) + { + gs->data->llb[2] = bp->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + if (Symmetry > 1) + { + for (int i = 0; i < 2; i++) + { + DH = bp->getdX(i); + if (feq(bp->bbox[i], 0, DH / 2)) + { + gs->data->llb[i] = bp->bbox[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + } + } + } + + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost nor buffer for given patch, +// and delete the ghost_width for interpolation consideration on the patch boundary +MyList *Parallel::build_owned_gsl4(Patch *Pat, int rank_in, int Symmetry) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] - Pat->uui[i] * DH : bp->bbox[dim + i]; + gs->data->uub[i] -= ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // NOTE: our dividing structure is (exclude ghost) + // -1 0 + // 1 2 + // so (0,1) does not belong to any part for vertex structure, we always put it to right part, this is consistent to + // the fortran routine where we always take floor to get index + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i]; + gs->data->llb[i] += (ghost_width - 1) * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i]; + gs->data->llb[i] += ghost_width * DH; + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + // Symmetry consideration + if (Symmetry > 0) + { + double DH = bp->getdX(2); + if (feq(bp->bbox[2], 0, DH / 2)) + { + gs->data->llb[2] = bp->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[2] = int((gs->data->uub[2] - gs->data->llb[2]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + if (Symmetry > 1) + { + for (int i = 0; i < 2; i++) + { + DH = bp->getdX(i); + if (feq(bp->bbox[i], 0, DH / 2)) + { + gs->data->llb[i] = bp->bbox[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + } + } + } + + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost nor buffer for given patch, no extention +MyList *Parallel::build_owned_gsl5(Patch *Pat, int rank_in) +{ + MyList *cgsl = 0, *gs; + MyList *BP = Pat->blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], Pat->bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] - Pat->uui[i] * DH : bp->bbox[dim + i] - ghost_width * DH; + gs->data->llb[i] = (feq(bp->bbox[i], Pat->bbox[i], DH / 2)) ? bp->bbox[i] + Pat->lli[i] * DH : bp->bbox[i] + ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == Pat->ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost for given patch list +// stupid method +/* +MyList *Parallel::build_owned_gsl(MyList *PatL,int rank_in,int type,int Symmetry) +{ + MyList *cgsl=0,*gs; + while(PatL) + { + if(!cgsl) + { + switch(type) + { + case 0: + cgsl = build_owned_gsl0(PatL->data,rank_in); + break; + case 1: + cgsl = build_owned_gsl1(PatL->data,rank_in); + break; + case 2: + cgsl = build_owned_gsl2(PatL->data,rank_in); + break; + case 3: + cgsl = build_owned_gsl3(PatL->data,rank_in,Symmetry); + break; + case 4: + cgsl = build_owned_gsl4(PatL->data,rank_in,Symmetry); + break; + case 5: + cgsl = build_owned_gsl5(PatL->data,rank_in); + break; + default: + cout<<"Parallel::build_owned_gsl : unknown type = "<next) gs = gs->next; + } + else + { + switch(type) + { + case 0: + gs->next = build_owned_gsl0(PatL->data,rank_in); + break; + case 1: + gs->next = build_owned_gsl1(PatL->data,rank_in); + break; + case 2: + gs->next = build_owned_gsl2(PatL->data,rank_in); + break; + case 3: + gs->next = build_owned_gsl3(PatL->data,rank_in,Symmetry); + break; + case 4: + gs->next = build_owned_gsl4(PatL->data,rank_in,Symmetry); + break; + case 5: + gs->next = build_owned_gsl5(PatL->data,rank_in); + break; + default: + cout<<"Parallel::build_owned_gsl : unknown type = "<next) gs = gs->next; + } + PatL = PatL->next; + } + + return cgsl; +} +*/ +// more clever method +MyList *Parallel::build_owned_gsl(MyList *PatL, int rank_in, int type, int Symmetry) +{ + MyList *cgsl = 0, *gs; + while (PatL) + { + switch (type) + { + case 0: + gs = build_owned_gsl0(PatL->data, rank_in); + break; + case 1: + gs = build_owned_gsl1(PatL->data, rank_in); + break; + case 2: + gs = build_owned_gsl2(PatL->data, rank_in); + break; + case 3: + gs = build_owned_gsl3(PatL->data, rank_in, Symmetry); + break; + case 4: + gs = build_owned_gsl4(PatL->data, rank_in, Symmetry); + break; + case 5: + gs = build_owned_gsl5(PatL->data, rank_in); + break; + default: + cout << "Parallel::build_owned_gsl : unknown type = " << type << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (cgsl) + cgsl->catList(gs); + else + cgsl = gs; + PatL = PatL->next; + } + + return cgsl; +} +// according to overlape to determine real grid segments +void Parallel::build_gstl(MyList *srci, MyList *dsti, + MyList **out_src, MyList **out_dst) +{ + *out_src = *out_dst = 0; + + if (!srci || !dsti) + return; + + MyList *s, *d; + MyList *s2, *d2; + + double llb[dim], uub[dim]; + + s = srci; + while (s) + { + Parallel::gridseg *sd = s->data; + d = dsti; + while (d) + { + Parallel::gridseg *dd = d->data; + bool flag = true; + for (int i = 0; i < dim; i++) + { + double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); + llb[i] = Mymax(sd->llb[i], dd->llb[i]); + uub[i] = Mymin(sd->uub[i], dd->uub[i]); + // make sure the region boundary is consistent to the grids + // here we only judge if the domain is empty, so do not need to adjust the align + double lb = llb[i], ub = uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // ---*--- + // x-------x + // if (int(2*(sd->uub[i]-uub[i])/SH+0.4)%2 == 1) ub = uub[i]-SH/2; + // else if(int(2*(dd->uub[i]-uub[i])/DH+0.4)%2 == 1) ub = uub[i]-DH/2; + // if (int(2*(llb[i]-sd->llb[i])/SH+0.4)%2 == 1) lb = llb[i]+SH/2; + // else if(int(2*(llb[i]-dd->llb[i])/DH+0.4)%2 == 1) lb = llb[i]+DH/2; + if (lb > ub + Mymin(SH, DH) / 2) + { + flag = false; + break; + } // special for isolated point +#else +#ifdef Cell + // |------| + // |-------------| + // if (int(2*(sd->uub[i]-uub[i])/SH+0.4)%2 == 1) ub = uub[i]+SH/2; + // else if(int(2*(dd->uub[i]-uub[i])/DH+0.4)%2 == 1) ub = uub[i]+DH/2; + // |------| + // |-------------| + // if (int(2*(llb[i]-sd->llb[i])/SH+0.4)%2 == 1) lb = llb[i]-SH/2; + // else if(int(2*(llb[i]-dd->llb[i])/DH+0.4)%2 == 1) lb = llb[i]-DH/2; + if (ub - lb < Mymin(SH, DH) / 2) + { + flag = false; + break; + } // even for isolated point, it has a cell belong to it +#else +#error Not define Vertex nor Cell +#endif +#endif + } + + if (flag) + { + if (!(*out_src)) + { + *out_src = s2 = new MyList; + *out_dst = d2 = new MyList; + s2->data = new Parallel::gridseg; + d2->data = new Parallel::gridseg; + } + else + { + s2->next = new MyList; + s2 = s2->next; + d2->next = new MyList; + d2 = d2->next; + s2->data = new Parallel::gridseg; + d2->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); + s2->data->llb[i] = d2->data->llb[i] = llb[i]; + s2->data->uub[i] = d2->data->uub[i] = uub[i]; +// using float method to count point, we do not need following consideration (2012 nov 17) +#if 1 + +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + // old code distuinguish vertex and cell + // if (int(2*(sd->uub[i]-uub[i])/SH+0.4)%2 == 1) s2->data->uub[i] = uub[i]-SH/2; + // else if(int(2*(dd->uub[i]-uub[i])/DH+0.4)%2 == 1) d2->data->uub[i] = uub[i]-DH/2; + // if (int(2*(llb[i]-sd->llb[i])/SH+0.4)%2 == 1) s2->data->llb[i] = llb[i]+SH/2; + // else if(int(2*(llb[i]-dd->llb[i])/DH+0.4)%2 == 1) d2->data->llb[i] = llb[i]+DH/2; + // new code: here we concern much more about missing point, because overlaping domain has been gaureented above + if (int(2 * (sd->uub[i] - uub[i]) / SH + 0.4) % 2 == 1) + s2->data->uub[i] = uub[i] + SH / 2; + else if (int(2 * (dd->uub[i] - uub[i]) / DH + 0.4) % 2 == 1) + d2->data->uub[i] = uub[i] + DH / 2; + if (int(2 * (llb[i] - sd->llb[i]) / SH + 0.4) % 2 == 1) + s2->data->llb[i] = llb[i] - SH / 2; + else if (int(2 * (llb[i] - dd->llb[i]) / DH + 0.4) % 2 == 1) + d2->data->llb[i] = llb[i] - DH / 2; + s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4) + 1; + d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + if (int(2 * (sd->uub[i] - uub[i]) / SH + 0.4) % 2 == 1) + s2->data->uub[i] = uub[i] + SH / 2; + else if (int(2 * (dd->uub[i] - uub[i]) / DH + 0.4) % 2 == 1) + d2->data->uub[i] = uub[i] + DH / 2; + if (int(2 * (llb[i] - sd->llb[i]) / SH + 0.4) % 2 == 1) + s2->data->llb[i] = llb[i] - SH / 2; + else if (int(2 * (llb[i] - dd->llb[i]) / DH + 0.4) % 2 == 1) + d2->data->llb[i] = llb[i] - DH / 2; + s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4); + d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + +#endif + s2->data->illb[i] = sd->illb[i]; + d2->data->illb[i] = dd->illb[i]; + s2->data->iuub[i] = sd->iuub[i]; + d2->data->iuub[i] = dd->iuub[i]; + } + s2->data->Bg = sd->Bg; + s2->next = 0; + d2->data->Bg = dd->Bg; + d2->next = 0; + } + d = d->next; + } + s = s->next; + } +} +// PACK: prepare target data in 'data' +// UNPACK: copy target data from 'data' to corresponding numerical grids +int Parallel::data_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int DIM = dim; + + if (dir != PACK && dir != UNPACK) + { + cout << "error dir " << dir << " for data_packer " << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int size_out = 0; + + if (!src || !dst) + return size_out; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int type; /* 1 copy, 2 restrict, 3 prolong */ + if (src->data->Bg->lev == dst->data->Bg->lev) + type = 1; + else if (src->data->Bg->lev > dst->data->Bg->lev) + type = 2; + else + type = 3; + + while (src && dst) + { + if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || + (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) + { + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + if (data) + { + if (dir == PACK) + switch (type) + { + // attention must be paied to the difference between src's llb,uub and dst's llb,uub + case 1: + f_copy(DIM, dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, + src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], + dst->data->llb, dst->data->uub); + break; + case 2: + f_restrict3(DIM, dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, + src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], + dst->data->llb, dst->data->uub, varls->data->SoA, Symmetry); + break; + case 3: + f_prolong3(DIM, src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], + dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, + dst->data->llb, dst->data->uub, varls->data->SoA, Symmetry); + } + if (dir == UNPACK) // from target data to corresponding grid + f_copy(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], + dst->data->llb, dst->data->uub, dst->data->shape, data + size_out, + dst->data->llb, dst->data->uub); + } + size_out += dst->data->shape[0] * dst->data->shape[1] * dst->data->shape[2]; + varls = varls->next; + varld = varld->next; + } + } + dst = dst->next; + src = src->next; + } + + return size_out; +} +int Parallel::data_packermix(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int DIM = dim; + + if (dir != PACK && dir != UNPACK) + { + cout << "Parallel::data_packermix: error dir " << dir << " for data_packermix." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int size_out = 0; + + if (!src || !dst) + return size_out; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int type; /* 1 copy, 2 restrict, 3 prolong */ + if (src->data->Bg->lev == dst->data->Bg->lev) + type = 1; + else if (src->data->Bg->lev > dst->data->Bg->lev) + type = 2; + else + type = 3; + + if (type != 3) + { + cout << "Parallel::data_packermix: error type " << type << " for data_packermix." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + while (src && dst) + { + if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || + (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) + { + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + if (data) + { + if (dir == PACK) + f_prolongcopy3(DIM, src->data->Bg->bbox, src->data->Bg->bbox + dim, src->data->Bg->shape, src->data->Bg->fgfs[varls->data->sgfn], + dst->data->llb, dst->data->uub, src->data->shape, data + size_out, + src->data->llb, src->data->uub, varls->data->SoA, Symmetry); + if (dir == UNPACK) // from target data to corresponding grid + f_prolongmix3(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], + src->data->llb, src->data->uub, src->data->shape, data + size_out, + dst->data->llb, dst->data->uub, varls->data->SoA, Symmetry, dst->data->illb, dst->data->iuub); + } + // the symmetry problem should be dealt in prolongcopy3, + // so we always have ghost_width for both sides + size_out += (src->data->shape[0] + 2 * ghost_width) * (src->data->shape[1] + 2 * ghost_width) * (src->data->shape[2] + 2 * ghost_width); + varls = varls->next; + varld = varld->next; + } + } + dst = dst->next; + src = src->next; + } + + return size_out; +} +// +void Parallel::transfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry) +{ + int myrank, cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int node; + + MPI_Request *reqs = new MPI_Request[2 * cpusize]; + MPI_Status *stats = new MPI_Status[2 * cpusize]; + int *req_node = new int[2 * cpusize]; + int *req_is_recv = new int[2 * cpusize]; + int *completed = new int[2 * cpusize]; + int req_no = 0; + int pending_recv = 0; + + double **send_data = new double *[cpusize]; + double **rec_data = new double *[cpusize]; + int *send_lengths = new int[cpusize]; + int *recv_lengths = new int[cpusize]; + + for (node = 0; node < cpusize; node++) + { + send_data[node] = rec_data[node] = 0; + send_lengths[node] = recv_lengths[node] = 0; + } + + // Post receives first so peers can progress rendezvous early. + for (node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + recv_lengths[node] = data_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); + if (recv_lengths[node] > 0) + { + rec_data[node] = new double[recv_lengths[node]]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 1" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Irecv((void *)rec_data[node], recv_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 1; + req_no++; + pending_recv++; + } + } + + // Local transfer on this rank. + recv_lengths[myrank] = data_packer(0, src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + if (recv_lengths[myrank] > 0) + { + rec_data[myrank] = new double[recv_lengths[myrank]]; + if (!rec_data[myrank]) + { + cout << "out of memory when new in short transfer, place 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + data_packer(rec_data[myrank], src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + } + + // Pack and post sends. + for (node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + send_lengths[node] = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + if (send_lengths[node] > 0) + { + send_data[node] = new double[send_lengths[node]]; + if (!send_data[node]) + { + cout << "out of memory when new in short transfer, place 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + data_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + MPI_Isend((void *)send_data[node], send_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 0; + req_no++; + } + } + + // Unpack as soon as receive completes to reduce pure wait time. + while (pending_recv > 0) + { + int outcount = 0; + MPI_Waitsome(req_no, reqs, &outcount, completed, stats); + if (outcount == MPI_UNDEFINED) break; + + for (int i = 0; i < outcount; i++) + { + int idx = completed[i]; + if (idx >= 0 && req_is_recv[idx]) + { + int recv_node = req_node[idx]; + data_packer(rec_data[recv_node], src[recv_node], dst[recv_node], recv_node, UNPACK, VarList1, VarList2, Symmetry); + pending_recv--; + } + } + } + + if (req_no > 0) MPI_Waitall(req_no, reqs, stats); + + if (rec_data[myrank]) + data_packer(rec_data[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); + + for (node = 0; node < cpusize; node++) + { + if (send_data[node]) + delete[] send_data[node]; + if (rec_data[node]) + delete[] rec_data[node]; + } + + delete[] reqs; + delete[] stats; + delete[] req_node; + delete[] req_is_recv; + delete[] completed; + delete[] send_data; + delete[] rec_data; + delete[] send_lengths; + delete[] recv_lengths; +} +// +void Parallel::transfermix(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry) +{ + int myrank, cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int node; + + MPI_Request *reqs = new MPI_Request[2 * cpusize]; + MPI_Status *stats = new MPI_Status[2 * cpusize]; + int *req_node = new int[2 * cpusize]; + int *req_is_recv = new int[2 * cpusize]; + int *completed = new int[2 * cpusize]; + int req_no = 0; + int pending_recv = 0; + + double **send_data = new double *[cpusize]; + double **rec_data = new double *[cpusize]; + int *send_lengths = new int[cpusize]; + int *recv_lengths = new int[cpusize]; + + for (node = 0; node < cpusize; node++) + { + send_data[node] = rec_data[node] = 0; + send_lengths[node] = recv_lengths[node] = 0; + } + + // Post receives first so peers can progress rendezvous early. + for (node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + recv_lengths[node] = data_packermix(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); + if (recv_lengths[node] > 0) + { + rec_data[node] = new double[recv_lengths[node]]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 1" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Irecv((void *)rec_data[node], recv_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 1; + req_no++; + pending_recv++; + } + } + + // Local transfer on this rank. + recv_lengths[myrank] = data_packermix(0, src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + if (recv_lengths[myrank] > 0) + { + rec_data[myrank] = new double[recv_lengths[myrank]]; + if (!rec_data[myrank]) + { + cout << "out of memory when new in short transfer, place 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + data_packermix(rec_data[myrank], src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + } + + // Pack and post sends. + for (node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + send_lengths[node] = data_packermix(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + if (send_lengths[node] > 0) + { + send_data[node] = new double[send_lengths[node]]; + if (!send_data[node]) + { + cout << "out of memory when new in short transfer, place 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + data_packermix(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + MPI_Isend((void *)send_data[node], send_lengths[node], MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 0; + req_no++; + } + } + + // Unpack as soon as receive completes to reduce pure wait time. + while (pending_recv > 0) + { + int outcount = 0; + MPI_Waitsome(req_no, reqs, &outcount, completed, stats); + if (outcount == MPI_UNDEFINED) break; + + for (int i = 0; i < outcount; i++) + { + int idx = completed[i]; + if (idx >= 0 && req_is_recv[idx]) + { + int recv_node = req_node[idx]; + data_packermix(rec_data[recv_node], src[recv_node], dst[recv_node], recv_node, UNPACK, VarList1, VarList2, Symmetry); + pending_recv--; + } + } + } + + if (req_no > 0) MPI_Waitall(req_no, reqs, stats); + + if (rec_data[myrank]) + data_packermix(rec_data[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); + + for (node = 0; node < cpusize; node++) + { + if (send_data[node]) + delete[] send_data[node]; + if (rec_data[node]) + delete[] rec_data[node]; + } + + delete[] reqs; + delete[] stats; + delete[] req_node; + delete[] req_is_recv; + delete[] completed; + delete[] send_data; + delete[] rec_data; + delete[] send_lengths; + delete[] recv_lengths; +} +void Parallel::Sync(Patch *Pat, MyList *VarList, int Symmetry) +{ + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_ghost_gsl(Pat); // ghost region only + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl0(Pat, node); // for the part without ghost points and do not extend + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer_src[node], data locate on cpu#node; + // but for transfer_dst[node] the data may locate on any node + } + + transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +void Parallel::Sync(MyList *PatL, MyList *VarList, int Symmetry) +{ + // Patch inner Synch + MyList *Pp = PatL; + while (Pp) + { + Sync(Pp->data, VarList, Symmetry); + Pp = Pp->next; + } + + // Patch inter Synch + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_buffer_gsl(PatL); // buffer region only + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl(PatL, node, 5, Symmetry); // for the part without ghost nor buffer points and do not extend + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +// Merged Sync: collect all intra-patch and inter-patch grid segment lists, +// then issue a single transfer() call instead of N+1 separate ones. +void Parallel::Sync_merged(MyList *PatL, MyList *VarList, int Symmetry) +{ + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList **combined_src = new MyList *[cpusize]; + MyList **combined_dst = new MyList *[cpusize]; + for (int node = 0; node < cpusize; node++) + combined_src[node] = combined_dst[node] = 0; + + // Phase A: Intra-patch ghost exchange segments + MyList *Pp = PatL; + while (Pp) + { + Patch *Pat = Pp->data; + MyList *dst_ghost = build_ghost_gsl(Pat); + + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl0(Pat, node); + MyList *tsrc = 0, *tdst = 0; + build_gstl(src_owned, dst_ghost, &tsrc, &tdst); + + if (tsrc) + { + if (combined_src[node]) + combined_src[node]->catList(tsrc); + else + combined_src[node] = tsrc; + } + if (tdst) + { + if (combined_dst[node]) + combined_dst[node]->catList(tdst); + else + combined_dst[node] = tdst; + } + + if (src_owned) + src_owned->destroyList(); + } + + if (dst_ghost) + dst_ghost->destroyList(); + + Pp = Pp->next; + } + + // Phase B: Inter-patch buffer exchange segments + MyList *dst_buffer = build_buffer_gsl(PatL); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl(PatL, node, 5, Symmetry); + MyList *tsrc = 0, *tdst = 0; + build_gstl(src_owned, dst_buffer, &tsrc, &tdst); + + if (tsrc) + { + if (combined_src[node]) + combined_src[node]->catList(tsrc); + else + combined_src[node] = tsrc; + } + if (tdst) + { + if (combined_dst[node]) + combined_dst[node]->catList(tdst); + else + combined_dst[node] = tdst; + } + + if (src_owned) + src_owned->destroyList(); + } + if (dst_buffer) + dst_buffer->destroyList(); + + // Phase C: Single transfer + transfer(combined_src, combined_dst, VarList, VarList, Symmetry); + + // Phase D: Cleanup + for (int node = 0; node < cpusize; node++) + { + if (combined_src[node]) + combined_src[node]->destroyList(); + if (combined_dst[node]) + combined_dst[node]->destroyList(); + } + delete[] combined_src; + delete[] combined_dst; +} +// SyncCache constructor +Parallel::SyncCache::SyncCache() + : valid(false), cpusize(0), combined_src(0), combined_dst(0), + send_lengths(0), recv_lengths(0), send_bufs(0), recv_bufs(0), + send_buf_caps(0), recv_buf_caps(0), reqs(0), stats(0), max_reqs(0), + lengths_valid(false), tc_req_node(0), tc_req_is_recv(0), tc_completed(0) +{ +} +// SyncCache invalidate: free grid segment lists but keep buffers +void Parallel::SyncCache::invalidate() +{ + if (!valid) + return; + for (int i = 0; i < cpusize; i++) + { + if (combined_src[i]) + combined_src[i]->destroyList(); + if (combined_dst[i]) + combined_dst[i]->destroyList(); + combined_src[i] = combined_dst[i] = 0; + send_lengths[i] = recv_lengths[i] = 0; + } + valid = false; + lengths_valid = false; +} +// SyncCache destroy: free everything +void Parallel::SyncCache::destroy() +{ + invalidate(); + if (combined_src) delete[] combined_src; + if (combined_dst) delete[] combined_dst; + if (send_lengths) delete[] send_lengths; + if (recv_lengths) delete[] recv_lengths; + if (send_buf_caps) delete[] send_buf_caps; + if (recv_buf_caps) delete[] recv_buf_caps; + for (int i = 0; i < cpusize; i++) + { + if (send_bufs && send_bufs[i]) delete[] send_bufs[i]; + if (recv_bufs && recv_bufs[i]) delete[] recv_bufs[i]; + } + if (send_bufs) delete[] send_bufs; + if (recv_bufs) delete[] recv_bufs; + if (reqs) delete[] reqs; + if (stats) delete[] stats; + if (tc_req_node) delete[] tc_req_node; + if (tc_req_is_recv) delete[] tc_req_is_recv; + if (tc_completed) delete[] tc_completed; + combined_src = combined_dst = 0; + send_lengths = recv_lengths = 0; + send_buf_caps = recv_buf_caps = 0; + send_bufs = recv_bufs = 0; + reqs = 0; stats = 0; + tc_req_node = 0; tc_req_is_recv = 0; tc_completed = 0; + cpusize = 0; max_reqs = 0; +} +// transfer_cached: reuse pre-allocated buffers from SyncCache +void Parallel::transfer_cached(MyList **src, MyList **dst, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache) +{ + int myrank; + MPI_Comm_size(MPI_COMM_WORLD, &cache.cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + int cpusize = cache.cpusize; + + int req_no = 0; + int pending_recv = 0; + int node; + int *req_node = cache.tc_req_node; + int *req_is_recv = cache.tc_req_is_recv; + int *completed = cache.tc_completed; + + // Post receives first so peers can progress rendezvous early. + for (node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + int rlength = data_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); + cache.recv_lengths[node] = rlength; + if (rlength > 0) + { + if (rlength > cache.recv_buf_caps[node]) + { + if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; + cache.recv_bufs[node] = new double[rlength]; + cache.recv_buf_caps[node] = rlength; + } + MPI_Irecv((void *)cache.recv_bufs[node], rlength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 1; + req_no++; + pending_recv++; + } + } + + // Local transfer on this rank. + int self_len = data_packer(0, src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + cache.recv_lengths[myrank] = self_len; + if (self_len > 0) + { + if (self_len > cache.recv_buf_caps[myrank]) + { + if (cache.recv_bufs[myrank]) delete[] cache.recv_bufs[myrank]; + cache.recv_bufs[myrank] = new double[self_len]; + cache.recv_buf_caps[myrank] = self_len; + } + data_packer(cache.recv_bufs[myrank], src[myrank], dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + } + + // Pack and post sends. + for (node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + int slength = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + cache.send_lengths[node] = slength; + if (slength > 0) + { + if (slength > cache.send_buf_caps[node]) + { + if (cache.send_bufs[node]) delete[] cache.send_bufs[node]; + cache.send_bufs[node] = new double[slength]; + cache.send_buf_caps[node] = slength; + } + data_packer(cache.send_bufs[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + MPI_Isend((void *)cache.send_bufs[node], slength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 0; + req_no++; + } + } + + // Unpack as soon as receive completes to reduce pure wait time. + while (pending_recv > 0) + { + int outcount = 0; + MPI_Waitsome(req_no, cache.reqs, &outcount, completed, cache.stats); + if (outcount == MPI_UNDEFINED) break; + + for (int i = 0; i < outcount; i++) + { + int idx = completed[i]; + if (idx >= 0 && req_is_recv[idx]) + { + int recv_node_i = req_node[idx]; + data_packer(cache.recv_bufs[recv_node_i], src[recv_node_i], dst[recv_node_i], recv_node_i, UNPACK, VarList1, VarList2, Symmetry); + pending_recv--; + } + } + } + + if (req_no > 0) MPI_Waitall(req_no, cache.reqs, cache.stats); + + if (self_len > 0) + data_packer(cache.recv_bufs[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); +} +void Parallel::Sync_cached(MyList *PatL, MyList *VarList, int Symmetry, SyncCache &cache) +{ + if (!cache.valid) + { + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + cache.cpusize = cpusize; + + // Allocate cache arrays if needed + if (!cache.combined_src) + { + cache.combined_src = new MyList *[cpusize]; + cache.combined_dst = new MyList *[cpusize]; + cache.send_lengths = new int[cpusize]; + cache.recv_lengths = new int[cpusize]; + cache.send_bufs = new double *[cpusize]; + cache.recv_bufs = new double *[cpusize]; + cache.send_buf_caps = new int[cpusize]; + cache.recv_buf_caps = new int[cpusize]; + for (int i = 0; i < cpusize; i++) + { + cache.send_bufs[i] = cache.recv_bufs[i] = 0; + cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; + } + cache.max_reqs = 2 * cpusize; + cache.reqs = new MPI_Request[cache.max_reqs]; + cache.stats = new MPI_Status[cache.max_reqs]; + cache.tc_req_node = new int[cache.max_reqs]; + cache.tc_req_is_recv = new int[cache.max_reqs]; + cache.tc_completed = new int[cache.max_reqs]; + } + + for (int node = 0; node < cpusize; node++) + { + cache.combined_src[node] = cache.combined_dst[node] = 0; + cache.send_lengths[node] = cache.recv_lengths[node] = 0; + } + + // Build intra-patch segments (same as Sync_merged Phase A) + MyList *Pp = PatL; + while (Pp) + { + Patch *Pat = Pp->data; + MyList *dst_ghost = build_ghost_gsl(Pat); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl0(Pat, node); + MyList *tsrc = 0, *tdst = 0; + build_gstl(src_owned, dst_ghost, &tsrc, &tdst); + if (tsrc) + { + if (cache.combined_src[node]) + cache.combined_src[node]->catList(tsrc); + else + cache.combined_src[node] = tsrc; + } + if (tdst) + { + if (cache.combined_dst[node]) + cache.combined_dst[node]->catList(tdst); + else + cache.combined_dst[node] = tdst; + } + if (src_owned) src_owned->destroyList(); + } + if (dst_ghost) dst_ghost->destroyList(); + Pp = Pp->next; + } + + // Build inter-patch segments (same as Sync_merged Phase B) + MyList *dst_buffer = build_buffer_gsl(PatL); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl(PatL, node, 5, Symmetry); + MyList *tsrc = 0, *tdst = 0; + build_gstl(src_owned, dst_buffer, &tsrc, &tdst); + if (tsrc) + { + if (cache.combined_src[node]) + cache.combined_src[node]->catList(tsrc); + else + cache.combined_src[node] = tsrc; + } + if (tdst) + { + if (cache.combined_dst[node]) + cache.combined_dst[node]->catList(tdst); + else + cache.combined_dst[node] = tdst; + } + if (src_owned) src_owned->destroyList(); + } + if (dst_buffer) dst_buffer->destroyList(); + + cache.valid = true; + } + + // Use cached lists with buffer-reusing transfer + transfer_cached(cache.combined_src, cache.combined_dst, VarList, VarList, Symmetry, cache); +} +// Sync_start: pack and post MPI_Isend/Irecv, return immediately +void Parallel::Sync_start(MyList *PatL, MyList *VarList, int Symmetry, + SyncCache &cache, AsyncSyncState &state) +{ + // Ensure cache is built + if (!cache.valid) + { + // Build cache (same logic as Sync_cached) + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + cache.cpusize = cpusize; + + if (!cache.combined_src) + { + cache.combined_src = new MyList *[cpusize]; + cache.combined_dst = new MyList *[cpusize]; + cache.send_lengths = new int[cpusize]; + cache.recv_lengths = new int[cpusize]; + cache.send_bufs = new double *[cpusize]; + cache.recv_bufs = new double *[cpusize]; + cache.send_buf_caps = new int[cpusize]; + cache.recv_buf_caps = new int[cpusize]; + for (int i = 0; i < cpusize; i++) + { + cache.send_bufs[i] = cache.recv_bufs[i] = 0; + cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; + } + cache.max_reqs = 2 * cpusize; + cache.reqs = new MPI_Request[cache.max_reqs]; + cache.stats = new MPI_Status[cache.max_reqs]; + cache.tc_req_node = new int[cache.max_reqs]; + cache.tc_req_is_recv = new int[cache.max_reqs]; + cache.tc_completed = new int[cache.max_reqs]; + } + + for (int node = 0; node < cpusize; node++) + { + cache.combined_src[node] = cache.combined_dst[node] = 0; + cache.send_lengths[node] = cache.recv_lengths[node] = 0; + } + + MyList *Pp = PatL; + while (Pp) + { + Patch *Pat = Pp->data; + MyList *dst_ghost = build_ghost_gsl(Pat); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl0(Pat, node); + MyList *tsrc = 0, *tdst = 0; + build_gstl(src_owned, dst_ghost, &tsrc, &tdst); + if (tsrc) + { + if (cache.combined_src[node]) + cache.combined_src[node]->catList(tsrc); + else + cache.combined_src[node] = tsrc; + } + if (tdst) + { + if (cache.combined_dst[node]) + cache.combined_dst[node]->catList(tdst); + else + cache.combined_dst[node] = tdst; + } + if (src_owned) src_owned->destroyList(); + } + if (dst_ghost) dst_ghost->destroyList(); + Pp = Pp->next; + } + + MyList *dst_buffer = build_buffer_gsl(PatL); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl(PatL, node, 5, Symmetry); + MyList *tsrc = 0, *tdst = 0; + build_gstl(src_owned, dst_buffer, &tsrc, &tdst); + if (tsrc) + { + if (cache.combined_src[node]) + cache.combined_src[node]->catList(tsrc); + else + cache.combined_src[node] = tsrc; + } + if (tdst) + { + if (cache.combined_dst[node]) + cache.combined_dst[node]->catList(tdst); + else + cache.combined_dst[node] = tdst; + } + if (src_owned) src_owned->destroyList(); + } + if (dst_buffer) dst_buffer->destroyList(); + cache.valid = true; + } + + // Now pack and post async MPI operations + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + int cpusize = cache.cpusize; + state.req_no = 0; + state.active = true; + state.pending_recv = 0; + // Allocate tracking arrays + delete[] state.req_node; delete[] state.req_is_recv; + state.req_node = new int[cache.max_reqs]; + state.req_is_recv = new int[cache.max_reqs]; + + MyList **src = cache.combined_src; + MyList **dst = cache.combined_dst; + + for (int node = 0; node < cpusize; node++) + { + if (node == myrank) + { + int length; + if (!cache.lengths_valid) { + length = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); + cache.recv_lengths[node] = length; + } else { + length = cache.recv_lengths[node]; + } + if (length > 0) + { + if (length > cache.recv_buf_caps[node]) + { + if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; + cache.recv_bufs[node] = new double[length]; + cache.recv_buf_caps[node] = length; + } + data_packer(cache.recv_bufs[node], src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); + } + } + else + { + int slength; + if (!cache.lengths_valid) { + slength = data_packer(0, src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); + cache.send_lengths[node] = slength; + } else { + slength = cache.send_lengths[node]; + } + if (slength > 0) + { + if (slength > cache.send_buf_caps[node]) + { + if (cache.send_bufs[node]) delete[] cache.send_bufs[node]; + cache.send_bufs[node] = new double[slength]; + cache.send_buf_caps[node] = slength; + } + data_packer(cache.send_bufs[node], src[myrank], dst[myrank], node, PACK, VarList, VarList, Symmetry); + state.req_node[state.req_no] = node; + state.req_is_recv[state.req_no] = 0; + MPI_Isend((void *)cache.send_bufs[node], slength, MPI_DOUBLE, node, 2, MPI_COMM_WORLD, cache.reqs + state.req_no++); + } + int rlength; + if (!cache.lengths_valid) { + rlength = data_packer(0, src[node], dst[node], node, UNPACK, VarList, VarList, Symmetry); + cache.recv_lengths[node] = rlength; + } else { + rlength = cache.recv_lengths[node]; + } + if (rlength > 0) + { + if (rlength > cache.recv_buf_caps[node]) + { + if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; + cache.recv_bufs[node] = new double[rlength]; + cache.recv_buf_caps[node] = rlength; + } + state.req_node[state.req_no] = node; + state.req_is_recv[state.req_no] = 1; + state.pending_recv++; + MPI_Irecv((void *)cache.recv_bufs[node], rlength, MPI_DOUBLE, node, 2, MPI_COMM_WORLD, cache.reqs + state.req_no++); + } + } + } + cache.lengths_valid = true; +} +// Sync_finish: progressive unpack as receives complete, then wait for sends +void Parallel::Sync_finish(SyncCache &cache, AsyncSyncState &state, + MyList *VarList, int Symmetry) +{ + if (!state.active) + return; + + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + MyList **src = cache.combined_src; + MyList **dst = cache.combined_dst; + + // Unpack local data first (no MPI needed) + if (cache.recv_bufs[myrank] && cache.recv_lengths[myrank] > 0) + data_packer(cache.recv_bufs[myrank], src[myrank], dst[myrank], myrank, UNPACK, VarList, VarList, Symmetry); + + // Progressive unpack of remote receives + if (state.pending_recv > 0 && state.req_no > 0) + { + int pending = state.pending_recv; + int *completed = new int[cache.max_reqs]; + while (pending > 0) + { + int outcount = 0; + MPI_Waitsome(state.req_no, cache.reqs, &outcount, completed, cache.stats); + if (outcount == MPI_UNDEFINED) break; + for (int i = 0; i < outcount; i++) + { + int idx = completed[i]; + if (idx >= 0 && state.req_is_recv[idx]) + { + int recv_node = state.req_node[idx]; + data_packer(cache.recv_bufs[recv_node], src[recv_node], dst[recv_node], recv_node, UNPACK, VarList, VarList, Symmetry); + pending--; + } + } + } + delete[] completed; + } + + // Wait for remaining sends + if (state.req_no > 0) MPI_Waitall(state.req_no, cache.reqs, cache.stats); + + delete[] state.req_node; state.req_node = 0; + delete[] state.req_is_recv; state.req_is_recv = 0; + state.active = false; +} +// collect buffer grid segments or blocks for the periodic boundary condition of given patch +// --------------------------------------------------- +// |con | |con | +// |ner | PhysBD |ner | +// |-------------------------------------------------| +// | | | | +// |Phy | |Phy | +// |sBD | |BD | +// | | | | +// | | | | +// | | | | +// |-------------------------------------------------| +// |con | PhysBD |con | +// |ner | |ner | +// --------------------------------------------------- +// first order derivetive does not need conner information, +// but second order derivative needs! +/* the following code does not include conner part +MyList *Parallel::build_PhysBD_gsl(Patch *Pat) +{ + MyList *cgsl,*gsc,*gsb=0,*p; + gsc = build_ghost_gsl(Pat); + for(int i=0;idata->Bg->getdX(i); +// lower boundary + if(gsb) + { + p = new MyList; + p->data = new Parallel::gridseg; + p->next=gsb; + gsb=p; + } + else + { + gsb = new MyList; + gsb->data = new Parallel::gridseg; + gsb->next=0; + } + for(int j=0;jdata->llb[i] = Pat->bbox[i]-ghost_width*DH; + gsb->data->uub[i] = Pat->bbox[i]-DH; +#else +#ifdef Cell + gsb->data->llb[i] = Pat->bbox[i]-ghost_width*DH; + gsb->data->uub[i] = Pat->bbox[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + gsb->data->shape[i] = ghost_width; + } + else + { + gsb->data->llb[j] = Pat->bbox[j]; + gsb->data->uub[j] = Pat->bbox[j+dim]; + gsb->data->shape[j] = Pat->shape[j]; + } + } + gsb->data->Bg = 0; //vertual grid segment +// upper boundary + p = new MyList; + p->data = new Parallel::gridseg; + p->next=gsb; + gsb=p; + for(int j=0;jdata->llb[i] = Pat->bbox[i+dim]+DH; + gsb->data->uub[i] = Pat->bbox[i+dim]+ghost_width*DH; +#else +#ifdef Cell + gsb->data->llb[i] = Pat->bbox[i+dim]; + gsb->data->uub[i] = Pat->bbox[i+dim]+ghost_width*DH; +#else +#error Not define Vertex nor Cell +#endif +#endif + gsb->data->shape[i] = ghost_width; + } + else + { + gsb->data->llb[j] = Pat->bbox[j]; + gsb->data->uub[j] = Pat->bbox[j+dim]; + gsb->data->shape[j] = Pat->shape[j]; + } + } + gsb->data->Bg = 0; //vertual grid segment + } + + cgsl = gsl_and(gsc,gsb); + + gsc->destroyList(); + gsb->destroyList(); + + return cgsl; +} +*/ +// the following code includes conner part +MyList *Parallel::build_PhysBD_gsl(Patch *Pat) +{ + MyList *cgsl, *gsc, *gsb = 0, *p; + + gsc = build_complete_gsl(Pat); + + gsb = new MyList; + gsb->data = new Parallel::gridseg; + gsb->next = 0; + gsb->data->Bg = 0; + + for (int j = 0; j < dim; j++) + { + gsb->data->llb[j] = Pat->bbox[j]; + gsb->data->uub[j] = Pat->bbox[j + dim]; + gsb->data->shape[j] = Pat->shape[j]; + } + + p = gsl_subtract(gsc, gsb); + + gsc->destroyList(); + gsb->destroyList(); + + cgsl = divide_gsl(p, Pat); + + p->destroyList(); + + return cgsl; +} +MyList *Parallel::divide_gsl(MyList *p, Patch *Pat) +{ + MyList *cgsl = 0; + while (p) + { + if (cgsl) + cgsl->catList(divide_gs(p, Pat)); + else + cgsl = divide_gs(p, Pat); + p = p->next; + } + + return cgsl; +} +// divide the gs into pices which locate either totally outside of the given Patch coordinate range +// or totally inside it. It's usefull for periodic boundary condition +MyList *Parallel::divide_gs(MyList *p, Patch *Pat) +{ + double DH[dim]; + for (int i = 0; i < dim; i++) + { + DH[i] = p->data->Bg->getdX(i); + } + + int num[dim]; + double llb[3][dim], uub[3][dim]; + for (int i = 0; i < dim; i++) + { + if (p->data->llb[i] < Pat->bbox[i] - DH[i] / 2) + { + if (p->data->uub[i] > Pat->bbox[i + dim] + DH[i] / 2) + { + num[i] = 3; + llb[0][i] = p->data->llb[i]; + llb[1][i] = Pat->bbox[i]; + uub[1][i] = Pat->bbox[i + dim]; + uub[2][i] = p->data->uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + uub[0][i] = Pat->bbox[i] - DH[i]; + llb[2][i] = Pat->bbox[i + dim] + DH[i]; +#else +#ifdef Cell + uub[0][i] = Pat->bbox[i]; + llb[2][i] = Pat->bbox[i + dim]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else if (p->data->uub[i] > Pat->bbox[i] + DH[i] / 2) + { + num[i] = 2; + llb[0][i] = p->data->llb[i]; + llb[1][i] = Pat->bbox[i]; + uub[1][i] = p->data->uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + uub[0][i] = Pat->bbox[i] - DH[i]; +#else +#ifdef Cell + uub[0][i] = Pat->bbox[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else + { + num[i] = 1; + llb[0][i] = p->data->llb[i]; + uub[0][i] = p->data->uub[i]; + } + } + else if (p->data->llb[i] < Pat->bbox[i + dim] - DH[i] / 2) + { + if (p->data->uub[i] > Pat->bbox[i + dim] + DH[i] / 2) + { + num[i] = 2; + llb[0][i] = p->data->llb[i]; + uub[0][i] = Pat->bbox[i + dim]; + uub[1][i] = p->data->uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[1][i] = Pat->bbox[i + dim] + DH[i]; +#else +#ifdef Cell + llb[1][i] = Pat->bbox[i + dim]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + else + { + num[i] = 1; + llb[0][i] = p->data->llb[i]; + uub[0][i] = p->data->uub[i]; + } + } + else + { + num[i] = 1; + llb[0][i] = p->data->llb[i]; + uub[0][i] = p->data->uub[i]; + } + } + MyList *cgsl = 0, *gg; + int NN = 1; + for (int i = 0; i < dim; i++) + NN = NN * num[i]; + + for (int i = 0; i < NN; i++) + { + int ind[dim]; + getarrayindex(dim, num, ind, i); + gg = clone_gsl(p, true); + for (int k = 0; k < dim; k++) + { + gg->data->llb[k] = llb[ind[k]][k]; + gg->data->uub[k] = uub[ind[k]][k]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gg->data->shape[k] = int((uub[ind[k]][k] - llb[ind[k]][k]) / DH[k] + 0.4) + 1; +#else +#ifdef Cell + gg->data->shape[k] = int((uub[ind[k]][k] - llb[ind[k]][k]) / DH[k] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + + if (cgsl) + cgsl->catList(gg); + else + cgsl = gg; + } + + return cgsl; +} +// after mod operation, according to overlape to determine real grid segments +void Parallel::build_PhysBD_gstl(Patch *Pat, MyList *srci, MyList *dsti, + MyList **out_src, MyList **out_dst) +{ + *out_src = *out_dst = 0; + + if (!srci || !dsti) + return; + + MyList *s, *d; + MyList *s2, *d2; + + double llb[dim], uub[dim]; + + s = srci; + while (s) + { + Parallel::gridseg *sd = s->data; + d = dsti; + while (d) + { + Parallel::gridseg *dd = d->data; + bool flag = true; + for (int i = 0; i < dim; i++) + { + double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); + if (!feq(SH, DH, SH / 2)) + { + cout << "Parallel::build_PhysBD_gstl meets different grid space SH = " << SH << ", DH = " << DH << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + // we assume dst and src locate on the same Patch + if (dd->llb[i] < Pat->bbox[i]) + llb[i] = Mymax(sd->llb[i], dd->llb[i] + Pat->bbox[dim + i] - Pat->bbox[i]); + else if (dd->llb[i] > Pat->bbox[i + dim]) + llb[i] = Mymax(sd->llb[i], dd->llb[i] - Pat->bbox[dim + i] + Pat->bbox[i]); + else + llb[i] = Mymax(sd->llb[i], dd->llb[i]); + + if (dd->uub[i] < Pat->bbox[i]) + uub[i] = Mymin(sd->uub[i], dd->uub[i] + Pat->bbox[dim + i] - Pat->bbox[i]); + else if (dd->uub[i] > Pat->bbox[dim + i]) + uub[i] = Mymin(sd->uub[i], dd->uub[i] - Pat->bbox[dim + i] + Pat->bbox[i]); + else + uub[i] = Mymin(sd->uub[i], dd->uub[i]); +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (llb[i] > uub[i] + SH / 2) + { + flag = false; + break; + } // special for isolated point +#else +#ifdef Cell + if (llb[i] > uub[i]) + { + flag = false; + break; + } +#else +#error Not define Vertex nor Cell +#endif +#endif + } + + if (flag) + { + if (!(*out_src)) + { + *out_src = s2 = new MyList; + *out_dst = d2 = new MyList; + s2->data = new Parallel::gridseg; + d2->data = new Parallel::gridseg; + } + else + { + s2->next = new MyList; + s2 = s2->next; + d2->next = new MyList; + d2 = d2->next; + s2->data = new Parallel::gridseg; + d2->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double SH = sd->Bg->getdX(i), DH = dd->Bg->getdX(i); + s2->data->llb[i] = llb[i]; + s2->data->uub[i] = uub[i]; + + if (dd->llb[i] < Pat->bbox[i]) + d2->data->llb[i] = llb[i] - Pat->bbox[dim + i] + Pat->bbox[i]; + else if (dd->llb[i] > Pat->bbox[i + dim]) + d2->data->llb[i] = llb[i] + Pat->bbox[dim + i] - Pat->bbox[i]; + else + d2->data->llb[i] = llb[i]; + + if (dd->uub[i] < Pat->bbox[i]) + d2->data->uub[i] = uub[i] - Pat->bbox[dim + i] + Pat->bbox[i]; + else if (dd->uub[i] > Pat->bbox[dim + i]) + d2->data->uub[i] = uub[i] + Pat->bbox[dim + i] - Pat->bbox[i]; + else + d2->data->uub[i] = uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4) + 1; + d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + s2->data->shape[i] = int((s2->data->uub[i] - s2->data->llb[i]) / SH + 0.4); + d2->data->shape[i] = int((d2->data->uub[i] - d2->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + s2->data->Bg = sd->Bg; + s2->next = 0; + d2->data->Bg = dd->Bg; + d2->next = 0; + } + d = d->next; + } + s = s->next; + } +} +void Parallel::PeriodicBD(Patch *Pat, MyList *VarList, int Symmetry) +{ + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_PhysBD_gsl(Pat); + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl0(Pat, node); // for the part without ghost points and do not extend + build_PhysBD_gstl(Pat, src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} double Parallel::L2Norm(Patch *Pat, var *vf) { int myrank; MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - double tvf, dtvf = 0; - int BDW = ghost_width; - - MyList *BP = Pat->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_l2normhelper(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pat->bbox[0], Pat->bbox[1], Pat->bbox[2], - Pat->bbox[3], Pat->bbox[4], Pat->bbox[5], - cg->fgfs[vf->sgfn], tvf, BDW); - dtvf += tvf; - } - if (BP == Pat->ble) - break; - BP = BP->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - tvf = sqrt(tvf); + + double tvf, dtvf = 0; + int BDW = ghost_width; + + MyList *BP = Pat->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_l2normhelper(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pat->bbox[0], Pat->bbox[1], Pat->bbox[2], + Pat->bbox[3], Pat->bbox[4], Pat->bbox[5], + cg->fgfs[vf->sgfn], tvf, BDW); + dtvf += tvf; + } + if (BP == Pat->ble) + break; + BP = BP->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + tvf = sqrt(tvf); return tvf; } @@ -5323,30 +5323,30 @@ double Parallel::L2Norm(Patch *Pat, var *vf, MPI_Comm Comm_here) { int myrank; MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - double tvf, dtvf = 0; - int BDW = ghost_width; - - MyList *BP = Pat->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_l2normhelper(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pat->bbox[0], Pat->bbox[1], Pat->bbox[2], - Pat->bbox[3], Pat->bbox[4], Pat->bbox[5], - cg->fgfs[vf->sgfn], tvf, BDW); - dtvf += tvf; - } - if (BP == Pat->ble) - break; - BP = BP->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, Comm_here); - - tvf = sqrt(tvf); + + double tvf, dtvf = 0; + int BDW = ghost_width; + + MyList *BP = Pat->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_l2normhelper(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pat->bbox[0], Pat->bbox[1], Pat->bbox[2], + Pat->bbox[3], Pat->bbox[4], Pat->bbox[5], + cg->fgfs[vf->sgfn], tvf, BDW); + dtvf += tvf; + } + if (BP == Pat->ble) + break; + BP = BP->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, Comm_here); + + tvf = sqrt(tvf); return tvf; } @@ -5388,1762 +5388,1762 @@ void Parallel::L2Norm7(Patch *Pat, var **vf, double *norms, MPI_Comm Comm_here) void Parallel::checkgsl(MyList *pp, bool first_only) { int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - if (!pp) - cout << " Parallel::checkgsl meets empty gsl" << endl; - while (pp) - { - if (pp->data->Bg) - cout << " on node#" << pp->data->Bg->rank << endl; - else - cout << " virtual grid segment" << endl; - cout << " shape: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->shape[i] << ","; - else - cout << pp->data->shape[i] << ")" << endl; - } - cout << " range: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->llb[i] << ":" << pp->data->uub[i] << ","; - else - cout << pp->data->llb[i] << ":" << pp->data->uub[i] << ")" << endl; - } - if (first_only) - return; - pp = pp->next; - } - } -} -void Parallel::checkvarl(MyList *pp, bool first_only) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - while (pp) - { - cout << "name: " << pp->data->name << endl; - cout << "SoA = (" << pp->data->SoA[0] << "," << pp->data->SoA[1] << "," << pp->data->SoA[2] << ")" << endl; - cout << "sgfn = " << pp->data->sgfn << endl; - if (first_only) - return; - pp = pp->next; - } - } -} -void Parallel::prepare_inter_time_level(MyList *PatL, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* target (t+a*dt) */, int tindex) -{ - while (PatL) - { - prepare_inter_time_level(PatL->data, VarList1, VarList2, VarList3, tindex); - PatL = PatL->next; - } -} -void Parallel::prepare_inter_time_level(Patch *Pat, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* target (t+a*dt) */, int tindex) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - MyList *varl1; - MyList *varl2; - MyList *varl3; - - MyList *BP = Pat->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - varl1 = VarList1; - varl2 = VarList2; - varl3 = VarList3; - while (varl1) - { - if (tindex == 0) - f_average(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], cg->fgfs[varl3->data->sgfn]); - else if (tindex == 1) - f_average3(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], cg->fgfs[varl3->data->sgfn]); - else if (tindex == -1) - // just change data order to use average3 - f_average3(cg->shape, cg->fgfs[varl2->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varl3->data->sgfn]); - else - { - cout << "error tindex in Parallel::prepare_inter_time_level" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - varl1 = varl1->next; - varl2 = varl2->next; - varl3 = varl3->next; - } - } - if (BP == Pat->ble) - break; - BP = BP->next; - } -} -void Parallel::prepare_inter_time_level(MyList *PatL, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex) -{ - while (PatL) - { - prepare_inter_time_level(PatL->data, VarList1, VarList2, VarList3, VarList4, tindex); - PatL = PatL->next; - } -} -void Parallel::prepare_inter_time_level(Patch *Pat, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - MyList *varl1; - MyList *varl2; - MyList *varl3; - MyList *varl4; - - MyList *BP = Pat->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - varl1 = VarList1; - varl2 = VarList2; - varl3 = VarList3; - varl4 = VarList4; - while (varl1) - { - if (tindex == 0) - f_average2(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], - cg->fgfs[varl3->data->sgfn], cg->fgfs[varl4->data->sgfn]); - else if (tindex == 1) - f_average2p(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], - cg->fgfs[varl3->data->sgfn], cg->fgfs[varl4->data->sgfn]); - else if (tindex == -1) - f_average2m(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], - cg->fgfs[varl3->data->sgfn], cg->fgfs[varl4->data->sgfn]); - else - { - cout << "error tindex in long cgh::prepare_inter_time_level" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - varl1 = varl1->next; - varl2 = varl2->next; - varl3 = varl3->next; - varl4 = varl4->next; - } - } - if (BP == Pat->ble) - break; - BP = BP->next; - } -} -void Parallel::Prolong(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - if (Patc->lev >= Patf->lev) - { - cout << "Parallel::Prolong: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_complete_gsl(Patf); // including ghost - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl4(Patc, node, Symmetry); // - buffer - ghost - BD ghost - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -void Parallel::Restrict(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - if (PatcL->data->lev >= PatfL->data->lev) - { - cout << "Parallel::Restrict: meet requst of Restrict from lev#" << PatfL->data->lev << " to lev#" << PatcL->data->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_complete_gsl(PatcL); // including ghost - for (int node = 0; node < cpusize; node++) - { -#if 0 -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - src[node]=build_owned_gsl(PatfL,node,2,Symmetry); // - buffer - ghost -#else -#ifdef Cell - src[node]=build_owned_gsl(PatfL,node,4,Symmetry); // - buffer - ghost - BD ghost -#else -#error Not define Vertex nor Cell -#endif -#endif -#else - // it seems bam always use this - src[node] = build_owned_gsl(PatfL, node, 2, Symmetry); // - buffer - ghost -#endif - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -void Parallel::Restrict_after(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - if (PatcL->data->lev >= PatfL->data->lev) - { - cout << "Parallel::Restrict: meet requst of Restrict from lev#" << PatfL->data->lev << " to lev#" << PatcL->data->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_complete_gsl(PatcL); // including ghost - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl(PatfL, node, 3, Symmetry); // - ghost - BD ghost - - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -// for the same time level -void Parallel::OutBdLow2Hi(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - if (Patc->lev >= Patf->lev) - { - cout << "Parallel::OutBdLow2Hi: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_buffer_gsl(Patf); // buffer region only - - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl4(Patc, node, Symmetry); // - buffer - ghost - BD ghost - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -void Parallel::OutBdLow2Hi(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - MyList *Pp, *Ppc; - Ppc = PatcL; - while (Ppc) - { - Pp = PatfL; - while (Pp) - { - if (Ppc->data->lev >= Pp->data->lev) - { - cout << "Parallel::OutBdLow2Hi(list): meet requst of Prolong from lev#" << Ppc->data->lev << " to lev#" << Pp->data->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - Pp = Pp->next; - } - Ppc = Ppc->next; - } - - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_buffer_gsl(PatfL); // buffer region only - - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl(PatcL, node, 4, Symmetry); // - buffer - ghost - BD ghost - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -// for the same time level -void Parallel::OutBdLow2Himix(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - if (Patc->lev >= Patf->lev) - { - cout << "Parallel::OutBdLow2Himix: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_buffer_gsl(Patf); // buffer region only - - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl4(Patc, node, Symmetry); // - buffer - ghost - BD ghost - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfermix(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; - - // do not need this, we have done after calling of this routine in ProlongRestrict or RestrictProlong - // Sync(Patf,VarList2,Symmetry); // fine level points may be not enough for interpolation -} -void Parallel::OutBdLow2Himix(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - MyList *Pp, *Ppc; - Ppc = PatcL; - while (Ppc) - { - Pp = PatfL; - while (Pp) - { - if (Ppc->data->lev >= Pp->data->lev) - { - cout << "Parallel::OutBdLow2Himix(list): meet requst of Prolong from lev#" << Ppc->data->lev << " to lev#" << Pp->data->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - Pp = Pp->next; - } - Ppc = Ppc->next; - } - - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_buffer_gsl(PatfL); // buffer region only - - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl(PatcL, node, 4, Symmetry); // - buffer - ghost - BD ghost - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfermix(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} - -// Restrict_cached: cache grid segment lists, reuse buffers via transfer_cached -void Parallel::Restrict_cached(MyList *PatcL, MyList *PatfL, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache) -{ - if (!cache.valid) - { - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - cache.cpusize = cpusize; - - if (!cache.combined_src) - { - cache.combined_src = new MyList *[cpusize]; - cache.combined_dst = new MyList *[cpusize]; - cache.send_lengths = new int[cpusize]; - cache.recv_lengths = new int[cpusize]; - cache.send_bufs = new double *[cpusize]; - cache.recv_bufs = new double *[cpusize]; - cache.send_buf_caps = new int[cpusize]; - cache.recv_buf_caps = new int[cpusize]; - for (int i = 0; i < cpusize; i++) - { - cache.send_bufs[i] = cache.recv_bufs[i] = 0; - cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; - } - cache.max_reqs = 2 * cpusize; - cache.reqs = new MPI_Request[cache.max_reqs]; - cache.stats = new MPI_Status[cache.max_reqs]; - cache.tc_req_node = new int[cache.max_reqs]; - cache.tc_req_is_recv = new int[cache.max_reqs]; - cache.tc_completed = new int[cache.max_reqs]; - } - - MyList *dst = build_complete_gsl(PatcL); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl(PatfL, node, 2, Symmetry); - build_gstl(src_owned, dst, &cache.combined_src[node], &cache.combined_dst[node]); - if (src_owned) src_owned->destroyList(); - } - if (dst) dst->destroyList(); - - cache.valid = true; - } - - transfer_cached(cache.combined_src, cache.combined_dst, VarList1, VarList2, Symmetry, cache); -} - -// OutBdLow2Hi_cached: cache grid segment lists, reuse buffers via transfer_cached -void Parallel::OutBdLow2Hi_cached(MyList *PatcL, MyList *PatfL, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache) -{ - if (!cache.valid) - { - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - cache.cpusize = cpusize; - - if (!cache.combined_src) - { - cache.combined_src = new MyList *[cpusize]; - cache.combined_dst = new MyList *[cpusize]; - cache.send_lengths = new int[cpusize]; - cache.recv_lengths = new int[cpusize]; - cache.send_bufs = new double *[cpusize]; - cache.recv_bufs = new double *[cpusize]; - cache.send_buf_caps = new int[cpusize]; - cache.recv_buf_caps = new int[cpusize]; - for (int i = 0; i < cpusize; i++) - { - cache.send_bufs[i] = cache.recv_bufs[i] = 0; - cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; - } - cache.max_reqs = 2 * cpusize; - cache.reqs = new MPI_Request[cache.max_reqs]; - cache.stats = new MPI_Status[cache.max_reqs]; - cache.tc_req_node = new int[cache.max_reqs]; - cache.tc_req_is_recv = new int[cache.max_reqs]; - cache.tc_completed = new int[cache.max_reqs]; - } - - MyList *dst = build_buffer_gsl(PatfL); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl(PatcL, node, 4, Symmetry); - build_gstl(src_owned, dst, &cache.combined_src[node], &cache.combined_dst[node]); - if (src_owned) src_owned->destroyList(); - } - if (dst) dst->destroyList(); - - cache.valid = true; - } - - transfer_cached(cache.combined_src, cache.combined_dst, VarList1, VarList2, Symmetry, cache); -} - -// OutBdLow2Himix_cached: same as OutBdLow2Hi_cached but uses transfermix for unpacking -void Parallel::OutBdLow2Himix_cached(MyList *PatcL, MyList *PatfL, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache) -{ - if (!cache.valid) - { - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - cache.cpusize = cpusize; - - if (!cache.combined_src) - { - cache.combined_src = new MyList *[cpusize]; - cache.combined_dst = new MyList *[cpusize]; - cache.send_lengths = new int[cpusize]; - cache.recv_lengths = new int[cpusize]; - cache.send_bufs = new double *[cpusize]; - cache.recv_bufs = new double *[cpusize]; - cache.send_buf_caps = new int[cpusize]; - cache.recv_buf_caps = new int[cpusize]; - for (int i = 0; i < cpusize; i++) - { - cache.send_bufs[i] = cache.recv_bufs[i] = 0; - cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; - } - cache.max_reqs = 2 * cpusize; - cache.reqs = new MPI_Request[cache.max_reqs]; - cache.stats = new MPI_Status[cache.max_reqs]; - cache.tc_req_node = new int[cache.max_reqs]; - cache.tc_req_is_recv = new int[cache.max_reqs]; - cache.tc_completed = new int[cache.max_reqs]; - } - - MyList *dst = build_buffer_gsl(PatfL); - for (int node = 0; node < cpusize; node++) - { - MyList *src_owned = build_owned_gsl(PatcL, node, 4, Symmetry); - build_gstl(src_owned, dst, &cache.combined_src[node], &cache.combined_dst[node]); - if (src_owned) src_owned->destroyList(); - } - if (dst) dst->destroyList(); - - cache.valid = true; - } - - // Use transfermix instead of transfer for mix-mode interpolation - int myrank; - MPI_Comm_size(MPI_COMM_WORLD, &cache.cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - int cpusize = cache.cpusize; - - int req_no = 0; - int pending_recv = 0; - int *req_node = new int[cache.max_reqs]; - int *req_is_recv = new int[cache.max_reqs]; - int *completed = new int[cache.max_reqs]; - - // Post receives first so peers can progress rendezvous early. - for (int node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - int rlength = data_packermix(0, cache.combined_src[node], cache.combined_dst[node], node, UNPACK, VarList1, VarList2, Symmetry); - cache.recv_lengths[node] = rlength; - if (rlength > 0) - { - if (rlength > cache.recv_buf_caps[node]) - { - if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; - cache.recv_bufs[node] = new double[rlength]; - cache.recv_buf_caps[node] = rlength; - } - MPI_Irecv((void *)cache.recv_bufs[node], rlength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 1; - req_no++; - pending_recv++; - } - } - - // Local transfer on this rank. - int self_len = data_packermix(0, cache.combined_src[myrank], cache.combined_dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - cache.recv_lengths[myrank] = self_len; - if (self_len > 0) - { - if (self_len > cache.recv_buf_caps[myrank]) - { - if (cache.recv_bufs[myrank]) delete[] cache.recv_bufs[myrank]; - cache.recv_bufs[myrank] = new double[self_len]; - cache.recv_buf_caps[myrank] = self_len; - } - data_packermix(cache.recv_bufs[myrank], cache.combined_src[myrank], cache.combined_dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); - } - - // Pack and post sends. - for (int node = 0; node < cpusize; node++) - { - if (node == myrank) continue; - - int slength = data_packermix(0, cache.combined_src[myrank], cache.combined_dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - cache.send_lengths[node] = slength; - if (slength > 0) - { - if (slength > cache.send_buf_caps[node]) - { - if (cache.send_bufs[node]) delete[] cache.send_bufs[node]; - cache.send_bufs[node] = new double[slength]; - cache.send_buf_caps[node] = slength; - } - data_packermix(cache.send_bufs[node], cache.combined_src[myrank], cache.combined_dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - MPI_Isend((void *)cache.send_bufs[node], slength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); - req_node[req_no] = node; - req_is_recv[req_no] = 0; - req_no++; - } - } - - // Unpack as soon as receive completes to reduce pure wait time. - while (pending_recv > 0) - { - int outcount = 0; - MPI_Waitsome(req_no, cache.reqs, &outcount, completed, cache.stats); - if (outcount == MPI_UNDEFINED) break; - - for (int i = 0; i < outcount; i++) - { - int idx = completed[i]; - if (idx >= 0 && req_is_recv[idx]) - { - int recv_node_i = req_node[idx]; - data_packermix(cache.recv_bufs[recv_node_i], cache.combined_src[recv_node_i], cache.combined_dst[recv_node_i], recv_node_i, UNPACK, VarList1, VarList2, Symmetry); - pending_recv--; - } - } - } - - if (req_no > 0) MPI_Waitall(req_no, cache.reqs, cache.stats); - - if (self_len > 0) - data_packermix(cache.recv_bufs[myrank], cache.combined_src[myrank], cache.combined_dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); - - delete[] req_node; - delete[] req_is_recv; - delete[] completed; -} - -// collect all buffer grid segments or blocks for given patch -MyList *Parallel::build_buffer_gsl(Patch *Pat) -{ - MyList *cgsl, *gsc, *gsb; - - gsc = build_complete_gsl(Pat); // including ghost - - gsb = new MyList; - gsb->data = new Parallel::gridseg; - - for (int i = 0; i < dim; i++) - { - double DH = Pat->blb->data->getdX(i); - gsb->data->uub[i] = Pat->bbox[dim + i] - Pat->uui[i] * DH; - gsb->data->llb[i] = Pat->bbox[i] + Pat->lli[i] * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gsb->data->shape[i] = int((gsb->data->uub[i] - gsb->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gsb->data->shape[i] = int((gsb->data->uub[i] - gsb->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gsb->data->Bg = 0; - gsb->next = 0; - - cgsl = gsl_subtract(gsc, gsb); - - gsc->destroyList(); - gsb->destroyList(); - - // set illb and iuub - gsb = cgsl; - while (gsb) - { - for (int i = 0; i < dim; i++) - { - double DH = Pat->blb->data->getdX(i); - gsb->data->iuub[i] = Pat->bbox[dim + i] - Pat->uui[i] * DH; - gsb->data->illb[i] = Pat->bbox[i] + Pat->lli[i] * DH; - } - gsb = gsb->next; - } - - return cgsl; -} -MyList *Parallel::build_buffer_gsl(MyList *PatL) -{ - MyList *cgsl = 0, *gs; - while (PatL) - { - if (cgsl) - { - gs->next = build_buffer_gsl(PatL->data); - gs = gs->next; - if (gs) - while (gs->next) - gs = gs->next; - } - else - { - cgsl = build_buffer_gsl(PatL->data); - gs = cgsl; - if (gs) - while (gs->next) - gs = gs->next; - } - PatL = PatL->next; - } - - return cgsl; -} -void Parallel::Prolongint(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - if (Patc->lev >= Patf->lev) - { - cout << "Parallel::Prolong: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int num_var = 0; - MyList *varl; - varl = VarList1; - while (varl) - { - num_var++; - varl = varl->next; - } - - MyList *BP = Patf->blb; - while (BP) - { - int Npts; - if (myrank == BP->data->rank) - Npts = BP->data->shape[0] * BP->data->shape[1] * BP->data->shape[2]; - MPI_Bcast(&Npts, 1, MPI_INT, BP->data->rank, MPI_COMM_WORLD); - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[Npts]; - if (myrank == BP->data->rank) - { - for (int i = 0; i < Npts; i++) - { - int ind[3]; - Parallel::getarrayindex(3, BP->data->shape, ind, i); - pox[0][i] = BP->data->X[0][ind[0]]; - pox[1][i] = BP->data->X[1][ind[1]]; - pox[2][i] = BP->data->X[2][ind[2]]; - } - } - for (int i = 0; i < 3; i++) - MPI_Bcast(pox[i], Npts, MPI_DOUBLE, BP->data->rank, MPI_COMM_WORLD); - double *res; - res = new double[num_var * Npts]; - Patc->Interp_Points(VarList1, Npts, pox, res, Symmetry); // because this operation is a global operation (for all processors) - // we have to isolate it out of myrank==BP->data->rank - if (myrank == BP->data->rank) - { - for (int i = 0; i < Npts; i++) - { - varl = VarList2; - int j = 0; - while (varl) - { - (BP->data->fgfs[varl->data->sgfn])[i] = res[j + i * num_var]; - j++; - varl = varl->next; - } - } - } - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] res; - BP = BP->next; - } -} -// -void Parallel::merge_gsl(MyList *&A, const double ratio) -{ - if (!A) - return; - - MyList *B, *C, *D = A; - bool flag = false; - while (D->next) - { - B = D->next; - while (B) - { - flag = merge_gs(D, B, C, ratio); - if (flag) - break; - B = B->next; - } - if (flag) - break; - D = D->next; - } - - if (flag) - { - // delete D and B from A - MyList *E = A; - while (E->next) - { - MyList *tp = E->next; - if (D == tp || B == tp) - { - E->next = (tp->next) ? tp->next : 0; - delete tp->data; - delete tp; - } - if (E->next) - E = E->next; - } - - if (D == A) - { - MyList *tp = A; - A = (A->next) ? A->next : 0; - delete tp->data; - delete tp; - } - // cat C to A - if (A) - A->catList(C); - else - A = C; - - merge_gsl(A, ratio); - } -} -// -bool Parallel::merge_gs(MyList *D, MyList *B, MyList *&C, const double ratio) -{ - if (!B || !D) - return false; - - C = 0; - double llb[dim], uub[dim], DH[dim]; - for (int i = 0; i < dim; i++) - { - double tdh; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH[i] = (D->data->uub[i] - D->data->llb[i]) / (D->data->shape[i] - 1); - tdh = (B->data->uub[i] - B->data->llb[i]) / (B->data->shape[i] - 1); -#else -#ifdef Cell - DH[i] = (D->data->uub[i] - D->data->llb[i]) / D->data->shape[i]; - tdh = (B->data->uub[i] - B->data->llb[i]) / B->data->shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (!feq(DH[i], tdh, DH[i] / 2)) - { - cout << "Parallel::merge_gs meets different grid segment " << DH[i] << " vs " << tdh << endl; - checkgsl(B, true); - checkgsl(D, true); - MPI_Abort(MPI_COMM_WORLD, 1); - } - llb[i] = Mymax(D->data->llb[i], B->data->llb[i]); - uub[i] = Mymin(D->data->uub[i], B->data->uub[i]); - // if(uub[i]-llb[i] < DH[i]/2) return false; //here this is valid for both vertex and cell - - // use 0 instead of DH[i]/2, we consider contact case, 2012 Aug 8 - if (uub[i] - llb[i] < 0) - return false; // here this is valid for both vertex and cell - } - - // vb: volume of B - // vd: volume of D - // vo: volume of overlap - // vt: volume of smallest common box (virtual merged box) - double vd = 1, vb = 1, vt = 1, vo = 1; - for (int i = 0; i < dim; i++) - { - vt = vt * (Mymax(D->data->uub[i], B->data->uub[i]) - Mymin(D->data->llb[i], B->data->llb[i])); - vo = vo * (uub[i] - llb[i]); - vd = vd * (D->data->uub[i] - D->data->llb[i]); - vb = vb * (B->data->uub[i] - B->data->llb[i]); - } - - // smller ratio, more possible to merge - if ((vd + vb - vo) / vt > ratio) - { - C = new MyList; - C->data = new gridseg; - for (int i = 0; i < dim; i++) - { - C->data->uub[i] = Mymax(D->data->uub[i], B->data->uub[i]); - C->data->llb[i] = Mymin(D->data->llb[i], B->data->llb[i]); -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - if (D->data->Bg == B->data->Bg) - C->data->Bg = D->data->Bg; - else - C->data->Bg = 0; - - C->next = 0; - - return true; - } - else - { - return false; - } -} -// Add ghost region to tangent plane -// we assume the grids have the same resolution -void Parallel::add_ghost_touch(MyList *&A) -{ - if (!A || !(A->next)) - return; - - double DH[dim]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - for (int i = 0; i < dim; i++) - DH[i] = (A->data->uub[i] - A->data->llb[i]) / (A->data->shape[i] - 1) / 2; -#else -#ifdef Cell - for (int i = 0; i < dim; i++) - DH[i] = (A->data->uub[i] - A->data->llb[i]) / A->data->shape[i] / 2; -#else -#error Not define Vertex nor Cell -#endif -#endif - - MyList *C1, *C2, *A1 = A, *A2, *dc; - dc = C1 = clone_gsl(A, false); - while (C1) - { - C2 = C1->next; - A2 = A1->next; - while (C2) - { - for (int i = 0; i < dim; i++) - { - if (feq(C1->data->llb[i], C2->data->uub[i], DH[i])) - { - // direction i touch, other directions overlap - bool flag = true; - for (int j = 0; j < i; j++) - if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && - (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) - flag = false; - for (int j = i + 1; j < dim; j++) - if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && - (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) - flag = false; - - if (flag) - { - // only add one ghost region - if (feq(A1->data->llb[i], C1->data->llb[i], DH[i])) - { - A1->data->llb[i] -= ghost_width * 2 * DH[i]; - A1->data->shape[i] += ghost_width; - } - if (feq(A2->data->uub[i], C2->data->uub[i], DH[i])) - { - A2->data->uub[i] += ghost_width * 2 * DH[i]; - A2->data->shape[i] += ghost_width; - } - } - } - if (feq(C1->data->uub[i], C2->data->llb[i], DH[i])) - { - // direction i touch, other directions overlap - bool flag = true; - for (int j = 0; j < i; j++) - if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && - (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) - flag = false; - for (int j = i + 1; j < dim; j++) - if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && - (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) - flag = false; - - if (flag) - { - // only add one ghost region - if (feq(A1->data->uub[i], C1->data->uub[i], DH[i])) - { - A1->data->uub[i] += ghost_width * 2 * DH[i]; - A1->data->shape[i] += ghost_width; - } - if (feq(A2->data->llb[i], C2->data->llb[i], DH[i])) - { - A2->data->llb[i] -= ghost_width * 2 * DH[i]; - A2->data->shape[i] += ghost_width; - } - } - } - } - C2 = C2->next; - A2 = A2->next; - } - C1 = C1->next; - A1 = A1->next; - } - - if (dc) - dc->destroyList(); -} -// According to overlap to cut the gsl into recular pices -void Parallel::cut_gsl(MyList *&A) -{ - if (!A) - return; - - MyList *B, *C, *D = A; - bool flag = false; - while (D->next) - { - B = D->next; - while (B) - { - flag = cut_gs(D, B, C); - if (flag) - break; - B = B->next; - } - if (flag) - break; - D = D->next; - } - - if (flag) - { - // delete D and B from A - MyList *E = A; - while (E->next) - { - MyList *tp = E->next; - if (D == tp || B == tp) - { - E->next = (tp->next) ? tp->next : 0; - delete tp->data; - delete tp; - } - if (E->next) - E = E->next; - } - - if (D == A) - { - MyList *tp = A; - A = (A->next) ? A->next : 0; - delete tp->data; - delete tp; - } - // cat C to A - if (A) - A->catList(C); - else - A = C; - - cut_gsl(A); - } -} -// when D and B have overlap, cut them into C and return true -// otherwise return false and C=0 -bool Parallel::cut_gs(MyList *D, MyList *B, MyList *&C) -{ - C = 0; - double llb[dim], uub[dim], DH[dim]; - for (int i = 0; i < dim; i++) - { - double tdh; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH[i] = (D->data->uub[i] - D->data->llb[i]) / (D->data->shape[i] - 1); - tdh = (B->data->uub[i] - B->data->llb[i]) / (B->data->shape[i] - 1); -#else -#ifdef Cell - DH[i] = (D->data->uub[i] - D->data->llb[i]) / D->data->shape[i]; - tdh = (B->data->uub[i] - B->data->llb[i]) / B->data->shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (!feq(DH[i], tdh, DH[i] / 2)) - { - cout << "Parallel::cut_gs meets different grid segment " << DH[i] << " vs " << tdh << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - llb[i] = Mymax(D->data->llb[i], B->data->llb[i]); - uub[i] = Mymin(D->data->uub[i], B->data->uub[i]); - // for efficiency we ask the width of the patch at least 2(buffer+ghost+BD ghost) - if (uub[i] - llb[i] < DH[i] * 2 * (buffer_width + 2 * ghost_width)) - return false; // here this is valid for both vertex and cell - } - - // this part code results in 5 patches generally - - C = new MyList; - C->data = new gridseg; - for (int i = 0; i < dim; i++) - { - C->data->llb[i] = llb[i]; - C->data->uub[i] = uub[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - if (D->data->Bg == B->data->Bg) - C->data->Bg = D->data->Bg; - else - C->data->Bg = 0; - - C->next = gs_subtract_virtual(D, C); - - MyList *E = C; - - while (E->next) - E = E->next; - - E->next = gs_subtract_virtual(B, C); - - // this part code results in 3 patches generally - /* - C = clone_gsl(D,true); - C->next = gs_subtract_virtual(B,C); - */ - - return true; -} -// note here it is different to real cut, we need leave the cutting edge for both vertex center and cell center -MyList *Parallel::gs_subtract_virtual(MyList *A, MyList *B) -{ - if (!A) - return 0; - if (!B) - return clone_gsl(A, true); - - double cut_plane[2 * dim], DH[dim]; - - for (int i = 0; i < dim; i++) - { - double tdh; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH[i] = (A->data->uub[i] - A->data->llb[i]) / (A->data->shape[i] - 1); - tdh = (B->data->uub[i] - B->data->llb[i]) / (B->data->shape[i] - 1); -#else -#ifdef Cell - DH[i] = (A->data->uub[i] - A->data->llb[i]) / A->data->shape[i]; - tdh = (B->data->uub[i] - B->data->llb[i]) / B->data->shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (!feq(DH[i], tdh, DH[i] / 2)) - { - cout << "Parallel::gs_subtract_virtual meets different grid segment " << DH[i] << " vs " << tdh << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *C = 0, *q; - for (int i = 0; i < dim; i++) - { - if (B->data->llb[i] > A->data->uub[i] || B->data->uub[i] < A->data->llb[i]) - return clone_gsl(A, true); - cut_plane[i] = A->data->llb[i]; - cut_plane[i + dim] = A->data->uub[i]; - } - - for (int i = 0; i < dim; i++) - { - cut_plane[i] = Mymax(A->data->llb[i], B->data->llb[i]); - if (cut_plane[i] > A->data->llb[i]) - { - q = clone_gsl(A, true); - // prolong the list from head - if (C) - q->next = C; - C = q; - for (int j = 0; j < dim; j++) - { - if (i == j) - { - C->data->llb[i] = A->data->llb[i]; - // **note here it is different to real cut, we need leave the cutting edge for both vertex center and cell center** - C->data->uub[i] = Mymax(C->data->llb[i], cut_plane[i]); - } - else - { - C->data->llb[j] = cut_plane[j]; - C->data->uub[j] = cut_plane[j + dim]; - } -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - } - - cut_plane[i + dim] = Mymin(A->data->uub[i], B->data->uub[i]); - if (cut_plane[i + dim] < A->data->uub[i]) - { - q = clone_gsl(A, true); - if (C) - q->next = C; - C = q; - for (int j = 0; j < dim; j++) - { - if (i == j) - { - C->data->uub[i] = A->data->uub[i]; - // note here it is different to real cut, we need leave the cutting edge for both vertex center and cell center - C->data->llb[i] = Mymin(C->data->uub[i], cut_plane[i + dim]); - } - else - { - C->data->llb[j] = cut_plane[j]; - C->data->uub[j] = cut_plane[j + dim]; - } -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; -#else -#ifdef Cell - C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - } - } - return C; -} -// note the data structure -// if CC is true -// 1 ----------- 1 ------ ^ -// 0 ------ | t -// 0 ----------- old ------ | -// -// old ----------- -// if CC is false -// 1 ----------- 1 ------ ^ -// 0 ----------- 0 ------ | t -// old ----------- old ------ | -void Parallel::fill_level_data(MyList *PatLd, MyList *PatLs, MyList *PatcL, - MyList *OldList, MyList *StateList, MyList *FutureList, - MyList *tmList, int Symmetry, bool BB, bool CC) -{ - if (PatLd->data->lev != PatLs->data->lev) - { - cout << "Parallel::fill_level_data: meet requst from lev#" << PatLs->data->lev << " to lev#" << PatLd->data->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (PatLd->data->lev <= PatcL->data->lev) - { - cout << "Parallel::fill_level_data: meet prolong requst from lev#" << PatcL->data->lev << " to lev#" << PatLd->data->lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *VarList = 0; - MyList *p; - p = StateList; - while (p) - { - if (VarList) - VarList->insert(p->data); - else - VarList = new MyList(p->data); - p = p->next; - } - p = FutureList; - while (p) - { - if (VarList) - VarList->insert(p->data); - else - VarList = new MyList(p->data); - p = p->next; - } - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_complete_gsl(PatLd); // including ghost - // copy part - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl(PatLs, node, 0, Symmetry); // similar to Sync - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); - - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - MyList *dsts, *dstd; - dsts = build_complete_gsl_virtual(PatLs); - dstd = dst; - dst = gsl_subtract(dstd, dsts); - if (dstd) - dstd->destroyList(); - if (dsts) - dsts->destroyList(); - - if (dst) - { - // prolongation part - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl(PatcL, node, 4, Symmetry); // - buffer - ghost - BD ghost - build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - if (CC) - { - // for FutureList - // restrict first~~~> - { - Restrict(PatcL, PatLs, FutureList, FutureList, Symmetry); - Sync(PatcL, FutureList, Symmetry); - } - //<~~~prolong then - transfer(transfer_src, transfer_dst, FutureList, FutureList, Symmetry); - - // for StateList - // time interpolation part - if (BB) - prepare_inter_time_level(PatcL, FutureList, StateList, OldList, - tmList, 0); // use SynchList_pre as temporal storage space - else - prepare_inter_time_level(PatcL, FutureList, StateList, - tmList, 0); // use SynchList_pre as temporal storage space - // restrict first~~~> - { - Restrict(PatcL, PatLs, StateList, tmList, Symmetry); - Sync(PatcL, tmList, Symmetry); - } - //<~~~prolong then - transfer(transfer_src, transfer_dst, tmList, StateList, Symmetry); - } - else - { - // for both FutureList and StateList - // restrict first~~~> - { - Restrict(PatcL, PatLs, VarList, VarList, Symmetry); - Sync(PatcL, VarList, Symmetry); - } - //<~~~prolong then - transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); - } - - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - dst->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; - - VarList->clearList(); -} -void Parallel::KillBlocks(MyList *PatchLIST) -{ - while (PatchLIST) - { - Patch *Pp = PatchLIST->data; - MyList *bg; - while (Pp->blb) - { - if (Pp->blb == Pp->ble) - break; - bg = (Pp->blb->next) ? Pp->blb->next : 0; - delete Pp->blb->data; - delete Pp->blb; - Pp->blb = bg; - } - if (Pp->ble) - { - delete Pp->ble->data; - delete Pp->ble; - } - Pp->blb = Pp->ble = 0; - PatchLIST = PatchLIST->next; - } -} -bool Parallel::PatList_Interp_Points(MyList *PatL, MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry) -{ - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double lld[dim], uud[dim]; - double **pox; - pox = new double *[dim]; - for (int j = 0; j < dim; j++) - pox[j] = new double[1]; - for (int i = 0; i < NN; i++) - { - MyList *PL = PatL; - while (PL) - { - bool flag = true; - for (int j = 0; j < dim; j++) - { - double h = PL->data->getdX(j); - lld[j] = PL->data->lli[j] * h; - uud[j] = PL->data->uui[j] * h; - if (XX[j][i] < PL->data->bbox[j] + lld[j] || XX[j][i] > PL->data->bbox[j + dim] - uud[j]) - { - flag = false; - break; - } - pox[j][0] = XX[j][i]; - } - if (flag) - { - PL->data->Interp_Points(VarList, 1, pox, Shellf + i * num_var, Symmetry); - break; - } - PL = PL->next; - } - if (!PL) - { - checkpatchlist(PatL, false); - return false; - } - } - for (int j = 0; j < dim; j++) - delete[] pox[j]; - delete[] pox; - - return true; -} -bool Parallel::PatList_Interp_Points(MyList *PatL, MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry, MPI_Comm Comm_here) -{ - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double lld[dim], uud[dim]; - double **pox; - pox = new double *[dim]; - for (int j = 0; j < dim; j++) - pox[j] = new double[1]; - for (int i = 0; i < NN; i++) - { - MyList *PL = PatL; - while (PL) - { - bool flag = true; - for (int j = 0; j < dim; j++) - { - double h = PL->data->getdX(j); - lld[j] = PL->data->lli[j] * h; - uud[j] = PL->data->uui[j] * h; - if (XX[j][i] < PL->data->bbox[j] + lld[j] || XX[j][i] > PL->data->bbox[j + dim] - uud[j]) - { - flag = false; - break; - } - pox[j][0] = XX[j][i]; - } - if (flag) - { - PL->data->Interp_Points(VarList, 1, pox, Shellf + i * num_var, Symmetry, Comm_here); - break; - } - PL = PL->next; - } - if (!PL) - { - checkpatchlist(PatL, false); - return false; - } - } - for (int j = 0; j < dim; j++) - delete[] pox[j]; - delete[] pox; - - return true; -} -void Parallel::aligncheck(double *bbox0, double *bboxl, int lev, double *DH0, int *shape) -{ - const double aligntiny = 0.1; - double DHl, rr; - int NN; - for (int i = 0; i < dim; i++) - { - DHl = DH0[i] * pow(0.5, lev); - rr = bboxl[i] - bbox0[i]; - bboxl[i] = bbox0[i] + int(rr / DHl + 0.4) * DHl; - rr = bbox0[i + dim] - bboxl[i + dim]; - bboxl[i + dim] = bbox0[i + dim] - int(rr / DHl + 0.4) * DHl; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - NN = int((bboxl[i + dim] - bboxl[i]) / DHl + 0.4) + 1; -#else -#ifdef Cell - NN = int((bboxl[i + dim] - bboxl[i]) / DHl + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - if (NN != shape[i]) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << "Parallel::aligncheck want shape " << NN << " for lev#" << lev << ", but " << shape[i] << endl; - cout << "i = " << i << ", low = " << bboxl[i] << ", up = " << bboxl[i + dim] << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } -} -bool Parallel::point_locat_gsl(double *pox, MyList *gsl) -{ - bool flag = false; - while (gsl) - { - for (int i = 0; i < dim; i++) - { - if (pox[i] > gsl->data->llb[i] && pox[i] < gsl->data->uub[i]) - flag = true; - else - { - flag = false; - break; - } - } - if (flag) - break; - gsl = gsl->next; - } - - return flag; -} -void Parallel::checkpatchlist(MyList *PatL, bool buflog) -{ - MyList *PL = PatL; - while (PL) - { - PL->data->checkPatch(buflog); - PL = PL->next; - } -} + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + if (!pp) + cout << " Parallel::checkgsl meets empty gsl" << endl; + while (pp) + { + if (pp->data->Bg) + cout << " on node#" << pp->data->Bg->rank << endl; + else + cout << " virtual grid segment" << endl; + cout << " shape: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->shape[i] << ","; + else + cout << pp->data->shape[i] << ")" << endl; + } + cout << " range: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->llb[i] << ":" << pp->data->uub[i] << ","; + else + cout << pp->data->llb[i] << ":" << pp->data->uub[i] << ")" << endl; + } + if (first_only) + return; + pp = pp->next; + } + } +} +void Parallel::checkvarl(MyList *pp, bool first_only) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + while (pp) + { + cout << "name: " << pp->data->name << endl; + cout << "SoA = (" << pp->data->SoA[0] << "," << pp->data->SoA[1] << "," << pp->data->SoA[2] << ")" << endl; + cout << "sgfn = " << pp->data->sgfn << endl; + if (first_only) + return; + pp = pp->next; + } + } +} +void Parallel::prepare_inter_time_level(MyList *PatL, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* target (t+a*dt) */, int tindex) +{ + while (PatL) + { + prepare_inter_time_level(PatL->data, VarList1, VarList2, VarList3, tindex); + PatL = PatL->next; + } +} +void Parallel::prepare_inter_time_level(Patch *Pat, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* target (t+a*dt) */, int tindex) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + MyList *varl1; + MyList *varl2; + MyList *varl3; + + MyList *BP = Pat->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + varl1 = VarList1; + varl2 = VarList2; + varl3 = VarList3; + while (varl1) + { + if (tindex == 0) + f_average(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], cg->fgfs[varl3->data->sgfn]); + else if (tindex == 1) + f_average3(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], cg->fgfs[varl3->data->sgfn]); + else if (tindex == -1) + // just change data order to use average3 + f_average3(cg->shape, cg->fgfs[varl2->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varl3->data->sgfn]); + else + { + cout << "error tindex in Parallel::prepare_inter_time_level" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + varl1 = varl1->next; + varl2 = varl2->next; + varl3 = varl3->next; + } + } + if (BP == Pat->ble) + break; + BP = BP->next; + } +} +void Parallel::prepare_inter_time_level(MyList *PatL, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex) +{ + while (PatL) + { + prepare_inter_time_level(PatL->data, VarList1, VarList2, VarList3, VarList4, tindex); + PatL = PatL->next; + } +} +void Parallel::prepare_inter_time_level(Patch *Pat, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + MyList *varl1; + MyList *varl2; + MyList *varl3; + MyList *varl4; + + MyList *BP = Pat->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + varl1 = VarList1; + varl2 = VarList2; + varl3 = VarList3; + varl4 = VarList4; + while (varl1) + { + if (tindex == 0) + f_average2(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], + cg->fgfs[varl3->data->sgfn], cg->fgfs[varl4->data->sgfn]); + else if (tindex == 1) + f_average2p(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], + cg->fgfs[varl3->data->sgfn], cg->fgfs[varl4->data->sgfn]); + else if (tindex == -1) + f_average2m(cg->shape, cg->fgfs[varl1->data->sgfn], cg->fgfs[varl2->data->sgfn], + cg->fgfs[varl3->data->sgfn], cg->fgfs[varl4->data->sgfn]); + else + { + cout << "error tindex in long cgh::prepare_inter_time_level" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + varl1 = varl1->next; + varl2 = varl2->next; + varl3 = varl3->next; + varl4 = varl4->next; + } + } + if (BP == Pat->ble) + break; + BP = BP->next; + } +} +void Parallel::Prolong(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + if (Patc->lev >= Patf->lev) + { + cout << "Parallel::Prolong: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_complete_gsl(Patf); // including ghost + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl4(Patc, node, Symmetry); // - buffer - ghost - BD ghost + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +void Parallel::Restrict(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + if (PatcL->data->lev >= PatfL->data->lev) + { + cout << "Parallel::Restrict: meet requst of Restrict from lev#" << PatfL->data->lev << " to lev#" << PatcL->data->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_complete_gsl(PatcL); // including ghost + for (int node = 0; node < cpusize; node++) + { +#if 0 +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + src[node]=build_owned_gsl(PatfL,node,2,Symmetry); // - buffer - ghost +#else +#ifdef Cell + src[node]=build_owned_gsl(PatfL,node,4,Symmetry); // - buffer - ghost - BD ghost +#else +#error Not define Vertex nor Cell +#endif +#endif +#else + // it seems bam always use this + src[node] = build_owned_gsl(PatfL, node, 2, Symmetry); // - buffer - ghost +#endif + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +void Parallel::Restrict_after(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + if (PatcL->data->lev >= PatfL->data->lev) + { + cout << "Parallel::Restrict: meet requst of Restrict from lev#" << PatfL->data->lev << " to lev#" << PatcL->data->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_complete_gsl(PatcL); // including ghost + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl(PatfL, node, 3, Symmetry); // - ghost - BD ghost + + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +// for the same time level +void Parallel::OutBdLow2Hi(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + if (Patc->lev >= Patf->lev) + { + cout << "Parallel::OutBdLow2Hi: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_buffer_gsl(Patf); // buffer region only + + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl4(Patc, node, Symmetry); // - buffer - ghost - BD ghost + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +void Parallel::OutBdLow2Hi(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + MyList *Pp, *Ppc; + Ppc = PatcL; + while (Ppc) + { + Pp = PatfL; + while (Pp) + { + if (Ppc->data->lev >= Pp->data->lev) + { + cout << "Parallel::OutBdLow2Hi(list): meet requst of Prolong from lev#" << Ppc->data->lev << " to lev#" << Pp->data->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + Pp = Pp->next; + } + Ppc = Ppc->next; + } + + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_buffer_gsl(PatfL); // buffer region only + + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl(PatcL, node, 4, Symmetry); // - buffer - ghost - BD ghost + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +// for the same time level +void Parallel::OutBdLow2Himix(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + if (Patc->lev >= Patf->lev) + { + cout << "Parallel::OutBdLow2Himix: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_buffer_gsl(Patf); // buffer region only + + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl4(Patc, node, Symmetry); // - buffer - ghost - BD ghost + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfermix(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; + + // do not need this, we have done after calling of this routine in ProlongRestrict or RestrictProlong + // Sync(Patf,VarList2,Symmetry); // fine level points may be not enough for interpolation +} +void Parallel::OutBdLow2Himix(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + MyList *Pp, *Ppc; + Ppc = PatcL; + while (Ppc) + { + Pp = PatfL; + while (Pp) + { + if (Ppc->data->lev >= Pp->data->lev) + { + cout << "Parallel::OutBdLow2Himix(list): meet requst of Prolong from lev#" << Ppc->data->lev << " to lev#" << Pp->data->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + Pp = Pp->next; + } + Ppc = Ppc->next; + } + + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_buffer_gsl(PatfL); // buffer region only + + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl(PatcL, node, 4, Symmetry); // - buffer - ghost - BD ghost + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfermix(transfer_src, transfer_dst, VarList1, VarList2, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} + +// Restrict_cached: cache grid segment lists, reuse buffers via transfer_cached +void Parallel::Restrict_cached(MyList *PatcL, MyList *PatfL, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache) +{ + if (!cache.valid) + { + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + cache.cpusize = cpusize; + + if (!cache.combined_src) + { + cache.combined_src = new MyList *[cpusize]; + cache.combined_dst = new MyList *[cpusize]; + cache.send_lengths = new int[cpusize]; + cache.recv_lengths = new int[cpusize]; + cache.send_bufs = new double *[cpusize]; + cache.recv_bufs = new double *[cpusize]; + cache.send_buf_caps = new int[cpusize]; + cache.recv_buf_caps = new int[cpusize]; + for (int i = 0; i < cpusize; i++) + { + cache.send_bufs[i] = cache.recv_bufs[i] = 0; + cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; + } + cache.max_reqs = 2 * cpusize; + cache.reqs = new MPI_Request[cache.max_reqs]; + cache.stats = new MPI_Status[cache.max_reqs]; + cache.tc_req_node = new int[cache.max_reqs]; + cache.tc_req_is_recv = new int[cache.max_reqs]; + cache.tc_completed = new int[cache.max_reqs]; + } + + MyList *dst = build_complete_gsl(PatcL); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl(PatfL, node, 2, Symmetry); + build_gstl(src_owned, dst, &cache.combined_src[node], &cache.combined_dst[node]); + if (src_owned) src_owned->destroyList(); + } + if (dst) dst->destroyList(); + + cache.valid = true; + } + + transfer_cached(cache.combined_src, cache.combined_dst, VarList1, VarList2, Symmetry, cache); +} + +// OutBdLow2Hi_cached: cache grid segment lists, reuse buffers via transfer_cached +void Parallel::OutBdLow2Hi_cached(MyList *PatcL, MyList *PatfL, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache) +{ + if (!cache.valid) + { + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + cache.cpusize = cpusize; + + if (!cache.combined_src) + { + cache.combined_src = new MyList *[cpusize]; + cache.combined_dst = new MyList *[cpusize]; + cache.send_lengths = new int[cpusize]; + cache.recv_lengths = new int[cpusize]; + cache.send_bufs = new double *[cpusize]; + cache.recv_bufs = new double *[cpusize]; + cache.send_buf_caps = new int[cpusize]; + cache.recv_buf_caps = new int[cpusize]; + for (int i = 0; i < cpusize; i++) + { + cache.send_bufs[i] = cache.recv_bufs[i] = 0; + cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; + } + cache.max_reqs = 2 * cpusize; + cache.reqs = new MPI_Request[cache.max_reqs]; + cache.stats = new MPI_Status[cache.max_reqs]; + cache.tc_req_node = new int[cache.max_reqs]; + cache.tc_req_is_recv = new int[cache.max_reqs]; + cache.tc_completed = new int[cache.max_reqs]; + } + + MyList *dst = build_buffer_gsl(PatfL); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl(PatcL, node, 4, Symmetry); + build_gstl(src_owned, dst, &cache.combined_src[node], &cache.combined_dst[node]); + if (src_owned) src_owned->destroyList(); + } + if (dst) dst->destroyList(); + + cache.valid = true; + } + + transfer_cached(cache.combined_src, cache.combined_dst, VarList1, VarList2, Symmetry, cache); +} + +// OutBdLow2Himix_cached: same as OutBdLow2Hi_cached but uses transfermix for unpacking +void Parallel::OutBdLow2Himix_cached(MyList *PatcL, MyList *PatfL, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache) +{ + if (!cache.valid) + { + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + cache.cpusize = cpusize; + + if (!cache.combined_src) + { + cache.combined_src = new MyList *[cpusize]; + cache.combined_dst = new MyList *[cpusize]; + cache.send_lengths = new int[cpusize]; + cache.recv_lengths = new int[cpusize]; + cache.send_bufs = new double *[cpusize]; + cache.recv_bufs = new double *[cpusize]; + cache.send_buf_caps = new int[cpusize]; + cache.recv_buf_caps = new int[cpusize]; + for (int i = 0; i < cpusize; i++) + { + cache.send_bufs[i] = cache.recv_bufs[i] = 0; + cache.send_buf_caps[i] = cache.recv_buf_caps[i] = 0; + } + cache.max_reqs = 2 * cpusize; + cache.reqs = new MPI_Request[cache.max_reqs]; + cache.stats = new MPI_Status[cache.max_reqs]; + cache.tc_req_node = new int[cache.max_reqs]; + cache.tc_req_is_recv = new int[cache.max_reqs]; + cache.tc_completed = new int[cache.max_reqs]; + } + + MyList *dst = build_buffer_gsl(PatfL); + for (int node = 0; node < cpusize; node++) + { + MyList *src_owned = build_owned_gsl(PatcL, node, 4, Symmetry); + build_gstl(src_owned, dst, &cache.combined_src[node], &cache.combined_dst[node]); + if (src_owned) src_owned->destroyList(); + } + if (dst) dst->destroyList(); + + cache.valid = true; + } + + // Use transfermix instead of transfer for mix-mode interpolation + int myrank; + MPI_Comm_size(MPI_COMM_WORLD, &cache.cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + int cpusize = cache.cpusize; + + int req_no = 0; + int pending_recv = 0; + int *req_node = new int[cache.max_reqs]; + int *req_is_recv = new int[cache.max_reqs]; + int *completed = new int[cache.max_reqs]; + + // Post receives first so peers can progress rendezvous early. + for (int node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + int rlength = data_packermix(0, cache.combined_src[node], cache.combined_dst[node], node, UNPACK, VarList1, VarList2, Symmetry); + cache.recv_lengths[node] = rlength; + if (rlength > 0) + { + if (rlength > cache.recv_buf_caps[node]) + { + if (cache.recv_bufs[node]) delete[] cache.recv_bufs[node]; + cache.recv_bufs[node] = new double[rlength]; + cache.recv_buf_caps[node] = rlength; + } + MPI_Irecv((void *)cache.recv_bufs[node], rlength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 1; + req_no++; + pending_recv++; + } + } + + // Local transfer on this rank. + int self_len = data_packermix(0, cache.combined_src[myrank], cache.combined_dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + cache.recv_lengths[myrank] = self_len; + if (self_len > 0) + { + if (self_len > cache.recv_buf_caps[myrank]) + { + if (cache.recv_bufs[myrank]) delete[] cache.recv_bufs[myrank]; + cache.recv_bufs[myrank] = new double[self_len]; + cache.recv_buf_caps[myrank] = self_len; + } + data_packermix(cache.recv_bufs[myrank], cache.combined_src[myrank], cache.combined_dst[myrank], myrank, PACK, VarList1, VarList2, Symmetry); + } + + // Pack and post sends. + for (int node = 0; node < cpusize; node++) + { + if (node == myrank) continue; + + int slength = data_packermix(0, cache.combined_src[myrank], cache.combined_dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + cache.send_lengths[node] = slength; + if (slength > 0) + { + if (slength > cache.send_buf_caps[node]) + { + if (cache.send_bufs[node]) delete[] cache.send_bufs[node]; + cache.send_bufs[node] = new double[slength]; + cache.send_buf_caps[node] = slength; + } + data_packermix(cache.send_bufs[node], cache.combined_src[myrank], cache.combined_dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + MPI_Isend((void *)cache.send_bufs[node], slength, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, cache.reqs + req_no); + req_node[req_no] = node; + req_is_recv[req_no] = 0; + req_no++; + } + } + + // Unpack as soon as receive completes to reduce pure wait time. + while (pending_recv > 0) + { + int outcount = 0; + MPI_Waitsome(req_no, cache.reqs, &outcount, completed, cache.stats); + if (outcount == MPI_UNDEFINED) break; + + for (int i = 0; i < outcount; i++) + { + int idx = completed[i]; + if (idx >= 0 && req_is_recv[idx]) + { + int recv_node_i = req_node[idx]; + data_packermix(cache.recv_bufs[recv_node_i], cache.combined_src[recv_node_i], cache.combined_dst[recv_node_i], recv_node_i, UNPACK, VarList1, VarList2, Symmetry); + pending_recv--; + } + } + } + + if (req_no > 0) MPI_Waitall(req_no, cache.reqs, cache.stats); + + if (self_len > 0) + data_packermix(cache.recv_bufs[myrank], cache.combined_src[myrank], cache.combined_dst[myrank], myrank, UNPACK, VarList1, VarList2, Symmetry); + + delete[] req_node; + delete[] req_is_recv; + delete[] completed; +} + +// collect all buffer grid segments or blocks for given patch +MyList *Parallel::build_buffer_gsl(Patch *Pat) +{ + MyList *cgsl, *gsc, *gsb; + + gsc = build_complete_gsl(Pat); // including ghost + + gsb = new MyList; + gsb->data = new Parallel::gridseg; + + for (int i = 0; i < dim; i++) + { + double DH = Pat->blb->data->getdX(i); + gsb->data->uub[i] = Pat->bbox[dim + i] - Pat->uui[i] * DH; + gsb->data->llb[i] = Pat->bbox[i] + Pat->lli[i] * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gsb->data->shape[i] = int((gsb->data->uub[i] - gsb->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gsb->data->shape[i] = int((gsb->data->uub[i] - gsb->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gsb->data->Bg = 0; + gsb->next = 0; + + cgsl = gsl_subtract(gsc, gsb); + + gsc->destroyList(); + gsb->destroyList(); + + // set illb and iuub + gsb = cgsl; + while (gsb) + { + for (int i = 0; i < dim; i++) + { + double DH = Pat->blb->data->getdX(i); + gsb->data->iuub[i] = Pat->bbox[dim + i] - Pat->uui[i] * DH; + gsb->data->illb[i] = Pat->bbox[i] + Pat->lli[i] * DH; + } + gsb = gsb->next; + } + + return cgsl; +} +MyList *Parallel::build_buffer_gsl(MyList *PatL) +{ + MyList *cgsl = 0, *gs; + while (PatL) + { + if (cgsl) + { + gs->next = build_buffer_gsl(PatL->data); + gs = gs->next; + if (gs) + while (gs->next) + gs = gs->next; + } + else + { + cgsl = build_buffer_gsl(PatL->data); + gs = cgsl; + if (gs) + while (gs->next) + gs = gs->next; + } + PatL = PatL->next; + } + + return cgsl; +} +void Parallel::Prolongint(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + if (Patc->lev >= Patf->lev) + { + cout << "Parallel::Prolong: meet requst of Prolong from lev#" << Patc->lev << " to lev#" << Patf->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int num_var = 0; + MyList *varl; + varl = VarList1; + while (varl) + { + num_var++; + varl = varl->next; + } + + MyList *BP = Patf->blb; + while (BP) + { + int Npts; + if (myrank == BP->data->rank) + Npts = BP->data->shape[0] * BP->data->shape[1] * BP->data->shape[2]; + MPI_Bcast(&Npts, 1, MPI_INT, BP->data->rank, MPI_COMM_WORLD); + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[Npts]; + if (myrank == BP->data->rank) + { + for (int i = 0; i < Npts; i++) + { + int ind[3]; + Parallel::getarrayindex(3, BP->data->shape, ind, i); + pox[0][i] = BP->data->X[0][ind[0]]; + pox[1][i] = BP->data->X[1][ind[1]]; + pox[2][i] = BP->data->X[2][ind[2]]; + } + } + for (int i = 0; i < 3; i++) + MPI_Bcast(pox[i], Npts, MPI_DOUBLE, BP->data->rank, MPI_COMM_WORLD); + double *res; + res = new double[num_var * Npts]; + Patc->Interp_Points(VarList1, Npts, pox, res, Symmetry); // because this operation is a global operation (for all processors) + // we have to isolate it out of myrank==BP->data->rank + if (myrank == BP->data->rank) + { + for (int i = 0; i < Npts; i++) + { + varl = VarList2; + int j = 0; + while (varl) + { + (BP->data->fgfs[varl->data->sgfn])[i] = res[j + i * num_var]; + j++; + varl = varl->next; + } + } + } + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] res; + BP = BP->next; + } +} +// +void Parallel::merge_gsl(MyList *&A, const double ratio) +{ + if (!A) + return; + + MyList *B, *C, *D = A; + bool flag = false; + while (D->next) + { + B = D->next; + while (B) + { + flag = merge_gs(D, B, C, ratio); + if (flag) + break; + B = B->next; + } + if (flag) + break; + D = D->next; + } + + if (flag) + { + // delete D and B from A + MyList *E = A; + while (E->next) + { + MyList *tp = E->next; + if (D == tp || B == tp) + { + E->next = (tp->next) ? tp->next : 0; + delete tp->data; + delete tp; + } + if (E->next) + E = E->next; + } + + if (D == A) + { + MyList *tp = A; + A = (A->next) ? A->next : 0; + delete tp->data; + delete tp; + } + // cat C to A + if (A) + A->catList(C); + else + A = C; + + merge_gsl(A, ratio); + } +} +// +bool Parallel::merge_gs(MyList *D, MyList *B, MyList *&C, const double ratio) +{ + if (!B || !D) + return false; + + C = 0; + double llb[dim], uub[dim], DH[dim]; + for (int i = 0; i < dim; i++) + { + double tdh; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH[i] = (D->data->uub[i] - D->data->llb[i]) / (D->data->shape[i] - 1); + tdh = (B->data->uub[i] - B->data->llb[i]) / (B->data->shape[i] - 1); +#else +#ifdef Cell + DH[i] = (D->data->uub[i] - D->data->llb[i]) / D->data->shape[i]; + tdh = (B->data->uub[i] - B->data->llb[i]) / B->data->shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (!feq(DH[i], tdh, DH[i] / 2)) + { + cout << "Parallel::merge_gs meets different grid segment " << DH[i] << " vs " << tdh << endl; + checkgsl(B, true); + checkgsl(D, true); + MPI_Abort(MPI_COMM_WORLD, 1); + } + llb[i] = Mymax(D->data->llb[i], B->data->llb[i]); + uub[i] = Mymin(D->data->uub[i], B->data->uub[i]); + // if(uub[i]-llb[i] < DH[i]/2) return false; //here this is valid for both vertex and cell + + // use 0 instead of DH[i]/2, we consider contact case, 2012 Aug 8 + if (uub[i] - llb[i] < 0) + return false; // here this is valid for both vertex and cell + } + + // vb: volume of B + // vd: volume of D + // vo: volume of overlap + // vt: volume of smallest common box (virtual merged box) + double vd = 1, vb = 1, vt = 1, vo = 1; + for (int i = 0; i < dim; i++) + { + vt = vt * (Mymax(D->data->uub[i], B->data->uub[i]) - Mymin(D->data->llb[i], B->data->llb[i])); + vo = vo * (uub[i] - llb[i]); + vd = vd * (D->data->uub[i] - D->data->llb[i]); + vb = vb * (B->data->uub[i] - B->data->llb[i]); + } + + // smller ratio, more possible to merge + if ((vd + vb - vo) / vt > ratio) + { + C = new MyList; + C->data = new gridseg; + for (int i = 0; i < dim; i++) + { + C->data->uub[i] = Mymax(D->data->uub[i], B->data->uub[i]); + C->data->llb[i] = Mymin(D->data->llb[i], B->data->llb[i]); +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + if (D->data->Bg == B->data->Bg) + C->data->Bg = D->data->Bg; + else + C->data->Bg = 0; + + C->next = 0; + + return true; + } + else + { + return false; + } +} +// Add ghost region to tangent plane +// we assume the grids have the same resolution +void Parallel::add_ghost_touch(MyList *&A) +{ + if (!A || !(A->next)) + return; + + double DH[dim]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + for (int i = 0; i < dim; i++) + DH[i] = (A->data->uub[i] - A->data->llb[i]) / (A->data->shape[i] - 1) / 2; +#else +#ifdef Cell + for (int i = 0; i < dim; i++) + DH[i] = (A->data->uub[i] - A->data->llb[i]) / A->data->shape[i] / 2; +#else +#error Not define Vertex nor Cell +#endif +#endif + + MyList *C1, *C2, *A1 = A, *A2, *dc; + dc = C1 = clone_gsl(A, false); + while (C1) + { + C2 = C1->next; + A2 = A1->next; + while (C2) + { + for (int i = 0; i < dim; i++) + { + if (feq(C1->data->llb[i], C2->data->uub[i], DH[i])) + { + // direction i touch, other directions overlap + bool flag = true; + for (int j = 0; j < i; j++) + if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && + (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) + flag = false; + for (int j = i + 1; j < dim; j++) + if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && + (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) + flag = false; + + if (flag) + { + // only add one ghost region + if (feq(A1->data->llb[i], C1->data->llb[i], DH[i])) + { + A1->data->llb[i] -= ghost_width * 2 * DH[i]; + A1->data->shape[i] += ghost_width; + } + if (feq(A2->data->uub[i], C2->data->uub[i], DH[i])) + { + A2->data->uub[i] += ghost_width * 2 * DH[i]; + A2->data->shape[i] += ghost_width; + } + } + } + if (feq(C1->data->uub[i], C2->data->llb[i], DH[i])) + { + // direction i touch, other directions overlap + bool flag = true; + for (int j = 0; j < i; j++) + if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && + (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) + flag = false; + for (int j = i + 1; j < dim; j++) + if ((C1->data->llb[j] - C2->data->llb[j]) * (C1->data->uub[j] - C2->data->llb[j]) > 0 && + (C2->data->llb[j] - C1->data->llb[j]) * (C2->data->uub[j] - C1->data->llb[j]) > 0) + flag = false; + + if (flag) + { + // only add one ghost region + if (feq(A1->data->uub[i], C1->data->uub[i], DH[i])) + { + A1->data->uub[i] += ghost_width * 2 * DH[i]; + A1->data->shape[i] += ghost_width; + } + if (feq(A2->data->llb[i], C2->data->llb[i], DH[i])) + { + A2->data->llb[i] -= ghost_width * 2 * DH[i]; + A2->data->shape[i] += ghost_width; + } + } + } + } + C2 = C2->next; + A2 = A2->next; + } + C1 = C1->next; + A1 = A1->next; + } + + if (dc) + dc->destroyList(); +} +// According to overlap to cut the gsl into recular pices +void Parallel::cut_gsl(MyList *&A) +{ + if (!A) + return; + + MyList *B, *C, *D = A; + bool flag = false; + while (D->next) + { + B = D->next; + while (B) + { + flag = cut_gs(D, B, C); + if (flag) + break; + B = B->next; + } + if (flag) + break; + D = D->next; + } + + if (flag) + { + // delete D and B from A + MyList *E = A; + while (E->next) + { + MyList *tp = E->next; + if (D == tp || B == tp) + { + E->next = (tp->next) ? tp->next : 0; + delete tp->data; + delete tp; + } + if (E->next) + E = E->next; + } + + if (D == A) + { + MyList *tp = A; + A = (A->next) ? A->next : 0; + delete tp->data; + delete tp; + } + // cat C to A + if (A) + A->catList(C); + else + A = C; + + cut_gsl(A); + } +} +// when D and B have overlap, cut them into C and return true +// otherwise return false and C=0 +bool Parallel::cut_gs(MyList *D, MyList *B, MyList *&C) +{ + C = 0; + double llb[dim], uub[dim], DH[dim]; + for (int i = 0; i < dim; i++) + { + double tdh; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH[i] = (D->data->uub[i] - D->data->llb[i]) / (D->data->shape[i] - 1); + tdh = (B->data->uub[i] - B->data->llb[i]) / (B->data->shape[i] - 1); +#else +#ifdef Cell + DH[i] = (D->data->uub[i] - D->data->llb[i]) / D->data->shape[i]; + tdh = (B->data->uub[i] - B->data->llb[i]) / B->data->shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (!feq(DH[i], tdh, DH[i] / 2)) + { + cout << "Parallel::cut_gs meets different grid segment " << DH[i] << " vs " << tdh << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + llb[i] = Mymax(D->data->llb[i], B->data->llb[i]); + uub[i] = Mymin(D->data->uub[i], B->data->uub[i]); + // for efficiency we ask the width of the patch at least 2(buffer+ghost+BD ghost) + if (uub[i] - llb[i] < DH[i] * 2 * (buffer_width + 2 * ghost_width)) + return false; // here this is valid for both vertex and cell + } + + // this part code results in 5 patches generally + + C = new MyList; + C->data = new gridseg; + for (int i = 0; i < dim; i++) + { + C->data->llb[i] = llb[i]; + C->data->uub[i] = uub[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[i] = int((C->data->uub[i] - C->data->llb[i]) / DH[i] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + if (D->data->Bg == B->data->Bg) + C->data->Bg = D->data->Bg; + else + C->data->Bg = 0; + + C->next = gs_subtract_virtual(D, C); + + MyList *E = C; + + while (E->next) + E = E->next; + + E->next = gs_subtract_virtual(B, C); + + // this part code results in 3 patches generally + /* + C = clone_gsl(D,true); + C->next = gs_subtract_virtual(B,C); + */ + + return true; +} +// note here it is different to real cut, we need leave the cutting edge for both vertex center and cell center +MyList *Parallel::gs_subtract_virtual(MyList *A, MyList *B) +{ + if (!A) + return 0; + if (!B) + return clone_gsl(A, true); + + double cut_plane[2 * dim], DH[dim]; + + for (int i = 0; i < dim; i++) + { + double tdh; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH[i] = (A->data->uub[i] - A->data->llb[i]) / (A->data->shape[i] - 1); + tdh = (B->data->uub[i] - B->data->llb[i]) / (B->data->shape[i] - 1); +#else +#ifdef Cell + DH[i] = (A->data->uub[i] - A->data->llb[i]) / A->data->shape[i]; + tdh = (B->data->uub[i] - B->data->llb[i]) / B->data->shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (!feq(DH[i], tdh, DH[i] / 2)) + { + cout << "Parallel::gs_subtract_virtual meets different grid segment " << DH[i] << " vs " << tdh << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *C = 0, *q; + for (int i = 0; i < dim; i++) + { + if (B->data->llb[i] > A->data->uub[i] || B->data->uub[i] < A->data->llb[i]) + return clone_gsl(A, true); + cut_plane[i] = A->data->llb[i]; + cut_plane[i + dim] = A->data->uub[i]; + } + + for (int i = 0; i < dim; i++) + { + cut_plane[i] = Mymax(A->data->llb[i], B->data->llb[i]); + if (cut_plane[i] > A->data->llb[i]) + { + q = clone_gsl(A, true); + // prolong the list from head + if (C) + q->next = C; + C = q; + for (int j = 0; j < dim; j++) + { + if (i == j) + { + C->data->llb[i] = A->data->llb[i]; + // **note here it is different to real cut, we need leave the cutting edge for both vertex center and cell center** + C->data->uub[i] = Mymax(C->data->llb[i], cut_plane[i]); + } + else + { + C->data->llb[j] = cut_plane[j]; + C->data->uub[j] = cut_plane[j + dim]; + } +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + } + + cut_plane[i + dim] = Mymin(A->data->uub[i], B->data->uub[i]); + if (cut_plane[i + dim] < A->data->uub[i]) + { + q = clone_gsl(A, true); + if (C) + q->next = C; + C = q; + for (int j = 0; j < dim; j++) + { + if (i == j) + { + C->data->uub[i] = A->data->uub[i]; + // note here it is different to real cut, we need leave the cutting edge for both vertex center and cell center + C->data->llb[i] = Mymin(C->data->uub[i], cut_plane[i + dim]); + } + else + { + C->data->llb[j] = cut_plane[j]; + C->data->uub[j] = cut_plane[j + dim]; + } +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4) + 1; +#else +#ifdef Cell + C->data->shape[j] = int((C->data->uub[j] - C->data->llb[j]) / DH[j] + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + } + } + return C; +} +// note the data structure +// if CC is true +// 1 ----------- 1 ------ ^ +// 0 ------ | t +// 0 ----------- old ------ | +// +// old ----------- +// if CC is false +// 1 ----------- 1 ------ ^ +// 0 ----------- 0 ------ | t +// old ----------- old ------ | +void Parallel::fill_level_data(MyList *PatLd, MyList *PatLs, MyList *PatcL, + MyList *OldList, MyList *StateList, MyList *FutureList, + MyList *tmList, int Symmetry, bool BB, bool CC) +{ + if (PatLd->data->lev != PatLs->data->lev) + { + cout << "Parallel::fill_level_data: meet requst from lev#" << PatLs->data->lev << " to lev#" << PatLd->data->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (PatLd->data->lev <= PatcL->data->lev) + { + cout << "Parallel::fill_level_data: meet prolong requst from lev#" << PatcL->data->lev << " to lev#" << PatLd->data->lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *VarList = 0; + MyList *p; + p = StateList; + while (p) + { + if (VarList) + VarList->insert(p->data); + else + VarList = new MyList(p->data); + p = p->next; + } + p = FutureList; + while (p) + { + if (VarList) + VarList->insert(p->data); + else + VarList = new MyList(p->data); + p = p->next; + } + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_complete_gsl(PatLd); // including ghost + // copy part + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl(PatLs, node, 0, Symmetry); // similar to Sync + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); + + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + MyList *dsts, *dstd; + dsts = build_complete_gsl_virtual(PatLs); + dstd = dst; + dst = gsl_subtract(dstd, dsts); + if (dstd) + dstd->destroyList(); + if (dsts) + dsts->destroyList(); + + if (dst) + { + // prolongation part + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl(PatcL, node, 4, Symmetry); // - buffer - ghost - BD ghost + build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + if (CC) + { + // for FutureList + // restrict first~~~> + { + Restrict(PatcL, PatLs, FutureList, FutureList, Symmetry); + Sync(PatcL, FutureList, Symmetry); + } + //<~~~prolong then + transfer(transfer_src, transfer_dst, FutureList, FutureList, Symmetry); + + // for StateList + // time interpolation part + if (BB) + prepare_inter_time_level(PatcL, FutureList, StateList, OldList, + tmList, 0); // use SynchList_pre as temporal storage space + else + prepare_inter_time_level(PatcL, FutureList, StateList, + tmList, 0); // use SynchList_pre as temporal storage space + // restrict first~~~> + { + Restrict(PatcL, PatLs, StateList, tmList, Symmetry); + Sync(PatcL, tmList, Symmetry); + } + //<~~~prolong then + transfer(transfer_src, transfer_dst, tmList, StateList, Symmetry); + } + else + { + // for both FutureList and StateList + // restrict first~~~> + { + Restrict(PatcL, PatLs, VarList, VarList, Symmetry); + Sync(PatcL, VarList, Symmetry); + } + //<~~~prolong then + transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); + } + + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + dst->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; + + VarList->clearList(); +} +void Parallel::KillBlocks(MyList *PatchLIST) +{ + while (PatchLIST) + { + Patch *Pp = PatchLIST->data; + MyList *bg; + while (Pp->blb) + { + if (Pp->blb == Pp->ble) + break; + bg = (Pp->blb->next) ? Pp->blb->next : 0; + delete Pp->blb->data; + delete Pp->blb; + Pp->blb = bg; + } + if (Pp->ble) + { + delete Pp->ble->data; + delete Pp->ble; + } + Pp->blb = Pp->ble = 0; + PatchLIST = PatchLIST->next; + } +} +bool Parallel::PatList_Interp_Points(MyList *PatL, MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry) +{ + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double lld[dim], uud[dim]; + double **pox; + pox = new double *[dim]; + for (int j = 0; j < dim; j++) + pox[j] = new double[1]; + for (int i = 0; i < NN; i++) + { + MyList *PL = PatL; + while (PL) + { + bool flag = true; + for (int j = 0; j < dim; j++) + { + double h = PL->data->getdX(j); + lld[j] = PL->data->lli[j] * h; + uud[j] = PL->data->uui[j] * h; + if (XX[j][i] < PL->data->bbox[j] + lld[j] || XX[j][i] > PL->data->bbox[j + dim] - uud[j]) + { + flag = false; + break; + } + pox[j][0] = XX[j][i]; + } + if (flag) + { + PL->data->Interp_Points(VarList, 1, pox, Shellf + i * num_var, Symmetry); + break; + } + PL = PL->next; + } + if (!PL) + { + checkpatchlist(PatL, false); + return false; + } + } + for (int j = 0; j < dim; j++) + delete[] pox[j]; + delete[] pox; + + return true; +} +bool Parallel::PatList_Interp_Points(MyList *PatL, MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry, MPI_Comm Comm_here) +{ + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double lld[dim], uud[dim]; + double **pox; + pox = new double *[dim]; + for (int j = 0; j < dim; j++) + pox[j] = new double[1]; + for (int i = 0; i < NN; i++) + { + MyList *PL = PatL; + while (PL) + { + bool flag = true; + for (int j = 0; j < dim; j++) + { + double h = PL->data->getdX(j); + lld[j] = PL->data->lli[j] * h; + uud[j] = PL->data->uui[j] * h; + if (XX[j][i] < PL->data->bbox[j] + lld[j] || XX[j][i] > PL->data->bbox[j + dim] - uud[j]) + { + flag = false; + break; + } + pox[j][0] = XX[j][i]; + } + if (flag) + { + PL->data->Interp_Points(VarList, 1, pox, Shellf + i * num_var, Symmetry, Comm_here); + break; + } + PL = PL->next; + } + if (!PL) + { + checkpatchlist(PatL, false); + return false; + } + } + for (int j = 0; j < dim; j++) + delete[] pox[j]; + delete[] pox; + + return true; +} +void Parallel::aligncheck(double *bbox0, double *bboxl, int lev, double *DH0, int *shape) +{ + const double aligntiny = 0.1; + double DHl, rr; + int NN; + for (int i = 0; i < dim; i++) + { + DHl = DH0[i] * pow(0.5, lev); + rr = bboxl[i] - bbox0[i]; + bboxl[i] = bbox0[i] + int(rr / DHl + 0.4) * DHl; + rr = bbox0[i + dim] - bboxl[i + dim]; + bboxl[i + dim] = bbox0[i + dim] - int(rr / DHl + 0.4) * DHl; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + NN = int((bboxl[i + dim] - bboxl[i]) / DHl + 0.4) + 1; +#else +#ifdef Cell + NN = int((bboxl[i + dim] - bboxl[i]) / DHl + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + if (NN != shape[i]) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << "Parallel::aligncheck want shape " << NN << " for lev#" << lev << ", but " << shape[i] << endl; + cout << "i = " << i << ", low = " << bboxl[i] << ", up = " << bboxl[i + dim] << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } +} +bool Parallel::point_locat_gsl(double *pox, MyList *gsl) +{ + bool flag = false; + while (gsl) + { + for (int i = 0; i < dim; i++) + { + if (pox[i] > gsl->data->llb[i] && pox[i] < gsl->data->uub[i]) + flag = true; + else + { + flag = false; + break; + } + } + if (flag) + break; + gsl = gsl->next; + } + + return flag; +} +void Parallel::checkpatchlist(MyList *PatL, bool buflog) +{ + MyList *PL = PatL; + while (PL) + { + PL->data->checkPatch(buflog); + PL = PL->next; + } +} diff --git a/AMSS_NCKU_source/Parallel.h b/AMSS_NCKU_source/Parallel/Parallel.h similarity index 98% rename from AMSS_NCKU_source/Parallel.h rename to AMSS_NCKU_source/Parallel/Parallel.h index d2b268f..7a8ef5d 100644 --- a/AMSS_NCKU_source/Parallel.h +++ b/AMSS_NCKU_source/Parallel/Parallel.h @@ -1,184 +1,184 @@ - -#ifndef PARALLEL_H -#define PARALLEL_H - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "Parallel_bam.h" -#include "var.h" -#include "MPatch.h" -#include "Block.h" -#include "MyList.h" -#include "macrodef.h" //need dim; ghost_width; CONTRACT -namespace Parallel -{ - struct gridseg - { - double llb[dim]; - double uub[dim]; - int shape[dim]; - double illb[dim], iuub[dim]; // only use for OutBdLow2Hi - Block *Bg; - }; - int partition1(int &nx, int split_size, int min_width, int cpusize, int shape); // special for 1 diemnsion - int partition2(int *nxy, int split_size, int *min_width, int cpusize, int *shape); // special for 2 diemnsions - int partition3(int *nxyz, int split_size, int *min_width, int cpusize, int *shape); - MyList *distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfs, bool periodic, int nodes = 0); // produce corresponding Blocks - MyList *distribute_optimize(MyList *PatchLIST, int cpusize, int ingfsi, int fngfs, bool periodic, int nodes = 0); - Block* splitHotspotBlock(MyList* &BlL, int _dim, - int ib0_orig, int ib3_orig, - int jb1_orig, int jb4_orig, - int kb2_orig, int kb5_orig, - Patch* PP, int r_left, int r_right, - int ingfsi, int fngfsi, bool periodic, - Block* &split_first_block, Block* &split_last_block); - Block* createMappedBlock(MyList* &BlL, int _dim, int* shape, double* bbox, - int block_id, int ingfsi, int fngfsi, int lev); - void KillBlocks(MyList *PatchLIST); - - void setfunction(MyList *BlL, var *vn, double func(double x, double y, double z)); - void setfunction(int rank, MyList *BlL, var *vn, double func(double x, double y, double z)); - void writefile(double time, int nx, int ny, int nz, double xmin, double xmax, double ymin, double ymax, - double zmin, double zmax, char *filename, double *data_out); - void writefile(double time, int nx, int ny, double xmin, double xmax, double ymin, double ymax, - char *filename, double *datain); - void getarrayindex(int DIM, int *shape, int *index, int n); - int getarraylocation(int DIM, int *shape, int *index); - void copy(int DIM, double *llbout, double *uubout, int *Dshape, double *DD, double *llbin, double *uubin, - int *shape, double *datain, double *llb, double *uub); - void Dump_CPU_Data(MyList *BlL, MyList *DumpList, char *tag, double time, double dT); - void Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT); - void Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd); - double *Collect_Data(Patch *PP, var *VP); - void d2Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT); - void d2Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd); - void Dump_Data0(Patch *PP, MyList *DumpList, char *tag, double time, double dT); - double global_interp(int DIM, int *ext, double **CoX, double *datain, - double *poX, int ordn, double *SoA, int Symmetry); - double global_interp(int DIM, int *ext, double **CoX, double *datain, - double *poX, int ordn); - double Lagrangian_Int(double x, int npts, double *xpts, double *funcvals); - double LagrangePoly(double x, int pt, int npts, double *xpts); - MyList *build_complete_gsl(Patch *Pat); - MyList *build_complete_gsl(MyList *PatL); - MyList *build_complete_gsl_virtual(MyList *PatL); - MyList *build_complete_gsl_virtual2(MyList *PatL); // - buffer - MyList *build_owned_gsl0(Patch *Pat, int rank_in); // - ghost without extension, special for Sync usage - MyList *build_owned_gsl1(Patch *Pat, int rank_in); // - ghost, similar to build_owned_gsl0 but extend one point on left side for vertex grid - MyList *build_owned_gsl2(Patch *Pat, int rank_in); // - buffer - ghost - MyList *build_owned_gsl3(Patch *Pat, int rank_in, int Symmetry); // - ghost - BD ghost - MyList *build_owned_gsl4(Patch *Pat, int rank_in, int Symmetry); // - buffer - ghost - BD ghost - MyList *build_owned_gsl5(Patch *Pat, int rank_in); // similar to build_owned_gsl2 but no extension - MyList *build_owned_gsl(MyList *PatL, int rank_in, int type, int Symmetry); - void build_gstl(MyList *srci, MyList *dsti, MyList **out_src, MyList **out_dst); - int data_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists, MyList *VarListd, int Symmetry); - void transfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry); - int data_packermix(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists, MyList *VarListd, int Symmetry); - void transfermix(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry); - void Sync(Patch *Pat, MyList *VarList, int Symmetry); - void Sync(MyList *PatL, MyList *VarList, int Symmetry); - void Sync_merged(MyList *PatL, MyList *VarList, int Symmetry); - - struct SyncCache { - bool valid; - int cpusize; - MyList **combined_src; - MyList **combined_dst; - int *send_lengths; - int *recv_lengths; - double **send_bufs; - double **recv_bufs; - int *send_buf_caps; - int *recv_buf_caps; - MPI_Request *reqs; - MPI_Status *stats; - int max_reqs; - bool lengths_valid; - int *tc_req_node; - int *tc_req_is_recv; - int *tc_completed; - SyncCache(); - void invalidate(); - void destroy(); - }; - - void Sync_cached(MyList *PatL, MyList *VarList, int Symmetry, SyncCache &cache); - void transfer_cached(MyList **src, MyList **dst, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache); - - struct AsyncSyncState { - int req_no; - bool active; - int *req_node; - int *req_is_recv; - int pending_recv; - AsyncSyncState() : req_no(0), active(false), req_node(0), req_is_recv(0), pending_recv(0) {} - }; - - void Sync_start(MyList *PatL, MyList *VarList, int Symmetry, - SyncCache &cache, AsyncSyncState &state); - void Sync_finish(SyncCache &cache, AsyncSyncState &state, - MyList *VarList, int Symmetry); - void OutBdLow2Hi(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void OutBdLow2Hi(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void OutBdLow2Himix(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void OutBdLow2Himix(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void Restrict_cached(MyList *PatcL, MyList *PatfL, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache); - void OutBdLow2Hi_cached(MyList *PatcL, MyList *PatfL, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache); - void OutBdLow2Himix_cached(MyList *PatcL, MyList *PatfL, - MyList *VarList1, MyList *VarList2, - int Symmetry, SyncCache &cache); - void Prolong(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void Prolongint(Patch *Patc, Patch *Patf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void Restrict(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void Restrict_after(MyList *PatcL, MyList *PatfL, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); // for -ghost - BDghost - MyList *build_PhysBD_gsl(Patch *Pat); - MyList *build_ghost_gsl(MyList *PatL); - MyList *build_ghost_gsl(Patch *Pat); - MyList *build_buffer_gsl(Patch *Pat); - MyList *build_buffer_gsl(MyList *PatL); - MyList *gsl_subtract(MyList *A, MyList *B); - MyList *gs_subtract(MyList *A, MyList *B); - MyList *gsl_and(MyList *A, MyList *B); - MyList *gs_and(MyList *A, MyList *B); - MyList *clone_gsl(MyList *p, bool first_only); - MyList *build_bulk_gsl(Patch *Pat); // similar to build_owned_gsl0 but does not care rank issue - MyList *build_bulk_gsl(Block *bp, Patch *Pat); + +#ifndef PARALLEL_H +#define PARALLEL_H + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "Parallel_bam.h" +#include "var.h" +#include "MPatch.h" +#include "Block.h" +#include "MyList.h" +#include "macrodef.h" //need dim; ghost_width; CONTRACT +namespace Parallel +{ + struct gridseg + { + double llb[dim]; + double uub[dim]; + int shape[dim]; + double illb[dim], iuub[dim]; // only use for OutBdLow2Hi + Block *Bg; + }; + int partition1(int &nx, int split_size, int min_width, int cpusize, int shape); // special for 1 diemnsion + int partition2(int *nxy, int split_size, int *min_width, int cpusize, int *shape); // special for 2 diemnsions + int partition3(int *nxyz, int split_size, int *min_width, int cpusize, int *shape); + MyList *distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfs, bool periodic, int nodes = 0); // produce corresponding Blocks + MyList *distribute_optimize(MyList *PatchLIST, int cpusize, int ingfsi, int fngfs, bool periodic, int nodes = 0); + Block* splitHotspotBlock(MyList* &BlL, int _dim, + int ib0_orig, int ib3_orig, + int jb1_orig, int jb4_orig, + int kb2_orig, int kb5_orig, + Patch* PP, int r_left, int r_right, + int ingfsi, int fngfsi, bool periodic, + Block* &split_first_block, Block* &split_last_block); + Block* createMappedBlock(MyList* &BlL, int _dim, int* shape, double* bbox, + int block_id, int ingfsi, int fngfsi, int lev); + void KillBlocks(MyList *PatchLIST); + + void setfunction(MyList *BlL, var *vn, double func(double x, double y, double z)); + void setfunction(int rank, MyList *BlL, var *vn, double func(double x, double y, double z)); + void writefile(double time, int nx, int ny, int nz, double xmin, double xmax, double ymin, double ymax, + double zmin, double zmax, char *filename, double *data_out); + void writefile(double time, int nx, int ny, double xmin, double xmax, double ymin, double ymax, + char *filename, double *datain); + void getarrayindex(int DIM, int *shape, int *index, int n); + int getarraylocation(int DIM, int *shape, int *index); + void copy(int DIM, double *llbout, double *uubout, int *Dshape, double *DD, double *llbin, double *uubin, + int *shape, double *datain, double *llb, double *uub); + void Dump_CPU_Data(MyList *BlL, MyList *DumpList, char *tag, double time, double dT); + void Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT); + void Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd); + double *Collect_Data(Patch *PP, var *VP); + void d2Dump_Data(MyList *PL, MyList *DumpList, char *tag, double time, double dT); + void d2Dump_Data(Patch *PP, MyList *DumpList, char *tag, double time, double dT, int grd); + void Dump_Data0(Patch *PP, MyList *DumpList, char *tag, double time, double dT); + double global_interp(int DIM, int *ext, double **CoX, double *datain, + double *poX, int ordn, double *SoA, int Symmetry); + double global_interp(int DIM, int *ext, double **CoX, double *datain, + double *poX, int ordn); + double Lagrangian_Int(double x, int npts, double *xpts, double *funcvals); + double LagrangePoly(double x, int pt, int npts, double *xpts); + MyList *build_complete_gsl(Patch *Pat); + MyList *build_complete_gsl(MyList *PatL); + MyList *build_complete_gsl_virtual(MyList *PatL); + MyList *build_complete_gsl_virtual2(MyList *PatL); // - buffer + MyList *build_owned_gsl0(Patch *Pat, int rank_in); // - ghost without extension, special for Sync usage + MyList *build_owned_gsl1(Patch *Pat, int rank_in); // - ghost, similar to build_owned_gsl0 but extend one point on left side for vertex grid + MyList *build_owned_gsl2(Patch *Pat, int rank_in); // - buffer - ghost + MyList *build_owned_gsl3(Patch *Pat, int rank_in, int Symmetry); // - ghost - BD ghost + MyList *build_owned_gsl4(Patch *Pat, int rank_in, int Symmetry); // - buffer - ghost - BD ghost + MyList *build_owned_gsl5(Patch *Pat, int rank_in); // similar to build_owned_gsl2 but no extension + MyList *build_owned_gsl(MyList *PatL, int rank_in, int type, int Symmetry); + void build_gstl(MyList *srci, MyList *dsti, MyList **out_src, MyList **out_dst); + int data_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists, MyList *VarListd, int Symmetry); + void transfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry); + int data_packermix(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists, MyList *VarListd, int Symmetry); + void transfermix(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry); + void Sync(Patch *Pat, MyList *VarList, int Symmetry); + void Sync(MyList *PatL, MyList *VarList, int Symmetry); + void Sync_merged(MyList *PatL, MyList *VarList, int Symmetry); + + struct SyncCache { + bool valid; + int cpusize; + MyList **combined_src; + MyList **combined_dst; + int *send_lengths; + int *recv_lengths; + double **send_bufs; + double **recv_bufs; + int *send_buf_caps; + int *recv_buf_caps; + MPI_Request *reqs; + MPI_Status *stats; + int max_reqs; + bool lengths_valid; + int *tc_req_node; + int *tc_req_is_recv; + int *tc_completed; + SyncCache(); + void invalidate(); + void destroy(); + }; + + void Sync_cached(MyList *PatL, MyList *VarList, int Symmetry, SyncCache &cache); + void transfer_cached(MyList **src, MyList **dst, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache); + + struct AsyncSyncState { + int req_no; + bool active; + int *req_node; + int *req_is_recv; + int pending_recv; + AsyncSyncState() : req_no(0), active(false), req_node(0), req_is_recv(0), pending_recv(0) {} + }; + + void Sync_start(MyList *PatL, MyList *VarList, int Symmetry, + SyncCache &cache, AsyncSyncState &state); + void Sync_finish(SyncCache &cache, AsyncSyncState &state, + MyList *VarList, int Symmetry); + void OutBdLow2Hi(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void OutBdLow2Hi(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void OutBdLow2Himix(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void OutBdLow2Himix(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void Restrict_cached(MyList *PatcL, MyList *PatfL, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache); + void OutBdLow2Hi_cached(MyList *PatcL, MyList *PatfL, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache); + void OutBdLow2Himix_cached(MyList *PatcL, MyList *PatfL, + MyList *VarList1, MyList *VarList2, + int Symmetry, SyncCache &cache); + void Prolong(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void Prolongint(Patch *Patc, Patch *Patf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void Restrict(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void Restrict_after(MyList *PatcL, MyList *PatfL, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); // for -ghost - BDghost + MyList *build_PhysBD_gsl(Patch *Pat); + MyList *build_ghost_gsl(MyList *PatL); + MyList *build_ghost_gsl(Patch *Pat); + MyList *build_buffer_gsl(Patch *Pat); + MyList *build_buffer_gsl(MyList *PatL); + MyList *gsl_subtract(MyList *A, MyList *B); + MyList *gs_subtract(MyList *A, MyList *B); + MyList *gsl_and(MyList *A, MyList *B); + MyList *gs_and(MyList *A, MyList *B); + MyList *clone_gsl(MyList *p, bool first_only); + MyList *build_bulk_gsl(Patch *Pat); // similar to build_owned_gsl0 but does not care rank issue + MyList *build_bulk_gsl(Block *bp, Patch *Pat); void build_PhysBD_gstl(Patch *Pat, MyList *srci, MyList *dsti, MyList **out_src, MyList **out_dst); void PeriodicBD(Patch *Pat, MyList *VarList, int Symmetry); @@ -186,46 +186,46 @@ namespace Parallel void L2Norm7(Patch *Pat, var **vf, double *norms); void checkgsl(MyList *pp, bool first_only); void checkvarl(MyList *pp, bool first_only); - MyList *divide_gsl(MyList *p, Patch *Pat); - MyList *divide_gs(MyList *p, Patch *Pat); - void prepare_inter_time_level(Patch *Pat, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* target (t+a*dt) */, int tindex); - void prepare_inter_time_level(Patch *Pat, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex); - void prepare_inter_time_level(MyList *PatL, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* target (t+a*dt) */, int tindex); - void prepare_inter_time_level(MyList *Pat, - MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, - MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex); - void merge_gsl(MyList *&A, const double ratio); - bool merge_gs(MyList *D, MyList *B, MyList *&C, const double ratio); - // Add ghost region to tangent plane - // we assume the grids have the same resolution - void add_ghost_touch(MyList *&A); - void cut_gsl(MyList *&A); - bool cut_gs(MyList *D, MyList *B, MyList *&C); - MyList *gs_subtract_virtual(MyList *A, MyList *B); - void fill_level_data(MyList *PatLd, MyList *PatLs, MyList *PatcL, - MyList *OldList, MyList *StateList, MyList *FutureList, - MyList *tmList, int Symmetry, bool BB, bool CC); - bool PatList_Interp_Points(MyList *PatL, MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry); - void aligncheck(double *bbox0, double *bboxl, int lev, double *DH0, int *shape); - bool point_locat_gsl(double *pox, MyList *gsl); - void checkpatchlist(MyList *PatL, bool buflog); + MyList *divide_gsl(MyList *p, Patch *Pat); + MyList *divide_gs(MyList *p, Patch *Pat); + void prepare_inter_time_level(Patch *Pat, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* target (t+a*dt) */, int tindex); + void prepare_inter_time_level(Patch *Pat, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex); + void prepare_inter_time_level(MyList *PatL, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* target (t+a*dt) */, int tindex); + void prepare_inter_time_level(MyList *Pat, + MyList *VarList1 /* source (t+dt) */, MyList *VarList2 /* source (t) */, + MyList *VarList3 /* source (t-dt) */, MyList *VarList4 /* target (t+a*dt) */, int tindex); + void merge_gsl(MyList *&A, const double ratio); + bool merge_gs(MyList *D, MyList *B, MyList *&C, const double ratio); + // Add ghost region to tangent plane + // we assume the grids have the same resolution + void add_ghost_touch(MyList *&A); + void cut_gsl(MyList *&A); + bool cut_gs(MyList *D, MyList *B, MyList *&C); + MyList *gs_subtract_virtual(MyList *A, MyList *B); + void fill_level_data(MyList *PatLd, MyList *PatLs, MyList *PatcL, + MyList *OldList, MyList *StateList, MyList *FutureList, + MyList *tmList, int Symmetry, bool BB, bool CC); + bool PatList_Interp_Points(MyList *PatL, MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry); + void aligncheck(double *bbox0, double *bboxl, int lev, double *DH0, int *shape); + bool point_locat_gsl(double *pox, MyList *gsl); + void checkpatchlist(MyList *PatL, bool buflog); double L2Norm(Patch *Pat, var *vf, MPI_Comm Comm_here); void L2Norm7(Patch *Pat, var **vf, double *norms, MPI_Comm Comm_here); bool PatList_Interp_Points(MyList *PatL, MyList *VarList, int NN, double **XX, double *Shellf, int Symmetry, MPI_Comm Comm_here); -#if (PSTR == 1 || PSTR == 2 || PSTR == 3) - MyList *distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, - bool periodic, int start_rank, int end_rank, int nodes = 0); -#endif -} -#endif /*PARALLEL_H */ +#if (PSTR == 1 || PSTR == 2 || PSTR == 3) + MyList *distribute(MyList *PatchLIST, int cpusize, int ingfsi, int fngfsi, + bool periodic, int start_rank, int end_rank, int nodes = 0); +#endif +} +#endif /*PARALLEL_H */ diff --git a/AMSS_NCKU_source/Parallel_bam.C b/AMSS_NCKU_source/Parallel/Parallel_bam.C similarity index 96% rename from AMSS_NCKU_source/Parallel_bam.C rename to AMSS_NCKU_source/Parallel/Parallel_bam.C index d0afa9a..fd3e155 100644 --- a/AMSS_NCKU_source/Parallel_bam.C +++ b/AMSS_NCKU_source/Parallel/Parallel_bam.C @@ -1,662 +1,662 @@ - -#include "Parallel.h" -#include "fmisc.h" -#include "prolongrestrict.h" -#include "misc.h" - -void Parallel::OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - MyList *bdsul; - Constr_pointstr_OutBdLow2Hi(PLf, PLc, bdsul); - - intertransfer(bdsul, VarList1, VarList2, Symmetry); - - destroypsuList_bam(bdsul); -} -void Parallel::Restrict_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry) -{ - MyList *rsul; - Constr_pointstr_Restrict(PLf, PLc, rsul); - - intertransfer(rsul, VarList1, VarList2, Symmetry); - - destroypsuList_bam(rsul); -} -void Parallel::OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - MyList *bdsul, int Symmetry) -{ - intertransfer(bdsul, VarList1, VarList2, Symmetry); -} -void Parallel::Restrict_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - MyList *rsul, int Symmetry) -{ - intertransfer(rsul, VarList1, VarList2, Symmetry); -} -void Parallel::Constr_pointstr_OutBdLow2Hi(MyList *PLf, MyList *PLc, - MyList *&bdsul) -{ - MyList *PL; - - MyList *ps; - bdsul = 0; - - // find out points - PL = PLf; - while (PL) - { - double dx, dy, dz; - - dx = PL->data->blb->data->getdX(0); - dy = PL->data->blb->data->getdX(1); - dz = PL->data->blb->data->getdX(2); - - double uub[3], llb[3]; - - llb[0] = PL->data->bbox[0] + PL->data->lli[0] * dx; - llb[1] = PL->data->bbox[1] + PL->data->lli[1] * dy; - llb[2] = PL->data->bbox[2] + PL->data->lli[2] * dz; - uub[0] = PL->data->bbox[3] - PL->data->uui[0] * dx; - uub[1] = PL->data->bbox[4] - PL->data->uui[1] * dy; - uub[2] = PL->data->bbox[5] - PL->data->uui[2] * dz; - - double x, y, z; - - for (int i = 0; i < PL->data->shape[0]; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = PL->data->bbox[0] + i * dx; -#else -#ifdef Cell - x = PL->data->bbox[0] + (0.5 + i) * dx; -#else -#error Not define Vertex nor Cell -#endif -#endif - for (int j = 0; j < PL->data->shape[1]; j++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y = PL->data->bbox[1] + j * dy; -#else -#ifdef Cell - y = PL->data->bbox[1] + (0.5 + j) * dy; -#else -#error Not define Vertex nor Cell -#endif -#endif - for (int k = 0; k < PL->data->shape[2]; k++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - z = PL->data->bbox[2] + k * dz; -#else -#ifdef Cell - z = PL->data->bbox[2] + (0.5 + k) * dz; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (!(llb[0] - TINY < x && uub[0] + TINY > x && - llb[1] - TINY < y && uub[1] + TINY > y && - llb[2] - TINY < z && uub[2] + TINY > z)) // not in the inner part - { - if (bdsul) - { - ps->next = new MyList; - ps = ps->next; - ps->data = new Parallel::pointstru_bam; - } - else - { - bdsul = ps = new MyList; - ps->data = new Parallel::pointstru_bam; - } - - ps->data->pox[0] = x; - ps->data->pox[1] = y; - ps->data->pox[2] = z; - ps->data->Bgs = 0; - ps->data->Bgd = 0; - ps->data->coef = 0; - - ps->next = 0; - } - } - } - } - - PL = PL->next; - } - - // find out blocks - ps = bdsul; - while (ps) - { - double x, y, z; - x = ps->data->pox[0]; - y = ps->data->pox[1]; - z = ps->data->pox[2]; - bool flag; - // find target block - flag = true; - PL = PLf; - while (flag && PL) - { - MyList *BP = PL->data->blb; - while (flag && BP) - { - double llb[3], uub[3]; - - for (int i = 0; i < dim; i++) - { - double DH = BP->data->getdX(i); - uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; - llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; - } - - if (llb[0] - TINY < x && uub[0] + TINY > x && - llb[1] - TINY < y && uub[1] + TINY > y && - llb[2] - TINY < z && uub[2] + TINY > z) - { - ps->data->Bgd = BP->data; - flag = false; - } - - if (BP == PL->data->ble) - break; - BP = BP->next; - } - PL = PL->next; - } - if (flag) - { - cout << "error in Parallel::Constr_pointstr_OutBdLow2Hi 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - // find source block - flag = true; - PL = PLc; - while (flag && PL) - { - MyList *BP = PL->data->blb; - while (flag && BP) - { - double llb[3], uub[3]; - - for (int i = 0; i < dim; i++) - { - double DH = BP->data->getdX(i); - uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; - llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; - } - - if (llb[0] - TINY < x && uub[0] + TINY > x && - llb[1] - TINY < y && uub[1] + TINY > y && - llb[2] - TINY < z && uub[2] + TINY > z) - { - ps->data->Bgs = BP->data; - flag = false; - } - - if (BP == PL->data->ble) - break; - BP = BP->next; - } - PL = PL->next; - } - if (flag) - { - cout << "error in Parallel::Constr_pointstr_OutBdLow2Hi 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - ps = ps->next; - } -} -void Parallel::Constr_pointstr_Restrict(MyList *PLf, MyList *PLc, - MyList *&rsul) -{ - MyList *gdlf = 0, *gs; - MyList *PL = PLf; - while (PL) - { - if (gdlf) - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - else - { - gdlf = gs = new MyList; - gs->data = new Parallel::gridseg; - } - - gs->next = 0; - - for (int i = 0; i < dim; i++) - { - double DH = PL->data->blb->data->getdX(i); - - gs->data->llb[i] = PL->data->bbox[i] + PL->data->lli[i] * DH; - gs->data->uub[i] = PL->data->bbox[dim + i] - PL->data->uui[i] * DH; - } - - PL = PL->next; - } - - MyList *ps; - rsul = 0; - - // find out points - gs = gdlf; - while (gs) - { - PL = PLc; - bool flag = true; - while (flag) - { - if (!PL) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << "error in Parallel::Constr_pointstr_Restrict: fail to find grid segment [" << gs->data->llb[0] << ":" << gs->data->uub[0] << "," - << gs->data->llb[1] << ":" << gs->data->uub[1] << "," - << gs->data->llb[2] << ":" << gs->data->uub[2] << "]" - << endl; - PL = PLc; - while (PL) - { - PL->data->checkPatch(0); - PL = PL->next; - } - } - - misc::tillherecheck("for wait."); - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (gs->data->llb[0] > PL->data->bbox[0] - TINY && gs->data->uub[0] < PL->data->bbox[3] + TINY && - gs->data->llb[1] > PL->data->bbox[1] - TINY && gs->data->uub[1] < PL->data->bbox[4] + TINY && - gs->data->llb[2] > PL->data->bbox[2] - TINY && gs->data->uub[2] < PL->data->bbox[5] + TINY) - flag = false; - - if (flag) - PL = PL->next; - } - - double dx, dy, dz; - - dx = PL->data->blb->data->getdX(0); - dy = PL->data->blb->data->getdX(1); - dz = PL->data->blb->data->getdX(2); - - double x, y, z; - - for (int i = 0; i < PL->data->shape[0]; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = PL->data->bbox[0] + i * dx; -#else -#ifdef Cell - x = PL->data->bbox[0] + (0.5 + i) * dx; -#else -#error Not define Vertex nor Cell -#endif -#endif - for (int j = 0; j < PL->data->shape[1]; j++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y = PL->data->bbox[1] + j * dy; -#else -#ifdef Cell - y = PL->data->bbox[1] + (0.5 + j) * dy; -#else -#error Not define Vertex nor Cell -#endif -#endif - for (int k = 0; k < PL->data->shape[2]; k++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - z = PL->data->bbox[2] + k * dz; -#else -#ifdef Cell - z = PL->data->bbox[2] + (0.5 + k) * dz; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (gs->data->llb[0] - TINY < x && gs->data->uub[0] + TINY > x && - gs->data->llb[1] - TINY < y && gs->data->uub[1] + TINY > y && - gs->data->llb[2] - TINY < z && gs->data->uub[2] + TINY > z) // in the inner part - { - if (rsul) - { - ps->next = new MyList; - ps = ps->next; - ps->data = new Parallel::pointstru_bam; - } - else - { - rsul = ps = new MyList; - ps->data = new Parallel::pointstru_bam; - } - - ps->data->pox[0] = x; - ps->data->pox[1] = y; - ps->data->pox[2] = z; - ps->data->Bgs = 0; - ps->data->Bgd = 0; - ps->data->coef = 0; - - ps->next = 0; - } - } - } - } - - gs = gs->next; - } - - gdlf->destroyList(); - - // find out blocks - ps = rsul; - while (ps) - { - double x, y, z; - x = ps->data->pox[0]; - y = ps->data->pox[1]; - z = ps->data->pox[2]; - bool flag; - // find source block - flag = true; - PL = PLf; - while (flag && PL) - { - MyList *BP = PL->data->blb; - while (flag && BP) - { - double llb[3], uub[3]; - - for (int i = 0; i < dim; i++) - { - double DH = BP->data->getdX(i); - uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; - llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; - } - - if (llb[0] - TINY < x && uub[0] + TINY > x && - llb[1] - TINY < y && uub[1] + TINY > y && - llb[2] - TINY < z && uub[2] + TINY > z) - { - ps->data->Bgs = BP->data; - flag = false; - } - - if (BP == PL->data->ble) - break; - BP = BP->next; - } - PL = PL->next; - } - if (flag) - { - cout << "error in Parallel::Constr_pointstr_Restrict 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - // find target block - flag = true; - PL = PLc; - while (flag && PL) - { - MyList *BP = PL->data->blb; - while (flag && BP) - { - double llb[3], uub[3]; - - for (int i = 0; i < dim; i++) - { - double DH = BP->data->getdX(i); - uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; - llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; - } - - if (llb[0] - TINY < x && uub[0] + TINY > x && - llb[1] - TINY < y && uub[1] + TINY > y && - llb[2] - TINY < z && uub[2] + TINY > z) - { - ps->data->Bgd = BP->data; - flag = false; - } - - if (BP == PL->data->ble) - break; - BP = BP->next; - } - PL = PL->next; - } - if (flag) - { - cout << "error in Parallel::Constr_pointstr_Restrict 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - ps = ps->next; - } -} - -void Parallel::intertransfer(MyList *&sul, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry) -{ - int myrank, cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int node; - - MPI_Request *reqs; - MPI_Status *stats; - reqs = new MPI_Request[2 * cpusize]; - stats = new MPI_Status[2 * cpusize]; - int req_no = 0; - - double **send_data, **rec_data; - send_data = new double *[cpusize]; - rec_data = new double *[cpusize]; - int length; - - for (node = 0; node < cpusize; node++) - { - send_data[node] = rec_data[node] = 0; - if (node == myrank) - { - // myrank: local; node : remote - if (length = interdata_packer(0, sul, myrank, node, PACK, VarList1, VarList2, Symmetry)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "Parallel::intertransfer: out of memory when new in short transfer, place 1" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(rec_data[node], sul, myrank, node, PACK, VarList1, VarList2, Symmetry); - } - } - else - { - // send from this cpu to cpu#node - if (length = interdata_packer(0, sul, myrank, node, PACK, VarList1, VarList2, Symmetry)) - { - send_data[node] = new double[length]; - if (!send_data[node]) - { - cout << "Parallel::intertransfer: out of memory when new in short transfer, place 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(send_data[node], sul, myrank, node, PACK, VarList1, VarList2, Symmetry); - MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - // receive from cpu#node to this cpu - if (length = interdata_packer(0, sul, myrank, node, UNPACK, VarList1, VarList2, Symmetry)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "Parallel::intertransfer: out of memory when new in short transfer, place 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - } - } - // wait for all requests to complete - MPI_Waitall(req_no, reqs, stats); - - for (node = 0; node < cpusize; node++) - if (rec_data[node]) - interdata_packer(rec_data[node], sul, myrank, node, UNPACK, VarList1, VarList2, Symmetry); - - for (node = 0; node < cpusize; node++) - { - if (send_data[node]) - delete[] send_data[node]; - if (rec_data[node]) - delete[] rec_data[node]; - } - - delete[] reqs; - delete[] stats; - delete[] send_data; - delete[] rec_data; -} -// PACK: prepare target data in 'data' -// UNPACK: copy target data from 'data' to corresponding numerical grids -int Parallel::interdata_packer(double *data, MyList *sul, int myrank, int node, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) -{ - int DIM = dim; - int ordn = 2 * ghost_width; - - if (dir != PACK && dir != UNPACK) - { - cout << "Parallel::interdata_packer: error dir " << dir << " for data_packer " << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int size_out = 0; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - while (sul) - { - if ((dir == PACK && sul->data->Bgs->rank == myrank && sul->data->Bgd->rank == node) || - (dir == UNPACK && sul->data->Bgd->rank == myrank && sul->data->Bgs->rank == node)) - { - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - if (data) - { - if (dir == PACK) - { - // f_global_interp(sul->data->Bgs->shape,sul->data->Bgs->X[0],sul->data->Bgs->X[1],sul->data->Bgs->X[2], - // sul->data->Bgs->fgfs[varls->data->sgfn],data[size_out], - // sul->data->pox[0],sul->data->pox[1],sul->data->pox[2],ordn,varls->data->SoA,Symmetry); - if (sul->data->coef == 0) - { - sul->data->coef = new double[ordn * dim]; - for (int i = 0; i < dim; i++) - { - double dd = sul->data->Bgs->getdX(i); - sul->data->sind[i] = int((sul->data->pox[i] - sul->data->Bgs->X[i][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = sul->data->Bgs->X[i][0] + (sul->data->sind[i] + j) * dd; - sul->data->coef[i * ordn + j] = 1; - for (int k = 0; k < j; k++) - { - h2 = sul->data->Bgs->X[i][0] + (sul->data->sind[i] + k) * dd; - sul->data->coef[i * ordn + j] *= (sul->data->pox[i] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = sul->data->Bgs->X[i][0] + (sul->data->sind[i] + k) * dd; - sul->data->coef[i * ordn + j] *= (sul->data->pox[i] - h2) / (h1 - h2); - } - } - } - } - int sst = -1; - f_global_interpind(sul->data->Bgs->shape, sul->data->Bgs->X[0], sul->data->Bgs->X[1], sul->data->Bgs->X[2], - sul->data->Bgs->fgfs[varls->data->sgfn], data[size_out], - sul->data->pox[0], sul->data->pox[1], sul->data->pox[2], ordn, varls->data->SoA, Symmetry, - sul->data->sind, sul->data->coef, sst); - } - if (dir == UNPACK) // from target data to corresponding grid - f_pointcopy(DIM, sul->data->Bgd->bbox, sul->data->Bgd->bbox + dim, sul->data->Bgd->shape, sul->data->Bgd->fgfs[varld->data->sgfn], - sul->data->pox[0], sul->data->pox[1], sul->data->pox[2], data[size_out]); - } - size_out += 1; - varls = varls->next; - varld = varld->next; - } - } - sul = sul->next; - } - - return size_out; -} -void Parallel::destroypsuList_bam(MyList *ct) -{ - MyList *n; - while (ct) - { - n = ct->next; - if (ct->data->coef) - delete[] ct->data->coef; - delete ct->data; - delete ct; - ct = n; - } -} + +#include "Parallel.h" +#include "fmisc.h" +#include "prolongrestrict.h" +#include "misc.h" + +void Parallel::OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + MyList *bdsul; + Constr_pointstr_OutBdLow2Hi(PLf, PLc, bdsul); + + intertransfer(bdsul, VarList1, VarList2, Symmetry); + + destroypsuList_bam(bdsul); +} +void Parallel::Restrict_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry) +{ + MyList *rsul; + Constr_pointstr_Restrict(PLf, PLc, rsul); + + intertransfer(rsul, VarList1, VarList2, Symmetry); + + destroypsuList_bam(rsul); +} +void Parallel::OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + MyList *bdsul, int Symmetry) +{ + intertransfer(bdsul, VarList1, VarList2, Symmetry); +} +void Parallel::Restrict_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + MyList *rsul, int Symmetry) +{ + intertransfer(rsul, VarList1, VarList2, Symmetry); +} +void Parallel::Constr_pointstr_OutBdLow2Hi(MyList *PLf, MyList *PLc, + MyList *&bdsul) +{ + MyList *PL; + + MyList *ps; + bdsul = 0; + + // find out points + PL = PLf; + while (PL) + { + double dx, dy, dz; + + dx = PL->data->blb->data->getdX(0); + dy = PL->data->blb->data->getdX(1); + dz = PL->data->blb->data->getdX(2); + + double uub[3], llb[3]; + + llb[0] = PL->data->bbox[0] + PL->data->lli[0] * dx; + llb[1] = PL->data->bbox[1] + PL->data->lli[1] * dy; + llb[2] = PL->data->bbox[2] + PL->data->lli[2] * dz; + uub[0] = PL->data->bbox[3] - PL->data->uui[0] * dx; + uub[1] = PL->data->bbox[4] - PL->data->uui[1] * dy; + uub[2] = PL->data->bbox[5] - PL->data->uui[2] * dz; + + double x, y, z; + + for (int i = 0; i < PL->data->shape[0]; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = PL->data->bbox[0] + i * dx; +#else +#ifdef Cell + x = PL->data->bbox[0] + (0.5 + i) * dx; +#else +#error Not define Vertex nor Cell +#endif +#endif + for (int j = 0; j < PL->data->shape[1]; j++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y = PL->data->bbox[1] + j * dy; +#else +#ifdef Cell + y = PL->data->bbox[1] + (0.5 + j) * dy; +#else +#error Not define Vertex nor Cell +#endif +#endif + for (int k = 0; k < PL->data->shape[2]; k++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + z = PL->data->bbox[2] + k * dz; +#else +#ifdef Cell + z = PL->data->bbox[2] + (0.5 + k) * dz; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (!(llb[0] - TINY < x && uub[0] + TINY > x && + llb[1] - TINY < y && uub[1] + TINY > y && + llb[2] - TINY < z && uub[2] + TINY > z)) // not in the inner part + { + if (bdsul) + { + ps->next = new MyList; + ps = ps->next; + ps->data = new Parallel::pointstru_bam; + } + else + { + bdsul = ps = new MyList; + ps->data = new Parallel::pointstru_bam; + } + + ps->data->pox[0] = x; + ps->data->pox[1] = y; + ps->data->pox[2] = z; + ps->data->Bgs = 0; + ps->data->Bgd = 0; + ps->data->coef = 0; + + ps->next = 0; + } + } + } + } + + PL = PL->next; + } + + // find out blocks + ps = bdsul; + while (ps) + { + double x, y, z; + x = ps->data->pox[0]; + y = ps->data->pox[1]; + z = ps->data->pox[2]; + bool flag; + // find target block + flag = true; + PL = PLf; + while (flag && PL) + { + MyList *BP = PL->data->blb; + while (flag && BP) + { + double llb[3], uub[3]; + + for (int i = 0; i < dim; i++) + { + double DH = BP->data->getdX(i); + uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; + llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; + } + + if (llb[0] - TINY < x && uub[0] + TINY > x && + llb[1] - TINY < y && uub[1] + TINY > y && + llb[2] - TINY < z && uub[2] + TINY > z) + { + ps->data->Bgd = BP->data; + flag = false; + } + + if (BP == PL->data->ble) + break; + BP = BP->next; + } + PL = PL->next; + } + if (flag) + { + cout << "error in Parallel::Constr_pointstr_OutBdLow2Hi 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + // find source block + flag = true; + PL = PLc; + while (flag && PL) + { + MyList *BP = PL->data->blb; + while (flag && BP) + { + double llb[3], uub[3]; + + for (int i = 0; i < dim; i++) + { + double DH = BP->data->getdX(i); + uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; + llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; + } + + if (llb[0] - TINY < x && uub[0] + TINY > x && + llb[1] - TINY < y && uub[1] + TINY > y && + llb[2] - TINY < z && uub[2] + TINY > z) + { + ps->data->Bgs = BP->data; + flag = false; + } + + if (BP == PL->data->ble) + break; + BP = BP->next; + } + PL = PL->next; + } + if (flag) + { + cout << "error in Parallel::Constr_pointstr_OutBdLow2Hi 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + ps = ps->next; + } +} +void Parallel::Constr_pointstr_Restrict(MyList *PLf, MyList *PLc, + MyList *&rsul) +{ + MyList *gdlf = 0, *gs; + MyList *PL = PLf; + while (PL) + { + if (gdlf) + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + else + { + gdlf = gs = new MyList; + gs->data = new Parallel::gridseg; + } + + gs->next = 0; + + for (int i = 0; i < dim; i++) + { + double DH = PL->data->blb->data->getdX(i); + + gs->data->llb[i] = PL->data->bbox[i] + PL->data->lli[i] * DH; + gs->data->uub[i] = PL->data->bbox[dim + i] - PL->data->uui[i] * DH; + } + + PL = PL->next; + } + + MyList *ps; + rsul = 0; + + // find out points + gs = gdlf; + while (gs) + { + PL = PLc; + bool flag = true; + while (flag) + { + if (!PL) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << "error in Parallel::Constr_pointstr_Restrict: fail to find grid segment [" << gs->data->llb[0] << ":" << gs->data->uub[0] << "," + << gs->data->llb[1] << ":" << gs->data->uub[1] << "," + << gs->data->llb[2] << ":" << gs->data->uub[2] << "]" + << endl; + PL = PLc; + while (PL) + { + PL->data->checkPatch(0); + PL = PL->next; + } + } + + misc::tillherecheck("for wait."); + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (gs->data->llb[0] > PL->data->bbox[0] - TINY && gs->data->uub[0] < PL->data->bbox[3] + TINY && + gs->data->llb[1] > PL->data->bbox[1] - TINY && gs->data->uub[1] < PL->data->bbox[4] + TINY && + gs->data->llb[2] > PL->data->bbox[2] - TINY && gs->data->uub[2] < PL->data->bbox[5] + TINY) + flag = false; + + if (flag) + PL = PL->next; + } + + double dx, dy, dz; + + dx = PL->data->blb->data->getdX(0); + dy = PL->data->blb->data->getdX(1); + dz = PL->data->blb->data->getdX(2); + + double x, y, z; + + for (int i = 0; i < PL->data->shape[0]; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = PL->data->bbox[0] + i * dx; +#else +#ifdef Cell + x = PL->data->bbox[0] + (0.5 + i) * dx; +#else +#error Not define Vertex nor Cell +#endif +#endif + for (int j = 0; j < PL->data->shape[1]; j++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y = PL->data->bbox[1] + j * dy; +#else +#ifdef Cell + y = PL->data->bbox[1] + (0.5 + j) * dy; +#else +#error Not define Vertex nor Cell +#endif +#endif + for (int k = 0; k < PL->data->shape[2]; k++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + z = PL->data->bbox[2] + k * dz; +#else +#ifdef Cell + z = PL->data->bbox[2] + (0.5 + k) * dz; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (gs->data->llb[0] - TINY < x && gs->data->uub[0] + TINY > x && + gs->data->llb[1] - TINY < y && gs->data->uub[1] + TINY > y && + gs->data->llb[2] - TINY < z && gs->data->uub[2] + TINY > z) // in the inner part + { + if (rsul) + { + ps->next = new MyList; + ps = ps->next; + ps->data = new Parallel::pointstru_bam; + } + else + { + rsul = ps = new MyList; + ps->data = new Parallel::pointstru_bam; + } + + ps->data->pox[0] = x; + ps->data->pox[1] = y; + ps->data->pox[2] = z; + ps->data->Bgs = 0; + ps->data->Bgd = 0; + ps->data->coef = 0; + + ps->next = 0; + } + } + } + } + + gs = gs->next; + } + + gdlf->destroyList(); + + // find out blocks + ps = rsul; + while (ps) + { + double x, y, z; + x = ps->data->pox[0]; + y = ps->data->pox[1]; + z = ps->data->pox[2]; + bool flag; + // find source block + flag = true; + PL = PLf; + while (flag && PL) + { + MyList *BP = PL->data->blb; + while (flag && BP) + { + double llb[3], uub[3]; + + for (int i = 0; i < dim; i++) + { + double DH = BP->data->getdX(i); + uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; + llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; + } + + if (llb[0] - TINY < x && uub[0] + TINY > x && + llb[1] - TINY < y && uub[1] + TINY > y && + llb[2] - TINY < z && uub[2] + TINY > z) + { + ps->data->Bgs = BP->data; + flag = false; + } + + if (BP == PL->data->ble) + break; + BP = BP->next; + } + PL = PL->next; + } + if (flag) + { + cout << "error in Parallel::Constr_pointstr_Restrict 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + // find target block + flag = true; + PL = PLc; + while (flag && PL) + { + MyList *BP = PL->data->blb; + while (flag && BP) + { + double llb[3], uub[3]; + + for (int i = 0; i < dim; i++) + { + double DH = BP->data->getdX(i); + uub[i] = (feq(BP->data->bbox[dim + i], PL->data->bbox[dim + i], DH / 2)) ? BP->data->bbox[dim + i] : BP->data->bbox[dim + i] - ghost_width * DH; + llb[i] = (feq(BP->data->bbox[i], PL->data->bbox[i], DH / 2)) ? BP->data->bbox[i] : BP->data->bbox[i] + ghost_width * DH; + } + + if (llb[0] - TINY < x && uub[0] + TINY > x && + llb[1] - TINY < y && uub[1] + TINY > y && + llb[2] - TINY < z && uub[2] + TINY > z) + { + ps->data->Bgd = BP->data; + flag = false; + } + + if (BP == PL->data->ble) + break; + BP = BP->next; + } + PL = PL->next; + } + if (flag) + { + cout << "error in Parallel::Constr_pointstr_Restrict 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + ps = ps->next; + } +} + +void Parallel::intertransfer(MyList *&sul, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry) +{ + int myrank, cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int node; + + MPI_Request *reqs; + MPI_Status *stats; + reqs = new MPI_Request[2 * cpusize]; + stats = new MPI_Status[2 * cpusize]; + int req_no = 0; + + double **send_data, **rec_data; + send_data = new double *[cpusize]; + rec_data = new double *[cpusize]; + int length; + + for (node = 0; node < cpusize; node++) + { + send_data[node] = rec_data[node] = 0; + if (node == myrank) + { + // myrank: local; node : remote + if (length = interdata_packer(0, sul, myrank, node, PACK, VarList1, VarList2, Symmetry)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "Parallel::intertransfer: out of memory when new in short transfer, place 1" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(rec_data[node], sul, myrank, node, PACK, VarList1, VarList2, Symmetry); + } + } + else + { + // send from this cpu to cpu#node + if (length = interdata_packer(0, sul, myrank, node, PACK, VarList1, VarList2, Symmetry)) + { + send_data[node] = new double[length]; + if (!send_data[node]) + { + cout << "Parallel::intertransfer: out of memory when new in short transfer, place 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(send_data[node], sul, myrank, node, PACK, VarList1, VarList2, Symmetry); + MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + // receive from cpu#node to this cpu + if (length = interdata_packer(0, sul, myrank, node, UNPACK, VarList1, VarList2, Symmetry)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "Parallel::intertransfer: out of memory when new in short transfer, place 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + } + } + // wait for all requests to complete + MPI_Waitall(req_no, reqs, stats); + + for (node = 0; node < cpusize; node++) + if (rec_data[node]) + interdata_packer(rec_data[node], sul, myrank, node, UNPACK, VarList1, VarList2, Symmetry); + + for (node = 0; node < cpusize; node++) + { + if (send_data[node]) + delete[] send_data[node]; + if (rec_data[node]) + delete[] rec_data[node]; + } + + delete[] reqs; + delete[] stats; + delete[] send_data; + delete[] rec_data; +} +// PACK: prepare target data in 'data' +// UNPACK: copy target data from 'data' to corresponding numerical grids +int Parallel::interdata_packer(double *data, MyList *sul, int myrank, int node, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) +{ + int DIM = dim; + int ordn = 2 * ghost_width; + + if (dir != PACK && dir != UNPACK) + { + cout << "Parallel::interdata_packer: error dir " << dir << " for data_packer " << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int size_out = 0; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + while (sul) + { + if ((dir == PACK && sul->data->Bgs->rank == myrank && sul->data->Bgd->rank == node) || + (dir == UNPACK && sul->data->Bgd->rank == myrank && sul->data->Bgs->rank == node)) + { + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + if (data) + { + if (dir == PACK) + { + // f_global_interp(sul->data->Bgs->shape,sul->data->Bgs->X[0],sul->data->Bgs->X[1],sul->data->Bgs->X[2], + // sul->data->Bgs->fgfs[varls->data->sgfn],data[size_out], + // sul->data->pox[0],sul->data->pox[1],sul->data->pox[2],ordn,varls->data->SoA,Symmetry); + if (sul->data->coef == 0) + { + sul->data->coef = new double[ordn * dim]; + for (int i = 0; i < dim; i++) + { + double dd = sul->data->Bgs->getdX(i); + sul->data->sind[i] = int((sul->data->pox[i] - sul->data->Bgs->X[i][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = sul->data->Bgs->X[i][0] + (sul->data->sind[i] + j) * dd; + sul->data->coef[i * ordn + j] = 1; + for (int k = 0; k < j; k++) + { + h2 = sul->data->Bgs->X[i][0] + (sul->data->sind[i] + k) * dd; + sul->data->coef[i * ordn + j] *= (sul->data->pox[i] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = sul->data->Bgs->X[i][0] + (sul->data->sind[i] + k) * dd; + sul->data->coef[i * ordn + j] *= (sul->data->pox[i] - h2) / (h1 - h2); + } + } + } + } + int sst = -1; + f_global_interpind(sul->data->Bgs->shape, sul->data->Bgs->X[0], sul->data->Bgs->X[1], sul->data->Bgs->X[2], + sul->data->Bgs->fgfs[varls->data->sgfn], data[size_out], + sul->data->pox[0], sul->data->pox[1], sul->data->pox[2], ordn, varls->data->SoA, Symmetry, + sul->data->sind, sul->data->coef, sst); + } + if (dir == UNPACK) // from target data to corresponding grid + f_pointcopy(DIM, sul->data->Bgd->bbox, sul->data->Bgd->bbox + dim, sul->data->Bgd->shape, sul->data->Bgd->fgfs[varld->data->sgfn], + sul->data->pox[0], sul->data->pox[1], sul->data->pox[2], data[size_out]); + } + size_out += 1; + varls = varls->next; + varld = varld->next; + } + } + sul = sul->next; + } + + return size_out; +} +void Parallel::destroypsuList_bam(MyList *ct) +{ + MyList *n; + while (ct) + { + n = ct->next; + if (ct->data->coef) + delete[] ct->data->coef; + delete ct->data; + delete ct; + ct = n; + } +} diff --git a/AMSS_NCKU_source/Parallel_bam.h b/AMSS_NCKU_source/Parallel/Parallel_bam.h similarity index 97% rename from AMSS_NCKU_source/Parallel_bam.h rename to AMSS_NCKU_source/Parallel/Parallel_bam.h index 0916b16..8d9e977 100644 --- a/AMSS_NCKU_source/Parallel_bam.h +++ b/AMSS_NCKU_source/Parallel/Parallel_bam.h @@ -1,53 +1,53 @@ - -#ifndef PARALLEL_BAM_H -#define PARALLEL_BAM_H - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "var.h" -#include "MPatch.h" -#include "Block.h" -#include "MyList.h" -#include "macrodef.h" -namespace Parallel -{ - struct pointstru_bam - { - double pox[dim]; // cordinate - Block *Bgs; // interplate from - Block *Bgd; // interplate for - double *coef; // interpolation coefficients - int sind[dim]; // interpolation starting array index - }; - void destroypsuList_bam(MyList *ct); - void OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - MyList *bdsul, int Symmetry); - void Constr_pointstr_OutBdLow2Hi(MyList *PLf, MyList *PLc, - MyList *&bdsul); - void Restrict_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - int Symmetry); - void Restrict_bam(MyList *PLc, MyList *PLf, - MyList *VarList1 /* source */, MyList *VarList2 /* target */, - MyList *rsul, int Symmetry); - void Constr_pointstr_Restrict(MyList *PLf, MyList *PLc, - MyList *&rsul); - void intertransfer(MyList *&sul, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry); - int interdata_packer(double *data, MyList *sul, int myrank, int node, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry); -} -#endif /*PARALLEL_BAM_H */ + +#ifndef PARALLEL_BAM_H +#define PARALLEL_BAM_H + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "var.h" +#include "MPatch.h" +#include "Block.h" +#include "MyList.h" +#include "macrodef.h" +namespace Parallel +{ + struct pointstru_bam + { + double pox[dim]; // cordinate + Block *Bgs; // interplate from + Block *Bgd; // interplate for + double *coef; // interpolation coefficients + int sind[dim]; // interpolation starting array index + }; + void destroypsuList_bam(MyList *ct); + void OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void OutBdLow2Hi_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + MyList *bdsul, int Symmetry); + void Constr_pointstr_OutBdLow2Hi(MyList *PLf, MyList *PLc, + MyList *&bdsul); + void Restrict_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + int Symmetry); + void Restrict_bam(MyList *PLc, MyList *PLf, + MyList *VarList1 /* source */, MyList *VarList2 /* target */, + MyList *rsul, int Symmetry); + void Constr_pointstr_Restrict(MyList *PLf, MyList *PLc, + MyList *&rsul); + void intertransfer(MyList *&sul, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry); + int interdata_packer(double *data, MyList *sul, int myrank, int node, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry); +} +#endif /*PARALLEL_BAM_H */ diff --git a/AMSS_NCKU_source/MPatch.C b/AMSS_NCKU_source/Patch/MPatch.C similarity index 96% rename from AMSS_NCKU_source/MPatch.C rename to AMSS_NCKU_source/Patch/MPatch.C index 956e9c8..482c1f2 100644 --- a/AMSS_NCKU_source/MPatch.C +++ b/AMSS_NCKU_source/Patch/MPatch.C @@ -1,1777 +1,1777 @@ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "misc.h" -#include "MPatch.h" -#include "Parallel.h" -#include "fmisc.h" -#ifdef INTERP_LB_PROFILE -#include "interp_lb_profile.h" -#endif - -namespace -{ -struct InterpBlockView -{ - Block *bp; - double llb[dim]; - double uub[dim]; -}; - -struct BlockBinIndex -{ - int bins[dim]; - double lo[dim]; - double inv[dim]; - vector views; - vector> bin_to_blocks; - bool valid; - - BlockBinIndex() : valid(false) - { - for (int i = 0; i < dim; i++) - { - bins[i] = 1; - lo[i] = 0.0; - inv[i] = 0.0; - } - } -}; - -inline int clamp_int(int v, int lo, int hi) -{ - return (v < lo) ? lo : ((v > hi) ? hi : v); -} - -inline int coord_to_bin(double x, double lo, double inv, int nb) -{ - if (nb <= 1 || inv <= 0.0) - return 0; - int b = int(floor((x - lo) * inv)); - return clamp_int(b, 0, nb - 1); -} - -inline int bin_loc(const BlockBinIndex &index, int b0, int b1, int b2) -{ - return b0 + index.bins[0] * (b1 + index.bins[1] * b2); -} - -inline bool point_in_block_view(const InterpBlockView &view, const double *pox, const double *DH) -{ - for (int i = 0; i < dim; i++) - { - if (pox[i] - view.llb[i] < -DH[i] / 2 || pox[i] - view.uub[i] > DH[i] / 2) - return false; - } - return true; -} - -void build_block_bin_index(Patch *patch, const double *DH, BlockBinIndex &index) -{ - index = BlockBinIndex(); - - MyList *Bp = patch->blb; - while (Bp) - { - Block *BP = Bp->data; - InterpBlockView view; - view.bp = BP; - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - view.llb[i] = (feq(BP->bbox[i], patch->bbox[i], DH[i] / 2)) ? BP->bbox[i] + patch->lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - view.uub[i] = (feq(BP->bbox[dim + i], patch->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - patch->uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - view.llb[i] = (feq(BP->bbox[i], patch->bbox[i], DH[i] / 2)) ? BP->bbox[i] + patch->lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; - view.uub[i] = (feq(BP->bbox[dim + i], patch->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - patch->uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - index.views.push_back(view); - if (Bp == patch->ble) - break; - Bp = Bp->next; - } - - const int nblocks = int(index.views.size()); - if (nblocks <= 0) - return; - - int bins_1d = int(ceil(pow(double(nblocks), 1.0 / 3.0))); - bins_1d = clamp_int(bins_1d, 1, 32); - for (int i = 0; i < dim; i++) - { - index.bins[i] = bins_1d; - index.lo[i] = patch->bbox[i] + patch->lli[i] * DH[i]; - const double hi = patch->bbox[dim + i] - patch->uui[i] * DH[i]; - if (hi > index.lo[i] && bins_1d > 1) - index.inv[i] = bins_1d / (hi - index.lo[i]); - else - index.inv[i] = 0.0; - } - - index.bin_to_blocks.resize(index.bins[0] * index.bins[1] * index.bins[2]); - - for (int bi = 0; bi < nblocks; bi++) - { - const InterpBlockView &view = index.views[bi]; - int bmin[dim], bmax[dim]; - for (int d = 0; d < dim; d++) - { - const double low = view.llb[d] - DH[d] / 2; - const double up = view.uub[d] + DH[d] / 2; - bmin[d] = coord_to_bin(low, index.lo[d], index.inv[d], index.bins[d]); - bmax[d] = coord_to_bin(up, index.lo[d], index.inv[d], index.bins[d]); - if (bmax[d] < bmin[d]) - { - int t = bmin[d]; - bmin[d] = bmax[d]; - bmax[d] = t; - } - } - - for (int bz = bmin[2]; bz <= bmax[2]; bz++) - for (int by = bmin[1]; by <= bmax[1]; by++) - for (int bx = bmin[0]; bx <= bmax[0]; bx++) - index.bin_to_blocks[bin_loc(index, bx, by, bz)].push_back(bi); - } - - index.valid = true; -} - -int find_block_index_for_point(const BlockBinIndex &index, const double *pox, const double *DH) -{ - if (!index.valid) - return -1; - - const int bx = coord_to_bin(pox[0], index.lo[0], index.inv[0], index.bins[0]); - const int by = coord_to_bin(pox[1], index.lo[1], index.inv[1], index.bins[1]); - const int bz = coord_to_bin(pox[2], index.lo[2], index.inv[2], index.bins[2]); - const vector &cand = index.bin_to_blocks[bin_loc(index, bx, by, bz)]; - - for (size_t ci = 0; ci < cand.size(); ci++) - { - const int bi = cand[ci]; - if (point_in_block_view(index.views[bi], pox, DH)) - return bi; - } - - // Fallback to full scan for numerical edge cases around bin boundaries. - for (size_t bi = 0; bi < index.views.size(); bi++) - if (point_in_block_view(index.views[bi], pox, DH)) - return int(bi); - - return -1; -} -} // namespace - -Patch::Patch(int DIM, int *shapei, double *bboxi, int levi, bool buflog, int Symmetry) : lev(levi) -{ - - int hbuffer_width = buffer_width; - if (lev == 0) - hbuffer_width = CS_width; // specific for shell-box coulping - - if (DIM != dim) - { - cout << "dimension is not consistent in Patch construction" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - for (int i = 0; i < dim; i++) - { - shape[i] = shapei[i]; - bbox[i] = bboxi[i]; - bbox[dim + i] = bboxi[dim + i]; - lli[i] = uui[i] = 0; - if (buflog) - { - double DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); -#else -#ifdef Cell - DH = (bbox[dim + i] - bbox[i]) / shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - uui[i] = hbuffer_width; - bbox[dim + i] = bbox[dim + i] + uui[i] * DH; - shape[i] = shape[i] + uui[i]; - } - } - - if (buflog) - { - if (DIM != 3) - { - cout << "Symmetry in Patch construction only support 3 yet but dim = " << DIM << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double tmpb, DH; - if (Symmetry > 0) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH = (bbox[5] - bbox[2]) / (shape[2] - 1); -#else -#ifdef Cell - DH = (bbox[5] - bbox[2]) / shape[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - tmpb = Mymax(0, bbox[2] - hbuffer_width * DH); - lli[2] = int((bbox[2] - tmpb) / DH + 0.4); - bbox[2] = bbox[2] - lli[2] * DH; - shape[2] = shape[2] + lli[2]; - if (lli[2] < hbuffer_width) - { - if (feq(bbox[2], 0, DH / 2)) - lli[2] = 0; - else - { - cout << "Code mistake for lli[2] = " << lli[2] << ", bbox[2] = " << bbox[2] << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - if (Symmetry > 1) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH = (bbox[3] - bbox[0]) / (shape[0] - 1); -#else -#ifdef Cell - DH = (bbox[3] - bbox[0]) / shape[0]; -#else -#error Not define Vertex nor Cell -#endif -#endif - tmpb = Mymax(0, bbox[0] - hbuffer_width * DH); - lli[0] = int((bbox[0] - tmpb) / DH + 0.4); - bbox[0] = bbox[0] - lli[0] * DH; - shape[0] = shape[0] + lli[0]; - if (lli[0] < hbuffer_width) - { - if (feq(bbox[0], 0, DH / 2)) - lli[0] = 0; - else - { - cout << "Code mistake for lli[0] = " << lli[0] << ", bbox[0] = " << bbox[0] << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH = (bbox[4] - bbox[1]) / (shape[1] - 1); -#else -#ifdef Cell - DH = (bbox[4] - bbox[1]) / shape[1]; -#else -#error Not define Vertex nor Cell -#endif -#endif - tmpb = Mymax(0, bbox[1] - hbuffer_width * DH); - lli[1] = int((bbox[1] - tmpb) / DH + 0.4); - bbox[1] = bbox[1] - lli[1] * DH; - shape[1] = shape[1] + lli[1]; - if (lli[1] < hbuffer_width) - { - if (feq(bbox[1], 0, DH / 2)) - lli[1] = 0; - else - { - cout << "Code mistake for lli[1] = " << lli[1] << ", bbox[1] = " << bbox[1] << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - else - { - for (int i = 0; i < 2; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); -#else -#ifdef Cell - DH = (bbox[dim + i] - bbox[i]) / shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - lli[i] = hbuffer_width; - bbox[i] = bbox[i] - lli[i] * DH; - shape[i] = shape[i] + lli[i]; - } - } - } - else - { - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); -#else -#ifdef Cell - DH = (bbox[dim + i] - bbox[i]) / shape[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - lli[i] = hbuffer_width; - bbox[i] = bbox[i] - lli[i] * DH; - shape[i] = shape[i] + lli[i]; - } - } - } - - blb = ble = 0; -} -Patch::~Patch() -{ -} -// buflog 1: with buffer points; 0 without -void Patch::checkPatch(bool buflog) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - if (buflog) - { - cout << " belong to level " << lev << endl; - cout << " shape: ["; - for (int i = 0; i < dim; i++) - { - cout << shape[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]"; - } - cout << " resolution: ["; - for (int i = 0; i < dim; i++) - { - cout << getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << " range:" << "("; - for (int i = 0; i < dim; i++) - { - cout << bbox[i] << ":" << bbox[dim + i]; - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - } - else - { - cout << " belong to level " << lev << endl; - cout << " shape: ["; - for (int i = 0; i < dim; i++) - { - cout << shape[i] - lli[i] - uui[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]"; - } - cout << " resolution: ["; - for (int i = 0; i < dim; i++) - { - cout << getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << " range:" << "("; - for (int i = 0; i < dim; i++) - { - cout << bbox[i] + lli[i] * getdX(i) << ":" << bbox[dim + i] - uui[i] * getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - } - } -} -void Patch::checkPatch(bool buflog, const int out_rank) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == out_rank) - { - cout << " out_rank = " << out_rank << endl; - if (buflog) - { - cout << " belong to level " << lev << endl; - cout << " shape: ["; - for (int i = 0; i < dim; i++) - { - cout << shape[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]"; - } - cout << " resolution: ["; - for (int i = 0; i < dim; i++) - { - cout << getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << " range:" << "("; - for (int i = 0; i < dim; i++) - { - cout << bbox[i] << ":" << bbox[dim + i]; - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - } - else - { - cout << " belong to level " << lev << endl; - cout << " shape: ["; - for (int i = 0; i < dim; i++) - { - cout << shape[i] - lli[i] - uui[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]"; - } - cout << " resolution: ["; - for (int i = 0; i < dim; i++) - { - cout << getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << " range:" << "("; - for (int i = 0; i < dim; i++) - { - cout << bbox[i] + lli[i] * getdX(i) << ":" << bbox[dim + i] - uui[i] * getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - } - } -} -void Patch::Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank, nprocs; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - memset(Shellf, 0, sizeof(double) * NN * num_var); - - // owner_rank[j] records which MPI rank owns point j - // All ranks traverse the same block list so they all agree on ownership - int *owner_rank; - owner_rank = new int[NN]; - for (int j = 0; j < NN; j++) - owner_rank[j] = -1; - - double DH[dim]; - for (int i = 0; i < dim; i++) - DH[i] = getdX(i); - BlockBinIndex block_index; - build_block_bin_index(this, DH, block_index); - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - for (int i = 0; i < dim; i++) - { - pox[i] = XX[i][j]; - if (myrank == 0 && (XX[i][j] < bbox[i] + lli[i] * DH[i] || XX[i][j] > bbox[dim + i] - uui[i] * DH[i])) - { - cout << "Patch::Interp_Points: point ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - else - cout << ") is out of current Patch." << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - const int block_i = find_block_index_for_point(block_index, pox, DH); - if (block_i >= 0) - { - Block *BP = block_index.views[block_i].bp; - owner_rank[j] = BP->rank; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], Shellf[j * num_var + k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); - varl = varl->next; - k++; - } - } - } - } - - // Replace MPI_Allreduce with per-owner MPI_Bcast: - // Group consecutive points by owner rank and broadcast each group. - // Since each point's data is non-zero only on the owner rank, - // Bcast from owner is equivalent to Allreduce(MPI_SUM) but much cheaper. - { - int j = 0; - while (j < NN) - { - int cur_owner = owner_rank[j]; - if (cur_owner < 0) - { - if (myrank == 0) - { - cout << "ERROR: Patch::Interp_Points fails to find point ("; - for (int d = 0; d < dim; d++) - { - cout << XX[d][j]; - if (d < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on Patch ("; - for (int d = 0; d < dim; d++) - { - cout << bbox[d] << "+" << lli[d] * DH[d]; - if (d < dim - 1) - cout << ","; - else - cout << ")--"; - } - cout << "("; - for (int d = 0; d < dim; d++) - { - cout << bbox[dim + d] << "-" << uui[d] * DH[d]; - if (d < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - j++; - continue; - } - // Find contiguous run of points with the same owner - int jstart = j; - while (j < NN && owner_rank[j] == cur_owner) - j++; - int count = (j - jstart) * num_var; - MPI_Bcast(Shellf + jstart * num_var, count, MPI_DOUBLE, cur_owner, MPI_COMM_WORLD); - } - } - - delete[] owner_rank; -} -void Patch::Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry, - int Nmin_consumer, int Nmax_consumer) -{ - // Targeted point-to-point overload: each owner sends each point only to - // the one rank that needs it for integration (consumer), reducing - // communication volume by ~nprocs times compared to the Bcast version. -#ifdef INTERP_LB_PROFILE - double t_interp_start = MPI_Wtime(); -#endif - int myrank, nprocs; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - memset(Shellf, 0, sizeof(double) * NN * num_var); - - // owner_rank[j] records which MPI rank owns point j - int *owner_rank; - owner_rank = new int[NN]; - for (int j = 0; j < NN; j++) - owner_rank[j] = -1; - - double DH[dim]; - for (int i = 0; i < dim; i++) - DH[i] = getdX(i); - BlockBinIndex block_index; - build_block_bin_index(this, DH, block_index); - - // --- Interpolation phase (identical to original) --- - for (int j = 0; j < NN; j++) - { - double pox[dim]; - for (int i = 0; i < dim; i++) - { - pox[i] = XX[i][j]; - if (myrank == 0 && (XX[i][j] < bbox[i] + lli[i] * DH[i] || XX[i][j] > bbox[dim + i] - uui[i] * DH[i])) - { - cout << "Patch::Interp_Points: point ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - else - cout << ") is out of current Patch." << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - const int block_i = find_block_index_for_point(block_index, pox, DH); - if (block_i >= 0) - { - Block *BP = block_index.views[block_i].bp; - owner_rank[j] = BP->rank; - if (myrank == BP->rank) - { - varl = VarList; - int k = 0; - while (varl) - { - f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], Shellf[j * num_var + k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); - varl = varl->next; - k++; - } - } - } - } - -#ifdef INTERP_LB_PROFILE - double t_interp_end = MPI_Wtime(); - double t_interp_local = t_interp_end - t_interp_start; -#endif - - // --- Error check for unfound points --- - for (int j = 0; j < NN; j++) - { - if (owner_rank[j] < 0 && myrank == 0) - { - cout << "ERROR: Patch::Interp_Points fails to find point ("; - for (int d = 0; d < dim; d++) - { - cout << XX[d][j]; - if (d < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on Patch ("; - for (int d = 0; d < dim; d++) - { - cout << bbox[d] << "+" << lli[d] * DH[d]; - if (d < dim - 1) - cout << ","; - else - cout << ")--"; - } - cout << "("; - for (int d = 0; d < dim; d++) - { - cout << bbox[dim + d] << "-" << uui[d] * DH[d]; - if (d < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // --- Targeted point-to-point communication phase --- - // Compute consumer_rank[j] using the same deterministic formula as surface_integral - int *consumer_rank = new int[NN]; - { - int mp = NN / nprocs; - int Lp = NN - nprocs * mp; - for (int j = 0; j < NN; j++) - { - if (j < Lp * (mp + 1)) - consumer_rank[j] = j / (mp + 1); - else - consumer_rank[j] = Lp + (j - Lp * (mp + 1)) / mp; - } - } - - // Count sends and recvs per rank - int *send_count = new int[nprocs]; - int *recv_count = new int[nprocs]; - memset(send_count, 0, sizeof(int) * nprocs); - memset(recv_count, 0, sizeof(int) * nprocs); - - for (int j = 0; j < NN; j++) - { - int own = owner_rank[j]; - int con = consumer_rank[j]; - if (own == con) - continue; // local — no communication needed - if (own == myrank) - send_count[con]++; - if (con == myrank) - recv_count[own]++; - } - - // Build send buffers: for each destination rank, pack (index, data) pairs - // Each entry: 1 int (point index j) + num_var doubles - int total_send = 0, total_recv = 0; - int *send_offset = new int[nprocs]; - int *recv_offset = new int[nprocs]; - for (int r = 0; r < nprocs; r++) - { - send_offset[r] = total_send; - total_send += send_count[r]; - recv_offset[r] = total_recv; - total_recv += recv_count[r]; - } - - // Pack send buffers: each message contains (j, data[0..num_var-1]) per point - int stride = 1 + num_var; // 1 double for index + num_var doubles for data - double *sendbuf = new double[total_send * stride]; - double *recvbuf = new double[total_recv * stride]; - - // Temporary counters for packing - int *pack_pos = new int[nprocs]; - memset(pack_pos, 0, sizeof(int) * nprocs); - - for (int j = 0; j < NN; j++) - { - int own = owner_rank[j]; - int con = consumer_rank[j]; - if (own != myrank || con == myrank) - continue; - int pos = (send_offset[con] + pack_pos[con]) * stride; - sendbuf[pos] = (double)j; // point index - for (int v = 0; v < num_var; v++) - sendbuf[pos + 1 + v] = Shellf[j * num_var + v]; - pack_pos[con]++; - } - - // Post non-blocking recvs and sends - int n_req = 0; - for (int r = 0; r < nprocs; r++) - { - if (recv_count[r] > 0) n_req++; - if (send_count[r] > 0) n_req++; - } - - MPI_Request *reqs = new MPI_Request[n_req]; - int req_idx = 0; - - for (int r = 0; r < nprocs; r++) - { - if (recv_count[r] > 0) - { - MPI_Irecv(recvbuf + recv_offset[r] * stride, - recv_count[r] * stride, MPI_DOUBLE, - r, 0, MPI_COMM_WORLD, &reqs[req_idx++]); - } - } - for (int r = 0; r < nprocs; r++) - { - if (send_count[r] > 0) - { - MPI_Isend(sendbuf + send_offset[r] * stride, - send_count[r] * stride, MPI_DOUBLE, - r, 0, MPI_COMM_WORLD, &reqs[req_idx++]); - } - } - - if (n_req > 0) - MPI_Waitall(n_req, reqs, MPI_STATUSES_IGNORE); - - // Unpack recv buffers into Shellf - for (int i = 0; i < total_recv; i++) - { - int pos = i * stride; - int j = (int)recvbuf[pos]; - for (int v = 0; v < num_var; v++) - Shellf[j * num_var + v] = recvbuf[pos + 1 + v]; - } - - delete[] reqs; - delete[] sendbuf; - delete[] recvbuf; - delete[] pack_pos; - delete[] send_offset; - delete[] recv_offset; - delete[] send_count; - delete[] recv_count; - delete[] consumer_rank; - delete[] owner_rank; - -#ifdef INTERP_LB_PROFILE - { - static bool profile_written = false; - if (!profile_written) { - double *all_times = nullptr; - if (myrank == 0) all_times = new double[nprocs]; - MPI_Gather(&t_interp_local, 1, MPI_DOUBLE, - all_times, 1, MPI_DOUBLE, 0, MPI_COMM_WORLD); - if (myrank == 0) { - int heavy[64]; - int nh = InterpLBProfile::identify_heavy_ranks( - all_times, nprocs, 2.5, heavy, 64); - InterpLBProfile::write_profile( - "interp_lb_profile.bin", nprocs, - all_times, heavy, nh, 2.5); - printf("[InterpLB] Profile written: %d heavy ranks\n", nh); - for (int i = 0; i < nh; i++) - printf(" Heavy rank %d: %.6f s\n", heavy[i], all_times[heavy[i]]); - delete[] all_times; - } - profile_written = true; - } - } -#endif -} -void Patch::Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry, MPI_Comm Comm_here) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank, lmyrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - MPI_Comm_rank(Comm_here, &lmyrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - memset(Shellf, 0, sizeof(double) * NN * num_var); - - // owner_rank[j] stores the global rank that owns point j - int *owner_rank; - owner_rank = new int[NN]; - for (int j = 0; j < NN; j++) - owner_rank[j] = -1; - - // Build global-to-local rank translation for Comm_here - MPI_Group world_group, local_group; - MPI_Comm_group(MPI_COMM_WORLD, &world_group); - MPI_Comm_group(Comm_here, &local_group); - - double DH[dim]; - for (int i = 0; i < dim; i++) - DH[i] = getdX(i); - BlockBinIndex block_index; - build_block_bin_index(this, DH, block_index); - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - for (int i = 0; i < dim; i++) - { - pox[i] = XX[i][j]; - if (lmyrank == 0 && (XX[i][j] < bbox[i] + lli[i] * DH[i] || XX[i][j] > bbox[dim + i] - uui[i] * DH[i])) - { - cout << "Patch::Interp_Points: point ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - else - cout << ") is out of current Patch." << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - const int block_i = find_block_index_for_point(block_index, pox, DH); - if (block_i >= 0) - { - Block *BP = block_index.views[block_i].bp; - owner_rank[j] = BP->rank; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], Shellf[j * num_var + k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); - varl = varl->next; - k++; - } - } - } - } - - // Collect unique global owner ranks and translate to local ranks in Comm_here - // Then broadcast each owner's points via MPI_Bcast on Comm_here - { - int j = 0; - while (j < NN) - { - int cur_owner_global = owner_rank[j]; - if (cur_owner_global < 0) - { - // Point not found — skip (error check disabled for sub-communicator levels) - j++; - continue; - } - // Translate global rank to local rank in Comm_here - int cur_owner_local; - MPI_Group_translate_ranks(world_group, 1, &cur_owner_global, local_group, &cur_owner_local); - - // Find contiguous run of points with the same owner - int jstart = j; - while (j < NN && owner_rank[j] == cur_owner_global) - j++; - int count = (j - jstart) * num_var; - MPI_Bcast(Shellf + jstart * num_var, count, MPI_DOUBLE, cur_owner_local, Comm_here); - } - } - - MPI_Group_free(&world_group); - MPI_Group_free(&local_group); - delete[] owner_rank; -} -void Patch::checkBlock() -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - MyList *BP = blb; - while (BP) - { - BP->data->checkBlock(); - if (BP == ble) - break; - BP = BP->next; - } - } -} -double Patch::getdX(int dir) -{ - if (dir < 0 || dir >= dim) - { - cout << "Patch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double h; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (shape[dir] == 1) - { - cout << "Patch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - h = (bbox[dim + dir] - bbox[dir]) / (shape[dir] - 1); -#else -#ifdef Cell - h = (bbox[dim + dir] - bbox[dir]) / shape[dir]; -#else -#error Not define Vertex nor Cell -#endif -#endif - return h; -} -bool Patch::Interp_ONE_Point(MyList *VarList, double *XX, - double *Shellf, int Symmetry) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[num_var]; - memset(shellf, 0, sizeof(double) * num_var); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - double pox[dim]; - for (int i = 0; i < dim; i++) - { - pox[i] = XX[i]; - // has excluded the buffer points - if (XX[i] < bbox[i] + lli[i] * DH[i] - DH[i] / 100 || XX[i] > bbox[dim + i] - uui[i] * DH[i] + DH[i] / 100) - { - delete[] shellf; - delete[] DH; - delete[] llb; - delete[] uub; - return false; // out of current patch, - // remember to delete the allocated arrays before return!!! - } - } - - MyList *Bp = blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (XX[i] - llb[i] < -DH[i] / 2 || XX[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { -// test old code -#if 0 -#define floorint(a) ((a) < 0 ? int(a) - 1 : int(a)) -//---> interpolation - int ixl,iyl,izl,ixu,iyu,izu; - double Delx,Dely,Delz; - - ixl = 1+floorint((pox[0]-BP->X[0][0])/DH[0]); - iyl = 1+floorint((pox[1]-BP->X[1][0])/DH[1]); - izl = 1+floorint((pox[2]-BP->X[2][0])/DH[2]); - - int nn=ordn/2; - - ixl = ixl-nn; - iyl = iyl-nn; - izl = izl-nn; - - int tmi; - tmi = (Symmetry==2)?-1:0; - if(ixl0)?-1:0; - if(izlBP->shape[0]) ixl=BP->shape[0]-ordn; - if(iyl+ordn>BP->shape[1]) iyl=BP->shape[1]-ordn; - if(izl+ordn>BP->shape[2]) izl=BP->shape[2]-ordn; -// support cell center - if(ixl>=0) Delx = ( pox[0] - BP->X[0][ixl] )/ DH[0]; - else Delx = ( pox[0] + BP->X[0][0] )/ DH[0]; - if(iyl>=0) Dely = ( pox[1] - BP->X[1][iyl] )/ DH[1]; - else Dely = ( pox[1] + BP->X[1][0] )/ DH[1]; - if(izl>=0) Delz = ( pox[2] - BP->X[2][izl] )/ DH[2]; - else Delz = ( pox[2] + BP->X[2][0] )/ DH[2]; -//change to fortran index - ixl++; - iyl++; - izl++; - ixu = ixl + ordn - 1; - iyu = iyl + ordn - 1; - izu = izl + ordn - 1; - varl=VarList; - int j=0; - while(varl) - { - f_interp_2(BP->shape,BP->fgfs[varl->data->sgfn],shellf[j],ixl,ixu,iyl,iyu,izl,izu,Delx,Dely,Delz, - ordn,varl->data->SoA,Symmetry); - varl=varl->next; - j++; - } //varl -#else - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - // shellf[j*num_var+k] = Parallel::global_interp(dim,BP->shape,BP->X,BP->fgfs[varl->data->sgfn], - // pox,ordn,varl->data->SoA,Symmetry); - f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); - varl = varl->next; - k++; - } -#endif - } - } - if (Bp == ble) - break; - Bp = Bp->next; - } - - if (notfind && myrank == 0) - { - cout << "ERROR: Patch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on Patch ("; - for (int j = 0; j < dim; j++) - { - cout << bbox[j] << "+" << lli[j] * getdX(j); - if (j < dim - 1) - cout << ","; - else - cout << ")--"; - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << bbox[dim + j] << "-" << uui[j] * getdX(j); - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } -#if 0 - checkBlock(); -#else - cout << "splited domains:" << endl; - { - MyList *Bp = blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == ble) - break; - Bp = Bp->next; - } - } -#endif - MPI_Abort(MPI_COMM_WORLD, 1); - } - - MPI_Allreduce(shellf, Shellf, num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - delete[] shellf; - delete[] DH; - delete[] llb; - delete[] uub; - - return true; -} -bool Patch::Interp_ONE_Point(MyList *VarList, double *XX, - double *Shellf, int Symmetry, MPI_Comm Comm_here) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[num_var]; - memset(shellf, 0, sizeof(double) * num_var); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - double pox[dim]; - for (int i = 0; i < dim; i++) - { - pox[i] = XX[i]; - // has excluded the buffer points - if (XX[i] < bbox[i] + lli[i] * DH[i] - DH[i] / 100 || XX[i] > bbox[dim + i] - uui[i] * DH[i] + DH[i] / 100) - { - delete[] shellf; - delete[] DH; - delete[] llb; - delete[] uub; - return false; // out of current patch, - // remember to delete the allocated arrays before return!!! - } - } - - MyList *Bp = blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (XX[i] - llb[i] < -DH[i] / 2 || XX[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { -// test old code -#if 0 -#define floorint(a) ((a) < 0 ? int(a) - 1 : int(a)) -//---> interpolation - int ixl,iyl,izl,ixu,iyu,izu; - double Delx,Dely,Delz; - - ixl = 1+floorint((pox[0]-BP->X[0][0])/DH[0]); - iyl = 1+floorint((pox[1]-BP->X[1][0])/DH[1]); - izl = 1+floorint((pox[2]-BP->X[2][0])/DH[2]); - - int nn=ordn/2; - - ixl = ixl-nn; - iyl = iyl-nn; - izl = izl-nn; - - int tmi; - tmi = (Symmetry==2)?-1:0; - if(ixl0)?-1:0; - if(izlBP->shape[0]) ixl=BP->shape[0]-ordn; - if(iyl+ordn>BP->shape[1]) iyl=BP->shape[1]-ordn; - if(izl+ordn>BP->shape[2]) izl=BP->shape[2]-ordn; -// support cell center - if(ixl>=0) Delx = ( pox[0] - BP->X[0][ixl] )/ DH[0]; - else Delx = ( pox[0] + BP->X[0][0] )/ DH[0]; - if(iyl>=0) Dely = ( pox[1] - BP->X[1][iyl] )/ DH[1]; - else Dely = ( pox[1] + BP->X[1][0] )/ DH[1]; - if(izl>=0) Delz = ( pox[2] - BP->X[2][izl] )/ DH[2]; - else Delz = ( pox[2] + BP->X[2][0] )/ DH[2]; -//change to fortran index - ixl++; - iyl++; - izl++; - ixu = ixl + ordn - 1; - iyu = iyl + ordn - 1; - izu = izl + ordn - 1; - varl=VarList; - int j=0; - while(varl) - { - f_interp_2(BP->shape,BP->fgfs[varl->data->sgfn],shellf[j],ixl,ixu,iyl,iyu,izl,izu,Delx,Dely,Delz, - ordn,varl->data->SoA,Symmetry); - varl=varl->next; - j++; - } //varl -#else - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - // shellf[j*num_var+k] = Parallel::global_interp(dim,BP->shape,BP->X,BP->fgfs[varl->data->sgfn], - // pox,ordn,varl->data->SoA,Symmetry); - f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); - varl = varl->next; - k++; - } -#endif - } - } - if (Bp == ble) - break; - Bp = Bp->next; - } - - if (notfind && myrank == 0) - { - cout << "ERROR: Patch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on Patch ("; - for (int j = 0; j < dim; j++) - { - cout << bbox[j] << "+" << lli[j] * getdX(j); - if (j < dim - 1) - cout << ","; - else - cout << ")--"; - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << bbox[dim + j] << "-" << uui[j] * getdX(j); - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } -#if 0 - checkBlock(); -#else - cout << "splited domains:" << endl; - { - MyList *Bp = blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == ble) - break; - Bp = Bp->next; - } - } -#endif - MPI_Abort(MPI_COMM_WORLD, 1); - } - - MPI_Allreduce(shellf, Shellf, num_var, MPI_DOUBLE, MPI_SUM, Comm_here); - - delete[] shellf; - delete[] DH; - delete[] llb; - delete[] uub; - - return true; -} -// find maximum of abstract value, XX store position for maximum, Shellf store maximum themselvs -void Patch::Find_Maximum(MyList *VarList, double *XX, - double *Shellf) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf, *xx; - shellf = new double[num_var]; - xx = new double[dim * num_var]; - memset(shellf, 0, sizeof(double) * num_var); - memset(xx, 0, sizeof(double) * dim * num_var); - - double *DH; - int *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - - llb = new int[dim]; - uub = new int[dim]; - - MyList *Bp = blb; - while (Bp) // run along Blocks - { - Block *BP = Bp->data; - - if (myrank == BP->rank) - { - - for (int i = 0; i < dim; i++) - { - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? lli[i] : ghost_width; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? uui[i] : ghost_width; - } - - varl = VarList; - int k = 0; - double tmp, tmpx[dim]; - while (varl) // run along variables - { - f_find_maximum(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], tmp, tmpx, llb, uub); - if (tmp > shellf[k]) - { - shellf[k] = tmp; - for (int i = 0; i < dim; i++) - xx[dim * k + i] = tmpx[i]; - } - varl = varl->next; - k++; - } - } - - if (Bp == ble) - break; - Bp = Bp->next; - } - - struct mloc - { - double val; - int rank; - }; - - mloc *IN, *OUT; - IN = new mloc[num_var]; - OUT = new mloc[num_var]; - for (int i = 0; i < num_var; i++) - { - IN[i].val = shellf[i]; - IN[i].rank = myrank; - } - - MPI_Allreduce(IN, OUT, num_var, MPI_DOUBLE_INT, MPI_MAXLOC, MPI_COMM_WORLD); - - for (int i = 0; i < num_var; i++) - { - Shellf[i] = OUT[i].val; - if (myrank != OUT[i].rank) - for (int k = 0; k < 3; k++) - xx[3 * i + k] = 0; - } - - MPI_Allreduce(xx, XX, dim * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - delete[] IN; - delete[] OUT; - delete[] shellf; - delete[] xx; - delete[] DH; - delete[] llb; - delete[] uub; -} -void Patch::Find_Maximum(MyList *VarList, double *XX, - double *Shellf, MPI_Comm Comm_here) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf, *xx; - shellf = new double[num_var]; - xx = new double[dim * num_var]; - memset(shellf, 0, sizeof(double) * num_var); - memset(xx, 0, sizeof(double) * dim * num_var); - - double *DH; - int *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - - llb = new int[dim]; - uub = new int[dim]; - - MyList *Bp = blb; - while (Bp) // run along Blocks - { - Block *BP = Bp->data; - - if (myrank == BP->rank) - { - - for (int i = 0; i < dim; i++) - { - llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? lli[i] : ghost_width; - uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? uui[i] : ghost_width; - } - - varl = VarList; - int k = 0; - double tmp, tmpx[dim]; - while (varl) // run along variables - { - f_find_maximum(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], tmp, tmpx, llb, uub); - if (tmp > shellf[k]) - { - shellf[k] = tmp; - for (int i = 0; i < dim; i++) - xx[dim * k + i] = tmpx[i]; - } - varl = varl->next; - k++; - } - } - - if (Bp == ble) - break; - Bp = Bp->next; - } - - struct mloc - { - double val; - int rank; - }; - - mloc *IN, *OUT; - IN = new mloc[num_var]; - OUT = new mloc[num_var]; - for (int i = 0; i < num_var; i++) - { - IN[i].val = shellf[i]; - IN[i].rank = myrank; - } - - MPI_Allreduce(IN, OUT, num_var, MPI_DOUBLE_INT, MPI_MAXLOC, Comm_here); - - for (int i = 0; i < num_var; i++) - { - Shellf[i] = OUT[i].val; - if (myrank != OUT[i].rank) - for (int k = 0; k < 3; k++) - xx[3 * i + k] = 0; - } - - MPI_Allreduce(xx, XX, dim * num_var, MPI_DOUBLE, MPI_SUM, Comm_here); - - delete[] IN; - delete[] OUT; - delete[] shellf; - delete[] xx; - delete[] DH; - delete[] llb; - delete[] uub; -} -// if the given point locates in the present Patch return true -// otherwise return false -bool Patch::Find_Point(double *XX) -{ - double *DH; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - - for (int i = 0; i < dim; i++) - { - // has excluded the buffer points - if (XX[i] < bbox[i] + lli[i] * DH[i] - DH[i] / 100 || XX[i] > bbox[dim + i] - uui[i] * DH[i] + DH[i] / 100) - { - delete[] DH; - return false; // out of current patch, - // remember to delete the allocated arrays before return!!! - } - } - - delete[] DH; - - return true; -} + +#include +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "misc.h" +#include "MPatch.h" +#include "Parallel.h" +#include "fmisc.h" +#ifdef INTERP_LB_PROFILE +#include "interp_lb_profile.h" +#endif + +namespace +{ +struct InterpBlockView +{ + Block *bp; + double llb[dim]; + double uub[dim]; +}; + +struct BlockBinIndex +{ + int bins[dim]; + double lo[dim]; + double inv[dim]; + vector views; + vector> bin_to_blocks; + bool valid; + + BlockBinIndex() : valid(false) + { + for (int i = 0; i < dim; i++) + { + bins[i] = 1; + lo[i] = 0.0; + inv[i] = 0.0; + } + } +}; + +inline int clamp_int(int v, int lo, int hi) +{ + return (v < lo) ? lo : ((v > hi) ? hi : v); +} + +inline int coord_to_bin(double x, double lo, double inv, int nb) +{ + if (nb <= 1 || inv <= 0.0) + return 0; + int b = int(floor((x - lo) * inv)); + return clamp_int(b, 0, nb - 1); +} + +inline int bin_loc(const BlockBinIndex &index, int b0, int b1, int b2) +{ + return b0 + index.bins[0] * (b1 + index.bins[1] * b2); +} + +inline bool point_in_block_view(const InterpBlockView &view, const double *pox, const double *DH) +{ + for (int i = 0; i < dim; i++) + { + if (pox[i] - view.llb[i] < -DH[i] / 2 || pox[i] - view.uub[i] > DH[i] / 2) + return false; + } + return true; +} + +void build_block_bin_index(Patch *patch, const double *DH, BlockBinIndex &index) +{ + index = BlockBinIndex(); + + MyList *Bp = patch->blb; + while (Bp) + { + Block *BP = Bp->data; + InterpBlockView view; + view.bp = BP; + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + view.llb[i] = (feq(BP->bbox[i], patch->bbox[i], DH[i] / 2)) ? BP->bbox[i] + patch->lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + view.uub[i] = (feq(BP->bbox[dim + i], patch->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - patch->uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + view.llb[i] = (feq(BP->bbox[i], patch->bbox[i], DH[i] / 2)) ? BP->bbox[i] + patch->lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; + view.uub[i] = (feq(BP->bbox[dim + i], patch->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - patch->uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + index.views.push_back(view); + if (Bp == patch->ble) + break; + Bp = Bp->next; + } + + const int nblocks = int(index.views.size()); + if (nblocks <= 0) + return; + + int bins_1d = int(ceil(pow(double(nblocks), 1.0 / 3.0))); + bins_1d = clamp_int(bins_1d, 1, 32); + for (int i = 0; i < dim; i++) + { + index.bins[i] = bins_1d; + index.lo[i] = patch->bbox[i] + patch->lli[i] * DH[i]; + const double hi = patch->bbox[dim + i] - patch->uui[i] * DH[i]; + if (hi > index.lo[i] && bins_1d > 1) + index.inv[i] = bins_1d / (hi - index.lo[i]); + else + index.inv[i] = 0.0; + } + + index.bin_to_blocks.resize(index.bins[0] * index.bins[1] * index.bins[2]); + + for (int bi = 0; bi < nblocks; bi++) + { + const InterpBlockView &view = index.views[bi]; + int bmin[dim], bmax[dim]; + for (int d = 0; d < dim; d++) + { + const double low = view.llb[d] - DH[d] / 2; + const double up = view.uub[d] + DH[d] / 2; + bmin[d] = coord_to_bin(low, index.lo[d], index.inv[d], index.bins[d]); + bmax[d] = coord_to_bin(up, index.lo[d], index.inv[d], index.bins[d]); + if (bmax[d] < bmin[d]) + { + int t = bmin[d]; + bmin[d] = bmax[d]; + bmax[d] = t; + } + } + + for (int bz = bmin[2]; bz <= bmax[2]; bz++) + for (int by = bmin[1]; by <= bmax[1]; by++) + for (int bx = bmin[0]; bx <= bmax[0]; bx++) + index.bin_to_blocks[bin_loc(index, bx, by, bz)].push_back(bi); + } + + index.valid = true; +} + +int find_block_index_for_point(const BlockBinIndex &index, const double *pox, const double *DH) +{ + if (!index.valid) + return -1; + + const int bx = coord_to_bin(pox[0], index.lo[0], index.inv[0], index.bins[0]); + const int by = coord_to_bin(pox[1], index.lo[1], index.inv[1], index.bins[1]); + const int bz = coord_to_bin(pox[2], index.lo[2], index.inv[2], index.bins[2]); + const vector &cand = index.bin_to_blocks[bin_loc(index, bx, by, bz)]; + + for (size_t ci = 0; ci < cand.size(); ci++) + { + const int bi = cand[ci]; + if (point_in_block_view(index.views[bi], pox, DH)) + return bi; + } + + // Fallback to full scan for numerical edge cases around bin boundaries. + for (size_t bi = 0; bi < index.views.size(); bi++) + if (point_in_block_view(index.views[bi], pox, DH)) + return int(bi); + + return -1; +} +} // namespace + +Patch::Patch(int DIM, int *shapei, double *bboxi, int levi, bool buflog, int Symmetry) : lev(levi) +{ + + int hbuffer_width = buffer_width; + if (lev == 0) + hbuffer_width = CS_width; // specific for shell-box coulping + + if (DIM != dim) + { + cout << "dimension is not consistent in Patch construction" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + for (int i = 0; i < dim; i++) + { + shape[i] = shapei[i]; + bbox[i] = bboxi[i]; + bbox[dim + i] = bboxi[dim + i]; + lli[i] = uui[i] = 0; + if (buflog) + { + double DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); +#else +#ifdef Cell + DH = (bbox[dim + i] - bbox[i]) / shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + uui[i] = hbuffer_width; + bbox[dim + i] = bbox[dim + i] + uui[i] * DH; + shape[i] = shape[i] + uui[i]; + } + } + + if (buflog) + { + if (DIM != 3) + { + cout << "Symmetry in Patch construction only support 3 yet but dim = " << DIM << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double tmpb, DH; + if (Symmetry > 0) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH = (bbox[5] - bbox[2]) / (shape[2] - 1); +#else +#ifdef Cell + DH = (bbox[5] - bbox[2]) / shape[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + tmpb = Mymax(0, bbox[2] - hbuffer_width * DH); + lli[2] = int((bbox[2] - tmpb) / DH + 0.4); + bbox[2] = bbox[2] - lli[2] * DH; + shape[2] = shape[2] + lli[2]; + if (lli[2] < hbuffer_width) + { + if (feq(bbox[2], 0, DH / 2)) + lli[2] = 0; + else + { + cout << "Code mistake for lli[2] = " << lli[2] << ", bbox[2] = " << bbox[2] << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + if (Symmetry > 1) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH = (bbox[3] - bbox[0]) / (shape[0] - 1); +#else +#ifdef Cell + DH = (bbox[3] - bbox[0]) / shape[0]; +#else +#error Not define Vertex nor Cell +#endif +#endif + tmpb = Mymax(0, bbox[0] - hbuffer_width * DH); + lli[0] = int((bbox[0] - tmpb) / DH + 0.4); + bbox[0] = bbox[0] - lli[0] * DH; + shape[0] = shape[0] + lli[0]; + if (lli[0] < hbuffer_width) + { + if (feq(bbox[0], 0, DH / 2)) + lli[0] = 0; + else + { + cout << "Code mistake for lli[0] = " << lli[0] << ", bbox[0] = " << bbox[0] << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH = (bbox[4] - bbox[1]) / (shape[1] - 1); +#else +#ifdef Cell + DH = (bbox[4] - bbox[1]) / shape[1]; +#else +#error Not define Vertex nor Cell +#endif +#endif + tmpb = Mymax(0, bbox[1] - hbuffer_width * DH); + lli[1] = int((bbox[1] - tmpb) / DH + 0.4); + bbox[1] = bbox[1] - lli[1] * DH; + shape[1] = shape[1] + lli[1]; + if (lli[1] < hbuffer_width) + { + if (feq(bbox[1], 0, DH / 2)) + lli[1] = 0; + else + { + cout << "Code mistake for lli[1] = " << lli[1] << ", bbox[1] = " << bbox[1] << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + else + { + for (int i = 0; i < 2; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); +#else +#ifdef Cell + DH = (bbox[dim + i] - bbox[i]) / shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + lli[i] = hbuffer_width; + bbox[i] = bbox[i] - lli[i] * DH; + shape[i] = shape[i] + lli[i]; + } + } + } + else + { + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); +#else +#ifdef Cell + DH = (bbox[dim + i] - bbox[i]) / shape[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + lli[i] = hbuffer_width; + bbox[i] = bbox[i] - lli[i] * DH; + shape[i] = shape[i] + lli[i]; + } + } + } + + blb = ble = 0; +} +Patch::~Patch() +{ +} +// buflog 1: with buffer points; 0 without +void Patch::checkPatch(bool buflog) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + if (buflog) + { + cout << " belong to level " << lev << endl; + cout << " shape: ["; + for (int i = 0; i < dim; i++) + { + cout << shape[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]"; + } + cout << " resolution: ["; + for (int i = 0; i < dim; i++) + { + cout << getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << " range:" << "("; + for (int i = 0; i < dim; i++) + { + cout << bbox[i] << ":" << bbox[dim + i]; + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + } + else + { + cout << " belong to level " << lev << endl; + cout << " shape: ["; + for (int i = 0; i < dim; i++) + { + cout << shape[i] - lli[i] - uui[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]"; + } + cout << " resolution: ["; + for (int i = 0; i < dim; i++) + { + cout << getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << " range:" << "("; + for (int i = 0; i < dim; i++) + { + cout << bbox[i] + lli[i] * getdX(i) << ":" << bbox[dim + i] - uui[i] * getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + } + } +} +void Patch::checkPatch(bool buflog, const int out_rank) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == out_rank) + { + cout << " out_rank = " << out_rank << endl; + if (buflog) + { + cout << " belong to level " << lev << endl; + cout << " shape: ["; + for (int i = 0; i < dim; i++) + { + cout << shape[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]"; + } + cout << " resolution: ["; + for (int i = 0; i < dim; i++) + { + cout << getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << " range:" << "("; + for (int i = 0; i < dim; i++) + { + cout << bbox[i] << ":" << bbox[dim + i]; + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + } + else + { + cout << " belong to level " << lev << endl; + cout << " shape: ["; + for (int i = 0; i < dim; i++) + { + cout << shape[i] - lli[i] - uui[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]"; + } + cout << " resolution: ["; + for (int i = 0; i < dim; i++) + { + cout << getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << " range:" << "("; + for (int i = 0; i < dim; i++) + { + cout << bbox[i] + lli[i] * getdX(i) << ":" << bbox[dim + i] - uui[i] * getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + } + } +} +void Patch::Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank, nprocs; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + memset(Shellf, 0, sizeof(double) * NN * num_var); + + // owner_rank[j] records which MPI rank owns point j + // All ranks traverse the same block list so they all agree on ownership + int *owner_rank; + owner_rank = new int[NN]; + for (int j = 0; j < NN; j++) + owner_rank[j] = -1; + + double DH[dim]; + for (int i = 0; i < dim; i++) + DH[i] = getdX(i); + BlockBinIndex block_index; + build_block_bin_index(this, DH, block_index); + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + for (int i = 0; i < dim; i++) + { + pox[i] = XX[i][j]; + if (myrank == 0 && (XX[i][j] < bbox[i] + lli[i] * DH[i] || XX[i][j] > bbox[dim + i] - uui[i] * DH[i])) + { + cout << "Patch::Interp_Points: point ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + else + cout << ") is out of current Patch." << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + const int block_i = find_block_index_for_point(block_index, pox, DH); + if (block_i >= 0) + { + Block *BP = block_index.views[block_i].bp; + owner_rank[j] = BP->rank; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], Shellf[j * num_var + k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); + varl = varl->next; + k++; + } + } + } + } + + // Replace MPI_Allreduce with per-owner MPI_Bcast: + // Group consecutive points by owner rank and broadcast each group. + // Since each point's data is non-zero only on the owner rank, + // Bcast from owner is equivalent to Allreduce(MPI_SUM) but much cheaper. + { + int j = 0; + while (j < NN) + { + int cur_owner = owner_rank[j]; + if (cur_owner < 0) + { + if (myrank == 0) + { + cout << "ERROR: Patch::Interp_Points fails to find point ("; + for (int d = 0; d < dim; d++) + { + cout << XX[d][j]; + if (d < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on Patch ("; + for (int d = 0; d < dim; d++) + { + cout << bbox[d] << "+" << lli[d] * DH[d]; + if (d < dim - 1) + cout << ","; + else + cout << ")--"; + } + cout << "("; + for (int d = 0; d < dim; d++) + { + cout << bbox[dim + d] << "-" << uui[d] * DH[d]; + if (d < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + j++; + continue; + } + // Find contiguous run of points with the same owner + int jstart = j; + while (j < NN && owner_rank[j] == cur_owner) + j++; + int count = (j - jstart) * num_var; + MPI_Bcast(Shellf + jstart * num_var, count, MPI_DOUBLE, cur_owner, MPI_COMM_WORLD); + } + } + + delete[] owner_rank; +} +void Patch::Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry, + int Nmin_consumer, int Nmax_consumer) +{ + // Targeted point-to-point overload: each owner sends each point only to + // the one rank that needs it for integration (consumer), reducing + // communication volume by ~nprocs times compared to the Bcast version. +#ifdef INTERP_LB_PROFILE + double t_interp_start = MPI_Wtime(); +#endif + int myrank, nprocs; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + memset(Shellf, 0, sizeof(double) * NN * num_var); + + // owner_rank[j] records which MPI rank owns point j + int *owner_rank; + owner_rank = new int[NN]; + for (int j = 0; j < NN; j++) + owner_rank[j] = -1; + + double DH[dim]; + for (int i = 0; i < dim; i++) + DH[i] = getdX(i); + BlockBinIndex block_index; + build_block_bin_index(this, DH, block_index); + + // --- Interpolation phase (identical to original) --- + for (int j = 0; j < NN; j++) + { + double pox[dim]; + for (int i = 0; i < dim; i++) + { + pox[i] = XX[i][j]; + if (myrank == 0 && (XX[i][j] < bbox[i] + lli[i] * DH[i] || XX[i][j] > bbox[dim + i] - uui[i] * DH[i])) + { + cout << "Patch::Interp_Points: point ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + else + cout << ") is out of current Patch." << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + const int block_i = find_block_index_for_point(block_index, pox, DH); + if (block_i >= 0) + { + Block *BP = block_index.views[block_i].bp; + owner_rank[j] = BP->rank; + if (myrank == BP->rank) + { + varl = VarList; + int k = 0; + while (varl) + { + f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], Shellf[j * num_var + k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); + varl = varl->next; + k++; + } + } + } + } + +#ifdef INTERP_LB_PROFILE + double t_interp_end = MPI_Wtime(); + double t_interp_local = t_interp_end - t_interp_start; +#endif + + // --- Error check for unfound points --- + for (int j = 0; j < NN; j++) + { + if (owner_rank[j] < 0 && myrank == 0) + { + cout << "ERROR: Patch::Interp_Points fails to find point ("; + for (int d = 0; d < dim; d++) + { + cout << XX[d][j]; + if (d < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on Patch ("; + for (int d = 0; d < dim; d++) + { + cout << bbox[d] << "+" << lli[d] * DH[d]; + if (d < dim - 1) + cout << ","; + else + cout << ")--"; + } + cout << "("; + for (int d = 0; d < dim; d++) + { + cout << bbox[dim + d] << "-" << uui[d] * DH[d]; + if (d < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // --- Targeted point-to-point communication phase --- + // Compute consumer_rank[j] using the same deterministic formula as surface_integral + int *consumer_rank = new int[NN]; + { + int mp = NN / nprocs; + int Lp = NN - nprocs * mp; + for (int j = 0; j < NN; j++) + { + if (j < Lp * (mp + 1)) + consumer_rank[j] = j / (mp + 1); + else + consumer_rank[j] = Lp + (j - Lp * (mp + 1)) / mp; + } + } + + // Count sends and recvs per rank + int *send_count = new int[nprocs]; + int *recv_count = new int[nprocs]; + memset(send_count, 0, sizeof(int) * nprocs); + memset(recv_count, 0, sizeof(int) * nprocs); + + for (int j = 0; j < NN; j++) + { + int own = owner_rank[j]; + int con = consumer_rank[j]; + if (own == con) + continue; // local — no communication needed + if (own == myrank) + send_count[con]++; + if (con == myrank) + recv_count[own]++; + } + + // Build send buffers: for each destination rank, pack (index, data) pairs + // Each entry: 1 int (point index j) + num_var doubles + int total_send = 0, total_recv = 0; + int *send_offset = new int[nprocs]; + int *recv_offset = new int[nprocs]; + for (int r = 0; r < nprocs; r++) + { + send_offset[r] = total_send; + total_send += send_count[r]; + recv_offset[r] = total_recv; + total_recv += recv_count[r]; + } + + // Pack send buffers: each message contains (j, data[0..num_var-1]) per point + int stride = 1 + num_var; // 1 double for index + num_var doubles for data + double *sendbuf = new double[total_send * stride]; + double *recvbuf = new double[total_recv * stride]; + + // Temporary counters for packing + int *pack_pos = new int[nprocs]; + memset(pack_pos, 0, sizeof(int) * nprocs); + + for (int j = 0; j < NN; j++) + { + int own = owner_rank[j]; + int con = consumer_rank[j]; + if (own != myrank || con == myrank) + continue; + int pos = (send_offset[con] + pack_pos[con]) * stride; + sendbuf[pos] = (double)j; // point index + for (int v = 0; v < num_var; v++) + sendbuf[pos + 1 + v] = Shellf[j * num_var + v]; + pack_pos[con]++; + } + + // Post non-blocking recvs and sends + int n_req = 0; + for (int r = 0; r < nprocs; r++) + { + if (recv_count[r] > 0) n_req++; + if (send_count[r] > 0) n_req++; + } + + MPI_Request *reqs = new MPI_Request[n_req]; + int req_idx = 0; + + for (int r = 0; r < nprocs; r++) + { + if (recv_count[r] > 0) + { + MPI_Irecv(recvbuf + recv_offset[r] * stride, + recv_count[r] * stride, MPI_DOUBLE, + r, 0, MPI_COMM_WORLD, &reqs[req_idx++]); + } + } + for (int r = 0; r < nprocs; r++) + { + if (send_count[r] > 0) + { + MPI_Isend(sendbuf + send_offset[r] * stride, + send_count[r] * stride, MPI_DOUBLE, + r, 0, MPI_COMM_WORLD, &reqs[req_idx++]); + } + } + + if (n_req > 0) + MPI_Waitall(n_req, reqs, MPI_STATUSES_IGNORE); + + // Unpack recv buffers into Shellf + for (int i = 0; i < total_recv; i++) + { + int pos = i * stride; + int j = (int)recvbuf[pos]; + for (int v = 0; v < num_var; v++) + Shellf[j * num_var + v] = recvbuf[pos + 1 + v]; + } + + delete[] reqs; + delete[] sendbuf; + delete[] recvbuf; + delete[] pack_pos; + delete[] send_offset; + delete[] recv_offset; + delete[] send_count; + delete[] recv_count; + delete[] consumer_rank; + delete[] owner_rank; + +#ifdef INTERP_LB_PROFILE + { + static bool profile_written = false; + if (!profile_written) { + double *all_times = nullptr; + if (myrank == 0) all_times = new double[nprocs]; + MPI_Gather(&t_interp_local, 1, MPI_DOUBLE, + all_times, 1, MPI_DOUBLE, 0, MPI_COMM_WORLD); + if (myrank == 0) { + int heavy[64]; + int nh = InterpLBProfile::identify_heavy_ranks( + all_times, nprocs, 2.5, heavy, 64); + InterpLBProfile::write_profile( + "interp_lb_profile.bin", nprocs, + all_times, heavy, nh, 2.5); + printf("[InterpLB] Profile written: %d heavy ranks\n", nh); + for (int i = 0; i < nh; i++) + printf(" Heavy rank %d: %.6f s\n", heavy[i], all_times[heavy[i]]); + delete[] all_times; + } + profile_written = true; + } + } +#endif +} +void Patch::Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry, MPI_Comm Comm_here) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank, lmyrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + MPI_Comm_rank(Comm_here, &lmyrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + memset(Shellf, 0, sizeof(double) * NN * num_var); + + // owner_rank[j] stores the global rank that owns point j + int *owner_rank; + owner_rank = new int[NN]; + for (int j = 0; j < NN; j++) + owner_rank[j] = -1; + + // Build global-to-local rank translation for Comm_here + MPI_Group world_group, local_group; + MPI_Comm_group(MPI_COMM_WORLD, &world_group); + MPI_Comm_group(Comm_here, &local_group); + + double DH[dim]; + for (int i = 0; i < dim; i++) + DH[i] = getdX(i); + BlockBinIndex block_index; + build_block_bin_index(this, DH, block_index); + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + for (int i = 0; i < dim; i++) + { + pox[i] = XX[i][j]; + if (lmyrank == 0 && (XX[i][j] < bbox[i] + lli[i] * DH[i] || XX[i][j] > bbox[dim + i] - uui[i] * DH[i])) + { + cout << "Patch::Interp_Points: point ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + else + cout << ") is out of current Patch." << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + const int block_i = find_block_index_for_point(block_index, pox, DH); + if (block_i >= 0) + { + Block *BP = block_index.views[block_i].bp; + owner_rank[j] = BP->rank; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], Shellf[j * num_var + k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); + varl = varl->next; + k++; + } + } + } + } + + // Collect unique global owner ranks and translate to local ranks in Comm_here + // Then broadcast each owner's points via MPI_Bcast on Comm_here + { + int j = 0; + while (j < NN) + { + int cur_owner_global = owner_rank[j]; + if (cur_owner_global < 0) + { + // Point not found — skip (error check disabled for sub-communicator levels) + j++; + continue; + } + // Translate global rank to local rank in Comm_here + int cur_owner_local; + MPI_Group_translate_ranks(world_group, 1, &cur_owner_global, local_group, &cur_owner_local); + + // Find contiguous run of points with the same owner + int jstart = j; + while (j < NN && owner_rank[j] == cur_owner_global) + j++; + int count = (j - jstart) * num_var; + MPI_Bcast(Shellf + jstart * num_var, count, MPI_DOUBLE, cur_owner_local, Comm_here); + } + } + + MPI_Group_free(&world_group); + MPI_Group_free(&local_group); + delete[] owner_rank; +} +void Patch::checkBlock() +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + MyList *BP = blb; + while (BP) + { + BP->data->checkBlock(); + if (BP == ble) + break; + BP = BP->next; + } + } +} +double Patch::getdX(int dir) +{ + if (dir < 0 || dir >= dim) + { + cout << "Patch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double h; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (shape[dir] == 1) + { + cout << "Patch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + h = (bbox[dim + dir] - bbox[dir]) / (shape[dir] - 1); +#else +#ifdef Cell + h = (bbox[dim + dir] - bbox[dir]) / shape[dir]; +#else +#error Not define Vertex nor Cell +#endif +#endif + return h; +} +bool Patch::Interp_ONE_Point(MyList *VarList, double *XX, + double *Shellf, int Symmetry) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[num_var]; + memset(shellf, 0, sizeof(double) * num_var); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + double pox[dim]; + for (int i = 0; i < dim; i++) + { + pox[i] = XX[i]; + // has excluded the buffer points + if (XX[i] < bbox[i] + lli[i] * DH[i] - DH[i] / 100 || XX[i] > bbox[dim + i] - uui[i] * DH[i] + DH[i] / 100) + { + delete[] shellf; + delete[] DH; + delete[] llb; + delete[] uub; + return false; // out of current patch, + // remember to delete the allocated arrays before return!!! + } + } + + MyList *Bp = blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (XX[i] - llb[i] < -DH[i] / 2 || XX[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { +// test old code +#if 0 +#define floorint(a) ((a) < 0 ? int(a) - 1 : int(a)) +//---> interpolation + int ixl,iyl,izl,ixu,iyu,izu; + double Delx,Dely,Delz; + + ixl = 1+floorint((pox[0]-BP->X[0][0])/DH[0]); + iyl = 1+floorint((pox[1]-BP->X[1][0])/DH[1]); + izl = 1+floorint((pox[2]-BP->X[2][0])/DH[2]); + + int nn=ordn/2; + + ixl = ixl-nn; + iyl = iyl-nn; + izl = izl-nn; + + int tmi; + tmi = (Symmetry==2)?-1:0; + if(ixl0)?-1:0; + if(izlBP->shape[0]) ixl=BP->shape[0]-ordn; + if(iyl+ordn>BP->shape[1]) iyl=BP->shape[1]-ordn; + if(izl+ordn>BP->shape[2]) izl=BP->shape[2]-ordn; +// support cell center + if(ixl>=0) Delx = ( pox[0] - BP->X[0][ixl] )/ DH[0]; + else Delx = ( pox[0] + BP->X[0][0] )/ DH[0]; + if(iyl>=0) Dely = ( pox[1] - BP->X[1][iyl] )/ DH[1]; + else Dely = ( pox[1] + BP->X[1][0] )/ DH[1]; + if(izl>=0) Delz = ( pox[2] - BP->X[2][izl] )/ DH[2]; + else Delz = ( pox[2] + BP->X[2][0] )/ DH[2]; +//change to fortran index + ixl++; + iyl++; + izl++; + ixu = ixl + ordn - 1; + iyu = iyl + ordn - 1; + izu = izl + ordn - 1; + varl=VarList; + int j=0; + while(varl) + { + f_interp_2(BP->shape,BP->fgfs[varl->data->sgfn],shellf[j],ixl,ixu,iyl,iyu,izl,izu,Delx,Dely,Delz, + ordn,varl->data->SoA,Symmetry); + varl=varl->next; + j++; + } //varl +#else + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + // shellf[j*num_var+k] = Parallel::global_interp(dim,BP->shape,BP->X,BP->fgfs[varl->data->sgfn], + // pox,ordn,varl->data->SoA,Symmetry); + f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); + varl = varl->next; + k++; + } +#endif + } + } + if (Bp == ble) + break; + Bp = Bp->next; + } + + if (notfind && myrank == 0) + { + cout << "ERROR: Patch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on Patch ("; + for (int j = 0; j < dim; j++) + { + cout << bbox[j] << "+" << lli[j] * getdX(j); + if (j < dim - 1) + cout << ","; + else + cout << ")--"; + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << bbox[dim + j] << "-" << uui[j] * getdX(j); + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } +#if 0 + checkBlock(); +#else + cout << "splited domains:" << endl; + { + MyList *Bp = blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == ble) + break; + Bp = Bp->next; + } + } +#endif + MPI_Abort(MPI_COMM_WORLD, 1); + } + + MPI_Allreduce(shellf, Shellf, num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + delete[] shellf; + delete[] DH; + delete[] llb; + delete[] uub; + + return true; +} +bool Patch::Interp_ONE_Point(MyList *VarList, double *XX, + double *Shellf, int Symmetry, MPI_Comm Comm_here) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[num_var]; + memset(shellf, 0, sizeof(double) * num_var); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + double pox[dim]; + for (int i = 0; i < dim; i++) + { + pox[i] = XX[i]; + // has excluded the buffer points + if (XX[i] < bbox[i] + lli[i] * DH[i] - DH[i] / 100 || XX[i] > bbox[dim + i] - uui[i] * DH[i] + DH[i] / 100) + { + delete[] shellf; + delete[] DH; + delete[] llb; + delete[] uub; + return false; // out of current patch, + // remember to delete the allocated arrays before return!!! + } + } + + MyList *Bp = blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (XX[i] - llb[i] < -DH[i] / 2 || XX[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { +// test old code +#if 0 +#define floorint(a) ((a) < 0 ? int(a) - 1 : int(a)) +//---> interpolation + int ixl,iyl,izl,ixu,iyu,izu; + double Delx,Dely,Delz; + + ixl = 1+floorint((pox[0]-BP->X[0][0])/DH[0]); + iyl = 1+floorint((pox[1]-BP->X[1][0])/DH[1]); + izl = 1+floorint((pox[2]-BP->X[2][0])/DH[2]); + + int nn=ordn/2; + + ixl = ixl-nn; + iyl = iyl-nn; + izl = izl-nn; + + int tmi; + tmi = (Symmetry==2)?-1:0; + if(ixl0)?-1:0; + if(izlBP->shape[0]) ixl=BP->shape[0]-ordn; + if(iyl+ordn>BP->shape[1]) iyl=BP->shape[1]-ordn; + if(izl+ordn>BP->shape[2]) izl=BP->shape[2]-ordn; +// support cell center + if(ixl>=0) Delx = ( pox[0] - BP->X[0][ixl] )/ DH[0]; + else Delx = ( pox[0] + BP->X[0][0] )/ DH[0]; + if(iyl>=0) Dely = ( pox[1] - BP->X[1][iyl] )/ DH[1]; + else Dely = ( pox[1] + BP->X[1][0] )/ DH[1]; + if(izl>=0) Delz = ( pox[2] - BP->X[2][izl] )/ DH[2]; + else Delz = ( pox[2] + BP->X[2][0] )/ DH[2]; +//change to fortran index + ixl++; + iyl++; + izl++; + ixu = ixl + ordn - 1; + iyu = iyl + ordn - 1; + izu = izl + ordn - 1; + varl=VarList; + int j=0; + while(varl) + { + f_interp_2(BP->shape,BP->fgfs[varl->data->sgfn],shellf[j],ixl,ixu,iyl,iyu,izl,izu,Delx,Dely,Delz, + ordn,varl->data->SoA,Symmetry); + varl=varl->next; + j++; + } //varl +#else + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + // shellf[j*num_var+k] = Parallel::global_interp(dim,BP->shape,BP->X,BP->fgfs[varl->data->sgfn], + // pox,ordn,varl->data->SoA,Symmetry); + f_global_interp(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry); + varl = varl->next; + k++; + } +#endif + } + } + if (Bp == ble) + break; + Bp = Bp->next; + } + + if (notfind && myrank == 0) + { + cout << "ERROR: Patch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on Patch ("; + for (int j = 0; j < dim; j++) + { + cout << bbox[j] << "+" << lli[j] * getdX(j); + if (j < dim - 1) + cout << ","; + else + cout << ")--"; + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << bbox[dim + j] << "-" << uui[j] * getdX(j); + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } +#if 0 + checkBlock(); +#else + cout << "splited domains:" << endl; + { + MyList *Bp = blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? BP->bbox[i] + lli[i] * DH[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] - uui[i] * DH[i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == ble) + break; + Bp = Bp->next; + } + } +#endif + MPI_Abort(MPI_COMM_WORLD, 1); + } + + MPI_Allreduce(shellf, Shellf, num_var, MPI_DOUBLE, MPI_SUM, Comm_here); + + delete[] shellf; + delete[] DH; + delete[] llb; + delete[] uub; + + return true; +} +// find maximum of abstract value, XX store position for maximum, Shellf store maximum themselvs +void Patch::Find_Maximum(MyList *VarList, double *XX, + double *Shellf) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf, *xx; + shellf = new double[num_var]; + xx = new double[dim * num_var]; + memset(shellf, 0, sizeof(double) * num_var); + memset(xx, 0, sizeof(double) * dim * num_var); + + double *DH; + int *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + + llb = new int[dim]; + uub = new int[dim]; + + MyList *Bp = blb; + while (Bp) // run along Blocks + { + Block *BP = Bp->data; + + if (myrank == BP->rank) + { + + for (int i = 0; i < dim; i++) + { + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? lli[i] : ghost_width; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? uui[i] : ghost_width; + } + + varl = VarList; + int k = 0; + double tmp, tmpx[dim]; + while (varl) // run along variables + { + f_find_maximum(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], tmp, tmpx, llb, uub); + if (tmp > shellf[k]) + { + shellf[k] = tmp; + for (int i = 0; i < dim; i++) + xx[dim * k + i] = tmpx[i]; + } + varl = varl->next; + k++; + } + } + + if (Bp == ble) + break; + Bp = Bp->next; + } + + struct mloc + { + double val; + int rank; + }; + + mloc *IN, *OUT; + IN = new mloc[num_var]; + OUT = new mloc[num_var]; + for (int i = 0; i < num_var; i++) + { + IN[i].val = shellf[i]; + IN[i].rank = myrank; + } + + MPI_Allreduce(IN, OUT, num_var, MPI_DOUBLE_INT, MPI_MAXLOC, MPI_COMM_WORLD); + + for (int i = 0; i < num_var; i++) + { + Shellf[i] = OUT[i].val; + if (myrank != OUT[i].rank) + for (int k = 0; k < 3; k++) + xx[3 * i + k] = 0; + } + + MPI_Allreduce(xx, XX, dim * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + delete[] IN; + delete[] OUT; + delete[] shellf; + delete[] xx; + delete[] DH; + delete[] llb; + delete[] uub; +} +void Patch::Find_Maximum(MyList *VarList, double *XX, + double *Shellf, MPI_Comm Comm_here) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf, *xx; + shellf = new double[num_var]; + xx = new double[dim * num_var]; + memset(shellf, 0, sizeof(double) * num_var); + memset(xx, 0, sizeof(double) * dim * num_var); + + double *DH; + int *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + + llb = new int[dim]; + uub = new int[dim]; + + MyList *Bp = blb; + while (Bp) // run along Blocks + { + Block *BP = Bp->data; + + if (myrank == BP->rank) + { + + for (int i = 0; i < dim; i++) + { + llb[i] = (feq(BP->bbox[i], bbox[i], DH[i] / 2)) ? lli[i] : ghost_width; + uub[i] = (feq(BP->bbox[dim + i], bbox[dim + i], DH[i] / 2)) ? uui[i] : ghost_width; + } + + varl = VarList; + int k = 0; + double tmp, tmpx[dim]; + while (varl) // run along variables + { + f_find_maximum(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], tmp, tmpx, llb, uub); + if (tmp > shellf[k]) + { + shellf[k] = tmp; + for (int i = 0; i < dim; i++) + xx[dim * k + i] = tmpx[i]; + } + varl = varl->next; + k++; + } + } + + if (Bp == ble) + break; + Bp = Bp->next; + } + + struct mloc + { + double val; + int rank; + }; + + mloc *IN, *OUT; + IN = new mloc[num_var]; + OUT = new mloc[num_var]; + for (int i = 0; i < num_var; i++) + { + IN[i].val = shellf[i]; + IN[i].rank = myrank; + } + + MPI_Allreduce(IN, OUT, num_var, MPI_DOUBLE_INT, MPI_MAXLOC, Comm_here); + + for (int i = 0; i < num_var; i++) + { + Shellf[i] = OUT[i].val; + if (myrank != OUT[i].rank) + for (int k = 0; k < 3; k++) + xx[3 * i + k] = 0; + } + + MPI_Allreduce(xx, XX, dim * num_var, MPI_DOUBLE, MPI_SUM, Comm_here); + + delete[] IN; + delete[] OUT; + delete[] shellf; + delete[] xx; + delete[] DH; + delete[] llb; + delete[] uub; +} +// if the given point locates in the present Patch return true +// otherwise return false +bool Patch::Find_Point(double *XX) +{ + double *DH; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + + for (int i = 0; i < dim; i++) + { + // has excluded the buffer points + if (XX[i] < bbox[i] + lli[i] * DH[i] - DH[i] / 100 || XX[i] > bbox[dim + i] - uui[i] * DH[i] + DH[i] / 100) + { + delete[] DH; + return false; // out of current patch, + // remember to delete the allocated arrays before return!!! + } + } + + delete[] DH; + + return true; +} diff --git a/AMSS_NCKU_source/MPatch.h b/AMSS_NCKU_source/Patch/MPatch.h similarity index 96% rename from AMSS_NCKU_source/MPatch.h rename to AMSS_NCKU_source/Patch/MPatch.h index b993be6..44aa6f4 100644 --- a/AMSS_NCKU_source/MPatch.h +++ b/AMSS_NCKU_source/Patch/MPatch.h @@ -1,55 +1,55 @@ - -#ifndef PATCH_H -#define PATCH_H - -#include -#include "MyList.h" -#include "Block.h" -#include "var.h" -#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width - -class Patch -{ - -public: - int lev; - int shape[dim]; - double bbox[2 * dim]; // this bbox includes buffer points - MyList *blb, *ble; - int lli[dim], uui[dim]; // denote the buffer points on each boundary - -public: - Patch() {}; - Patch(int DIM, int *shapei, double *bboxi, int levi, bool buflog, int Symmetry); - - ~Patch(); - - void checkPatch(bool buflog); - void checkPatch(bool buflog, const int out_rank); - void checkBlock(); - void Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry); - bool Interp_ONE_Point(MyList *VarList, double *XX, - double *Shellf, int Symmetry); - double getdX(int dir); - - void Find_Maximum(MyList *VarList, double *XX, - double *Shellf); - - bool Find_Point(double *XX); - - void Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry, - int Nmin_consumer, int Nmax_consumer); - void Interp_Points(MyList *VarList, - int NN, double **XX, - double *Shellf, int Symmetry, MPI_Comm Comm_here); - bool Interp_ONE_Point(MyList *VarList, double *XX, - double *Shellf, int Symmetry, MPI_Comm Comm_here); - void Find_Maximum(MyList *VarList, double *XX, - double *Shellf, MPI_Comm Comm_here); -}; - -#endif /* PATCH_H */ + +#ifndef PATCH_H +#define PATCH_H + +#include +#include "MyList.h" +#include "Block.h" +#include "var.h" +#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width + +class Patch +{ + +public: + int lev; + int shape[dim]; + double bbox[2 * dim]; // this bbox includes buffer points + MyList *blb, *ble; + int lli[dim], uui[dim]; // denote the buffer points on each boundary + +public: + Patch() {}; + Patch(int DIM, int *shapei, double *bboxi, int levi, bool buflog, int Symmetry); + + ~Patch(); + + void checkPatch(bool buflog); + void checkPatch(bool buflog, const int out_rank); + void checkBlock(); + void Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry); + bool Interp_ONE_Point(MyList *VarList, double *XX, + double *Shellf, int Symmetry); + double getdX(int dir); + + void Find_Maximum(MyList *VarList, double *XX, + double *Shellf); + + bool Find_Point(double *XX); + + void Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry, + int Nmin_consumer, int Nmax_consumer); + void Interp_Points(MyList *VarList, + int NN, double **XX, + double *Shellf, int Symmetry, MPI_Comm Comm_here); + bool Interp_ONE_Point(MyList *VarList, double *XX, + double *Shellf, int Symmetry, MPI_Comm Comm_here); + void Find_Maximum(MyList *VarList, double *XX, + double *Shellf, MPI_Comm Comm_here); +}; + +#endif /* PATCH_H */ diff --git a/AMSS_NCKU_source/adm_ricci_gamma.f90 b/AMSS_NCKU_source/Psi4/adm_ricci_gamma.f90 similarity index 98% rename from AMSS_NCKU_source/adm_ricci_gamma.f90 rename to AMSS_NCKU_source/Psi4/adm_ricci_gamma.f90 index 3d0eca9..be03234 100644 --- a/AMSS_NCKU_source/adm_ricci_gamma.f90 +++ b/AMSS_NCKU_source/Psi4/adm_ricci_gamma.f90 @@ -1,306 +1,306 @@ - -! for ADM variables - subroutine adm_ricci_gamma(ex, X, Y, Z, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz - - real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - call kind1_connection(ex, & - gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) -! invert metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call kind2_connection(ex, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - - call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z,SYM, SYM ,SYM ,Symmetry,0) - call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - call adm_riemann(ex, & - gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & - ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & - ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) - - call adm_ricci(ex, & - gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & - Rxx , Rxy , Rxz , Ryy , Ryz , Rzz) - - return - - end subroutine adm_ricci_gamma -!---------------------------------------------------------------------------- - subroutine adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,Lev,sst) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz - - real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call kind1_connection(ex, & - gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) -! invert metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - call kind2_connection(ex, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - - call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - call adm_riemann(ex, & - gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & - ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & - ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) - - call adm_ricci(ex, & - gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & - Rxx , Rxy , Rxz , Ryy , Ryz , Rzz) - - return - - end subroutine adm_ricci_gamma_ss + +! for ADM variables + subroutine adm_ricci_gamma(ex, X, Y, Z, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz + + real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + call kind1_connection(ex, & + gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) +! invert metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call kind2_connection(ex, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + + call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z,SYM, SYM ,SYM ,Symmetry,0) + call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + call adm_riemann(ex, & + gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & + ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & + ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) + + call adm_ricci(ex, & + gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & + Rxx , Rxy , Rxz , Ryy , Ryz , Rzz) + + return + + end subroutine adm_ricci_gamma +!---------------------------------------------------------------------------- + subroutine adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,Lev,sst) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz + + real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call kind1_connection(ex, & + gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) +! invert metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + call kind2_connection(ex, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + + call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + call adm_riemann(ex, & + gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & + ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & + ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) + + call adm_ricci(ex, & + gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & + Rxx , Rxy , Rxz , Ryy , Ryz , Rzz) + + return + + end subroutine adm_ricci_gamma_ss diff --git a/AMSS_NCKU_source/getnp4.f90 b/AMSS_NCKU_source/Psi4/getnp4.f90 similarity index 97% rename from AMSS_NCKU_source/getnp4.f90 rename to AMSS_NCKU_source/Psi4/getnp4.f90 index 03a394e..e094739 100644 --- a/AMSS_NCKU_source/getnp4.f90 +++ b/AMSS_NCKU_source/Psi4/getnp4.f90 @@ -1,1345 +1,1345 @@ - - -#include "macrodef.fh" - -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! -!----------------------------------------------------------------------------- - - subroutine getnp4(ex, X, Y, Z, & - chi, trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4, & - symmetry) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz -! physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz - real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz - - real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: dX, dY, dZ - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - -#if (ABV == 1) - call bssn2adm(ex,chipn1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) - adm_dxx = adm_dxx - ONE - adm_dyy = adm_dyy - ONE - adm_dzz = adm_dzz - ONE - call adm_ricci_gamma(ex, X, Y, Z, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz,& - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) -#endif - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -#if (tetradtype == 0) - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - - call fderivs(ex,Axx,Axxx,Axxy,Axxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Axy,Axyx,Axyy,Axyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Axz,Axzx,Axzy,Axzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,Ayy,Ayyx,Ayyy,Ayyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Ayz,Ayzx,Ayzy,Ayzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,Azz,Azzx,Azzy,Azzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,0) - call fderivs(ex,trK,fx,fy,fz,X,Y,Z,SYM,SYM,SYM,symmetry,0) -! compute D_k K_ij up to chi^-1 - Axxx = Axxx - (Gamxxx*Axx + Gamyxx*Axy + Gamzxx*Axz)*TWO - chix/chipn1*Axx + F1o3*gxx*fx - Axxy = Axxy - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz)*TWO - chiy/chipn1*Axx + F1o3*gxx*fy - Axxz = Axxz - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz)*TWO - chiz/chipn1*Axx + F1o3*gxx*fz - Ayyx = Ayyx - (Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz)*TWO - chix/chipn1*Ayy + F1o3*gyy*fx - Ayyy = Ayyy - (Gamxyy*Axy + Gamyyy*Ayy + Gamzyy*Ayz)*TWO - chiy/chipn1*Ayy + F1o3*gyy*fy - Ayyz = Ayyz - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz)*TWO - chiz/chipn1*Ayy + F1o3*gyy*fz - Azzx = Azzx - (Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz)*TWO - chix/chipn1*Azz + F1o3*gzz*fx - Azzy = Azzy - (Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz)*TWO - chiy/chipn1*Azz + F1o3*gzz*fy - Azzz = Azzz - (Gamxzz*Axz + Gamyzz*Ayz + Gamzzz*Azz)*TWO - chiz/chipn1*Azz + F1o3*gzz*fz - Axyx = Axyx - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz + & - Gamxxx*Axy + Gamyxx*Ayy + Gamzxx*Ayz) - chix/chipn1*Axy + F1o3*gxy*fx - Axyy = Axyy - (Gamxyy*Axx + Gamyyy*Axy + Gamzyy*Axz + & - Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz) - chiy/chipn1*Axy + F1o3*gxy*fy - Axyz = Axyz - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & - Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz) - chiz/chipn1*Axy + F1o3*gxy*fz - Axzx = Axzx - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz + & - Gamxxx*Axz + Gamyxx*Ayz + Gamzxx*Azz) - chix/chipn1*Axz + F1o3*gxz*fx - Axzy = Axzy - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & - Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chiy/chipn1*Axz + F1o3*gxz*fy - Axzz = Axzz - (Gamxzz*Axx + Gamyzz*Axy + Gamzzz*Axz + & - Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz) - chiz/chipn1*Axz + F1o3*gxz*fz - Ayzx = Ayzx - (Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz + & - Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chix/chipn1*Ayz + F1o3*gyz*fx - Ayzy = Ayzy - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz + & - Gamxyy*Axz + Gamyyy*Ayz + Gamzyy*Azz) - chiy/chipn1*Ayz + F1o3*gyz*fy - Ayzz = Ayzz - (Gamxzz*Axy + Gamyzz*Ayy + Gamzzz*Ayz + & - Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz) - chiz/chipn1*Ayz + F1o3*gyz*fz -! symmetrize B_ij = v^k (D_k K_ij -D_j K_ik) - Bxx =(vy*(Axxy - Axyx) + vz*(Axxz - Axzx))*f - Byy =(vx*(Ayyx - Axyy) + vz*(Ayyz - Ayzy))*f - Bzz =(vx*(Azzx - Axzz) + vy*(Azzy - Ayzz))*f - Bxy =(vx*(Axyx - (Axxy+Axyx)/TWO) + vy*(Axyy-Ayyx)/TWO + vz*(Axyz - (Axzy+Ayzx)/TWO))*f - Bxz =(vx*(Axzx - (Axxz+Axzx)/TWO) + vy*(Axzy - (Axyz+Ayzx)/TWO) + vz*(Axzz-Azzx)/TWO)*f - Byz =(vx*(Ayzx - (Axyz+Axzy)/TWO) + vy*(Ayzy - (Ayyz+Ayzy)/TWO) + vz*(Ayzz-Azzy)/TWO)*f -! E_ij = R_ij - K_ik * K^k_j + K * K_ij - -! K_ij up to chi^-1 - Axxx = Axx + F1o3*trK*gxx - Axyx = Axy + F1o3*trK*gxy - Axzx = Axz + F1o3*trK*gxz - Ayyx = Ayy + F1o3*trK*gyy - Ayzx = Ayz + F1o3*trK*gyz - Azzx = Azz + F1o3*trK*gzz -! gup and A_ijk cancel a chi^-1 - Exx = gupxx * Axxx * Axxx + gupyy * Axyx * Axyx + gupzz * Axzx * Axzx + & - TWO * (gupxy * Axxx * Axyx + gupxz * Axxx * Axzx + gupyz * Axyx * Axzx) - Eyy = gupxx * Axyx * Axyx + gupyy * Ayyx * Ayyx + gupzz * Ayzx * Ayzx + & - TWO * (gupxy * Axyx * Ayyx + gupxz * Axyx * Ayzx + gupyz * Ayyx * Ayzx) - Ezz = gupxx * Axzx * Axzx + gupyy * Ayzx * Ayzx + gupzz * Azzx * Azzx + & - TWO * (gupxy * Axzx * Ayzx + gupxz * Axzx * Azzx + gupyz * Ayzx * Azzx) - Exy = gupxx * Axxx * Axyx + gupyy * Axyx * Ayyx + gupzz * Axzx * Ayzx + & - gupxy *(Axxx * Ayyx + Axyx * Axyx) + & - gupxz *(Axxx * Ayzx + Axzx * Axyx) + & - gupyz *(Axyx * Ayzx + Axzx * Ayyx) - Exz = gupxx * Axxx * Axzx + gupyy * Axyx * Ayzx + gupzz * Axzx * Azzx + & - gupxy *(Axxx * Ayzx + Axyx * Axzx) + & - gupxz *(Axxx * Azzx + Axzx * Axzx) + & - gupyz *(Axyx * Azzx + Axzx * Ayzx) - Eyz = gupxx * Axyx * Axzx + gupyy * Ayyx * Ayzx + gupzz * Ayzx * Azzx + & - gupxy *(Axyx * Ayzx + Ayyx * Axzx) + & - gupxz *(Axyx * Azzx + Ayzx * Axzx) + & - gupyz *(Ayyx * Azzx + Ayzx * Ayzx) - - Exx = Rxx - (Exx - Axxx*trK)*f - Bxx - Exy = Rxy - (Exy - Axyx*trK)*f - Bxy - Exz = Rxz - (Exz - Axzx*trK)*f - Bxz - Eyy = Ryy - (Eyy - Ayyx*trK)*f - Byy - Eyz = Ryz - (Eyz - Ayzx*trK)*f - Byz - Ezz = Rzz - (Ezz - Azzx*trK)*f - Bzz -!set m = (u - iw)/sqrt(2) following Frans, PRD 75, 124018(2007) -! compute uuww^ij = u^i * u^j - w^i * w^j - uuwwxx = ux * ux - wx * wx - uuwwxy = ux * uy - wx * wy - uuwwxz = ux * uz - wx * wz - uuwwyy = uy * uy - wy * wy - uuwwyz = uy * uz - wy * wz - uuwwzz = uz * uz - wz * wz - -! compute uw^ij = u^i * w^j + w^i * u^j - uwxx = ux * wx + wx * ux - uwxy = ux * wy + wx * uy - uwxz = ux * wz + wx * uz - uwyy = uy * wy + wy * uy - uwyz = uy * wz + wy * uz - uwzz = uz * wz + wz * uz -!the real part of Psi4 - Rpsi4 = Exx * uuwwxx + Eyy * uuwwyy + Ezz * uuwwzz & - + (Exy * uuwwxy + Exz * uuwwxz + Eyz * uuwwyz) * TWO - -!the imaginary part of Psi4 - Ipsi4 = Exx * uwxx + Eyy * uwyy + Ezz * uwzz & - + (Exy * uwxy + Exz * uwxz + Eyz * uwyz) * TWO - -!multiply with -1/2 - Rpsi4 = - Rpsi4/TWO - Ipsi4 = - Ipsi4/TWO - - return - - end subroutine getnp4 -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables for shell -! -!----------------------------------------------------------------------------- - - subroutine getnp4_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4, & - symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz -! physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz - real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz - - real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - -#if (ABV == 1) - call bssn2adm(ex,chipn1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & - Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) - adm_dxx = adm_dxx - ONE - adm_dyy = adm_dyy - ONE - adm_dzz = adm_dzz - ONE - call adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz,& - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,0,sst) -#endif - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -#if (tetradtype == 0) - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - - call fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,trK,fx,fy,fz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -! compute D_k K_ij up to chi^-1 - Axxx = Axxx - (Gamxxx*Axx + Gamyxx*Axy + Gamzxx*Axz)*TWO - chix/chipn1*Axx + F1o3*gxx*fx - Axxy = Axxy - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz)*TWO - chiy/chipn1*Axx + F1o3*gxx*fy - Axxz = Axxz - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz)*TWO - chiz/chipn1*Axx + F1o3*gxx*fz - Ayyx = Ayyx - (Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz)*TWO - chix/chipn1*Ayy + F1o3*gyy*fx - Ayyy = Ayyy - (Gamxyy*Axy + Gamyyy*Ayy + Gamzyy*Ayz)*TWO - chiy/chipn1*Ayy + F1o3*gyy*fy - Ayyz = Ayyz - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz)*TWO - chiz/chipn1*Ayy + F1o3*gyy*fz - Azzx = Azzx - (Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz)*TWO - chix/chipn1*Azz + F1o3*gzz*fx - Azzy = Azzy - (Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz)*TWO - chiy/chipn1*Azz + F1o3*gzz*fy - Azzz = Azzz - (Gamxzz*Axz + Gamyzz*Ayz + Gamzzz*Azz)*TWO - chiz/chipn1*Azz + F1o3*gzz*fz - Axyx = Axyx - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz + & - Gamxxx*Axy + Gamyxx*Ayy + Gamzxx*Ayz) - chix/chipn1*Axy + F1o3*gxy*fx - Axyy = Axyy - (Gamxyy*Axx + Gamyyy*Axy + Gamzyy*Axz + & - Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz) - chiy/chipn1*Axy + F1o3*gxy*fy - Axyz = Axyz - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & - Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz) - chiz/chipn1*Axy + F1o3*gxy*fz - Axzx = Axzx - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz + & - Gamxxx*Axz + Gamyxx*Ayz + Gamzxx*Azz) - chix/chipn1*Axz + F1o3*gxz*fx - Axzy = Axzy - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & - Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chiy/chipn1*Axz + F1o3*gxz*fy - Axzz = Axzz - (Gamxzz*Axx + Gamyzz*Axy + Gamzzz*Axz + & - Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz) - chiz/chipn1*Axz + F1o3*gxz*fz - Ayzx = Ayzx - (Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz + & - Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chix/chipn1*Ayz + F1o3*gyz*fx - Ayzy = Ayzy - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz + & - Gamxyy*Axz + Gamyyy*Ayz + Gamzyy*Azz) - chiy/chipn1*Ayz + F1o3*gyz*fy - Ayzz = Ayzz - (Gamxzz*Axy + Gamyzz*Ayy + Gamzzz*Ayz + & - Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz) - chiz/chipn1*Ayz + F1o3*gyz*fz -! symmetrize B_ij = v^k (D_k K_ij -D_j K_ik) - Bxx =(vy*(Axxy - Axyx) + vz*(Axxz - Axzx))*f - Byy =(vx*(Ayyx - Axyy) + vz*(Ayyz - Ayzy))*f - Bzz =(vx*(Azzx - Axzz) + vy*(Azzy - Ayzz))*f - Bxy =(vx*(Axyx - (Axxy+Axyx)/TWO) + vy*(Axyy-Ayyx)/TWO + vz*(Axyz - (Axzy+Ayzx)/TWO))*f - Bxz =(vx*(Axzx - (Axxz+Axzx)/TWO) + vy*(Axzy - (Axyz+Ayzx)/TWO) + vz*(Axzz-Azzx)/TWO)*f - Byz =(vx*(Ayzx - (Axyz+Axzy)/TWO) + vy*(Ayzy - (Ayyz+Ayzy)/TWO) + vz*(Ayzz-Azzy)/TWO)*f -! E_ij = R_ij - K_ik * K^k_j + K * K_ij - -! K_ij up to chi^-1 - Axxx = Axx + F1o3*trK*gxx - Axyx = Axy + F1o3*trK*gxy - Axzx = Axz + F1o3*trK*gxz - Ayyx = Ayy + F1o3*trK*gyy - Ayzx = Ayz + F1o3*trK*gyz - Azzx = Azz + F1o3*trK*gzz -! gup and A_ijk cancel a chi^-1 - Exx = gupxx * Axxx * Axxx + gupyy * Axyx * Axyx + gupzz * Axzx * Axzx + & - TWO * (gupxy * Axxx * Axyx + gupxz * Axxx * Axzx + gupyz * Axyx * Axzx) - Eyy = gupxx * Axyx * Axyx + gupyy * Ayyx * Ayyx + gupzz * Ayzx * Ayzx + & - TWO * (gupxy * Axyx * Ayyx + gupxz * Axyx * Ayzx + gupyz * Ayyx * Ayzx) - Ezz = gupxx * Axzx * Axzx + gupyy * Ayzx * Ayzx + gupzz * Azzx * Azzx + & - TWO * (gupxy * Axzx * Ayzx + gupxz * Axzx * Azzx + gupyz * Ayzx * Azzx) - Exy = gupxx * Axxx * Axyx + gupyy * Axyx * Ayyx + gupzz * Axzx * Ayzx + & - gupxy *(Axxx * Ayyx + Axyx * Axyx) + & - gupxz *(Axxx * Ayzx + Axzx * Axyx) + & - gupyz *(Axyx * Ayzx + Axzx * Ayyx) - Exz = gupxx * Axxx * Axzx + gupyy * Axyx * Ayzx + gupzz * Axzx * Azzx + & - gupxy *(Axxx * Ayzx + Axyx * Axzx) + & - gupxz *(Axxx * Azzx + Axzx * Axzx) + & - gupyz *(Axyx * Azzx + Axzx * Ayzx) - Eyz = gupxx * Axyx * Axzx + gupyy * Ayyx * Ayzx + gupzz * Ayzx * Azzx + & - gupxy *(Axyx * Ayzx + Ayyx * Axzx) + & - gupxz *(Axyx * Azzx + Ayzx * Axzx) + & - gupyz *(Ayyx * Azzx + Ayzx * Ayzx) - - Exx = Rxx - (Exx - Axxx*trK)*f - Bxx - Exy = Rxy - (Exy - Axyx*trK)*f - Bxy - Exz = Rxz - (Exz - Axzx*trK)*f - Bxz - Eyy = Ryy - (Eyy - Ayyx*trK)*f - Byy - Eyz = Ryz - (Eyz - Ayzx*trK)*f - Byz - Ezz = Rzz - (Ezz - Azzx*trK)*f - Bzz -!set m = (u - iw)/sqrt(2) following Frans, PRD 75, 124018(2007) -! compute uuww^ij = u^i * u^j - w^i * w^j - uuwwxx = ux * ux - wx * wx - uuwwxy = ux * uy - wx * wy - uuwwxz = ux * uz - wx * wz - uuwwyy = uy * uy - wy * wy - uuwwyz = uy * uz - wy * wz - uuwwzz = uz * uz - wz * wz - -! compute uw^ij = u^i * w^j + w^i * u^j - uwxx = ux * wx + wx * ux - uwxy = ux * wy + wx * uy - uwxz = ux * wz + wx * uz - uwyy = uy * wy + wy * uy - uwyz = uy * wz + wy * uz - uwzz = uz * wz + wz * uz -!the real part of Psi4 - Rpsi4 = Exx * uuwwxx + Eyy * uuwwyy + Ezz * uuwwzz & - + (Exy * uuwwxy + Exz * uuwwxz + Eyz * uuwwyz) * TWO - -!the imaginary part of Psi4 - Ipsi4 = Exx * uwxx + Eyy * uwyy + Ezz * uwzz & - + (Exy * uwxy + Exz * uwxz + Eyz * uwyz) * TWO - -!multiply with -1/2 - Rpsi4 = - Rpsi4/TWO - Ipsi4 = - Ipsi4/TWO - - return - - end subroutine getnp4_ss -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! for single point -!----------------------------------------------------------------------------- - - subroutine getnp4_point(X, Y, Z, & - chi, trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - chix,chiy,chiz, & - trKx,trKy,trKz, & - Axxx,Axxy,Axxz, & - Axyx,Axyy,Axyz, & - Axzx,Axzy,Axzz, & - Ayyx,Ayyy,Ayyz, & - Ayzx,Ayzy,Ayzz, & - Azzx,Azzy,Azzz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4) - - implicit none - -!~~~~~~> Input parameters: - - real*8, intent(in ) :: X,Y,Z - real*8,intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8,intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8,intent(in ) :: chi,trK - real*8,intent(in ) :: chix,chiy,chiz - real*8,intent(in ) :: trKx,trKy,trKz -! covariant derivatives when out - real*8,intent(inout) :: Axxx,Axxy,Axxz - real*8,intent(inout) :: Axyx,Axyy,Axyz - real*8,intent(inout) :: Axzx,Axzy,Axzz - real*8,intent(inout) :: Ayyx,Ayyy,Ayyz - real*8,intent(inout) :: Ayzx,Ayzy,Ayzz - real*8,intent(inout) :: Azzx,Azzy,Azzz -! physical second kind of connection - real*8,intent(in) :: Gamxxx, Gamxxy, Gamxxz - real*8,intent(in) :: Gamxyy, Gamxyz, Gamxzz - real*8,intent(in) :: Gamyxx, Gamyxy, Gamyxz - real*8,intent(in) :: Gamyyy, Gamyyz, Gamyzz - real*8,intent(in) :: Gamzxx, Gamzxy, Gamzxz - real*8,intent(in) :: Gamzyy, Gamzyz, Gamzzz -! physical Ricci tensor - real*8,intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, intent(out):: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8 :: f,fx,fy,fz - real*8 :: gxx,gyy,gzz,chipn1 - real*8 :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8 :: Exx,Exy,Exz,Eyy,Eyz,Ezz - real*8 :: Bxx,Bxy,Bxz,Byy,Byz,Bzz - real*8 :: gupxx,gupxy,gupxz - real*8 :: gupyy,gupyz,gupzz - real*8 :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz - real*8 :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8,parameter::TINYRR=1.d-14 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -! v:r; u: phi; w: theta -#if (tetradtype == 0) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - -! compute D_k K_ij up to chi^-1 - Axxx = Axxx - (Gamxxx*Axx + Gamyxx*Axy + Gamzxx*Axz)*TWO - chix/chipn1*Axx + F1o3*gxx*trKx - Axxy = Axxy - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz)*TWO - chiy/chipn1*Axx + F1o3*gxx*trKy - Axxz = Axxz - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz)*TWO - chiz/chipn1*Axx + F1o3*gxx*trKz - Ayyx = Ayyx - (Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz)*TWO - chix/chipn1*Ayy + F1o3*gyy*trKx - Ayyy = Ayyy - (Gamxyy*Axy + Gamyyy*Ayy + Gamzyy*Ayz)*TWO - chiy/chipn1*Ayy + F1o3*gyy*trKy - Ayyz = Ayyz - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz)*TWO - chiz/chipn1*Ayy + F1o3*gyy*trKz - Azzx = Azzx - (Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz)*TWO - chix/chipn1*Azz + F1o3*gzz*trKx - Azzy = Azzy - (Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz)*TWO - chiy/chipn1*Azz + F1o3*gzz*trKy - Azzz = Azzz - (Gamxzz*Axz + Gamyzz*Ayz + Gamzzz*Azz)*TWO - chiz/chipn1*Azz + F1o3*gzz*trKz - Axyx = Axyx - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz + & - Gamxxx*Axy + Gamyxx*Ayy + Gamzxx*Ayz) - chix/chipn1*Axy + F1o3*gxy*trKx - Axyy = Axyy - (Gamxyy*Axx + Gamyyy*Axy + Gamzyy*Axz + & - Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz) - chiy/chipn1*Axy + F1o3*gxy*trKy - Axyz = Axyz - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & - Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz) - chiz/chipn1*Axy + F1o3*gxy*trKz - Axzx = Axzx - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz + & - Gamxxx*Axz + Gamyxx*Ayz + Gamzxx*Azz) - chix/chipn1*Axz + F1o3*gxz*trKx - Axzy = Axzy - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & - Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chiy/chipn1*Axz + F1o3*gxz*trKy - Axzz = Axzz - (Gamxzz*Axx + Gamyzz*Axy + Gamzzz*Axz + & - Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz) - chiz/chipn1*Axz + F1o3*gxz*trKz - Ayzx = Ayzx - (Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz + & - Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chix/chipn1*Ayz + F1o3*gyz*trKx - Ayzy = Ayzy - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz + & - Gamxyy*Axz + Gamyyy*Ayz + Gamzyy*Azz) - chiy/chipn1*Ayz + F1o3*gyz*trKy - Ayzz = Ayzz - (Gamxzz*Axy + Gamyzz*Ayy + Gamzzz*Ayz + & - Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz) - chiz/chipn1*Ayz + F1o3*gyz*trKz -! symmetrize B_ij = v^k (D_k K_ij -D_j K_ik) - Bxx =(vy*(Axxy - Axyx) + vz*(Axxz - Axzx))*f - Byy =(vx*(Ayyx - Axyy) + vz*(Ayyz - Ayzy))*f - Bzz =(vx*(Azzx - Axzz) + vy*(Azzy - Ayzz))*f - Bxy =(vx*(Axyx - (Axxy+Axyx)/TWO) + vy*(Axyy-Ayyx)/TWO + vz*(Axyz - (Axzy+Ayzx)/TWO))*f - Bxz =(vx*(Axzx - (Axxz+Axzx)/TWO) + vy*(Axzy - (Axyz+Ayzx)/TWO) + vz*(Axzz-Azzx)/TWO)*f - Byz =(vx*(Ayzx - (Axyz+Axzy)/TWO) + vy*(Ayzy - (Ayyz+Ayzy)/TWO) + vz*(Ayzz-Azzy)/TWO)*f -! E_ij = R_ij - K_ik * K^k_j + K * K_ij - -! K_ij up to chi^-1 - Axxx = Axx + F1o3*trK*gxx - Axyx = Axy + F1o3*trK*gxy - Axzx = Axz + F1o3*trK*gxz - Ayyx = Ayy + F1o3*trK*gyy - Ayzx = Ayz + F1o3*trK*gyz - Azzx = Azz + F1o3*trK*gzz -! gup and A_ijk cancel a chi^-1 - Exx = gupxx * Axxx * Axxx + gupyy * Axyx * Axyx + gupzz * Axzx * Axzx + & - TWO * (gupxy * Axxx * Axyx + gupxz * Axxx * Axzx + gupyz * Axyx * Axzx) - Eyy = gupxx * Axyx * Axyx + gupyy * Ayyx * Ayyx + gupzz * Ayzx * Ayzx + & - TWO * (gupxy * Axyx * Ayyx + gupxz * Axyx * Ayzx + gupyz * Ayyx * Ayzx) - Ezz = gupxx * Axzx * Axzx + gupyy * Ayzx * Ayzx + gupzz * Azzx * Azzx + & - TWO * (gupxy * Axzx * Ayzx + gupxz * Axzx * Azzx + gupyz * Ayzx * Azzx) - Exy = gupxx * Axxx * Axyx + gupyy * Axyx * Ayyx + gupzz * Axzx * Ayzx + & - gupxy *(Axxx * Ayyx + Axyx * Axyx) + & - gupxz *(Axxx * Ayzx + Axzx * Axyx) + & - gupyz *(Axyx * Ayzx + Axzx * Ayyx) - Exz = gupxx * Axxx * Axzx + gupyy * Axyx * Ayzx + gupzz * Axzx * Azzx + & - gupxy *(Axxx * Ayzx + Axyx * Axzx) + & - gupxz *(Axxx * Azzx + Axzx * Axzx) + & - gupyz *(Axyx * Azzx + Axzx * Ayzx) - Eyz = gupxx * Axyx * Axzx + gupyy * Ayyx * Ayzx + gupzz * Ayzx * Azzx + & - gupxy *(Axyx * Ayzx + Ayyx * Axzx) + & - gupxz *(Axyx * Azzx + Ayzx * Axzx) + & - gupyz *(Ayyx * Azzx + Ayzx * Ayzx) - - Exx = Rxx - (Exx - Axxx*trK)*f - Bxx - Exy = Rxy - (Exy - Axyx*trK)*f - Bxy - Exz = Rxz - (Exz - Axzx*trK)*f - Bxz - Eyy = Ryy - (Eyy - Ayyx*trK)*f - Byy - Eyz = Ryz - (Eyz - Ayzx*trK)*f - Byz - Ezz = Rzz - (Ezz - Azzx*trK)*f - Bzz -!set m = (u - iw)/sqrt(2) following Frans, PRD 75, 124018(2007) -! compute uuww^ij = u^i * u^j - w^i * w^j - uuwwxx = ux * ux - wx * wx - uuwwxy = ux * uy - wx * wy - uuwwxz = ux * uz - wx * wz - uuwwyy = uy * uy - wy * wy - uuwwyz = uy * uz - wy * wz - uuwwzz = uz * uz - wz * wz - -! compute uw^ij = u^i * w^j + w^i * u^j - uwxx = ux * wx + wx * ux - uwxy = ux * wy + wx * uy - uwxz = ux * wz + wx * uz - uwyy = uy * wy + wy * uy - uwyz = uy * wz + wy * uz - uwzz = uz * wz + wz * uz -!the real part of Psi4 - Rpsi4 = Exx * uuwwxx + Eyy * uuwwyy + Ezz * uuwwzz & - + (Exy * uuwwxy + Exz * uuwwxz + Eyz * uuwwyz) * TWO - -!the imaginary part of Psi4 - Ipsi4 = Exx * uwxx + Eyy * uwyy + Ezz * uwzz & - + (Exy * uwxy + Exz * uwxz + Eyz * uwyz) * TWO - -!multiply with -1/2 - Rpsi4 = - Rpsi4/TWO - Ipsi4 = - Ipsi4/TWO - - return - - end subroutine getnp4_point + + +#include "macrodef.fh" + +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! +!----------------------------------------------------------------------------- + + subroutine getnp4(ex, X, Y, Z, & + chi, trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4, & + symmetry) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz +! physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz + real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz + + real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: dX, dY, dZ + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + +#if (ABV == 1) + call bssn2adm(ex,chipn1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) + adm_dxx = adm_dxx - ONE + adm_dyy = adm_dyy - ONE + adm_dzz = adm_dzz - ONE + call adm_ricci_gamma(ex, X, Y, Z, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz,& + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) +#endif + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +#if (tetradtype == 0) + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + + call fderivs(ex,Axx,Axxx,Axxy,Axxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Axy,Axyx,Axyy,Axyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Axz,Axzx,Axzy,Axzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,Ayy,Ayyx,Ayyy,Ayyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Ayz,Ayzx,Ayzy,Ayzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,Azz,Azzx,Azzy,Azzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,0) + call fderivs(ex,trK,fx,fy,fz,X,Y,Z,SYM,SYM,SYM,symmetry,0) +! compute D_k K_ij up to chi^-1 + Axxx = Axxx - (Gamxxx*Axx + Gamyxx*Axy + Gamzxx*Axz)*TWO - chix/chipn1*Axx + F1o3*gxx*fx + Axxy = Axxy - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz)*TWO - chiy/chipn1*Axx + F1o3*gxx*fy + Axxz = Axxz - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz)*TWO - chiz/chipn1*Axx + F1o3*gxx*fz + Ayyx = Ayyx - (Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz)*TWO - chix/chipn1*Ayy + F1o3*gyy*fx + Ayyy = Ayyy - (Gamxyy*Axy + Gamyyy*Ayy + Gamzyy*Ayz)*TWO - chiy/chipn1*Ayy + F1o3*gyy*fy + Ayyz = Ayyz - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz)*TWO - chiz/chipn1*Ayy + F1o3*gyy*fz + Azzx = Azzx - (Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz)*TWO - chix/chipn1*Azz + F1o3*gzz*fx + Azzy = Azzy - (Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz)*TWO - chiy/chipn1*Azz + F1o3*gzz*fy + Azzz = Azzz - (Gamxzz*Axz + Gamyzz*Ayz + Gamzzz*Azz)*TWO - chiz/chipn1*Azz + F1o3*gzz*fz + Axyx = Axyx - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz + & + Gamxxx*Axy + Gamyxx*Ayy + Gamzxx*Ayz) - chix/chipn1*Axy + F1o3*gxy*fx + Axyy = Axyy - (Gamxyy*Axx + Gamyyy*Axy + Gamzyy*Axz + & + Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz) - chiy/chipn1*Axy + F1o3*gxy*fy + Axyz = Axyz - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & + Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz) - chiz/chipn1*Axy + F1o3*gxy*fz + Axzx = Axzx - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz + & + Gamxxx*Axz + Gamyxx*Ayz + Gamzxx*Azz) - chix/chipn1*Axz + F1o3*gxz*fx + Axzy = Axzy - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & + Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chiy/chipn1*Axz + F1o3*gxz*fy + Axzz = Axzz - (Gamxzz*Axx + Gamyzz*Axy + Gamzzz*Axz + & + Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz) - chiz/chipn1*Axz + F1o3*gxz*fz + Ayzx = Ayzx - (Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz + & + Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chix/chipn1*Ayz + F1o3*gyz*fx + Ayzy = Ayzy - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz + & + Gamxyy*Axz + Gamyyy*Ayz + Gamzyy*Azz) - chiy/chipn1*Ayz + F1o3*gyz*fy + Ayzz = Ayzz - (Gamxzz*Axy + Gamyzz*Ayy + Gamzzz*Ayz + & + Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz) - chiz/chipn1*Ayz + F1o3*gyz*fz +! symmetrize B_ij = v^k (D_k K_ij -D_j K_ik) + Bxx =(vy*(Axxy - Axyx) + vz*(Axxz - Axzx))*f + Byy =(vx*(Ayyx - Axyy) + vz*(Ayyz - Ayzy))*f + Bzz =(vx*(Azzx - Axzz) + vy*(Azzy - Ayzz))*f + Bxy =(vx*(Axyx - (Axxy+Axyx)/TWO) + vy*(Axyy-Ayyx)/TWO + vz*(Axyz - (Axzy+Ayzx)/TWO))*f + Bxz =(vx*(Axzx - (Axxz+Axzx)/TWO) + vy*(Axzy - (Axyz+Ayzx)/TWO) + vz*(Axzz-Azzx)/TWO)*f + Byz =(vx*(Ayzx - (Axyz+Axzy)/TWO) + vy*(Ayzy - (Ayyz+Ayzy)/TWO) + vz*(Ayzz-Azzy)/TWO)*f +! E_ij = R_ij - K_ik * K^k_j + K * K_ij + +! K_ij up to chi^-1 + Axxx = Axx + F1o3*trK*gxx + Axyx = Axy + F1o3*trK*gxy + Axzx = Axz + F1o3*trK*gxz + Ayyx = Ayy + F1o3*trK*gyy + Ayzx = Ayz + F1o3*trK*gyz + Azzx = Azz + F1o3*trK*gzz +! gup and A_ijk cancel a chi^-1 + Exx = gupxx * Axxx * Axxx + gupyy * Axyx * Axyx + gupzz * Axzx * Axzx + & + TWO * (gupxy * Axxx * Axyx + gupxz * Axxx * Axzx + gupyz * Axyx * Axzx) + Eyy = gupxx * Axyx * Axyx + gupyy * Ayyx * Ayyx + gupzz * Ayzx * Ayzx + & + TWO * (gupxy * Axyx * Ayyx + gupxz * Axyx * Ayzx + gupyz * Ayyx * Ayzx) + Ezz = gupxx * Axzx * Axzx + gupyy * Ayzx * Ayzx + gupzz * Azzx * Azzx + & + TWO * (gupxy * Axzx * Ayzx + gupxz * Axzx * Azzx + gupyz * Ayzx * Azzx) + Exy = gupxx * Axxx * Axyx + gupyy * Axyx * Ayyx + gupzz * Axzx * Ayzx + & + gupxy *(Axxx * Ayyx + Axyx * Axyx) + & + gupxz *(Axxx * Ayzx + Axzx * Axyx) + & + gupyz *(Axyx * Ayzx + Axzx * Ayyx) + Exz = gupxx * Axxx * Axzx + gupyy * Axyx * Ayzx + gupzz * Axzx * Azzx + & + gupxy *(Axxx * Ayzx + Axyx * Axzx) + & + gupxz *(Axxx * Azzx + Axzx * Axzx) + & + gupyz *(Axyx * Azzx + Axzx * Ayzx) + Eyz = gupxx * Axyx * Axzx + gupyy * Ayyx * Ayzx + gupzz * Ayzx * Azzx + & + gupxy *(Axyx * Ayzx + Ayyx * Axzx) + & + gupxz *(Axyx * Azzx + Ayzx * Axzx) + & + gupyz *(Ayyx * Azzx + Ayzx * Ayzx) + + Exx = Rxx - (Exx - Axxx*trK)*f - Bxx + Exy = Rxy - (Exy - Axyx*trK)*f - Bxy + Exz = Rxz - (Exz - Axzx*trK)*f - Bxz + Eyy = Ryy - (Eyy - Ayyx*trK)*f - Byy + Eyz = Ryz - (Eyz - Ayzx*trK)*f - Byz + Ezz = Rzz - (Ezz - Azzx*trK)*f - Bzz +!set m = (u - iw)/sqrt(2) following Frans, PRD 75, 124018(2007) +! compute uuww^ij = u^i * u^j - w^i * w^j + uuwwxx = ux * ux - wx * wx + uuwwxy = ux * uy - wx * wy + uuwwxz = ux * uz - wx * wz + uuwwyy = uy * uy - wy * wy + uuwwyz = uy * uz - wy * wz + uuwwzz = uz * uz - wz * wz + +! compute uw^ij = u^i * w^j + w^i * u^j + uwxx = ux * wx + wx * ux + uwxy = ux * wy + wx * uy + uwxz = ux * wz + wx * uz + uwyy = uy * wy + wy * uy + uwyz = uy * wz + wy * uz + uwzz = uz * wz + wz * uz +!the real part of Psi4 + Rpsi4 = Exx * uuwwxx + Eyy * uuwwyy + Ezz * uuwwzz & + + (Exy * uuwwxy + Exz * uuwwxz + Eyz * uuwwyz) * TWO + +!the imaginary part of Psi4 + Ipsi4 = Exx * uwxx + Eyy * uwyy + Ezz * uwzz & + + (Exy * uwxy + Exz * uwxz + Eyz * uwyz) * TWO + +!multiply with -1/2 + Rpsi4 = - Rpsi4/TWO + Ipsi4 = - Ipsi4/TWO + + return + + end subroutine getnp4 +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables for shell +! +!----------------------------------------------------------------------------- + + subroutine getnp4_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4, & + symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz +! physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz + real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz + + real*8, dimension(ex(1),ex(2),ex(3)) :: adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + +#if (ABV == 1) + call bssn2adm(ex,chipn1,trK,gxx,gxy,gxz,gyy,gyz,gzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz, & + Kxx,Kxy,Kxz,Kyy,Kyz,Kzz) + adm_dxx = adm_dxx - ONE + adm_dyy = adm_dyy - ONE + adm_dzz = adm_dzz - ONE + call adm_ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + adm_dxx,adm_gxy,adm_gxz,adm_dyy,adm_gyz,adm_dzz,& + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,0,sst) +#endif + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +#if (tetradtype == 0) + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + + call fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,trK,fx,fy,fz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +! compute D_k K_ij up to chi^-1 + Axxx = Axxx - (Gamxxx*Axx + Gamyxx*Axy + Gamzxx*Axz)*TWO - chix/chipn1*Axx + F1o3*gxx*fx + Axxy = Axxy - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz)*TWO - chiy/chipn1*Axx + F1o3*gxx*fy + Axxz = Axxz - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz)*TWO - chiz/chipn1*Axx + F1o3*gxx*fz + Ayyx = Ayyx - (Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz)*TWO - chix/chipn1*Ayy + F1o3*gyy*fx + Ayyy = Ayyy - (Gamxyy*Axy + Gamyyy*Ayy + Gamzyy*Ayz)*TWO - chiy/chipn1*Ayy + F1o3*gyy*fy + Ayyz = Ayyz - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz)*TWO - chiz/chipn1*Ayy + F1o3*gyy*fz + Azzx = Azzx - (Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz)*TWO - chix/chipn1*Azz + F1o3*gzz*fx + Azzy = Azzy - (Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz)*TWO - chiy/chipn1*Azz + F1o3*gzz*fy + Azzz = Azzz - (Gamxzz*Axz + Gamyzz*Ayz + Gamzzz*Azz)*TWO - chiz/chipn1*Azz + F1o3*gzz*fz + Axyx = Axyx - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz + & + Gamxxx*Axy + Gamyxx*Ayy + Gamzxx*Ayz) - chix/chipn1*Axy + F1o3*gxy*fx + Axyy = Axyy - (Gamxyy*Axx + Gamyyy*Axy + Gamzyy*Axz + & + Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz) - chiy/chipn1*Axy + F1o3*gxy*fy + Axyz = Axyz - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & + Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz) - chiz/chipn1*Axy + F1o3*gxy*fz + Axzx = Axzx - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz + & + Gamxxx*Axz + Gamyxx*Ayz + Gamzxx*Azz) - chix/chipn1*Axz + F1o3*gxz*fx + Axzy = Axzy - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & + Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chiy/chipn1*Axz + F1o3*gxz*fy + Axzz = Axzz - (Gamxzz*Axx + Gamyzz*Axy + Gamzzz*Axz + & + Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz) - chiz/chipn1*Axz + F1o3*gxz*fz + Ayzx = Ayzx - (Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz + & + Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chix/chipn1*Ayz + F1o3*gyz*fx + Ayzy = Ayzy - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz + & + Gamxyy*Axz + Gamyyy*Ayz + Gamzyy*Azz) - chiy/chipn1*Ayz + F1o3*gyz*fy + Ayzz = Ayzz - (Gamxzz*Axy + Gamyzz*Ayy + Gamzzz*Ayz + & + Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz) - chiz/chipn1*Ayz + F1o3*gyz*fz +! symmetrize B_ij = v^k (D_k K_ij -D_j K_ik) + Bxx =(vy*(Axxy - Axyx) + vz*(Axxz - Axzx))*f + Byy =(vx*(Ayyx - Axyy) + vz*(Ayyz - Ayzy))*f + Bzz =(vx*(Azzx - Axzz) + vy*(Azzy - Ayzz))*f + Bxy =(vx*(Axyx - (Axxy+Axyx)/TWO) + vy*(Axyy-Ayyx)/TWO + vz*(Axyz - (Axzy+Ayzx)/TWO))*f + Bxz =(vx*(Axzx - (Axxz+Axzx)/TWO) + vy*(Axzy - (Axyz+Ayzx)/TWO) + vz*(Axzz-Azzx)/TWO)*f + Byz =(vx*(Ayzx - (Axyz+Axzy)/TWO) + vy*(Ayzy - (Ayyz+Ayzy)/TWO) + vz*(Ayzz-Azzy)/TWO)*f +! E_ij = R_ij - K_ik * K^k_j + K * K_ij + +! K_ij up to chi^-1 + Axxx = Axx + F1o3*trK*gxx + Axyx = Axy + F1o3*trK*gxy + Axzx = Axz + F1o3*trK*gxz + Ayyx = Ayy + F1o3*trK*gyy + Ayzx = Ayz + F1o3*trK*gyz + Azzx = Azz + F1o3*trK*gzz +! gup and A_ijk cancel a chi^-1 + Exx = gupxx * Axxx * Axxx + gupyy * Axyx * Axyx + gupzz * Axzx * Axzx + & + TWO * (gupxy * Axxx * Axyx + gupxz * Axxx * Axzx + gupyz * Axyx * Axzx) + Eyy = gupxx * Axyx * Axyx + gupyy * Ayyx * Ayyx + gupzz * Ayzx * Ayzx + & + TWO * (gupxy * Axyx * Ayyx + gupxz * Axyx * Ayzx + gupyz * Ayyx * Ayzx) + Ezz = gupxx * Axzx * Axzx + gupyy * Ayzx * Ayzx + gupzz * Azzx * Azzx + & + TWO * (gupxy * Axzx * Ayzx + gupxz * Axzx * Azzx + gupyz * Ayzx * Azzx) + Exy = gupxx * Axxx * Axyx + gupyy * Axyx * Ayyx + gupzz * Axzx * Ayzx + & + gupxy *(Axxx * Ayyx + Axyx * Axyx) + & + gupxz *(Axxx * Ayzx + Axzx * Axyx) + & + gupyz *(Axyx * Ayzx + Axzx * Ayyx) + Exz = gupxx * Axxx * Axzx + gupyy * Axyx * Ayzx + gupzz * Axzx * Azzx + & + gupxy *(Axxx * Ayzx + Axyx * Axzx) + & + gupxz *(Axxx * Azzx + Axzx * Axzx) + & + gupyz *(Axyx * Azzx + Axzx * Ayzx) + Eyz = gupxx * Axyx * Axzx + gupyy * Ayyx * Ayzx + gupzz * Ayzx * Azzx + & + gupxy *(Axyx * Ayzx + Ayyx * Axzx) + & + gupxz *(Axyx * Azzx + Ayzx * Axzx) + & + gupyz *(Ayyx * Azzx + Ayzx * Ayzx) + + Exx = Rxx - (Exx - Axxx*trK)*f - Bxx + Exy = Rxy - (Exy - Axyx*trK)*f - Bxy + Exz = Rxz - (Exz - Axzx*trK)*f - Bxz + Eyy = Ryy - (Eyy - Ayyx*trK)*f - Byy + Eyz = Ryz - (Eyz - Ayzx*trK)*f - Byz + Ezz = Rzz - (Ezz - Azzx*trK)*f - Bzz +!set m = (u - iw)/sqrt(2) following Frans, PRD 75, 124018(2007) +! compute uuww^ij = u^i * u^j - w^i * w^j + uuwwxx = ux * ux - wx * wx + uuwwxy = ux * uy - wx * wy + uuwwxz = ux * uz - wx * wz + uuwwyy = uy * uy - wy * wy + uuwwyz = uy * uz - wy * wz + uuwwzz = uz * uz - wz * wz + +! compute uw^ij = u^i * w^j + w^i * u^j + uwxx = ux * wx + wx * ux + uwxy = ux * wy + wx * uy + uwxz = ux * wz + wx * uz + uwyy = uy * wy + wy * uy + uwyz = uy * wz + wy * uz + uwzz = uz * wz + wz * uz +!the real part of Psi4 + Rpsi4 = Exx * uuwwxx + Eyy * uuwwyy + Ezz * uuwwzz & + + (Exy * uuwwxy + Exz * uuwwxz + Eyz * uuwwyz) * TWO + +!the imaginary part of Psi4 + Ipsi4 = Exx * uwxx + Eyy * uwyy + Ezz * uwzz & + + (Exy * uwxy + Exz * uwxz + Eyz * uwyz) * TWO + +!multiply with -1/2 + Rpsi4 = - Rpsi4/TWO + Ipsi4 = - Ipsi4/TWO + + return + + end subroutine getnp4_ss +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! for single point +!----------------------------------------------------------------------------- + + subroutine getnp4_point(X, Y, Z, & + chi, trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + chix,chiy,chiz, & + trKx,trKy,trKz, & + Axxx,Axxy,Axxz, & + Axyx,Axyy,Axyz, & + Axzx,Axzy,Axzz, & + Ayyx,Ayyy,Ayyz, & + Ayzx,Ayzy,Ayzz, & + Azzx,Azzy,Azzz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4) + + implicit none + +!~~~~~~> Input parameters: + + real*8, intent(in ) :: X,Y,Z + real*8,intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8,intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8,intent(in ) :: chi,trK + real*8,intent(in ) :: chix,chiy,chiz + real*8,intent(in ) :: trKx,trKy,trKz +! covariant derivatives when out + real*8,intent(inout) :: Axxx,Axxy,Axxz + real*8,intent(inout) :: Axyx,Axyy,Axyz + real*8,intent(inout) :: Axzx,Axzy,Axzz + real*8,intent(inout) :: Ayyx,Ayyy,Ayyz + real*8,intent(inout) :: Ayzx,Ayzy,Ayzz + real*8,intent(inout) :: Azzx,Azzy,Azzz +! physical second kind of connection + real*8,intent(in) :: Gamxxx, Gamxxy, Gamxxz + real*8,intent(in) :: Gamxyy, Gamxyz, Gamxzz + real*8,intent(in) :: Gamyxx, Gamyxy, Gamyxz + real*8,intent(in) :: Gamyyy, Gamyyz, Gamyzz + real*8,intent(in) :: Gamzxx, Gamzxy, Gamzxz + real*8,intent(in) :: Gamzyy, Gamzyz, Gamzzz +! physical Ricci tensor + real*8,intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, intent(out):: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8 :: f,fx,fy,fz + real*8 :: gxx,gyy,gzz,chipn1 + real*8 :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8 :: Exx,Exy,Exz,Eyy,Eyz,Ezz + real*8 :: Bxx,Bxy,Bxz,Byy,Byz,Bzz + real*8 :: gupxx,gupxy,gupxz + real*8 :: gupyy,gupyz,gupzz + real*8 :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz + real*8 :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8,parameter::TINYRR=1.d-14 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +! v:r; u: phi; w: theta +#if (tetradtype == 0) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + +! compute D_k K_ij up to chi^-1 + Axxx = Axxx - (Gamxxx*Axx + Gamyxx*Axy + Gamzxx*Axz)*TWO - chix/chipn1*Axx + F1o3*gxx*trKx + Axxy = Axxy - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz)*TWO - chiy/chipn1*Axx + F1o3*gxx*trKy + Axxz = Axxz - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz)*TWO - chiz/chipn1*Axx + F1o3*gxx*trKz + Ayyx = Ayyx - (Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz)*TWO - chix/chipn1*Ayy + F1o3*gyy*trKx + Ayyy = Ayyy - (Gamxyy*Axy + Gamyyy*Ayy + Gamzyy*Ayz)*TWO - chiy/chipn1*Ayy + F1o3*gyy*trKy + Ayyz = Ayyz - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz)*TWO - chiz/chipn1*Ayy + F1o3*gyy*trKz + Azzx = Azzx - (Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz)*TWO - chix/chipn1*Azz + F1o3*gzz*trKx + Azzy = Azzy - (Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz)*TWO - chiy/chipn1*Azz + F1o3*gzz*trKy + Azzz = Azzz - (Gamxzz*Axz + Gamyzz*Ayz + Gamzzz*Azz)*TWO - chiz/chipn1*Azz + F1o3*gzz*trKz + Axyx = Axyx - (Gamxxy*Axx + Gamyxy*Axy + Gamzxy*Axz + & + Gamxxx*Axy + Gamyxx*Ayy + Gamzxx*Ayz) - chix/chipn1*Axy + F1o3*gxy*trKx + Axyy = Axyy - (Gamxyy*Axx + Gamyyy*Axy + Gamzyy*Axz + & + Gamxxy*Axy + Gamyxy*Ayy + Gamzxy*Ayz) - chiy/chipn1*Axy + F1o3*gxy*trKy + Axyz = Axyz - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & + Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz) - chiz/chipn1*Axy + F1o3*gxy*trKz + Axzx = Axzx - (Gamxxz*Axx + Gamyxz*Axy + Gamzxz*Axz + & + Gamxxx*Axz + Gamyxx*Ayz + Gamzxx*Azz) - chix/chipn1*Axz + F1o3*gxz*trKx + Axzy = Axzy - (Gamxyz*Axx + Gamyyz*Axy + Gamzyz*Axz + & + Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chiy/chipn1*Axz + F1o3*gxz*trKy + Axzz = Axzz - (Gamxzz*Axx + Gamyzz*Axy + Gamzzz*Axz + & + Gamxxz*Axz + Gamyxz*Ayz + Gamzxz*Azz) - chiz/chipn1*Axz + F1o3*gxz*trKz + Ayzx = Ayzx - (Gamxxz*Axy + Gamyxz*Ayy + Gamzxz*Ayz + & + Gamxxy*Axz + Gamyxy*Ayz + Gamzxy*Azz) - chix/chipn1*Ayz + F1o3*gyz*trKx + Ayzy = Ayzy - (Gamxyz*Axy + Gamyyz*Ayy + Gamzyz*Ayz + & + Gamxyy*Axz + Gamyyy*Ayz + Gamzyy*Azz) - chiy/chipn1*Ayz + F1o3*gyz*trKy + Ayzz = Ayzz - (Gamxzz*Axy + Gamyzz*Ayy + Gamzzz*Ayz + & + Gamxyz*Axz + Gamyyz*Ayz + Gamzyz*Azz) - chiz/chipn1*Ayz + F1o3*gyz*trKz +! symmetrize B_ij = v^k (D_k K_ij -D_j K_ik) + Bxx =(vy*(Axxy - Axyx) + vz*(Axxz - Axzx))*f + Byy =(vx*(Ayyx - Axyy) + vz*(Ayyz - Ayzy))*f + Bzz =(vx*(Azzx - Axzz) + vy*(Azzy - Ayzz))*f + Bxy =(vx*(Axyx - (Axxy+Axyx)/TWO) + vy*(Axyy-Ayyx)/TWO + vz*(Axyz - (Axzy+Ayzx)/TWO))*f + Bxz =(vx*(Axzx - (Axxz+Axzx)/TWO) + vy*(Axzy - (Axyz+Ayzx)/TWO) + vz*(Axzz-Azzx)/TWO)*f + Byz =(vx*(Ayzx - (Axyz+Axzy)/TWO) + vy*(Ayzy - (Ayyz+Ayzy)/TWO) + vz*(Ayzz-Azzy)/TWO)*f +! E_ij = R_ij - K_ik * K^k_j + K * K_ij + +! K_ij up to chi^-1 + Axxx = Axx + F1o3*trK*gxx + Axyx = Axy + F1o3*trK*gxy + Axzx = Axz + F1o3*trK*gxz + Ayyx = Ayy + F1o3*trK*gyy + Ayzx = Ayz + F1o3*trK*gyz + Azzx = Azz + F1o3*trK*gzz +! gup and A_ijk cancel a chi^-1 + Exx = gupxx * Axxx * Axxx + gupyy * Axyx * Axyx + gupzz * Axzx * Axzx + & + TWO * (gupxy * Axxx * Axyx + gupxz * Axxx * Axzx + gupyz * Axyx * Axzx) + Eyy = gupxx * Axyx * Axyx + gupyy * Ayyx * Ayyx + gupzz * Ayzx * Ayzx + & + TWO * (gupxy * Axyx * Ayyx + gupxz * Axyx * Ayzx + gupyz * Ayyx * Ayzx) + Ezz = gupxx * Axzx * Axzx + gupyy * Ayzx * Ayzx + gupzz * Azzx * Azzx + & + TWO * (gupxy * Axzx * Ayzx + gupxz * Axzx * Azzx + gupyz * Ayzx * Azzx) + Exy = gupxx * Axxx * Axyx + gupyy * Axyx * Ayyx + gupzz * Axzx * Ayzx + & + gupxy *(Axxx * Ayyx + Axyx * Axyx) + & + gupxz *(Axxx * Ayzx + Axzx * Axyx) + & + gupyz *(Axyx * Ayzx + Axzx * Ayyx) + Exz = gupxx * Axxx * Axzx + gupyy * Axyx * Ayzx + gupzz * Axzx * Azzx + & + gupxy *(Axxx * Ayzx + Axyx * Axzx) + & + gupxz *(Axxx * Azzx + Axzx * Axzx) + & + gupyz *(Axyx * Azzx + Axzx * Ayzx) + Eyz = gupxx * Axyx * Axzx + gupyy * Ayyx * Ayzx + gupzz * Ayzx * Azzx + & + gupxy *(Axyx * Ayzx + Ayyx * Axzx) + & + gupxz *(Axyx * Azzx + Ayzx * Axzx) + & + gupyz *(Ayyx * Azzx + Ayzx * Ayzx) + + Exx = Rxx - (Exx - Axxx*trK)*f - Bxx + Exy = Rxy - (Exy - Axyx*trK)*f - Bxy + Exz = Rxz - (Exz - Axzx*trK)*f - Bxz + Eyy = Ryy - (Eyy - Ayyx*trK)*f - Byy + Eyz = Ryz - (Eyz - Ayzx*trK)*f - Byz + Ezz = Rzz - (Ezz - Azzx*trK)*f - Bzz +!set m = (u - iw)/sqrt(2) following Frans, PRD 75, 124018(2007) +! compute uuww^ij = u^i * u^j - w^i * w^j + uuwwxx = ux * ux - wx * wx + uuwwxy = ux * uy - wx * wy + uuwwxz = ux * uz - wx * wz + uuwwyy = uy * uy - wy * wy + uuwwyz = uy * uz - wy * wz + uuwwzz = uz * uz - wz * wz + +! compute uw^ij = u^i * w^j + w^i * u^j + uwxx = ux * wx + wx * ux + uwxy = ux * wy + wx * uy + uwxz = ux * wz + wx * uz + uwyy = uy * wy + wy * uy + uwyz = uy * wz + wy * uz + uwzz = uz * wz + wz * uz +!the real part of Psi4 + Rpsi4 = Exx * uuwwxx + Eyy * uuwwyy + Ezz * uuwwzz & + + (Exy * uuwwxy + Exz * uuwwxz + Eyz * uuwwyz) * TWO + +!the imaginary part of Psi4 + Ipsi4 = Exx * uwxx + Eyy * uwyy + Ezz * uwzz & + + (Exy * uwxy + Exz * uwxz + Eyz * uwyz) * TWO + +!multiply with -1/2 + Rpsi4 = - Rpsi4/TWO + Ipsi4 = - Ipsi4/TWO + + return + + end subroutine getnp4_point diff --git a/AMSS_NCKU_source/getnp4.h b/AMSS_NCKU_source/Psi4/getnp4.h similarity index 98% rename from AMSS_NCKU_source/getnp4.h rename to AMSS_NCKU_source/Psi4/getnp4.h index eb7ea5c..b7fd59f 100644 --- a/AMSS_NCKU_source/getnp4.h +++ b/AMSS_NCKU_source/Psi4/getnp4.h @@ -1,180 +1,180 @@ - -#ifndef GETNP4_H -#define GETNP4_H - -#ifdef fortran1 -#define f_getnp4old getnp4old -#define f_getnp4oldscalar getnp4oldscalar -#define f_getnp4oldscalar_ss getnp4oldscalar_ss -#define f_getnp4 getnp4 -#define f_getnp4_point getnp4_point -#define f_getnp4_ss getnp4_ss -#define f_getnp4old_ss getnp4old_ss -#define f_getnp4scalar getnp4scalar -#define f_getnp4scalar_ss getnp4scalar_ss -#endif -#ifdef fortran2 -#define f_getnp4 GETNP4 -#define f_getnp4_point GETNP4_POINT -#define f_getnp4 GETNP4OLD -#define f_getnp4scalar GETNP4OLDSCALAR -#define f_getnp4_ss GETNP4_SS -#define f_getnp4old_ss GETNP4OLD_SS -#define f_getnp4oldscalar_ss GETNP4OLDSCALAR_SS -#define f_getnp4scalar GETNP4SCALAR -#define f_getnp4scalar_ss GETNP4SCALAR_SS -#endif -#ifdef fortran3 -#define f_getnp4old getnp4old_ -#define f_getnp4_point getnp4_point_ -#define f_getnp4oldscalar getnp4oldscalar_ -#define f_getnp4oldscalar_ss getnp4oldscalar_ss_ -#define f_getnp4 getnp4_ -#define f_getnp4_ss getnp4_ss_ -#define f_getnp4old_ss getnp4old_ss_ -#define f_getnp4scalar getnp4scalar_ -#define f_getnp4scalar_ss getnp4scalar_ss_ -#endif - -extern "C" -{ - void f_getnp4old(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, int &); -} - -extern "C" -{ - void f_getnp4old_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, int &, int &); -} - -extern "C" -{ - void f_getnp4oldscalar(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, int &); -} - -extern "C" -{ - void f_getnp4oldscalar_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, int &, int &); -} - -extern "C" -{ - void f_getnp4(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &); -} - -extern "C" -{ - void f_getnp4_point(double &, double &, double &, // XYZ - double &, double &, // chi,trK - double &, double &, double &, double &, double &, double &, // gamma_ij - double &, double &, double &, double &, double &, double &, // A_ij - double &, double &, double &, // chi_i - double &, double &, double &, // trK_i - double &, double &, double &, // A_ijk - double &, double &, double &, - double &, double &, double &, - double &, double &, double &, - double &, double &, double &, - double &, double &, double &, - double &, double &, double &, double &, double &, double &, // Gam_ijk - double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, // R_ij - double &, double &); -} - -extern "C" -{ - void f_getnp4_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &, int &); -} - -extern "C" -{ - void f_getnp4scalar(int *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &); -} - -extern "C" -{ - void f_getnp4scalar_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &, int &); -} - -#endif /* GETNP4_H */ + +#ifndef GETNP4_H +#define GETNP4_H + +#ifdef fortran1 +#define f_getnp4old getnp4old +#define f_getnp4oldscalar getnp4oldscalar +#define f_getnp4oldscalar_ss getnp4oldscalar_ss +#define f_getnp4 getnp4 +#define f_getnp4_point getnp4_point +#define f_getnp4_ss getnp4_ss +#define f_getnp4old_ss getnp4old_ss +#define f_getnp4scalar getnp4scalar +#define f_getnp4scalar_ss getnp4scalar_ss +#endif +#ifdef fortran2 +#define f_getnp4 GETNP4 +#define f_getnp4_point GETNP4_POINT +#define f_getnp4 GETNP4OLD +#define f_getnp4scalar GETNP4OLDSCALAR +#define f_getnp4_ss GETNP4_SS +#define f_getnp4old_ss GETNP4OLD_SS +#define f_getnp4oldscalar_ss GETNP4OLDSCALAR_SS +#define f_getnp4scalar GETNP4SCALAR +#define f_getnp4scalar_ss GETNP4SCALAR_SS +#endif +#ifdef fortran3 +#define f_getnp4old getnp4old_ +#define f_getnp4_point getnp4_point_ +#define f_getnp4oldscalar getnp4oldscalar_ +#define f_getnp4oldscalar_ss getnp4oldscalar_ss_ +#define f_getnp4 getnp4_ +#define f_getnp4_ss getnp4_ss_ +#define f_getnp4old_ss getnp4old_ss_ +#define f_getnp4scalar getnp4scalar_ +#define f_getnp4scalar_ss getnp4scalar_ss_ +#endif + +extern "C" +{ + void f_getnp4old(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, int &); +} + +extern "C" +{ + void f_getnp4old_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, int &, int &); +} + +extern "C" +{ + void f_getnp4oldscalar(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, int &); +} + +extern "C" +{ + void f_getnp4oldscalar_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, int &, int &); +} + +extern "C" +{ + void f_getnp4(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &); +} + +extern "C" +{ + void f_getnp4_point(double &, double &, double &, // XYZ + double &, double &, // chi,trK + double &, double &, double &, double &, double &, double &, // gamma_ij + double &, double &, double &, double &, double &, double &, // A_ij + double &, double &, double &, // chi_i + double &, double &, double &, // trK_i + double &, double &, double &, // A_ijk + double &, double &, double &, + double &, double &, double &, + double &, double &, double &, + double &, double &, double &, + double &, double &, double &, + double &, double &, double &, double &, double &, double &, // Gam_ijk + double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, // R_ij + double &, double &); +} + +extern "C" +{ + void f_getnp4_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &, int &); +} + +extern "C" +{ + void f_getnp4scalar(int *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &); +} + +extern "C" +{ + void f_getnp4scalar_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &, int &); +} + +#endif /* GETNP4_H */ diff --git a/AMSS_NCKU_source/getnp4EScalar.f90 b/AMSS_NCKU_source/Psi4/getnp4EScalar.f90 similarity index 97% rename from AMSS_NCKU_source/getnp4EScalar.f90 rename to AMSS_NCKU_source/Psi4/getnp4EScalar.f90 index bb4c2ca..95e398e 100644 --- a/AMSS_NCKU_source/getnp4EScalar.f90 +++ b/AMSS_NCKU_source/Psi4/getnp4EScalar.f90 @@ -1,290 +1,290 @@ - - -#include "macrodef.fh" - -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! -!----------------------------------------------------------------------------- - - subroutine getnp4scalar(ex, X, Y, Z, & - chi, trK, Sphi,& - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4, & - symmetry) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz -! physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz - real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: dX, dY, dZ - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - real*8 :: PI - - PI = dacos(-ONE) - - call getnp4(ex, X, Y, Z, & - chi, trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4, & - symmetry) - - Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 - Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 - - return - - end subroutine getnp4scalar -! 4D method - subroutine getnp4oldscalar(ex, X, Y, Z, chi, trK,Sphi, & - dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 - - real*8 :: PI - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - - PI = dacos(-ONE) - - call getnp4old(ex, X, Y, Z, chi, trK, & - dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry) - - Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 - Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 - - return - - end subroutine getnp4oldscalar -!----------------------------------------------------------------------------- -! for shell -!----------------------------------------------------------------------------- - - subroutine getnp4scalar_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, trK, Sphi,& - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4, & - symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz -! physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz - real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz - real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - real*8 :: PI - - PI = dacos(-ONE) - - call getnp4_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Rpsi4, Ipsi4, & - symmetry,sst) - - Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 - Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 - - return - - end subroutine getnp4scalar_ss -! 4D method - subroutine getnp4oldscalar_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, trK, Sphi, & - dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 - - real*8 :: PI - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - - PI = dacos(-ONE) - - call getnp4old_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, trK, & - dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry,sst) - - Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 - Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 - - return - - end subroutine getnp4oldscalar_ss + + +#include "macrodef.fh" + +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! +!----------------------------------------------------------------------------- + + subroutine getnp4scalar(ex, X, Y, Z, & + chi, trK, Sphi,& + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4, & + symmetry) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz +! physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz + real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: dX, dY, dZ + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + real*8 :: PI + + PI = dacos(-ONE) + + call getnp4(ex, X, Y, Z, & + chi, trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4, & + symmetry) + + Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 + Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 + + return + + end subroutine getnp4scalar +! 4D method + subroutine getnp4oldscalar(ex, X, Y, Z, chi, trK,Sphi, & + dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 + + real*8 :: PI + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + + PI = dacos(-ONE) + + call getnp4old(ex, X, Y, Z, chi, trK, & + dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry) + + Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 + Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 + + return + + end subroutine getnp4oldscalar +!----------------------------------------------------------------------------- +! for shell +!----------------------------------------------------------------------------- + + subroutine getnp4scalar_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, trK, Sphi,& + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4, & + symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz +! physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chipn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: Exx,Exy,Exz,Eyy,Eyz,Ezz + real*8, dimension(ex(1),ex(2),ex(3)) :: Bxx,Bxy,Bxz,Byy,Byz,Bzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Azzx,Azzy,Azzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz + real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + real*8 :: PI + + PI = dacos(-ONE) + + call getnp4_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Rpsi4, Ipsi4, & + symmetry,sst) + + Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 + Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 + + return + + end subroutine getnp4scalar_ss +! 4D method + subroutine getnp4oldscalar_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, trK, Sphi, & + dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,Sphi + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 + + real*8 :: PI + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + + PI = dacos(-ONE) + + call getnp4old_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, trK, & + dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry,sst) + + Rpsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Rpsi4 + Ipsi4 = dexp(-FOUR*dsqrt(PI/3)*Sphi)*Ipsi4 + + return + + end subroutine getnp4oldscalar_ss diff --git a/AMSS_NCKU_source/getnp4old.f90 b/AMSS_NCKU_source/Psi4/getnp4old.f90 similarity index 97% rename from AMSS_NCKU_source/getnp4old.f90 rename to AMSS_NCKU_source/Psi4/getnp4old.f90 index c760337..2a25b7f 100644 --- a/AMSS_NCKU_source/getnp4old.f90 +++ b/AMSS_NCKU_source/Psi4/getnp4old.f90 @@ -1,2422 +1,2422 @@ - - -#include "macrodef.fh" - -!----------------------------------------------------------------------------- -! -! compute rhw Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! -!----------------------------------------------------------------------------- - - subroutine getnp4old(ex, X, Y, Z, chi, trK, & - dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ep4phi,alpn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: phi,phix,phiy,phiz - real*8, dimension(ex(1),ex(2),ex(3)) :: phixx,phixy,phixz,phiyy,phiyz,phizz - real*8, dimension(ex(1),ex(2),ex(3)) :: tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: tRxx,tRxy,tRxz,tRyy,tRyz,tRzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz - - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz -!D_i K_jk ---> DKijk - real*8, dimension(ex(1),ex(2),ex(3)) :: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz -! Aij,k --> stored as Aijk - real*8, dimension(ex(1),ex(2),ex(3))::Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3))::Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3))::Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3))::Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3))::Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3))::Azzx,Azzy,Azzz -! trK,i - real*8, dimension(ex(1),ex(2),ex(3))::Kx,Ky,Kz - - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz -! first order partial derivative of metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxxy,gxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyx,gxyy,gxyz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzx,gxzy,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyyy,gyyz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzx,gyzy,gyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzx,gzzy,gzzz -! second order partial derivative of metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - - real*8, parameter :: F1o4=2.5d-1,ONE=1.d0,TWO=2.d0,FOUR=4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - phi = -0.25d0*dlog(chi+ONE) -!~~~~~~ - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - alpn1 = Lap + ONE - - ep4phi = dexp( FOUR * Phi ) - -!~~~~~~> - - call d1metric(ex,X,Y,Z, & - dxx ,gxy ,gxz ,dyy ,gyz ,dzz , & - gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, symmetry) - - call d2metric(ex,X,Y,Z, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, symmetry) - - call kind1_connection(ex, gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz,& - ass_Gamxyy, ass_Gamxyz, ass_Gamxzz,& - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz,& - ass_Gamyyy, ass_Gamyyz, ass_Gamyzz,& - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz,& - ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) - - call kind2_connection(ex, gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & - ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & - ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & - ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - -!~~~~~~> derivs of conformal factor - - call fderivs(ex,phi,phix,phiy,phiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - - call fdderivs(ex,phi,phixx,phixy,phixz,phiyy,phiyz,phizz,X,Y,Z, & - SYM,SYM,SYM,symmetry,0) - - call xcov_deriv(ex, phix, phiy, phiz, & - phixx, phixy, phixz, phiyy, phiyz, phizz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - -!~~~~~~> get spatial Riemann curvature - - call adm_riemann(ex, gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, & - ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & - ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, & - ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & - ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, & - ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & - tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz) - - call get_physical_riemann(ex, ep4phi, & - dxx , gxy , gxz , dyy , gyz , dzz , & - gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & - phix , phiy , phiz , & - phixx , phixy , phixz , phiyy , phiyz , phizz , & - tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) - -!~~~~~~> get spatial Ricci tensor - - call adm_ricci(ex, gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & - tRxyxy,tRxyxz,tRxyyz,tRxzxz,tRxzyz,tRyzyz, & - tRxx, tRxy, tRxz, tRyy, tRyz, tRzz) - - call get_physical_ricci(ex,dxx,gxy,gxz,dyy,gyz,dzz,phix,phiy,phiz, & - phixx,phixy,phixz,phiyy,phiyz,phizz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - tRxx, tRxy, tRxz, tRyy, tRyz, tRzz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) - -!~~~~~~> get the real spatial extrinsic curvature - - call get_physical_k(ex, phi, trK, dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Kxx, Kxy, Kxz, Kyy, Kyz, Kzz) - -!~~~~~~> derivs of trace of extrinsic curvature - - call fderivs(ex,trK, Kx, Ky, Kz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - -!~~~~~~> derivs of tilde extrinsic curvature - - call fderivs(ex,Axx,Axxx,Axxy,Axxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Axy,Axyx,Axyy,Axyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Axz,Axzx,Axzy,Axzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,Ayy,Ayyx,Ayyy,Ayyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Ayz,Ayzx,Ayzy,Ayzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,Azz,Azzx,Azzy,Azzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - -!~~~~~~> derivs of extrinsic curvature, Kij - - call get_diff_physical_k(ex, phi, trK, Kx, Ky, Kz, phix, phiy, phiz, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Axxx, Axxy, Axxz, Axyx, Axyy, Axyz, & - Axzx, Axzy, Axzz, Ayyx, Ayyy, Ayyz, & - Ayzx, Ayzy, Ayzz, Azzx, Azzy, Azzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - Kxx, Kxy, Kxz, Kyy, Kyz, Kzz, & - DKxxx, DKxxy, DKxxz, DKxyy, DKxyz, DKxzz, & - DKyxx, DKyxy, DKyxz, DKyyy, DKyyz, DKyzz, & - DKzxx, DKzxy, DKzxz, DKzyy, DKzyz, DKzzz) - -!~~~~~~> get the Gram-Schmidt orthonormalize triad coordinate -#if (tetradtype == 0) - call get_triad0(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) -#elif (tetradtype == 1) - call get_triad1(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) -#elif (tetradtype == 2) - call get_triad2(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) -#endif - -!~~~~~~> compute the Newnamm-Penrose psi4 which split real and image part - - ep4phi = ONE / ep4phi - - call bssn_compute_psi4(ex,ep4phi, alpn1, Sfx, Sfy, Sfz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz, & - trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Rxyxy,Rxyxz,Rxyyz,Rxzxz,Rxzyz,Ryzyz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, & - DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & - DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & - DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz, Rpsi4, Ipsi4) - - return - - end subroutine getnp4old -!----------------------------------------------------------------------------------- -! for shell -! - - subroutine getnp4old_ss(ex,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, trK, & - dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3),symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ep4phi,alpn1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: phi,phix,phiy,phiz - real*8, dimension(ex(1),ex(2),ex(3)) :: phixx,phixy,phixz,phiyy,phiyz,phizz - real*8, dimension(ex(1),ex(2),ex(3)) :: tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: tRxx,tRxy,tRxz,tRyy,tRyz,tRzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz - - real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz -!D_i K_jk ---> DKijk - real*8, dimension(ex(1),ex(2),ex(3)) :: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz -! Aij,k --> stored as Aijk - real*8, dimension(ex(1),ex(2),ex(3))::Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3))::Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3))::Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3))::Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3))::Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3))::Azzx,Azzy,Azzz -! trK,i - real*8, dimension(ex(1),ex(2),ex(3))::Kx,Ky,Kz - - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz -! first order partial derivative of metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxxy,gxxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyx,gxyy,gxyz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzx,gxzy,gxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyyy,gyyz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzx,gyzy,gyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzx,gzzy,gzzz -! second order partial derivative of metric - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - - real*8, parameter :: F1o4=2.5d-1,ONE=1.d0,TWO=2.d0,FOUR=4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8,parameter::TINYRR=1.d-14 - - phi = -0.25d0*dlog(chi+ONE) -!~~~~~~ - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - - alpn1 = Lap + ONE - - ep4phi = dexp( FOUR * Phi ) - -!~~~~~~> - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - call kind1_connection(ex, gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz,& - ass_Gamxyy, ass_Gamxyz, ass_Gamxzz,& - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz,& - ass_Gamyyy, ass_Gamyyz, ass_Gamyzz,& - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz,& - ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) - - call kind2_connection(ex, gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & - ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & - ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & - ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - -!~~~~~~> derivs of conformal factor - call fderivs_shc(ex,phi,phix,phiy,phiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fdderivs_shc(ex,phi,phixx,phixy,phixz,phiyy,phiyz,phizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - call xcov_deriv(ex, phix, phiy, phiz, & - phixx, phixy, phixz, phiyy, phiyz, phizz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - -!~~~~~~> get spatial Riemann curvature - - call adm_riemann(ex, gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, & - ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & - ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, & - ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & - ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, & - ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & - tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz) - - call get_physical_riemann(ex, ep4phi, & - dxx , gxy , gxz , dyy , gyz , dzz , & - gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & - phix , phiy , phiz , & - phixx , phixy , phixz , phiyy , phiyz , phizz , & - tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) - -!~~~~~~> get spatial Ricci tensor - - call adm_ricci(ex, gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & - tRxyxy,tRxyxz,tRxyyz,tRxzxz,tRxzyz,tRyzyz, & - tRxx, tRxy, tRxz, tRyy, tRyz, tRzz) - - call get_physical_ricci(ex,dxx,gxy,gxz,dyy,gyz,dzz,phix,phiy,phiz, & - phixx,phixy,phixz,phiyy,phiyz,phizz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - tRxx, tRxy, tRxz, tRyy, tRyz, tRzz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) - -!~~~~~~> get the real spatial extrinsic curvature - - call get_physical_k(ex, phi, trK, dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Kxx, Kxy, Kxz, Kyy, Kyz, Kzz) - -!~~~~~~> derivs of trace of extrinsic curvature - call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -!~~~~~~> derivs of tilde extrinsic curvature - - call fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -!~~~~~~> derivs of extrinsic curvature, Kij - - call get_diff_physical_k(ex, phi, trK, Kx, Ky, Kz, phix, phiy, phiz, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Axxx, Axxy, Axxz, Axyx, Axyy, Axyz, & - Axzx, Axzy, Axzz, Ayyx, Ayyy, Ayyz, & - Ayzx, Ayzy, Ayzz, Azzx, Azzy, Azzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - Kxx, Kxy, Kxz, Kyy, Kyz, Kzz, & - DKxxx, DKxxy, DKxxz, DKxyy, DKxyz, DKxzz, & - DKyxx, DKyxy, DKyxz, DKyyy, DKyyz, DKyzz, & - DKzxx, DKzxy, DKzxz, DKzyy, DKzyz, DKzzz) - -!~~~~~~> get the Gram-Schmidt orthonormalize triad coordinate - -#if (tetradtype == 0) - call get_triad0_ss(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) -#elif (tetradtype == 1) - call get_triad1_ss(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) -#elif (tetradtype == 2) - call get_triad2_ss(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) -#endif - -!~~~~~~> compute the Newnamm-Penrose psi4 which split real and image part - - ep4phi = ONE / ep4phi - - call bssn_compute_psi4(ex,ep4phi, alpn1, Sfx, Sfy, Sfz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz, & - trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Rxyxy,Rxyxz,Rxyyz,Rxzxz,Rxzyz,Ryzyz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, & - DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & - DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & - DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz, Rpsi4, Ipsi4) - - return - - end subroutine getnp4old_ss -!----------------------------------------------------------! -! ! -! derivatives related to 3-dimensional Riemann slice ! -! ! -!----------------------------------------------------------! - -!----------------------------------------------------------------------------- -! Interface to compute the first order derivative of metric -!----------------------------------------------------------------------------- - - subroutine d1metric(ex,X,Y,Z, & - dxx ,gxy ,gxz ,dyy ,gyz ,dzz , & - gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, symmetry) - - implicit none - -!~~~~~~ Input parameters: - - integer, intent(in ) :: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - -!~~~~~~ local variables - - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - -!~~~~~~ 1st derivs of matric - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,0) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,symmetry,0) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,symmetry,0) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,0) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,symmetry,0) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,0) - - return - - end subroutine d1metric - -!----------------------------------------------------------------------------- -! Interface to compute the second order derivative of metric -!----------------------------------------------------------------------------- - - subroutine d2metric(ex,X,Y,Z, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, symmetry) - - implicit none - -!~~~~~~ Input parameters: - - integer, intent(in ) :: ex(1:3),symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - -!~~~~~~ local variables - - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - -!~~~~~~ 2nd derivs of matric - - call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z, & - SYM ,SYM ,SYM ,symmetry,0) - call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z, & - ANTI,ANTI,SYM ,symmetry,0) - call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z, & - ANTI,SYM ,ANTI,symmetry,0) - call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z, & - SYM, SYM ,SYM ,symmetry,0) - call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z, & - SYM ,ANTI,ANTI,symmetry,0) - call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z, & - SYM ,SYM ,SYM ,symmetry,0) - - return - - end subroutine d2metric -!----------------------------------------------------------! -! ! -! algebraic computation based on geometric quantites ! -! and their partial derivatives related to 3-dimensional ! -! Riemann slice ! -! ! -!----------------------------------------------------------! - -!----------------------------------------------------------------------------- -! Get first kind of connection coefficients -! based on first order derivative of metric -! ass_Gam_ijk = 1/2 *(g_ij,k + g_ki,j - g_jk,i) -!----------------------------------------------------------------------------- - - subroutine kind1_connection(ex,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & - ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & - ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & - ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxxx,gxyx,gxzx - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxxy,gxyy,gxzy - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxxz,gxyz,gxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz - -!~~~~~~> Other variables: - - real*8, parameter :: HLF=0.5d0 - -!~~~~~~= Get Connection coefficients -! ass_Gam_ijk = 1/2 *(g_ij,k + g_ki,j - g_jk,i) - - ass_Gamxxx = HLF * ( gxxx ) - ass_Gamyxx = HLF * ( gxyx + gxyx - gxxy ) - ass_Gamzxx = HLF * ( gxzx + gxzx - gxxz ) - ass_Gamxyy = HLF * ( gxyy + gxyy - gyyx ) - ass_Gamyyy = HLF * ( gyyy ) - ass_Gamzyy = HLF * ( gyzy + gyzy - gyyz ) - ass_Gamxzz = HLF * ( gxzz + gxzz - gzzx ) - ass_Gamyzz = HLF * ( gyzz + gyzz - gzzy ) - ass_Gamzzz = HLF * ( gzzz ) - ass_Gamxxy = HLF * ( gxxy + gxyx - gxyx ) - ass_Gamyxy = HLF * ( gxyy + gyyx - gxyy ) - ass_Gamzxy = HLF * ( gxzy + gyzx - gxyz ) - ass_Gamxxz = HLF * ( gxxz + gxzx - gxzx ) - ass_Gamyxz = HLF * ( gxyz + gyzx - gxzy ) - ass_Gamzxz = HLF * ( gxzz + gzzx - gxzz ) - ass_Gamxyz = HLF * ( gxyz + gxzy - gyzx ) - ass_Gamyyz = HLF * ( gyyz + gyzy - gyzy ) - ass_Gamzyz = HLF * ( gyzz + gzzy - gyzz ) - - return - - end subroutine kind1_connection - -!----------------------------------------------------------------------------- -! Get second kind of connection coefficients -! based on first kind of connection coefficients -! and gup -!----------------------------------------------------------------------------- - - subroutine kind2_connection(ex,gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & - ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & - ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & - ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & - ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & - ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamzyy, Gamzyz, Gamzzz - -!~~~~~~> Other variables: - - Gamxxx = gupxx * ass_Gamxxx + gupxy * ass_Gamyxx + gupxz * ass_Gamzxx - Gamxxy = gupxx * ass_Gamxxy + gupxy * ass_Gamyxy + gupxz * ass_Gamzxy - Gamxxz = gupxx * ass_Gamxxz + gupxy * ass_Gamyxz + gupxz * ass_Gamzxz - Gamxyy = gupxx * ass_Gamxyy + gupxy * ass_Gamyyy + gupxz * ass_Gamzyy - Gamxyz = gupxx * ass_Gamxyz + gupxy * ass_Gamyyz + gupxz * ass_Gamzyz - Gamxzz = gupxx * ass_Gamxzz + gupxy * ass_Gamyzz + gupxz * ass_Gamzzz - - Gamyxx = gupxy * ass_Gamxxx + gupyy * ass_Gamyxx + gupyz * ass_Gamzxx - Gamyxy = gupxy * ass_Gamxxy + gupyy * ass_Gamyxy + gupyz * ass_Gamzxy - Gamyxz = gupxy * ass_Gamxxz + gupyy * ass_Gamyxz + gupyz * ass_Gamzxz - Gamyyy = gupxy * ass_Gamxyy + gupyy * ass_Gamyyy + gupyz * ass_Gamzyy - Gamyyz = gupxy * ass_Gamxyz + gupyy * ass_Gamyyz + gupyz * ass_Gamzyz - Gamyzz = gupxy * ass_Gamxzz + gupyy * ass_Gamyzz + gupyz * ass_Gamzzz - - Gamzxx = gupxz * ass_Gamxxx + gupyz * ass_Gamyxx + gupzz * ass_Gamzxx - Gamzxy = gupxz * ass_Gamxxy + gupyz * ass_Gamyxy + gupzz * ass_Gamzxy - Gamzxz = gupxz * ass_Gamxxz + gupyz * ass_Gamyxz + gupzz * ass_Gamzxz - Gamzyy = gupxz * ass_Gamxyy + gupyz * ass_Gamyyy + gupzz * ass_Gamzyy - Gamzyz = gupxz * ass_Gamxyz + gupyz * ass_Gamyyz + gupzz * ass_Gamzyz - Gamzzz = gupxz * ass_Gamxzz + gupyz * ass_Gamyzz + gupzz * ass_Gamzzz - - return - - end subroutine kind2_connection - -!---------------------------------------------------------------------- -! compute Riemann tensor for three dimensional space -! based on second derivatives of metric -! and first knid and second kind of connection -!---------------------------------------------------------------------- - - subroutine adm_riemann(ex,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & - ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, & - ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & - ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, & - ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & - ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, & - ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz - -!~~~~~~local variables - - real*8, parameter :: HLF=0.5d0 - -!R_ijkl = HLF *(@_jk g_il + @_il g_jk - @_jl g_ik - @_ik g_jl) -! + Gam_rjk Gam^r_il - Gam_rjl Gam^r_ik - - Rxyxy = HLF *( gxyxy + gxyxy - gxxyy - gyyxx ) + & - (ass_Gamxxy * Gamxxy + ass_Gamyxy * Gamyxy + ass_Gamzxy * Gamzxy) - & - (ass_Gamxyy * Gamxxx + ass_Gamyyy * Gamyxx + ass_Gamzyy * Gamzxx) - - Rxyxz = HLF *( gxzxy + gxyxz - gxxyz - gyzxx ) + & - (ass_Gamxxy * Gamxxz + ass_Gamyxy * Gamyxz + ass_Gamzxy * Gamzxz) - & - (ass_Gamxyz * Gamxxx + ass_Gamyyz * Gamyxx + ass_Gamzyz * Gamzxx) - - Rxyyz = HLF *( gxzyy + gyyxz - gxyyz - gyzxy ) + & - (ass_Gamxyy * Gamxxz + ass_Gamyyy * Gamyxz + ass_Gamzyy * Gamzxz) - & - (ass_Gamxyz * Gamxxy + ass_Gamyyz * Gamyxy + ass_Gamzyz * Gamzxy) - - Rxzxz = HLF *( gxzxz + gxzxz - gxxzz - gzzxx ) + & - (ass_Gamxxz * Gamxxz + ass_Gamyxz * Gamyxz + ass_Gamzxz * Gamzxz) - & - (ass_Gamxzz * Gamxxx + ass_Gamyzz * Gamyxx + ass_Gamzzz * Gamzxx) - - Rxzyz = HLF *( gxzyz + gyzxz - gxyzz - gzzxy ) + & - (ass_Gamxyz * Gamxxz + ass_Gamyyz * Gamyxz + ass_Gamzyz * Gamzxz) - & - (ass_Gamxzz * Gamxxy + ass_Gamyzz * Gamyxy + ass_Gamzzz * Gamzxy) - - Ryzyz = HLF *( gyzyz + gyzyz - gyyzz - gzzyy ) + & - (ass_Gamxyz * Gamxyz + ass_Gamyyz * Gamyyz + ass_Gamzyz * Gamzyz) - & - (ass_Gamxzz * Gamxyy + ass_Gamyzz * Gamyyy + ass_Gamzzz * Gamzyy) - - return - - end subroutine adm_riemann - -!----------------------------------------------------------------------------- -! Get Ricci tensor of metric g from Riemann tensor -! for adm form -! R_ij = gup^kl * R_ikjl -!----------------------------------------------------------------------------- - - subroutine adm_ricci(ex, gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in ) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Rxyxy, Rxyxz, Rxyyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Rxzxz, Rxzyz, Ryzyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - - Rxx = gupyy * Rxyxy + gupyz * Rxyxz + gupyz * Rxyxz + gupzz * Rxzxz - Rxy = - gupxy * Rxyxy + gupyz * Rxyyz - gupxz * Rxyxz + gupzz * Rxzyz - Rxz = - gupxy * Rxyxz - gupyy * Rxyyz - gupxz * Rxzxz - gupyz * Rxzyz - Ryy = gupxx * Rxyxy - gupxz * Rxyyz - gupxz * Rxyyz + gupzz * Ryzyz - Ryz = gupxx * Rxyxz + gupxy * Rxyyz - gupxz * Rxzyz - gupyz * Ryzyz - Rzz = gupxx * Rxzxz + gupxy * Rxzyz + gupxy * Rxzyz + gupyy * Ryzyz - - return - - end subroutine adm_ricci - -!----------------------------------------------------------------------------- -! raise index -!----------------------------------------------------------------------------- - - subroutine raise(ex,fx,fy,fz,fupx,fupy,fupz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) - implicit none - -!~~~~~~ Input parameters: - - integer, intent(in ) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupxx, gupxy, gupxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupyy, gupyz, gupzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: fupx,fupy,fupz - - fupx = gupxx * fx + gupxy * fy + gupxz * fz - fupy = gupxy * fx + gupyy * fy + gupyz * fz - fupz = gupxz * fx + gupyz * fy + gupzz * fz - - return - - end subroutine raise - -!----------------------------------------------------------------------------- -! lower index -!----------------------------------------------------------------------------- - - subroutine lower(ex,fx,fy,fz,Lfx,Lfy,Lfz,gxx,gxy,gxz,gyy,gyz,gzz) - implicit none - -!~~~~~~ Input parameters: - - integer, intent(in ) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Lfx,Lfy,Lfz - - Lfx = gxx * fx + gxy * fy + gxz * fz - Lfy = gxy * fx + gyy * fy + gyz * fz - Lfz = gxz * fx + gyz * fy + gzz * fz - - return - - end subroutine lower - -!---------------------------------------------------------------------------------- -! inner product of two three dimensional vectors with metric g_ij -! metric here do not upto ONE -!---------------------------------------------------------------------------------- - - subroutine InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::ux,uy,uz,vx,vy,vz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out)::norm - - norm = gxx * ux * vx + gxy * ux * vy + gxz * ux * vz & - + gxy * uy * vx + gyy * uy * vy + gyz * uy * vz & - + gxz * uz * vx + gyz * uz * vy + gzz * uz * vz - - return - - end subroutine InnerProd -!----------------------------------------------------------! -! ! -! algebraic computation based on geometric quantites ! -! and their partial derivatives related to 3-dimensional ! -! Riemann slice ! -! ! -! * for BSSN form * ! -!----------------------------------------------------------! - -!----------------------------------------------------------------------------- -! second order covariant derivatives w.r.t. *untilded* (i.e. physical) metric -! of *symmetric* variable of scalar field -!----------------------------------------------------------------------------- - - subroutine fnt_cov_s_dderiv(ex, fx, fy, fz, & - fxx, fxy, fxz, fyy, fyz, fzz, & - phix, phiy, phiz, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - Gmxxx,Gmxxy,Gmxxz,Gmxyy,Gmxyz,Gmxzz, & - Gmyxx,Gmyxy,Gmyxz,Gmyyy,Gmyyz,Gmyzz, & - Gmzxx,Gmzxy,Gmzxz,Gmzyy,Gmzyz,Gmzzz) - implicit none - -!~~~~~~ Input arguments - - integer, intent(in ) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: phix,phiy,phiz -! tilted Christofel symble - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmxxx, Gmxxy, Gmxxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmxyy, Gmxyz, Gmxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmyxx, Gmyxy, Gmyxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmyyy, Gmyyz, Gmyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmzxx, Gmzxy, Gmzxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmzyy, Gmzyz, Gmzzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupyy,gupyz,gupzz -! input partial derivatives, output covariant derivative respect to physical metric - real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: fxx,fxy,fxz,fyy,fyz,fzz - -!~~~~~~ Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: phiupx,phiupy,phiupz - real*8,parameter :: TWO = 2.d0 - -!~~~~~~ Make untilded Gamma's out of tilded ones - first raise index on phi_i... - - phiupx = gupxx * phix + gupxy * phiy + gupxz * phiz - phiupy = gupxy * phix + gupyy * phiy + gupyz * phiz - phiupz = gupxz * phix + gupyz * phiy + gupzz * phiz - -!~~~~~~ ... and then add reconstructed *untilded* Christofels... - - fxx = fxx - ( Gmxxx + TWO * ( phix + phix - dxx * phiupx - phiupx ))* fx - & - ( Gmyxx + TWO * ( - dxx * phiupy - phiupy ))* fy - & - ( Gmzxx + TWO * ( - dxx * phiupz - phiupz ))* fz - - fyy = fyy - ( Gmxyy + TWO * ( - dyy * phiupx - phiupx ))* fx - & - ( Gmyyy + TWO * ( phiy + phiy - dyy * phiupy - phiupy ))* fy - & - ( Gmzyy + TWO * ( - dyy * phiupz - phiupz ))* fz - - fzz = fzz - ( Gmxzz + TWO * ( - dzz * phiupx - phiupx ))* fx - & - ( Gmyzz + TWO * ( - dzz * phiupy - phiupy ))* fy - & - ( Gmzzz + TWO * ( phiz + phiz - dzz * phiupz - phiupz ))* fz - - fxy = fxy - ( Gmxxy + TWO * ( phiy - gxy * phiupx ))* fx - & - ( Gmyxy + TWO * ( phix - gxy * phiupy ))* fy - & - ( Gmzxy + TWO * ( - gxy * phiupz ))* fz - - fxz = fxz - ( Gmxxz + TWO * ( phiz - gxz * phiupx ))* fx - & - ( Gmyxz + TWO * ( - gxz * phiupy ))* fy - & - ( Gmzxz + TWO * ( phix - gxz * phiupz ))* fz - - fyz = fyz - ( Gmxyz + TWO * ( - gyz * phiupx ))* fx - & - ( Gmyyz + TWO * ( phiz - gyz * phiupy ))* fy - & - ( Gmzyz + TWO * ( phiy - gyz * phiupz ))* fz - - return - - end subroutine fnt_cov_s_dderiv - -!----------------------------------------------------------------------------- -! -! Get physical riemann tensor -! -!----------------------------------------------------------------------------- - - subroutine get_physical_riemann(ex, ep4phi, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & - phix, phiy, phiz, & - phixx, phixy, phixz, phiyy, phiyz, phizz, & - tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in ):: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: ep4phi - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phix,phiy,phiz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phixx,phixy,phixz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phiyy,phiyz,phizz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: tRxyxy,tRxyxz,tRxyyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: tRxzxz,tRxzyz,tRyzyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rxyxy, Rxyxz, Rxyyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rxzxz, Rxzyz, Ryzyz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: tmp - real*8,parameter::ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - -!~~~~~~> R_ijkl = tilde R_ijkl + TWO *( gli * D_j D_k phi - glj * D_i D_k phi - -! gki * D_j D_l phi + gkj * D_i D_l phi ) -! + FOUR*( gjl * D_i phi * D_k phi - gil * D_j phi * D_k phi - -! gjk * D_i phi * D_l phi + gik * D_j phi * D_l phi ) -! + FOUR*( gjk * gil - gik * gjl )* g^mn * D_m phi * D_n phi - - tmp = gupxx * phix * phix + gupyy * phiy * phiy + gupzz * phiz * phiz + & - TWO *( gupxy * phix * phiy + gupxz * phix * phiz + gupyz * phiy * phiz ) - -!~~~~~~> R_ijkl = tilde R_ijkl + TWO *( gli * phi_jk - glj * phi_ik - -! gki * phi_jl + gkj * phi_il ) -! + FOUR*( gjl * phi_i * phi_k - gil * phi_j * phi_k - -! gjk * phi_i * phi_l + gik * phi_j * phi_l ) -! + FOUR*( gjk * gil - gik * gjl )* tmp - - Rxyxy = tRxyxy + TWO *( gxy * phixy - gyy * phixx - gxx * phiyy + gxy * phixy ) & - + FOUR*( gyy * phix * phix - gxy * phiy * phix - & - gxy * phix * phiy + gxx * phiy * phiy ) & - + FOUR*( gxy * gxy - gxx * gyy )* tmp - - Rxyxz = tRxyxz + TWO *( gxz * phixy - gyz * phixx - gxx * phiyz + gxy * phixz ) & - + FOUR*( gyz * phix * phix - gxz * phiy * phix - & - gxy * phix * phiz + gxx * phiy * phiz ) & - + FOUR*( gxy * gxz - gxx * gyz )* tmp - - Rxyyz = tRxyyz + TWO *( gxz * phiyy - gyz * phixy - gxy * phiyz + gyy * phixz ) & - + FOUR*( gyz * phix * phiy - gxz * phiy * phiy - & - gyy * phix * phiz + gxy * phiy * phiz ) & - + FOUR*( gyy * gxz - gxy * gyz )* tmp - - Rxzxz = tRxzxz + TWO *( gxz * phixz - gzz * phixx - gxx * phizz + gxz * phixz ) & - + FOUR*( gzz * phix * phix - gxz * phiz * phix - & - gxz * phix * phiz + gxx * phiz * phiz ) & - + FOUR*( gxz * gxz - gxx * gzz )* tmp - - Rxzyz = tRxzyz + TWO *( gxz * phiyz - gzz * phixy - gxy * phizz + gyz * phixz ) & - + FOUR*( gzz * phix * phiy - gxz * phiz * phiy - & - gyz * phix * phiz + gxy * phiz * phiz ) & - + FOUR*( gyz * gxz - gxy * gzz )* tmp - - Ryzyz = tRyzyz + TWO *( gyz * phiyz - gzz * phiyy - gyy * phizz + gyz * phiyz ) & - + FOUR*( gzz * phiy * phiy - gyz * phiz * phiy - & - gyz * phiy * phiz + gyy * phiz * phiz ) & - + FOUR*( gyz * gyz - gyy * gzz )* tmp - -!multipli with factor exp( 4 * phi) - - Rxyxy = Rxyxy * ep4phi - Rxyxz = Rxyxz * ep4phi - Rxyyz = Rxyyz * ep4phi - Rxzxz = Rxzxz * ep4phi - Rxzyz = Rxzyz * ep4phi - Ryzyz = Ryzyz * ep4phi - - return - - end subroutine get_physical_riemann - -!----------------------------------------------------------------------------- -! -! Get physical Ricci tensor -! -!----------------------------------------------------------------------------- - - subroutine get_physical_ricci(ex,dxx,gxy,gxz,dyy,gyz,dzz,phix,phiy,phiz, & - phixx,phixy,phixz,phiyy,phiyz,phizz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - tRxx, tRxy, tRxz, tRyy, tRyz, tRzz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) - - implicit none - -!~~~~~~ argument variables - - integer, intent(in) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: phix,phiy,phiz -! covariant derivative respect to tilted metric - real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: phixx,phixy,phixz,phiyy,phiyz,phizz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: tRxx,tRxy,tRxz,tRyy,tRyz,tRzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: tempf - real*8,parameter::TWO = 2.d0, FOUR = 4.d0 - -!~~~~~~ - - tempf = TWO * (gupxx * ( phixx + TWO * phix * phix ) + & - gupyy * ( phiyy + TWO * phiy * phiy ) + & - gupzz * ( phizz + TWO * phiz * phiz ) + & - TWO * gupxy * ( phixy + TWO * phix * phiy ) + & - TWO * gupxz * ( phixz + TWO * phix * phiz ) + & - TWO * gupyz * ( phiyz + TWO * phiy * phiz ) ) - -! Add phi part to Ricci tensor: - - Rxx = tRxx - TWO * phixx + FOUR * phix * phix - dxx * tempf - tempf - Ryy = tRyy - TWO * phiyy + FOUR * phiy * phiy - dyy * tempf - tempf - Rzz = tRzz - TWO * phizz + FOUR * phiz * phiz - dzz * tempf - tempf - Rxy = tRxy - TWO * phixy + FOUR * phix * phiy - gxy * tempf - Rxz = tRxz - TWO * phixz + FOUR * phix * phiz - gxz * tempf - Ryz = tRyz - TWO * phiyz + FOUR * phiy * phiz - gyz * tempf - - return - - end subroutine get_physical_ricci - -!----------------------------------------------------------------------------- -! -! compute physical extrinic curver: -! Kij = exp( 4 * phi ) ( tilde Aij + F1o3 * tilde gij * trK ) -! -!----------------------------------------------------------------------------- - - subroutine get_physical_k(ex, phi, trK, dxx, gxy, gxz, dyy, gyz, dzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Kxx, Kxy, Kxz, Kyy, Kyz, Kzz) - implicit none - -!~~~~~~> Input parameters: - - integer,dimension(3) , intent(in) :: ex - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: phi, trK - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx, gyy, gzz - real*8, parameter :: F1o3 = 1.d0 / 3.d0, ONE = 1.d0, FOUR = 4.d0 - -!~~~~~~> - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - Kzz = exp( FOUR * phi ) - -!~~~~~~> - - Kxx = ( Axx + F1o3 * gxx * trK )* Kzz - Kxy = ( Axy + F1o3 * gxy * trK )* Kzz - Kxz = ( Axz + F1o3 * gxz * trK )* Kzz - Kyy = ( Ayy + F1o3 * gyy * trK )* Kzz - Kyz = ( Ayz + F1o3 * gyz * trK )* Kzz - Kzz = ( Azz + F1o3 * gzz * trK )* Kzz - - return - - end subroutine get_physical_k - -!------------------------------------------------------------------------------------------------------- -! -! compute covariant derivatives of extrinic curver -! -!D_i K_jk stored as DKijk -! -! DKijk = e^(4 phi) (A_jk,i - Gam^l_ij A_lk - Gam^l_ik A_jl + 1/3 g_jk trK,i) -! - 2 K_ik phi,j + 2 g_ij g^lm phi,m K_lk -! - 2 K_ij phi,k + 2 g_ik g^lm phi,m K_lj -!------------------------------------------------------------------------------------------------------- - - subroutine get_diff_physical_k(ex, phi, trK, Kx, Ky, Kz, phix, phiy, phiz, & - dxx, gxy, gxz, dyy, gyz, dzz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - Axx, Axy, Axz, Ayy, Ayz, Azz, & - Axxx, Axxy, Axxz, Axyx, Axyy, Axyz, & - Axzx, Axzy, Axzz, Ayyx, Ayyy, Ayyz, & - Ayzx, Ayzy, Ayzz, Azzx, Azzy, Azzz, & - Gmxxx,Gmxxy,Gmxxz,Gmxyy,Gmxyz,Gmxzz, & - Gmyxx,Gmyxy,Gmyxz,Gmyyy,Gmyyz,Gmyzz, & - Gmzxx,Gmzxy,Gmzxz,Gmzyy,Gmzyz,Gmzzz, & - Kxx, Kxy, Kxz, Kyy, Kyz, Kzz, & - DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & - DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & - DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz) - - implicit none - -!~~~~~~> Input parameters: - - integer,dimension(3), intent(in) :: ex - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phi,trK - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Kx,Ky,Kz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phix,phiy,phiz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axx,Axy,Axz,Ayy,Ayz,Azz -! Aij,k --> stored as Aijk - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axxx,Axxy,Axxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axyx,Axyy,Axyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axzx,Axzy,Axzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Ayyx,Ayyy,Ayyz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Ayzx,Ayzy,Ayzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Azzx,Azzy,Azzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmxxx,Gmxxy,Gmxxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmxyy,Gmxyz,Gmxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmyxx,Gmyxy,Gmyxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmyyy,Gmyyz,Gmyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmzxx,Gmzxy,Gmzxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmzyy,Gmzyz,Gmzzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz -! D_i K_jk --> stored as DKijk - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)):: phiupx,phiupy,phiupz - real*8, dimension(ex(1),ex(2),ex(3)):: phiupKx,phiupKy,phiupKz - real*8, dimension(ex(1),ex(2),ex(3)):: e4phi - real*8, dimension(ex(1),ex(2),ex(3)):: gxx,gyy,gzz - - real*8,parameter::ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 - real*8,parameter::F1o3 = 1.d0/3.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - -!~~~~~~> Input translation - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - e4phi = dexp(FOUR * phi) - -!~~~~~~> - - phiupx = gupxx * phix + gupxy * phiy + gupxz * phiz - phiupy = gupxy * phix + gupyy * phiy + gupyz * phiz - phiupz = gupxz * phix + gupyz * phiy + gupzz * phiz - - phiupKx = phiupx * Kxx + phiupy * Kxy + phiupz * Kxz - phiupKy = phiupx * Kxy + phiupy * Kyy + phiupz * Kyz - phiupKz = phiupx * Kxz + phiupy * Kyz + phiupz * Kzz - -!~~~~~~> tmp = - Gam^l_ij A_lk - Gam^l_ik A_jl - - DKxxx = - Gmxxx * Axx - Gmyxx * Axy - Gmzxx * Axz & - - Gmxxx * Axx - Gmyxx * Axy - Gmzxx * Axz - - DKxxy = - Gmxxx * Axy - Gmyxx * Ayy - Gmzxx * Ayz & - - Gmxxy * Axx - Gmyxy * Axy - Gmzxy * Axz - - DKxxz = - Gmxxx * Axz - Gmyxx * Ayz - Gmzxx * Azz & - - Gmxxz * Axx - Gmyxz * Axy - Gmzxz * Axz - - DKxyy = - Gmxxy * Axy - Gmyxy * Ayy - Gmzxy * Ayz & - - Gmxxy * Axy - Gmyxy * Ayy - Gmzxy * Ayz - - DKxyz = - Gmxxy * Axz - Gmyxy * Ayz - Gmzxy * Azz & - - Gmxxz * Axy - Gmyxz * Ayy - Gmzxz * Ayz - - DKxzz = - Gmxxz * Axz - Gmyxz * Ayz - Gmzxz * Azz & - - Gmxxz * Axz - Gmyxz * Ayz - Gmzxz * Azz - - DKyxx = - Gmxxy * Axx - Gmyxy * Axy - Gmzxy * Axz & - - Gmxxy * Axx - Gmyxy * Axy - Gmzxy * Axz - - DKyxy = - Gmxxy * Axy - Gmyxy * Ayy - Gmzxy * Ayz & - - Gmxyy * Axx - Gmyyy * Axy - Gmzyy * Axz - - DKyxz = - Gmxxy * Axz - Gmyxy * Ayz - Gmzxy * Azz & - - Gmxyz * Axx - Gmyyz * Axy - Gmzyz * Axz - - DKyyy = - Gmxyy * Axy - Gmyyy * Ayy - Gmzyy * Ayz & - - Gmxyy * Axy - Gmyyy * Ayy - Gmzyy * Ayz - - DKyyz = - Gmxyy * Axz - Gmyyy * Ayz - Gmzyy * Azz & - - Gmxyz * Axy - Gmyyz * Ayy - Gmzyz * Ayz - - DKyzz = - Gmxyz * Axz - Gmyyz * Ayz - Gmzyz * Azz & - - Gmxyz * Axz - Gmyyz * Ayz - Gmzyz * Azz - - DKzxx = - Gmxxz * Axx - Gmyxz * Axy - Gmzxz * Axz & - - Gmxxz * Axx - Gmyxz * Axy - Gmzxz * Axz - - DKzxy = - Gmxxz * Axy - Gmyxz * Ayy - Gmzxz * Ayz & - - Gmxyz * Axx - Gmyyz * Axy - Gmzyz * Axz - - DKzxz = - Gmxxz * Axz - Gmyxz * Ayz - Gmzxz * Azz & - - Gmxzz * Axx - Gmyzz * Axy - Gmzzz * Axz - - DKzyy = - Gmxyz * Axy - Gmyyz * Ayy - Gmzyz * Ayz & - - Gmxyz * Axy - Gmyyz * Ayy - Gmzyz * Ayz - - DKzyz = - Gmxyz * Axz - Gmyyz * Ayz - Gmzyz * Azz & - - Gmxzz * Axy - Gmyzz * Ayy - Gmzzz * Ayz - - DKzzz = - Gmxzz * Axz - Gmyzz * Ayz - Gmzzz * Azz & - - Gmxzz * Axz - Gmyzz * Ayz - Gmzzz * Azz - -!~~~~~~> DKijk = e^(4 phi) (A_jk,i + tmp + 1/3 g_jk K_i) -! - 2 K_ik phi,j + 2 g_ij phiupK_k -! - 2 K_ij phi,k + 2 g_ik phiupK_j - - DKxxx = e4phi * (Axxx + DKxxx + F1o3 * gxx * Kx) & - - TWO * Kxx * phix + TWO * gxx * phiupKx & - - TWO * Kxx * phix + TWO * gxx * phiupKx - - DKxxy = e4phi * (Axyx + DKxxy + F1o3 * gxy * Kx) & - - TWO * Kxy * phix + TWO * gxx * phiupKy & - - TWO * Kxx * phiy + TWO * gxy * phiupKx - - DKxxz = e4phi * (Axzx + DKxxz + F1o3 * gxz * Kx) & - - TWO * Kxz * phix + TWO * gxx * phiupKz & - - TWO * Kxx * phiz + TWO * gxz * phiupKx - - DKxyy = e4phi * (Ayyx + DKxyy + F1o3 * gyy * Kx) & - - TWO * Kxy * phiy + TWO * gxy * phiupKy & - - TWO * Kxy * phiy + TWO * gxy * phiupKy - - DKxyz = e4phi * (Ayzx + DKxyz + F1o3 * gyz * Kx) & - - TWO * Kxz * phiy + TWO * gxy * phiupKz & - - TWO * Kxy * phiz + TWO * gxz * phiupKy - - DKxzz = e4phi * (Azzx + DKxzz + F1o3 * gzz * Kx) & - - TWO * Kxz * phiz + TWO * gxz * phiupKz & - - TWO * Kxz * phiz + TWO * gxz * phiupKz - -!~~~~~~> - - DKyxx = e4phi * (Axxy + DKyxx + F1o3 * gxx * Ky) & - - TWO * Kxy * phix + TWO * gxy * phiupKx & - - TWO * Kxy * phix + TWO * gxy * phiupKx - - DKyxy = e4phi * (Axyy + DKyxy + F1o3 * gxy * Ky) & - - TWO * Kyy * phix + TWO * gxy * phiupKy & - - TWO * Kxy * phiy + TWO * gyy * phiupKx - - DKyxz = e4phi * (Axzy + DKyxz + F1o3 * gxz * Ky) & - - TWO * Kyz * phix + TWO * gxy * phiupKz & - - TWO * Kxy * phiz + TWO * gyz * phiupKx - - DKyyy = e4phi * (Ayyy + DKyyy + F1o3 * gyy * Ky) & - - TWO * Kyy * phiy + TWO * gyy * phiupKy & - - TWO * Kyy * phiy + TWO * gyy * phiupKy - - DKyyz = e4phi * (Ayzy + DKyyz + F1o3 * gyz * Ky) & - - TWO * Kyz * phiy + TWO * gyy * phiupKz & - - TWO * Kyy * phiz + TWO * gyz * phiupKy - - DKyzz = e4phi * (Azzy + DKyzz + F1o3 * gzz * Ky) & - - TWO * Kyz * phiz + TWO * gyz * phiupKz & - - TWO * Kyz * phiz + TWO * gyz * phiupKz - -!~~~~~~> - - DKzxx = e4phi * (Axxz + DKzxx + F1o3 * gxx * Kz) & - - TWO * Kxz * phix + TWO * gxz * phiupKx & - - TWO * Kxz * phix + TWO * gxz * phiupKx - - DKzxy = e4phi * (Axyz + DKzxy + F1o3 * gxy * Kz) & - - TWO * Kyz * phix + TWO * gxz * phiupKy & - - TWO * Kxz * phiy + TWO * gyz * phiupKx - - DKzxz = e4phi * (Axzz + DKzxz + F1o3 * gxz * Kz) & - - TWO * Kzz * phix + TWO * gxz * phiupKz & - - TWO * Kxz * phiz + TWO * gzz * phiupKx - - DKzyy = e4phi * (Ayyz + DKzyy + F1o3 * gyy * Kz) & - - TWO * Kyz * phiy + TWO * gyz * phiupKy & - - TWO * Kyz * phiy + TWO * gyz * phiupKy - - DKzyz = e4phi * (Ayzz + DKzyz + F1o3 * gyz * Kz) & - - TWO * Kzz * phiy + TWO * gyz * phiupKz & - - TWO * Kyz * phiz + TWO * gzz * phiupKy - - DKzzz = e4phi * (Azzz + DKzzz + F1o3 * gzz * Kz) & - - TWO * Kzz * phiz + TWO * gzz * phiupKz & - - TWO * Kzz * phiz + TWO * gzz * phiupKz - - return - - end subroutine get_diff_physical_k - -!---------------------------------------------------------------------- -!------>Begin to compute Psi4 -!------>based on quantites: -!------>triad v^i, u^i, w^i -!------>lapse and shift vector beta^i -!------>extrinsic curvature K_ij and trK -!------>covariant derivative of extrinsic curvature D_i K_jk -!------>Ricci tensor: R_ij -!------>gup^ij -!------>Riemann tensor R_ijkl -!---------------------------------------------------------------------- - - subroutine bssn_compute_psi4(ex, em4phi,lapse, betax,betay,betaz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & - vx,vy,vz,ux,uy,uz,wx,wy,wz, & - trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & - Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & - Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, & - DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & - DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & - DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz, Rpsi4, Ipsi4) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: em4phi - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: lapse - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz -!D_i K_jk ---> DKijk - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 - -!~~~~~~ local variables - -!n^i upto 1/sqrt(2) - real*8, dimension(ex(1),ex(2),ex(3)) :: nx,ny,nz -!n^i * n^k upto 1/2 - real*8, dimension(ex(1),ex(2),ex(3)) :: nnxx,nnxy,nnxz,nnyy,nnyz,nnzz -!u^j * u^l - w^j * w^l - real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz -!- u^j * w^l - w^j * u^l - real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz -! temp variables - real*8, dimension(ex(1),ex(2),ex(3)) ::temRxx, temRxy, temRxz, temRyy, temRyz, temRzz - real*8, dimension(ex(1),ex(2),ex(3)) ::temRxyxy,temRxyxz,temRxyyz,temRxzxz,temRxzyz,temRyzyz - real*8, dimension(ex(1),ex(2),ex(3)) ::lapse2 -! K^i_j - real*8, dimension(ex(1),ex(2),ex(3)) ::Kupxx,Kupxy,Kupxz,Kupyy,Kupyz,Kupzz - - real*8, parameter :: TWO = 2.d0, F1o4 = 1.d0/4.d0 - -!~~~~~~ - -! compute n^i = - beta^i/lapse - v^i - nx = - betax/lapse - vx - ny = - betay/lapse - vy - nz = - betaz/lapse - vz - -! compute nn^ij = n^i * n^j - nnxx = nx * nx - nnxy = nx * ny - nnxz = nx * nz - nnyy = ny * ny - nnyz = ny * nz - nnzz = nz * nz - -! compute uuww^ij = u^i * u^j - w^i * w^j - uuwwxx = ux * ux - wx * wx - uuwwxy = ux * uy - wx * wy - uuwwxz = ux * uz - wx * wz - uuwwyy = uy * uy - wy * wy - uuwwyz = uy * uz - wy * wz - uuwwzz = uz * uz - wz * wz - -! compute uw^ij = - u^i * w^j - w^i * u^j - uwxx = ux * wx + wx * ux - uwxy = ux * wy + wx * uy - uwxz = ux * wz + wx * uz - uwyy = uy * wy + wy * uy - uwyz = uy * wz + wy * uz - uwzz = uz * wz + wz * uz - -!Commonterm_jl = -1/4 * ( (R_ijkl + K_ik * K_jl - K_il * K_jk) * nn^ik -! - 2 * (D_l K_jk - D_k K_jl) * n^0 * n^k -! + (R_jl - K_jm * K^m_l + K * K_jl) * n^0 * n^0 -! ) - -!add trK * K_jl to R_jl - temRxx = Rxx + trK * Kxx - temRxy = Rxy + trK * Kxy - temRxz = Rxz + trK * Kxz - temRyy = Ryy + trK * Kyy - temRyz = Ryz + trK * Kyz - temRzz = Rzz + trK * Kzz - -!add - K_jm * K^m_l to R_jl - -! compute K^m_l - call raise(ex,Kxx,Kxy,Kxz,Kupxx,Kupxy,Kupxz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) - - call raise(ex,Kxy,Kyy,Kyz,Kupxy,Kupyy,Kupyz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) - - call raise(ex,Kxz,Kyz,Kzz,Kupxz,Kupyz,Kupzz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) - - temRxx = temRxx - em4phi * ( Kupxx * Kxx + Kupxy * Kxy + Kupxz * Kxz ) - - temRxy = temRxy - em4phi * ( Kupxx * Kxy + Kupxy * Kyy + Kupxz * Kyz ) - - temRxz = temRxz - em4phi * ( Kupxx * Kxz + Kupxy * Kyz + Kupxz * Kzz ) - - temRyy = temRyy - em4phi * ( Kupxy * Kxy + Kupyy * Kyy + Kupyz * Kyz ) - - temRyz = temRyz - em4phi * ( Kupxy * Kxz + Kupyy * Kyz + Kupyz * Kzz ) - - temRzz = temRzz - em4phi * ( Kupxz * Kxz + Kupyz * Kyz + Kupzz * Kzz ) - -! multiply with n^0 * n^0 upto 1/2 -! n^0 = 1/(sqrt(2) * lapse) - lapse2 = lapse * lapse - - temRxx = temRxx/lapse2 - temRxy = temRxy/lapse2 - temRxz = temRxz/lapse2 - temRyy = temRyy/lapse2 - temRyz = temRyz/lapse2 - temRzz = temRzz/lapse2 - -!add (K_ik * K_jl - K_il * K_jk) to R_ijkl, note they have the same symmetric index - - temRxyxy = Rxyxy + Kxx * Kyy - Kxy * Kxy - temRxyxz = Rxyxz + Kxx * Kyz - Kxz * Kxy - temRxyyz = Rxyyz + Kxy * Kyz - Kxz * Kyy - temRxzxz = Rxzxz + Kxx * Kzz - Kxz * Kxz - temRxzyz = Rxzyz + Kxy * Kzz - Kxz * Kyz - temRyzyz = Ryzyz + Kyy * Kzz - Kyz * Kyz - -!add (R_ijkl + K_ik * K_jl - K_il * K_jk) * nn^ik to R_jl, upto 1/2 -! note they have the same symmetric index - temRxx = temRxx + temRxyxy * nnyy + temRxyxz * nnyz + temRxyxz * nnyz + temRxzxz * nnzz - temRxy = temRxy - temRxyxy * nnxy + temRxyyz * nnyz - temRxyxz * nnxz + temRxzyz * nnzz - temRxz = temRxz - temRxyxz * nnxy - temRxyyz * nnyy - temRxzxz * nnxz - temRxzyz * nnyz - temRyy = temRyy + temRxyxy * nnxx - temRxyyz * nnxz - temRxyyz * nnxz + temRyzyz * nnzz - temRyz = temRyz + temRxyxz * nnxx + temRxyyz * nnxy - temRxzyz * nnxz - temRyzyz * nnyz - temRzz = temRzz + temRxzxz * nnxx + temRxzyz * nnxy + temRxzyz * nnxy + temRyzyz * nnyy - -!add 2 * (D_k K_jl * n^0 * n^k) to R_jl, upto 1/2 - temRxx = temRxx + TWO * ( DKxxx * nx + DKyxx * ny + DKzxx * nz)/lapse - temRxy = temRxy + TWO * ( DKxxy * nx + DKyxy * ny + DKzxy * nz)/lapse - temRxz = temRxz + TWO * ( DKxxz * nx + DKyxz * ny + DKzxz * nz)/lapse - temRyy = temRyy + TWO * ( DKxyy * nx + DKyyy * ny + DKzyy * nz)/lapse - temRyz = temRyz + TWO * ( DKxyz * nx + DKyyz * ny + DKzyz * nz)/lapse - temRzz = temRzz + TWO * ( DKxzz * nx + DKyzz * ny + DKzzz * nz)/lapse - -!add - (D_l K_jk + D_j K_lk) * n^0 * ^k to R_jl, upto 1/2 -! note we symmetrize the index here - temRxx = temRxx - ((DKxxx + DKxxx) * nx + (DKxxy + DKxxy) * ny + (DKxxz + DKxxz) * nz)/lapse - temRxy = temRxy - ((DKyxx + DKxxy) * nx + (DKyxy + DKxyy) * ny + (DKyxz + DKxyz) * nz)/lapse - temRxz = temRxz - ((DKzxx + DKxxz) * nx + (DKzxy + DKxyz) * ny + (DKzxz + DKxzz) * nz)/lapse - temRyy = temRyy - ((DKyxy + DKyxy) * nx + (DKyyy + DKyyy) * ny + (DKyyz + DKyyz) * nz)/lapse - temRyz = temRyz - ((DKzxy + DKyxz) * nx + (DKzyy + DKyyz) * ny + (DKzyz + DKyzz) * nz)/lapse - temRzz = temRzz - ((DKzxz + DKzxz) * nx + (DKzyz + DKzyz) * ny + (DKzzz + DKzzz) * nz)/lapse - -!the real part of Psi4 - Rpsi4 = temRxx * uuwwxx + temRyy * uuwwyy + temRzz * uuwwzz & - + (temRxy * uuwwxy + temRxz * uuwwxz + temRyz * uuwwyz) * TWO - -!the imaginary part of Psi4 - Ipsi4 = temRxx * uwxx + temRyy * uwyy + temRzz * uwzz & - + (temRxy * uwxy + temRxz * uwxz + temRyz * uwyz) * TWO - -!multiply with -1/4 - Rpsi4 = - F1o4 * Rpsi4 - Ipsi4 = - F1o4 * Ipsi4 - - return - - end subroutine bssn_compute_psi4 -!----------------------------------------------------------------------------- -! covariant derivatives w.r.t *tilded metric* of *symmetric* variable -!----------------------------------------------------------------------------- - - subroutine xcov_deriv(ex,fx,fy,fz,fxx,fxy,fxz,fyy,fyz,fzz, & - Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) - implicit none - -!~~~~~~ Input arguments - - integer, intent(in ) :: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx, fy, fz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamzyy, Gamzyz, Gamzzz - -!~~~~~~ Add Connection terms - - fxx = fxx - Gamxxx * fx - Gamyxx * fy - Gamzxx * fz - fxy = fxy - Gamxxy * fx - Gamyxy * fy - Gamzxy * fz - fxz = fxz - Gamxxz * fx - Gamyxz * fy - Gamzxz * fz - fyy = fyy - Gamxyy * fx - Gamyyy * fy - Gamzyy * fz - fyz = fyz - Gamxyz * fx - Gamyyz * fy - Gamzyz * fz - fzz = fzz - Gamxzz * fx - Gamyzz * fy - Gamzzz * fz - - return - - end subroutine xcov_deriv - -!-------------------------------------------------------------------- -! Gram-Schmidt orthonormal in Cartesin coordinate -! V1 = [ x, y, z ] -! V2 = [-y, x, ZEO] -! V3 = [xz,yz,-(x^2+y^2)] -! V1 -> V1 / sqrt(W11) -! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) -! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) -! W_ij = g_ab * Vi^a * Vj^b -! it is metric, not tilde metric -! V1 first -!-------------------------------------------------------------------- - - subroutine get_triad0(ex, X, Y, Z, ep4phi, & - gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) -! tilted metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: norm - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz - - real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 - integer::i,j,k - -!~~~~~~ - - gxx = gxxi * ep4phi - gxy = gxyi * ep4phi - gxz = gxzi * ep4phi - gyy = gyyi * ep4phi - gyz = gyzi * ep4phi - gzz = gzzi * ep4phi - -! initialize U, V, W vetors - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - - enddo - enddo - enddo - -! Gram-Schmidt orthonormalization - call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx/dsqrt(norm) - vy = vy/dsqrt(norm) - vz = vz/dsqrt(norm) - - call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux - norm*vx - uy = uy - norm*vy - uz = uz - norm*vz - - call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux/dsqrt(norm) - uy = uy/dsqrt(norm) - uz = uz/dsqrt(norm) - - call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*vx - wy = wy - norm*vy - wz = wz - norm*vz - - call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*ux - wy = wy - norm*uy - wz = wz - norm*uz - - call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx/dsqrt(norm) - wy = wy/dsqrt(norm) - wz = wz/dsqrt(norm) - - return - - end subroutine get_triad0 -!-------------------------------------------------------------------- -! Gram-Schmidt orthonormal in Cartesin coordinate -! V1 = [ x, y, z ] -! V2 = [-y, x, ZEO] -! V3 = [xz,yz,-(x^2+y^2)] -! V1 -> V1 / sqrt(W11) -! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) -! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) -! W_ij = g_ab * Vi^a * Vj^b -! it is metric, not tilde metric -! V2 first -!-------------------------------------------------------------------- - - subroutine get_triad1(ex, X, Y, Z, ep4phi, & - gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) -! tilted metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: norm - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz - - real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 - integer::i,j,k - -!~~~~~~ - - gxx = gxxi * ep4phi - gxy = gxyi * ep4phi - gxz = gxzi * ep4phi - gyy = gyyi * ep4phi - gyz = gyzi * ep4phi - gzz = gzzi * ep4phi - -! initialize U, V, W vetors - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - - enddo - enddo - enddo - -! Gram-Schmidt orthonormalization - call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux/dsqrt(norm) - uy = uy/dsqrt(norm) - uz = uz/dsqrt(norm) - - call InnerProd(ex,norm,vx,vy,vz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx - norm*ux - vy = vy - norm*uy - vz = vz - norm*uz - - call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx/dsqrt(norm) - vy = vy/dsqrt(norm) - vz = vz/dsqrt(norm) - - call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*ux - wy = wy - norm*uy - wz = wz - norm*uz - - call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*vx - wy = wy - norm*vy - wz = wz - norm*vz - - call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx/dsqrt(norm) - wy = wy/dsqrt(norm) - wz = wz/dsqrt(norm) - - return - - end subroutine get_triad1 -!-------------------------------------------------------------------- -! Gram-Schmidt orthonormal in Cartesin coordinate -! V1 = [ x, y, z ] -! V2 = [-y, x, ZEO] -! V3 = [xz,yz,-(x^2+y^2)] -! V1 -> V1 / sqrt(W11) -! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) -! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) -! W_ij = g_ab * Vi^a * Vj^b -! it is metric, not tilde metric -! raise V1, then V1 first -!-------------------------------------------------------------------- - - subroutine get_triad2(ex, X, Y, Z, ep4phi, & - gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) -! tilted metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: norm,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz - - real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 - integer::i,j,k - -!~~~~~~ - - gxx = gxxi * ep4phi - gxy = gxyi * ep4phi - gxz = gxzi * ep4phi - gyy = gyyi * ep4phi - gyz = gyzi * ep4phi - gzz = gzzi * ep4phi -! invert metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz -! initialize U, V, W vetors - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - call raise(ex,fx,fy,fz,vx,vy,vz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) -! Gram-Schmidt orthonormalization - call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx/dsqrt(norm) - vy = vy/dsqrt(norm) - vz = vz/dsqrt(norm) - - call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux - norm*vx - uy = uy - norm*vy - uz = uz - norm*vz - - call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux/dsqrt(norm) - uy = uy/dsqrt(norm) - uz = uz/dsqrt(norm) - - call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*vx - wy = wy - norm*vy - wz = wz - norm*vz - - call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*ux - wy = wy - norm*uy - wz = wz - norm*uz - - call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx/dsqrt(norm) - wy = wy/dsqrt(norm) - wz = wz/dsqrt(norm) - - return - - end subroutine get_triad2 -!***********for shell********************* -!-------------------------------------------------------------------- -! Gram-Schmidt orthonormal in Cartesin coordinate -! V1 = [ x, y, z ] -! V2 = [-y, x, ZEO] -! V3 = [xz,yz,-(x^2+y^2)] -! V1 -> V1 / sqrt(W11) -! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) -! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) -! W_ij = g_ab * Vi^a * Vj^b -! it is metric, not tilde metric -! V1 first -!-------------------------------------------------------------------- - - subroutine get_triad0_ss(ex, X, Y, Z, ep4phi, & - gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) -! tilted metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: norm - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz - - real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - -!~~~~~~ - - gxx = gxxi * ep4phi - gxy = gxyi * ep4phi - gxz = gxzi * ep4phi - gyy = gyyi * ep4phi - gyz = gyzi * ep4phi - gzz = gzzi * ep4phi - -! initialize U, V, W vetors - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - - enddo - enddo - enddo - -! Gram-Schmidt orthonormalization - call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx/dsqrt(norm) - vy = vy/dsqrt(norm) - vz = vz/dsqrt(norm) - - call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux - norm*vx - uy = uy - norm*vy - uz = uz - norm*vz - - call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux/dsqrt(norm) - uy = uy/dsqrt(norm) - uz = uz/dsqrt(norm) - - call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*vx - wy = wy - norm*vy - wz = wz - norm*vz - - call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*ux - wy = wy - norm*uy - wz = wz - norm*uz - - call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx/dsqrt(norm) - wy = wy/dsqrt(norm) - wz = wz/dsqrt(norm) - - return - - end subroutine get_triad0_ss -!-------------------------------------------------------------------- -! Gram-Schmidt orthonormal in Cartesin coordinate -! V1 = [ x, y, z ] -! V2 = [-y, x, ZEO] -! V3 = [xz,yz,-(x^2+y^2)] -! V1 -> V1 / sqrt(W11) -! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) -! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) -! W_ij = g_ab * Vi^a * Vj^b -! it is metric, not tilde metric -! V2 first -!-------------------------------------------------------------------- - - subroutine get_triad1_ss(ex, X, Y, Z, ep4phi, & - gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) -! tilted metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: norm - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz - - real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - -!~~~~~~ - - gxx = gxxi * ep4phi - gxy = gxyi * ep4phi - gxz = gxzi * ep4phi - gyy = gyyi * ep4phi - gyz = gyzi * ep4phi - gzz = gzzi * ep4phi - -! initialize U, V, W vetors - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - - enddo - enddo - enddo - -! Gram-Schmidt orthonormalization - call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux/dsqrt(norm) - uy = uy/dsqrt(norm) - uz = uz/dsqrt(norm) - - call InnerProd(ex,norm,vx,vy,vz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx - norm*ux - vy = vy - norm*uy - vz = vz - norm*uz - - call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx/dsqrt(norm) - vy = vy/dsqrt(norm) - vz = vz/dsqrt(norm) - - call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*ux - wy = wy - norm*uy - wz = wz - norm*uz - - call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*vx - wy = wy - norm*vy - wz = wz - norm*vz - - call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx/dsqrt(norm) - wy = wy/dsqrt(norm) - wz = wz/dsqrt(norm) - - return - - end subroutine get_triad1_ss -!-------------------------------------------------------------------- -! Gram-Schmidt orthonormal in Cartesin coordinate -! V1 = [ x, y, z ] -! V2 = [-y, x, ZEO] -! V3 = [xz,yz,-(x^2+y^2)] -! V1 -> V1 / sqrt(W11) -! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) -! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) -! W_ij = g_ab * Vi^a * Vj^b -! it is metric, not tilde metric -! raise V1, then V1 first -!-------------------------------------------------------------------- - - subroutine get_triad2_ss(ex, X, Y, Z, ep4phi, & - gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & - vx,vy,vz,ux,uy,uz,wx,wy,wz) - - implicit none - -!~~~~~~ argument variables - - integer,intent(in ):: ex(1:3) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) -! tilted metric - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - -!~~~~~~ local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: norm,fx,fy,fz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz - - real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - -!~~~~~~ - - gxx = gxxi * ep4phi - gxy = gxyi * ep4phi - gxz = gxzi * ep4phi - gyy = gyyi * ep4phi - gyz = gyzi * ep4phi - gzz = gzzi * ep4phi -! invert metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz -! initialize U, V, W vetors - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - call raise(ex,fx,fy,fz,vx,vy,vz, & - gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) -! Gram-Schmidt orthonormalization - call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - vx = vx/dsqrt(norm) - vy = vy/dsqrt(norm) - vz = vz/dsqrt(norm) - - call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux - norm*vx - uy = uy - norm*vy - uz = uz - norm*vz - - call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - ux = ux/dsqrt(norm) - uy = uy/dsqrt(norm) - uz = uz/dsqrt(norm) - - call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*vx - wy = wy - norm*vy - wz = wz - norm*vz - - call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx - norm*ux - wy = wy - norm*uy - wz = wz - norm*uz - - call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) - wx = wx/dsqrt(norm) - wy = wy/dsqrt(norm) - wz = wz/dsqrt(norm) - - return - - end subroutine get_triad2_ss + + +#include "macrodef.fh" + +!----------------------------------------------------------------------------- +! +! compute rhw Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! +!----------------------------------------------------------------------------- + + subroutine getnp4old(ex, X, Y, Z, chi, trK, & + dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ep4phi,alpn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: phi,phix,phiy,phiz + real*8, dimension(ex(1),ex(2),ex(3)) :: phixx,phixy,phixz,phiyy,phiyz,phizz + real*8, dimension(ex(1),ex(2),ex(3)) :: tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: tRxx,tRxy,tRxz,tRyy,tRyz,tRzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz + + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz +!D_i K_jk ---> DKijk + real*8, dimension(ex(1),ex(2),ex(3)) :: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz +! Aij,k --> stored as Aijk + real*8, dimension(ex(1),ex(2),ex(3))::Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3))::Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3))::Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3))::Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3))::Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3))::Azzx,Azzy,Azzz +! trK,i + real*8, dimension(ex(1),ex(2),ex(3))::Kx,Ky,Kz + + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz +! first order partial derivative of metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxxy,gxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyx,gxyy,gxyz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzx,gxzy,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyyy,gyyz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzx,gyzy,gyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzx,gzzy,gzzz +! second order partial derivative of metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + + real*8, parameter :: F1o4=2.5d-1,ONE=1.d0,TWO=2.d0,FOUR=4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + phi = -0.25d0*dlog(chi+ONE) +!~~~~~~ + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + alpn1 = Lap + ONE + + ep4phi = dexp( FOUR * Phi ) + +!~~~~~~> + + call d1metric(ex,X,Y,Z, & + dxx ,gxy ,gxz ,dyy ,gyz ,dzz , & + gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, symmetry) + + call d2metric(ex,X,Y,Z, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, symmetry) + + call kind1_connection(ex, gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz,& + ass_Gamxyy, ass_Gamxyz, ass_Gamxzz,& + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz,& + ass_Gamyyy, ass_Gamyyz, ass_Gamyzz,& + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz,& + ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) + + call kind2_connection(ex, gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & + ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & + ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & + ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + +!~~~~~~> derivs of conformal factor + + call fderivs(ex,phi,phix,phiy,phiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + + call fdderivs(ex,phi,phixx,phixy,phixz,phiyy,phiyz,phizz,X,Y,Z, & + SYM,SYM,SYM,symmetry,0) + + call xcov_deriv(ex, phix, phiy, phiz, & + phixx, phixy, phixz, phiyy, phiyz, phizz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + +!~~~~~~> get spatial Riemann curvature + + call adm_riemann(ex, gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, & + ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & + ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, & + ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & + ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, & + ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & + tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz) + + call get_physical_riemann(ex, ep4phi, & + dxx , gxy , gxz , dyy , gyz , dzz , & + gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & + phix , phiy , phiz , & + phixx , phixy , phixz , phiyy , phiyz , phizz , & + tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) + +!~~~~~~> get spatial Ricci tensor + + call adm_ricci(ex, gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & + tRxyxy,tRxyxz,tRxyyz,tRxzxz,tRxzyz,tRyzyz, & + tRxx, tRxy, tRxz, tRyy, tRyz, tRzz) + + call get_physical_ricci(ex,dxx,gxy,gxz,dyy,gyz,dzz,phix,phiy,phiz, & + phixx,phixy,phixz,phiyy,phiyz,phizz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + tRxx, tRxy, tRxz, tRyy, tRyz, tRzz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) + +!~~~~~~> get the real spatial extrinsic curvature + + call get_physical_k(ex, phi, trK, dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Kxx, Kxy, Kxz, Kyy, Kyz, Kzz) + +!~~~~~~> derivs of trace of extrinsic curvature + + call fderivs(ex,trK, Kx, Ky, Kz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + +!~~~~~~> derivs of tilde extrinsic curvature + + call fderivs(ex,Axx,Axxx,Axxy,Axxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Axy,Axyx,Axyy,Axyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Axz,Axzx,Axzy,Axzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,Ayy,Ayyx,Ayyy,Ayyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Ayz,Ayzx,Ayzy,Ayzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,Azz,Azzx,Azzy,Azzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + +!~~~~~~> derivs of extrinsic curvature, Kij + + call get_diff_physical_k(ex, phi, trK, Kx, Ky, Kz, phix, phiy, phiz, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Axxx, Axxy, Axxz, Axyx, Axyy, Axyz, & + Axzx, Axzy, Axzz, Ayyx, Ayyy, Ayyz, & + Ayzx, Ayzy, Ayzz, Azzx, Azzy, Azzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + Kxx, Kxy, Kxz, Kyy, Kyz, Kzz, & + DKxxx, DKxxy, DKxxz, DKxyy, DKxyz, DKxzz, & + DKyxx, DKyxy, DKyxz, DKyyy, DKyyz, DKyzz, & + DKzxx, DKzxy, DKzxz, DKzyy, DKzyz, DKzzz) + +!~~~~~~> get the Gram-Schmidt orthonormalize triad coordinate +#if (tetradtype == 0) + call get_triad0(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) +#elif (tetradtype == 1) + call get_triad1(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) +#elif (tetradtype == 2) + call get_triad2(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) +#endif + +!~~~~~~> compute the Newnamm-Penrose psi4 which split real and image part + + ep4phi = ONE / ep4phi + + call bssn_compute_psi4(ex,ep4phi, alpn1, Sfx, Sfy, Sfz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz, & + trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Rxyxy,Rxyxz,Rxyyz,Rxzxz,Rxzyz,Ryzyz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, & + DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & + DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & + DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz, Rpsi4, Ipsi4) + + return + + end subroutine getnp4old +!----------------------------------------------------------------------------------- +! for shell +! + + subroutine getnp4old_ss(ex,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, trK, & + dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,Rpsi4,Ipsi4, symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3),symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ep4phi,alpn1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: phi,phix,phiy,phiz + real*8, dimension(ex(1),ex(2),ex(3)) :: phixx,phixy,phixz,phiyy,phiyz,phizz + real*8, dimension(ex(1),ex(2),ex(3)) :: tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: tRxx,tRxy,tRxz,tRyy,tRyz,tRzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz + + real*8, dimension(ex(1),ex(2),ex(3)) :: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz +!D_i K_jk ---> DKijk + real*8, dimension(ex(1),ex(2),ex(3)) :: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz +! Aij,k --> stored as Aijk + real*8, dimension(ex(1),ex(2),ex(3))::Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3))::Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3))::Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3))::Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3))::Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3))::Azzx,Azzy,Azzz +! trK,i + real*8, dimension(ex(1),ex(2),ex(3))::Kx,Ky,Kz + + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz +! first order partial derivative of metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxxy,gxxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyx,gxyy,gxyz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzx,gxzy,gxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyx,gyyy,gyyz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzx,gyzy,gyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzx,gzzy,gzzz +! second order partial derivative of metric + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + + real*8, parameter :: F1o4=2.5d-1,ONE=1.d0,TWO=2.d0,FOUR=4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8,parameter::TINYRR=1.d-14 + + phi = -0.25d0*dlog(chi+ONE) +!~~~~~~ + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + + alpn1 = Lap + ONE + + ep4phi = dexp( FOUR * Phi ) + +!~~~~~~> + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + call kind1_connection(ex, gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz,& + ass_Gamxyy, ass_Gamxyz, ass_Gamxzz,& + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz,& + ass_Gamyyy, ass_Gamyyz, ass_Gamyzz,& + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz,& + ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) + + call kind2_connection(ex, gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & + ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & + ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & + ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + +!~~~~~~> derivs of conformal factor + call fderivs_shc(ex,phi,phix,phiy,phiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fdderivs_shc(ex,phi,phixx,phixy,phixz,phiyy,phiyz,phizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + call xcov_deriv(ex, phix, phiy, phiz, & + phixx, phixy, phixz, phiyy, phiyz, phizz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + +!~~~~~~> get spatial Riemann curvature + + call adm_riemann(ex, gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, & + ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & + ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, & + ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & + ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, & + ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & + tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz) + + call get_physical_riemann(ex, ep4phi, & + dxx , gxy , gxz , dyy , gyz , dzz , & + gupxx , gupxy , gupxz , gupyy , gupyz , gupzz , & + phix , phiy , phiz , & + phixx , phixy , phixz , phiyy , phiyz , phizz , & + tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) + +!~~~~~~> get spatial Ricci tensor + + call adm_ricci(ex, gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & + tRxyxy,tRxyxz,tRxyyz,tRxzxz,tRxzyz,tRyzyz, & + tRxx, tRxy, tRxz, tRyy, tRyz, tRzz) + + call get_physical_ricci(ex,dxx,gxy,gxz,dyy,gyz,dzz,phix,phiy,phiz, & + phixx,phixy,phixz,phiyy,phiyz,phizz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + tRxx, tRxy, tRxz, tRyy, tRyz, tRzz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) + +!~~~~~~> get the real spatial extrinsic curvature + + call get_physical_k(ex, phi, trK, dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Kxx, Kxy, Kxz, Kyy, Kyz, Kzz) + +!~~~~~~> derivs of trace of extrinsic curvature + call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +!~~~~~~> derivs of tilde extrinsic curvature + + call fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +!~~~~~~> derivs of extrinsic curvature, Kij + + call get_diff_physical_k(ex, phi, trK, Kx, Ky, Kz, phix, phiy, phiz, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Axxx, Axxy, Axxz, Axyx, Axyy, Axyz, & + Axzx, Axzy, Axzz, Ayyx, Ayyy, Ayyz, & + Ayzx, Ayzy, Ayzz, Azzx, Azzy, Azzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + Kxx, Kxy, Kxz, Kyy, Kyz, Kzz, & + DKxxx, DKxxy, DKxxz, DKxyy, DKxyz, DKxzz, & + DKyxx, DKyxy, DKyxz, DKyyy, DKyyz, DKyzz, & + DKzxx, DKzxy, DKzxz, DKzyy, DKzyz, DKzzz) + +!~~~~~~> get the Gram-Schmidt orthonormalize triad coordinate + +#if (tetradtype == 0) + call get_triad0_ss(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) +#elif (tetradtype == 1) + call get_triad1_ss(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) +#elif (tetradtype == 2) + call get_triad2_ss(ex, X, Y, Z, ep4phi, gxx, gxy, gxz, gyy, gyz, gzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) +#endif + +!~~~~~~> compute the Newnamm-Penrose psi4 which split real and image part + + ep4phi = ONE / ep4phi + + call bssn_compute_psi4(ex,ep4phi, alpn1, Sfx, Sfy, Sfz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz, & + trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Rxyxy,Rxyxz,Rxyyz,Rxzxz,Rxzyz,Ryzyz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, & + DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & + DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & + DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz, Rpsi4, Ipsi4) + + return + + end subroutine getnp4old_ss +!----------------------------------------------------------! +! ! +! derivatives related to 3-dimensional Riemann slice ! +! ! +!----------------------------------------------------------! + +!----------------------------------------------------------------------------- +! Interface to compute the first order derivative of metric +!----------------------------------------------------------------------------- + + subroutine d1metric(ex,X,Y,Z, & + dxx ,gxy ,gxz ,dyy ,gyz ,dzz , & + gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, symmetry) + + implicit none + +!~~~~~~ Input parameters: + + integer, intent(in ) :: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + +!~~~~~~ local variables + + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + +!~~~~~~ 1st derivs of matric + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,0) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,symmetry,0) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,symmetry,0) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,0) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,symmetry,0) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,0) + + return + + end subroutine d1metric + +!----------------------------------------------------------------------------- +! Interface to compute the second order derivative of metric +!----------------------------------------------------------------------------- + + subroutine d2metric(ex,X,Y,Z, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, symmetry) + + implicit none + +!~~~~~~ Input parameters: + + integer, intent(in ) :: ex(1:3),symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + +!~~~~~~ local variables + + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + +!~~~~~~ 2nd derivs of matric + + call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z, & + SYM ,SYM ,SYM ,symmetry,0) + call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z, & + ANTI,ANTI,SYM ,symmetry,0) + call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z, & + ANTI,SYM ,ANTI,symmetry,0) + call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z, & + SYM, SYM ,SYM ,symmetry,0) + call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z, & + SYM ,ANTI,ANTI,symmetry,0) + call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z, & + SYM ,SYM ,SYM ,symmetry,0) + + return + + end subroutine d2metric +!----------------------------------------------------------! +! ! +! algebraic computation based on geometric quantites ! +! and their partial derivatives related to 3-dimensional ! +! Riemann slice ! +! ! +!----------------------------------------------------------! + +!----------------------------------------------------------------------------- +! Get first kind of connection coefficients +! based on first order derivative of metric +! ass_Gam_ijk = 1/2 *(g_ij,k + g_ki,j - g_jk,i) +!----------------------------------------------------------------------------- + + subroutine kind1_connection(ex,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & + ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & + ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & + ass_Gamzyy, ass_Gamzyz, ass_Gamzzz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxxx,gxyx,gxzx + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxxy,gxyy,gxzy + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxxz,gxyz,gxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz + +!~~~~~~> Other variables: + + real*8, parameter :: HLF=0.5d0 + +!~~~~~~= Get Connection coefficients +! ass_Gam_ijk = 1/2 *(g_ij,k + g_ki,j - g_jk,i) + + ass_Gamxxx = HLF * ( gxxx ) + ass_Gamyxx = HLF * ( gxyx + gxyx - gxxy ) + ass_Gamzxx = HLF * ( gxzx + gxzx - gxxz ) + ass_Gamxyy = HLF * ( gxyy + gxyy - gyyx ) + ass_Gamyyy = HLF * ( gyyy ) + ass_Gamzyy = HLF * ( gyzy + gyzy - gyyz ) + ass_Gamxzz = HLF * ( gxzz + gxzz - gzzx ) + ass_Gamyzz = HLF * ( gyzz + gyzz - gzzy ) + ass_Gamzzz = HLF * ( gzzz ) + ass_Gamxxy = HLF * ( gxxy + gxyx - gxyx ) + ass_Gamyxy = HLF * ( gxyy + gyyx - gxyy ) + ass_Gamzxy = HLF * ( gxzy + gyzx - gxyz ) + ass_Gamxxz = HLF * ( gxxz + gxzx - gxzx ) + ass_Gamyxz = HLF * ( gxyz + gyzx - gxzy ) + ass_Gamzxz = HLF * ( gxzz + gzzx - gxzz ) + ass_Gamxyz = HLF * ( gxyz + gxzy - gyzx ) + ass_Gamyyz = HLF * ( gyyz + gyzy - gyzy ) + ass_Gamzyz = HLF * ( gyzz + gzzy - gyzz ) + + return + + end subroutine kind1_connection + +!----------------------------------------------------------------------------- +! Get second kind of connection coefficients +! based on first kind of connection coefficients +! and gup +!----------------------------------------------------------------------------- + + subroutine kind2_connection(ex,gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + ass_Gamxxx, ass_Gamxxy, ass_Gamxxz, & + ass_Gamxyy, ass_Gamxyz, ass_Gamxzz, & + ass_Gamyxx, ass_Gamyxy, ass_Gamyxz, & + ass_Gamyyy, ass_Gamyyz, ass_Gamyzz, & + ass_Gamzxx, ass_Gamzxy, ass_Gamzxz, & + ass_Gamzyy, ass_Gamzyz, ass_Gamzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gamzyy, Gamzyz, Gamzzz + +!~~~~~~> Other variables: + + Gamxxx = gupxx * ass_Gamxxx + gupxy * ass_Gamyxx + gupxz * ass_Gamzxx + Gamxxy = gupxx * ass_Gamxxy + gupxy * ass_Gamyxy + gupxz * ass_Gamzxy + Gamxxz = gupxx * ass_Gamxxz + gupxy * ass_Gamyxz + gupxz * ass_Gamzxz + Gamxyy = gupxx * ass_Gamxyy + gupxy * ass_Gamyyy + gupxz * ass_Gamzyy + Gamxyz = gupxx * ass_Gamxyz + gupxy * ass_Gamyyz + gupxz * ass_Gamzyz + Gamxzz = gupxx * ass_Gamxzz + gupxy * ass_Gamyzz + gupxz * ass_Gamzzz + + Gamyxx = gupxy * ass_Gamxxx + gupyy * ass_Gamyxx + gupyz * ass_Gamzxx + Gamyxy = gupxy * ass_Gamxxy + gupyy * ass_Gamyxy + gupyz * ass_Gamzxy + Gamyxz = gupxy * ass_Gamxxz + gupyy * ass_Gamyxz + gupyz * ass_Gamzxz + Gamyyy = gupxy * ass_Gamxyy + gupyy * ass_Gamyyy + gupyz * ass_Gamzyy + Gamyyz = gupxy * ass_Gamxyz + gupyy * ass_Gamyyz + gupyz * ass_Gamzyz + Gamyzz = gupxy * ass_Gamxzz + gupyy * ass_Gamyzz + gupyz * ass_Gamzzz + + Gamzxx = gupxz * ass_Gamxxx + gupyz * ass_Gamyxx + gupzz * ass_Gamzxx + Gamzxy = gupxz * ass_Gamxxy + gupyz * ass_Gamyxy + gupzz * ass_Gamzxy + Gamzxz = gupxz * ass_Gamxxz + gupyz * ass_Gamyxz + gupzz * ass_Gamzxz + Gamzyy = gupxz * ass_Gamxyy + gupyz * ass_Gamyyy + gupzz * ass_Gamzyy + Gamzyz = gupxz * ass_Gamxyz + gupyz * ass_Gamyyz + gupzz * ass_Gamzyz + Gamzzz = gupxz * ass_Gamxzz + gupyz * ass_Gamyzz + gupzz * ass_Gamzzz + + return + + end subroutine kind2_connection + +!---------------------------------------------------------------------- +! compute Riemann tensor for three dimensional space +! based on second derivatives of metric +! and first knid and second kind of connection +!---------------------------------------------------------------------- + + subroutine adm_riemann(ex,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz, & + ass_Gamxxx,ass_Gamxxy,ass_Gamxxz, & + ass_Gamxyy,ass_Gamxyz,ass_Gamxzz, & + ass_Gamyxx,ass_Gamyxy,ass_Gamyxz, & + ass_Gamyyy,ass_Gamyyz,ass_Gamyzz, & + ass_Gamzxx,ass_Gamzxy,ass_Gamzxz, & + ass_Gamzyy,ass_Gamzyz,ass_Gamzzz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamzyy, Gamzyz, Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamxxx,ass_Gamxxy,ass_Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamxyy,ass_Gamxyz,ass_Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamyxx,ass_Gamyxy,ass_Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamyyy,ass_Gamyyz,ass_Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamzxx,ass_Gamzxy,ass_Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ass_Gamzyy,ass_Gamzyz,ass_Gamzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz + +!~~~~~~local variables + + real*8, parameter :: HLF=0.5d0 + +!R_ijkl = HLF *(@_jk g_il + @_il g_jk - @_jl g_ik - @_ik g_jl) +! + Gam_rjk Gam^r_il - Gam_rjl Gam^r_ik + + Rxyxy = HLF *( gxyxy + gxyxy - gxxyy - gyyxx ) + & + (ass_Gamxxy * Gamxxy + ass_Gamyxy * Gamyxy + ass_Gamzxy * Gamzxy) - & + (ass_Gamxyy * Gamxxx + ass_Gamyyy * Gamyxx + ass_Gamzyy * Gamzxx) + + Rxyxz = HLF *( gxzxy + gxyxz - gxxyz - gyzxx ) + & + (ass_Gamxxy * Gamxxz + ass_Gamyxy * Gamyxz + ass_Gamzxy * Gamzxz) - & + (ass_Gamxyz * Gamxxx + ass_Gamyyz * Gamyxx + ass_Gamzyz * Gamzxx) + + Rxyyz = HLF *( gxzyy + gyyxz - gxyyz - gyzxy ) + & + (ass_Gamxyy * Gamxxz + ass_Gamyyy * Gamyxz + ass_Gamzyy * Gamzxz) - & + (ass_Gamxyz * Gamxxy + ass_Gamyyz * Gamyxy + ass_Gamzyz * Gamzxy) + + Rxzxz = HLF *( gxzxz + gxzxz - gxxzz - gzzxx ) + & + (ass_Gamxxz * Gamxxz + ass_Gamyxz * Gamyxz + ass_Gamzxz * Gamzxz) - & + (ass_Gamxzz * Gamxxx + ass_Gamyzz * Gamyxx + ass_Gamzzz * Gamzxx) + + Rxzyz = HLF *( gxzyz + gyzxz - gxyzz - gzzxy ) + & + (ass_Gamxyz * Gamxxz + ass_Gamyyz * Gamyxz + ass_Gamzyz * Gamzxz) - & + (ass_Gamxzz * Gamxxy + ass_Gamyzz * Gamyxy + ass_Gamzzz * Gamzxy) + + Ryzyz = HLF *( gyzyz + gyzyz - gyyzz - gzzyy ) + & + (ass_Gamxyz * Gamxyz + ass_Gamyyz * Gamyyz + ass_Gamzyz * Gamzyz) - & + (ass_Gamxzz * Gamxyy + ass_Gamyzz * Gamyyy + ass_Gamzzz * Gamzyy) + + return + + end subroutine adm_riemann + +!----------------------------------------------------------------------------- +! Get Ricci tensor of metric g from Riemann tensor +! for adm form +! R_ij = gup^kl * R_ikjl +!----------------------------------------------------------------------------- + + subroutine adm_ricci(ex, gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in ) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Rxyxy, Rxyxz, Rxyyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Rxzxz, Rxzyz, Ryzyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + + Rxx = gupyy * Rxyxy + gupyz * Rxyxz + gupyz * Rxyxz + gupzz * Rxzxz + Rxy = - gupxy * Rxyxy + gupyz * Rxyyz - gupxz * Rxyxz + gupzz * Rxzyz + Rxz = - gupxy * Rxyxz - gupyy * Rxyyz - gupxz * Rxzxz - gupyz * Rxzyz + Ryy = gupxx * Rxyxy - gupxz * Rxyyz - gupxz * Rxyyz + gupzz * Ryzyz + Ryz = gupxx * Rxyxz + gupxy * Rxyyz - gupxz * Rxzyz - gupyz * Ryzyz + Rzz = gupxx * Rxzxz + gupxy * Rxzyz + gupxy * Rxzyz + gupyy * Ryzyz + + return + + end subroutine adm_ricci + +!----------------------------------------------------------------------------- +! raise index +!----------------------------------------------------------------------------- + + subroutine raise(ex,fx,fy,fz,fupx,fupy,fupz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) + implicit none + +!~~~~~~ Input parameters: + + integer, intent(in ) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupxx, gupxy, gupxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupyy, gupyz, gupzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: fupx,fupy,fupz + + fupx = gupxx * fx + gupxy * fy + gupxz * fz + fupy = gupxy * fx + gupyy * fy + gupyz * fz + fupz = gupxz * fx + gupyz * fy + gupzz * fz + + return + + end subroutine raise + +!----------------------------------------------------------------------------- +! lower index +!----------------------------------------------------------------------------- + + subroutine lower(ex,fx,fy,fz,Lfx,Lfy,Lfz,gxx,gxy,gxz,gyy,gyz,gzz) + implicit none + +!~~~~~~ Input parameters: + + integer, intent(in ) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Lfx,Lfy,Lfz + + Lfx = gxx * fx + gxy * fy + gxz * fz + Lfy = gxy * fx + gyy * fy + gyz * fz + Lfz = gxz * fx + gyz * fy + gzz * fz + + return + + end subroutine lower + +!---------------------------------------------------------------------------------- +! inner product of two three dimensional vectors with metric g_ij +! metric here do not upto ONE +!---------------------------------------------------------------------------------- + + subroutine InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::ux,uy,uz,vx,vy,vz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in)::gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out)::norm + + norm = gxx * ux * vx + gxy * ux * vy + gxz * ux * vz & + + gxy * uy * vx + gyy * uy * vy + gyz * uy * vz & + + gxz * uz * vx + gyz * uz * vy + gzz * uz * vz + + return + + end subroutine InnerProd +!----------------------------------------------------------! +! ! +! algebraic computation based on geometric quantites ! +! and their partial derivatives related to 3-dimensional ! +! Riemann slice ! +! ! +! * for BSSN form * ! +!----------------------------------------------------------! + +!----------------------------------------------------------------------------- +! second order covariant derivatives w.r.t. *untilded* (i.e. physical) metric +! of *symmetric* variable of scalar field +!----------------------------------------------------------------------------- + + subroutine fnt_cov_s_dderiv(ex, fx, fy, fz, & + fxx, fxy, fxz, fyy, fyz, fzz, & + phix, phiy, phiz, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + Gmxxx,Gmxxy,Gmxxz,Gmxyy,Gmxyz,Gmxzz, & + Gmyxx,Gmyxy,Gmyxz,Gmyyy,Gmyyz,Gmyzz, & + Gmzxx,Gmzxy,Gmzxz,Gmzyy,Gmzyz,Gmzzz) + implicit none + +!~~~~~~ Input arguments + + integer, intent(in ) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: phix,phiy,phiz +! tilted Christofel symble + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmxxx, Gmxxy, Gmxxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmxyy, Gmxyz, Gmxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmyxx, Gmyxy, Gmyxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmyyy, Gmyyz, Gmyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmzxx, Gmzxy, Gmzxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gmzyy, Gmzyz, Gmzzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: gupyy,gupyz,gupzz +! input partial derivatives, output covariant derivative respect to physical metric + real*8, dimension(ex(1),ex(2),ex(3)), intent(inout) :: fxx,fxy,fxz,fyy,fyz,fzz + +!~~~~~~ Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: phiupx,phiupy,phiupz + real*8,parameter :: TWO = 2.d0 + +!~~~~~~ Make untilded Gamma's out of tilded ones - first raise index on phi_i... + + phiupx = gupxx * phix + gupxy * phiy + gupxz * phiz + phiupy = gupxy * phix + gupyy * phiy + gupyz * phiz + phiupz = gupxz * phix + gupyz * phiy + gupzz * phiz + +!~~~~~~ ... and then add reconstructed *untilded* Christofels... + + fxx = fxx - ( Gmxxx + TWO * ( phix + phix - dxx * phiupx - phiupx ))* fx - & + ( Gmyxx + TWO * ( - dxx * phiupy - phiupy ))* fy - & + ( Gmzxx + TWO * ( - dxx * phiupz - phiupz ))* fz + + fyy = fyy - ( Gmxyy + TWO * ( - dyy * phiupx - phiupx ))* fx - & + ( Gmyyy + TWO * ( phiy + phiy - dyy * phiupy - phiupy ))* fy - & + ( Gmzyy + TWO * ( - dyy * phiupz - phiupz ))* fz + + fzz = fzz - ( Gmxzz + TWO * ( - dzz * phiupx - phiupx ))* fx - & + ( Gmyzz + TWO * ( - dzz * phiupy - phiupy ))* fy - & + ( Gmzzz + TWO * ( phiz + phiz - dzz * phiupz - phiupz ))* fz + + fxy = fxy - ( Gmxxy + TWO * ( phiy - gxy * phiupx ))* fx - & + ( Gmyxy + TWO * ( phix - gxy * phiupy ))* fy - & + ( Gmzxy + TWO * ( - gxy * phiupz ))* fz + + fxz = fxz - ( Gmxxz + TWO * ( phiz - gxz * phiupx ))* fx - & + ( Gmyxz + TWO * ( - gxz * phiupy ))* fy - & + ( Gmzxz + TWO * ( phix - gxz * phiupz ))* fz + + fyz = fyz - ( Gmxyz + TWO * ( - gyz * phiupx ))* fx - & + ( Gmyyz + TWO * ( phiz - gyz * phiupy ))* fy - & + ( Gmzyz + TWO * ( phiy - gyz * phiupz ))* fz + + return + + end subroutine fnt_cov_s_dderiv + +!----------------------------------------------------------------------------- +! +! Get physical riemann tensor +! +!----------------------------------------------------------------------------- + + subroutine get_physical_riemann(ex, ep4phi, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gupxx, gupxy, gupxz, gupyy, gupyz, gupzz, & + phix, phiy, phiz, & + phixx, phixy, phixz, phiyy, phiyz, phizz, & + tRxyxy, tRxyxz, tRxyyz, tRxzxz, tRxzyz, tRyzyz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in ):: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: ep4phi + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phix,phiy,phiz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phixx,phixy,phixz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phiyy,phiyz,phizz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: tRxyxy,tRxyxz,tRxyyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: tRxzxz,tRxzyz,tRyzyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rxyxy, Rxyxz, Rxyyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Rxzxz, Rxzyz, Ryzyz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: tmp + real*8,parameter::ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + +!~~~~~~> R_ijkl = tilde R_ijkl + TWO *( gli * D_j D_k phi - glj * D_i D_k phi - +! gki * D_j D_l phi + gkj * D_i D_l phi ) +! + FOUR*( gjl * D_i phi * D_k phi - gil * D_j phi * D_k phi - +! gjk * D_i phi * D_l phi + gik * D_j phi * D_l phi ) +! + FOUR*( gjk * gil - gik * gjl )* g^mn * D_m phi * D_n phi + + tmp = gupxx * phix * phix + gupyy * phiy * phiy + gupzz * phiz * phiz + & + TWO *( gupxy * phix * phiy + gupxz * phix * phiz + gupyz * phiy * phiz ) + +!~~~~~~> R_ijkl = tilde R_ijkl + TWO *( gli * phi_jk - glj * phi_ik - +! gki * phi_jl + gkj * phi_il ) +! + FOUR*( gjl * phi_i * phi_k - gil * phi_j * phi_k - +! gjk * phi_i * phi_l + gik * phi_j * phi_l ) +! + FOUR*( gjk * gil - gik * gjl )* tmp + + Rxyxy = tRxyxy + TWO *( gxy * phixy - gyy * phixx - gxx * phiyy + gxy * phixy ) & + + FOUR*( gyy * phix * phix - gxy * phiy * phix - & + gxy * phix * phiy + gxx * phiy * phiy ) & + + FOUR*( gxy * gxy - gxx * gyy )* tmp + + Rxyxz = tRxyxz + TWO *( gxz * phixy - gyz * phixx - gxx * phiyz + gxy * phixz ) & + + FOUR*( gyz * phix * phix - gxz * phiy * phix - & + gxy * phix * phiz + gxx * phiy * phiz ) & + + FOUR*( gxy * gxz - gxx * gyz )* tmp + + Rxyyz = tRxyyz + TWO *( gxz * phiyy - gyz * phixy - gxy * phiyz + gyy * phixz ) & + + FOUR*( gyz * phix * phiy - gxz * phiy * phiy - & + gyy * phix * phiz + gxy * phiy * phiz ) & + + FOUR*( gyy * gxz - gxy * gyz )* tmp + + Rxzxz = tRxzxz + TWO *( gxz * phixz - gzz * phixx - gxx * phizz + gxz * phixz ) & + + FOUR*( gzz * phix * phix - gxz * phiz * phix - & + gxz * phix * phiz + gxx * phiz * phiz ) & + + FOUR*( gxz * gxz - gxx * gzz )* tmp + + Rxzyz = tRxzyz + TWO *( gxz * phiyz - gzz * phixy - gxy * phizz + gyz * phixz ) & + + FOUR*( gzz * phix * phiy - gxz * phiz * phiy - & + gyz * phix * phiz + gxy * phiz * phiz ) & + + FOUR*( gyz * gxz - gxy * gzz )* tmp + + Ryzyz = tRyzyz + TWO *( gyz * phiyz - gzz * phiyy - gyy * phizz + gyz * phiyz ) & + + FOUR*( gzz * phiy * phiy - gyz * phiz * phiy - & + gyz * phiy * phiz + gyy * phiz * phiz ) & + + FOUR*( gyz * gyz - gyy * gzz )* tmp + +!multipli with factor exp( 4 * phi) + + Rxyxy = Rxyxy * ep4phi + Rxyxz = Rxyxz * ep4phi + Rxyyz = Rxyyz * ep4phi + Rxzxz = Rxzxz * ep4phi + Rxzyz = Rxzyz * ep4phi + Ryzyz = Ryzyz * ep4phi + + return + + end subroutine get_physical_riemann + +!----------------------------------------------------------------------------- +! +! Get physical Ricci tensor +! +!----------------------------------------------------------------------------- + + subroutine get_physical_ricci(ex,dxx,gxy,gxz,dyy,gyz,dzz,phix,phiy,phiz, & + phixx,phixy,phixz,phiyy,phiyz,phizz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + tRxx, tRxy, tRxz, tRyy, tRyz, tRzz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz) + + implicit none + +!~~~~~~ argument variables + + integer, intent(in) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: phix,phiy,phiz +! covariant derivative respect to tilted metric + real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: phixx,phixy,phixz,phiyy,phiyz,phizz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in):: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: tRxx,tRxy,tRxz,tRyy,tRyz,tRzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: tempf + real*8,parameter::TWO = 2.d0, FOUR = 4.d0 + +!~~~~~~ + + tempf = TWO * (gupxx * ( phixx + TWO * phix * phix ) + & + gupyy * ( phiyy + TWO * phiy * phiy ) + & + gupzz * ( phizz + TWO * phiz * phiz ) + & + TWO * gupxy * ( phixy + TWO * phix * phiy ) + & + TWO * gupxz * ( phixz + TWO * phix * phiz ) + & + TWO * gupyz * ( phiyz + TWO * phiy * phiz ) ) + +! Add phi part to Ricci tensor: + + Rxx = tRxx - TWO * phixx + FOUR * phix * phix - dxx * tempf - tempf + Ryy = tRyy - TWO * phiyy + FOUR * phiy * phiy - dyy * tempf - tempf + Rzz = tRzz - TWO * phizz + FOUR * phiz * phiz - dzz * tempf - tempf + Rxy = tRxy - TWO * phixy + FOUR * phix * phiy - gxy * tempf + Rxz = tRxz - TWO * phixz + FOUR * phix * phiz - gxz * tempf + Ryz = tRyz - TWO * phiyz + FOUR * phiy * phiz - gyz * tempf + + return + + end subroutine get_physical_ricci + +!----------------------------------------------------------------------------- +! +! compute physical extrinic curver: +! Kij = exp( 4 * phi ) ( tilde Aij + F1o3 * tilde gij * trK ) +! +!----------------------------------------------------------------------------- + + subroutine get_physical_k(ex, phi, trK, dxx, gxy, gxz, dyy, gyz, dzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Kxx, Kxy, Kxz, Kyy, Kyz, Kzz) + implicit none + +!~~~~~~> Input parameters: + + integer,dimension(3) , intent(in) :: ex + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: phi, trK + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx, gyy, gzz + real*8, parameter :: F1o3 = 1.d0 / 3.d0, ONE = 1.d0, FOUR = 4.d0 + +!~~~~~~> + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + Kzz = exp( FOUR * phi ) + +!~~~~~~> + + Kxx = ( Axx + F1o3 * gxx * trK )* Kzz + Kxy = ( Axy + F1o3 * gxy * trK )* Kzz + Kxz = ( Axz + F1o3 * gxz * trK )* Kzz + Kyy = ( Ayy + F1o3 * gyy * trK )* Kzz + Kyz = ( Ayz + F1o3 * gyz * trK )* Kzz + Kzz = ( Azz + F1o3 * gzz * trK )* Kzz + + return + + end subroutine get_physical_k + +!------------------------------------------------------------------------------------------------------- +! +! compute covariant derivatives of extrinic curver +! +!D_i K_jk stored as DKijk +! +! DKijk = e^(4 phi) (A_jk,i - Gam^l_ij A_lk - Gam^l_ik A_jl + 1/3 g_jk trK,i) +! - 2 K_ik phi,j + 2 g_ij g^lm phi,m K_lk +! - 2 K_ij phi,k + 2 g_ik g^lm phi,m K_lj +!------------------------------------------------------------------------------------------------------- + + subroutine get_diff_physical_k(ex, phi, trK, Kx, Ky, Kz, phix, phiy, phiz, & + dxx, gxy, gxz, dyy, gyz, dzz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + Axx, Axy, Axz, Ayy, Ayz, Azz, & + Axxx, Axxy, Axxz, Axyx, Axyy, Axyz, & + Axzx, Axzy, Axzz, Ayyx, Ayyy, Ayyz, & + Ayzx, Ayzy, Ayzz, Azzx, Azzy, Azzz, & + Gmxxx,Gmxxy,Gmxxz,Gmxyy,Gmxyz,Gmxzz, & + Gmyxx,Gmyxy,Gmyxz,Gmyyy,Gmyyz,Gmyzz, & + Gmzxx,Gmzxy,Gmzxz,Gmzyy,Gmzyz,Gmzzz, & + Kxx, Kxy, Kxz, Kyy, Kyz, Kzz, & + DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & + DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & + DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz) + + implicit none + +!~~~~~~> Input parameters: + + integer,dimension(3), intent(in) :: ex + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phi,trK + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Kx,Ky,Kz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: phix,phiy,phiz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axx,Axy,Axz,Ayy,Ayz,Azz +! Aij,k --> stored as Aijk + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axxx,Axxy,Axxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axyx,Axyy,Axyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Axzx,Axzy,Axzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Ayyx,Ayyy,Ayyz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Ayzx,Ayzy,Ayzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Azzx,Azzy,Azzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmxxx,Gmxxy,Gmxxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmxyy,Gmxyz,Gmxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmyxx,Gmyxy,Gmyxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmyyy,Gmyyz,Gmyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmzxx,Gmzxy,Gmzxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Gmzyy,Gmzyz,Gmzzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ):: Kxx,Kxy,Kxz,Kyy,Kyz,Kzz +! D_i K_jk --> stored as DKijk + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)):: phiupx,phiupy,phiupz + real*8, dimension(ex(1),ex(2),ex(3)):: phiupKx,phiupKy,phiupKz + real*8, dimension(ex(1),ex(2),ex(3)):: e4phi + real*8, dimension(ex(1),ex(2),ex(3)):: gxx,gyy,gzz + + real*8,parameter::ONE = 1.d0, TWO = 2.d0, FOUR = 4.d0 + real*8,parameter::F1o3 = 1.d0/3.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + +!~~~~~~> Input translation + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + e4phi = dexp(FOUR * phi) + +!~~~~~~> + + phiupx = gupxx * phix + gupxy * phiy + gupxz * phiz + phiupy = gupxy * phix + gupyy * phiy + gupyz * phiz + phiupz = gupxz * phix + gupyz * phiy + gupzz * phiz + + phiupKx = phiupx * Kxx + phiupy * Kxy + phiupz * Kxz + phiupKy = phiupx * Kxy + phiupy * Kyy + phiupz * Kyz + phiupKz = phiupx * Kxz + phiupy * Kyz + phiupz * Kzz + +!~~~~~~> tmp = - Gam^l_ij A_lk - Gam^l_ik A_jl + + DKxxx = - Gmxxx * Axx - Gmyxx * Axy - Gmzxx * Axz & + - Gmxxx * Axx - Gmyxx * Axy - Gmzxx * Axz + + DKxxy = - Gmxxx * Axy - Gmyxx * Ayy - Gmzxx * Ayz & + - Gmxxy * Axx - Gmyxy * Axy - Gmzxy * Axz + + DKxxz = - Gmxxx * Axz - Gmyxx * Ayz - Gmzxx * Azz & + - Gmxxz * Axx - Gmyxz * Axy - Gmzxz * Axz + + DKxyy = - Gmxxy * Axy - Gmyxy * Ayy - Gmzxy * Ayz & + - Gmxxy * Axy - Gmyxy * Ayy - Gmzxy * Ayz + + DKxyz = - Gmxxy * Axz - Gmyxy * Ayz - Gmzxy * Azz & + - Gmxxz * Axy - Gmyxz * Ayy - Gmzxz * Ayz + + DKxzz = - Gmxxz * Axz - Gmyxz * Ayz - Gmzxz * Azz & + - Gmxxz * Axz - Gmyxz * Ayz - Gmzxz * Azz + + DKyxx = - Gmxxy * Axx - Gmyxy * Axy - Gmzxy * Axz & + - Gmxxy * Axx - Gmyxy * Axy - Gmzxy * Axz + + DKyxy = - Gmxxy * Axy - Gmyxy * Ayy - Gmzxy * Ayz & + - Gmxyy * Axx - Gmyyy * Axy - Gmzyy * Axz + + DKyxz = - Gmxxy * Axz - Gmyxy * Ayz - Gmzxy * Azz & + - Gmxyz * Axx - Gmyyz * Axy - Gmzyz * Axz + + DKyyy = - Gmxyy * Axy - Gmyyy * Ayy - Gmzyy * Ayz & + - Gmxyy * Axy - Gmyyy * Ayy - Gmzyy * Ayz + + DKyyz = - Gmxyy * Axz - Gmyyy * Ayz - Gmzyy * Azz & + - Gmxyz * Axy - Gmyyz * Ayy - Gmzyz * Ayz + + DKyzz = - Gmxyz * Axz - Gmyyz * Ayz - Gmzyz * Azz & + - Gmxyz * Axz - Gmyyz * Ayz - Gmzyz * Azz + + DKzxx = - Gmxxz * Axx - Gmyxz * Axy - Gmzxz * Axz & + - Gmxxz * Axx - Gmyxz * Axy - Gmzxz * Axz + + DKzxy = - Gmxxz * Axy - Gmyxz * Ayy - Gmzxz * Ayz & + - Gmxyz * Axx - Gmyyz * Axy - Gmzyz * Axz + + DKzxz = - Gmxxz * Axz - Gmyxz * Ayz - Gmzxz * Azz & + - Gmxzz * Axx - Gmyzz * Axy - Gmzzz * Axz + + DKzyy = - Gmxyz * Axy - Gmyyz * Ayy - Gmzyz * Ayz & + - Gmxyz * Axy - Gmyyz * Ayy - Gmzyz * Ayz + + DKzyz = - Gmxyz * Axz - Gmyyz * Ayz - Gmzyz * Azz & + - Gmxzz * Axy - Gmyzz * Ayy - Gmzzz * Ayz + + DKzzz = - Gmxzz * Axz - Gmyzz * Ayz - Gmzzz * Azz & + - Gmxzz * Axz - Gmyzz * Ayz - Gmzzz * Azz + +!~~~~~~> DKijk = e^(4 phi) (A_jk,i + tmp + 1/3 g_jk K_i) +! - 2 K_ik phi,j + 2 g_ij phiupK_k +! - 2 K_ij phi,k + 2 g_ik phiupK_j + + DKxxx = e4phi * (Axxx + DKxxx + F1o3 * gxx * Kx) & + - TWO * Kxx * phix + TWO * gxx * phiupKx & + - TWO * Kxx * phix + TWO * gxx * phiupKx + + DKxxy = e4phi * (Axyx + DKxxy + F1o3 * gxy * Kx) & + - TWO * Kxy * phix + TWO * gxx * phiupKy & + - TWO * Kxx * phiy + TWO * gxy * phiupKx + + DKxxz = e4phi * (Axzx + DKxxz + F1o3 * gxz * Kx) & + - TWO * Kxz * phix + TWO * gxx * phiupKz & + - TWO * Kxx * phiz + TWO * gxz * phiupKx + + DKxyy = e4phi * (Ayyx + DKxyy + F1o3 * gyy * Kx) & + - TWO * Kxy * phiy + TWO * gxy * phiupKy & + - TWO * Kxy * phiy + TWO * gxy * phiupKy + + DKxyz = e4phi * (Ayzx + DKxyz + F1o3 * gyz * Kx) & + - TWO * Kxz * phiy + TWO * gxy * phiupKz & + - TWO * Kxy * phiz + TWO * gxz * phiupKy + + DKxzz = e4phi * (Azzx + DKxzz + F1o3 * gzz * Kx) & + - TWO * Kxz * phiz + TWO * gxz * phiupKz & + - TWO * Kxz * phiz + TWO * gxz * phiupKz + +!~~~~~~> + + DKyxx = e4phi * (Axxy + DKyxx + F1o3 * gxx * Ky) & + - TWO * Kxy * phix + TWO * gxy * phiupKx & + - TWO * Kxy * phix + TWO * gxy * phiupKx + + DKyxy = e4phi * (Axyy + DKyxy + F1o3 * gxy * Ky) & + - TWO * Kyy * phix + TWO * gxy * phiupKy & + - TWO * Kxy * phiy + TWO * gyy * phiupKx + + DKyxz = e4phi * (Axzy + DKyxz + F1o3 * gxz * Ky) & + - TWO * Kyz * phix + TWO * gxy * phiupKz & + - TWO * Kxy * phiz + TWO * gyz * phiupKx + + DKyyy = e4phi * (Ayyy + DKyyy + F1o3 * gyy * Ky) & + - TWO * Kyy * phiy + TWO * gyy * phiupKy & + - TWO * Kyy * phiy + TWO * gyy * phiupKy + + DKyyz = e4phi * (Ayzy + DKyyz + F1o3 * gyz * Ky) & + - TWO * Kyz * phiy + TWO * gyy * phiupKz & + - TWO * Kyy * phiz + TWO * gyz * phiupKy + + DKyzz = e4phi * (Azzy + DKyzz + F1o3 * gzz * Ky) & + - TWO * Kyz * phiz + TWO * gyz * phiupKz & + - TWO * Kyz * phiz + TWO * gyz * phiupKz + +!~~~~~~> + + DKzxx = e4phi * (Axxz + DKzxx + F1o3 * gxx * Kz) & + - TWO * Kxz * phix + TWO * gxz * phiupKx & + - TWO * Kxz * phix + TWO * gxz * phiupKx + + DKzxy = e4phi * (Axyz + DKzxy + F1o3 * gxy * Kz) & + - TWO * Kyz * phix + TWO * gxz * phiupKy & + - TWO * Kxz * phiy + TWO * gyz * phiupKx + + DKzxz = e4phi * (Axzz + DKzxz + F1o3 * gxz * Kz) & + - TWO * Kzz * phix + TWO * gxz * phiupKz & + - TWO * Kxz * phiz + TWO * gzz * phiupKx + + DKzyy = e4phi * (Ayyz + DKzyy + F1o3 * gyy * Kz) & + - TWO * Kyz * phiy + TWO * gyz * phiupKy & + - TWO * Kyz * phiy + TWO * gyz * phiupKy + + DKzyz = e4phi * (Ayzz + DKzyz + F1o3 * gyz * Kz) & + - TWO * Kzz * phiy + TWO * gyz * phiupKz & + - TWO * Kyz * phiz + TWO * gzz * phiupKy + + DKzzz = e4phi * (Azzz + DKzzz + F1o3 * gzz * Kz) & + - TWO * Kzz * phiz + TWO * gzz * phiupKz & + - TWO * Kzz * phiz + TWO * gzz * phiupKz + + return + + end subroutine get_diff_physical_k + +!---------------------------------------------------------------------- +!------>Begin to compute Psi4 +!------>based on quantites: +!------>triad v^i, u^i, w^i +!------>lapse and shift vector beta^i +!------>extrinsic curvature K_ij and trK +!------>covariant derivative of extrinsic curvature D_i K_jk +!------>Ricci tensor: R_ij +!------>gup^ij +!------>Riemann tensor R_ijkl +!---------------------------------------------------------------------- + + subroutine bssn_compute_psi4(ex, em4phi,lapse, betax,betay,betaz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz, & + vx,vy,vz,ux,uy,uz,wx,wy,wz, & + trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz, & + Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz, & + Rxx, Rxy, Rxz, Ryy, Ryz, Rzz, & + DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz, & + DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz, & + DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz, Rpsi4, Ipsi4) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: em4phi + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: lapse + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK,Kxx,Kxy,Kxz,Kyy,Kyz,Kzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxyxy, Rxyxz, Rxyyz, Rxzxz, Rxzyz, Ryzyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx, Rxy, Rxz, Ryy, Ryz, Rzz +!D_i K_jk ---> DKijk + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: DKxxx,DKxxy,DKxxz,DKxyy,DKxyz,DKxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: DKyxx,DKyxy,DKyxz,DKyyy,DKyyz,DKyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: DKzxx,DKzxy,DKzxz,DKzyy,DKzyz,DKzzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rpsi4,Ipsi4 + +!~~~~~~ local variables + +!n^i upto 1/sqrt(2) + real*8, dimension(ex(1),ex(2),ex(3)) :: nx,ny,nz +!n^i * n^k upto 1/2 + real*8, dimension(ex(1),ex(2),ex(3)) :: nnxx,nnxy,nnxz,nnyy,nnyz,nnzz +!u^j * u^l - w^j * w^l + real*8, dimension(ex(1),ex(2),ex(3)) :: uuwwxx,uuwwxy,uuwwxz,uuwwyy,uuwwyz,uuwwzz +!- u^j * w^l - w^j * u^l + real*8, dimension(ex(1),ex(2),ex(3)) :: uwxx,uwxy,uwxz,uwyy,uwyz,uwzz +! temp variables + real*8, dimension(ex(1),ex(2),ex(3)) ::temRxx, temRxy, temRxz, temRyy, temRyz, temRzz + real*8, dimension(ex(1),ex(2),ex(3)) ::temRxyxy,temRxyxz,temRxyyz,temRxzxz,temRxzyz,temRyzyz + real*8, dimension(ex(1),ex(2),ex(3)) ::lapse2 +! K^i_j + real*8, dimension(ex(1),ex(2),ex(3)) ::Kupxx,Kupxy,Kupxz,Kupyy,Kupyz,Kupzz + + real*8, parameter :: TWO = 2.d0, F1o4 = 1.d0/4.d0 + +!~~~~~~ + +! compute n^i = - beta^i/lapse - v^i + nx = - betax/lapse - vx + ny = - betay/lapse - vy + nz = - betaz/lapse - vz + +! compute nn^ij = n^i * n^j + nnxx = nx * nx + nnxy = nx * ny + nnxz = nx * nz + nnyy = ny * ny + nnyz = ny * nz + nnzz = nz * nz + +! compute uuww^ij = u^i * u^j - w^i * w^j + uuwwxx = ux * ux - wx * wx + uuwwxy = ux * uy - wx * wy + uuwwxz = ux * uz - wx * wz + uuwwyy = uy * uy - wy * wy + uuwwyz = uy * uz - wy * wz + uuwwzz = uz * uz - wz * wz + +! compute uw^ij = - u^i * w^j - w^i * u^j + uwxx = ux * wx + wx * ux + uwxy = ux * wy + wx * uy + uwxz = ux * wz + wx * uz + uwyy = uy * wy + wy * uy + uwyz = uy * wz + wy * uz + uwzz = uz * wz + wz * uz + +!Commonterm_jl = -1/4 * ( (R_ijkl + K_ik * K_jl - K_il * K_jk) * nn^ik +! - 2 * (D_l K_jk - D_k K_jl) * n^0 * n^k +! + (R_jl - K_jm * K^m_l + K * K_jl) * n^0 * n^0 +! ) + +!add trK * K_jl to R_jl + temRxx = Rxx + trK * Kxx + temRxy = Rxy + trK * Kxy + temRxz = Rxz + trK * Kxz + temRyy = Ryy + trK * Kyy + temRyz = Ryz + trK * Kyz + temRzz = Rzz + trK * Kzz + +!add - K_jm * K^m_l to R_jl + +! compute K^m_l + call raise(ex,Kxx,Kxy,Kxz,Kupxx,Kupxy,Kupxz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) + + call raise(ex,Kxy,Kyy,Kyz,Kupxy,Kupyy,Kupyz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) + + call raise(ex,Kxz,Kyz,Kzz,Kupxz,Kupyz,Kupzz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) + + temRxx = temRxx - em4phi * ( Kupxx * Kxx + Kupxy * Kxy + Kupxz * Kxz ) + + temRxy = temRxy - em4phi * ( Kupxx * Kxy + Kupxy * Kyy + Kupxz * Kyz ) + + temRxz = temRxz - em4phi * ( Kupxx * Kxz + Kupxy * Kyz + Kupxz * Kzz ) + + temRyy = temRyy - em4phi * ( Kupxy * Kxy + Kupyy * Kyy + Kupyz * Kyz ) + + temRyz = temRyz - em4phi * ( Kupxy * Kxz + Kupyy * Kyz + Kupyz * Kzz ) + + temRzz = temRzz - em4phi * ( Kupxz * Kxz + Kupyz * Kyz + Kupzz * Kzz ) + +! multiply with n^0 * n^0 upto 1/2 +! n^0 = 1/(sqrt(2) * lapse) + lapse2 = lapse * lapse + + temRxx = temRxx/lapse2 + temRxy = temRxy/lapse2 + temRxz = temRxz/lapse2 + temRyy = temRyy/lapse2 + temRyz = temRyz/lapse2 + temRzz = temRzz/lapse2 + +!add (K_ik * K_jl - K_il * K_jk) to R_ijkl, note they have the same symmetric index + + temRxyxy = Rxyxy + Kxx * Kyy - Kxy * Kxy + temRxyxz = Rxyxz + Kxx * Kyz - Kxz * Kxy + temRxyyz = Rxyyz + Kxy * Kyz - Kxz * Kyy + temRxzxz = Rxzxz + Kxx * Kzz - Kxz * Kxz + temRxzyz = Rxzyz + Kxy * Kzz - Kxz * Kyz + temRyzyz = Ryzyz + Kyy * Kzz - Kyz * Kyz + +!add (R_ijkl + K_ik * K_jl - K_il * K_jk) * nn^ik to R_jl, upto 1/2 +! note they have the same symmetric index + temRxx = temRxx + temRxyxy * nnyy + temRxyxz * nnyz + temRxyxz * nnyz + temRxzxz * nnzz + temRxy = temRxy - temRxyxy * nnxy + temRxyyz * nnyz - temRxyxz * nnxz + temRxzyz * nnzz + temRxz = temRxz - temRxyxz * nnxy - temRxyyz * nnyy - temRxzxz * nnxz - temRxzyz * nnyz + temRyy = temRyy + temRxyxy * nnxx - temRxyyz * nnxz - temRxyyz * nnxz + temRyzyz * nnzz + temRyz = temRyz + temRxyxz * nnxx + temRxyyz * nnxy - temRxzyz * nnxz - temRyzyz * nnyz + temRzz = temRzz + temRxzxz * nnxx + temRxzyz * nnxy + temRxzyz * nnxy + temRyzyz * nnyy + +!add 2 * (D_k K_jl * n^0 * n^k) to R_jl, upto 1/2 + temRxx = temRxx + TWO * ( DKxxx * nx + DKyxx * ny + DKzxx * nz)/lapse + temRxy = temRxy + TWO * ( DKxxy * nx + DKyxy * ny + DKzxy * nz)/lapse + temRxz = temRxz + TWO * ( DKxxz * nx + DKyxz * ny + DKzxz * nz)/lapse + temRyy = temRyy + TWO * ( DKxyy * nx + DKyyy * ny + DKzyy * nz)/lapse + temRyz = temRyz + TWO * ( DKxyz * nx + DKyyz * ny + DKzyz * nz)/lapse + temRzz = temRzz + TWO * ( DKxzz * nx + DKyzz * ny + DKzzz * nz)/lapse + +!add - (D_l K_jk + D_j K_lk) * n^0 * ^k to R_jl, upto 1/2 +! note we symmetrize the index here + temRxx = temRxx - ((DKxxx + DKxxx) * nx + (DKxxy + DKxxy) * ny + (DKxxz + DKxxz) * nz)/lapse + temRxy = temRxy - ((DKyxx + DKxxy) * nx + (DKyxy + DKxyy) * ny + (DKyxz + DKxyz) * nz)/lapse + temRxz = temRxz - ((DKzxx + DKxxz) * nx + (DKzxy + DKxyz) * ny + (DKzxz + DKxzz) * nz)/lapse + temRyy = temRyy - ((DKyxy + DKyxy) * nx + (DKyyy + DKyyy) * ny + (DKyyz + DKyyz) * nz)/lapse + temRyz = temRyz - ((DKzxy + DKyxz) * nx + (DKzyy + DKyyz) * ny + (DKzyz + DKyzz) * nz)/lapse + temRzz = temRzz - ((DKzxz + DKzxz) * nx + (DKzyz + DKzyz) * ny + (DKzzz + DKzzz) * nz)/lapse + +!the real part of Psi4 + Rpsi4 = temRxx * uuwwxx + temRyy * uuwwyy + temRzz * uuwwzz & + + (temRxy * uuwwxy + temRxz * uuwwxz + temRyz * uuwwyz) * TWO + +!the imaginary part of Psi4 + Ipsi4 = temRxx * uwxx + temRyy * uwyy + temRzz * uwzz & + + (temRxy * uwxy + temRxz * uwxz + temRyz * uwyz) * TWO + +!multiply with -1/4 + Rpsi4 = - F1o4 * Rpsi4 + Ipsi4 = - F1o4 * Ipsi4 + + return + + end subroutine bssn_compute_psi4 +!----------------------------------------------------------------------------- +! covariant derivatives w.r.t *tilded metric* of *symmetric* variable +!----------------------------------------------------------------------------- + + subroutine xcov_deriv(ex,fx,fy,fz,fxx,fxy,fxz,fyy,fyz,fzz, & + Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz) + implicit none + +!~~~~~~ Input arguments + + integer, intent(in ) :: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: fx, fy, fz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)), intent(in ) :: Gamzyy, Gamzyz, Gamzzz + +!~~~~~~ Add Connection terms + + fxx = fxx - Gamxxx * fx - Gamyxx * fy - Gamzxx * fz + fxy = fxy - Gamxxy * fx - Gamyxy * fy - Gamzxy * fz + fxz = fxz - Gamxxz * fx - Gamyxz * fy - Gamzxz * fz + fyy = fyy - Gamxyy * fx - Gamyyy * fy - Gamzyy * fz + fyz = fyz - Gamxyz * fx - Gamyyz * fy - Gamzyz * fz + fzz = fzz - Gamxzz * fx - Gamyzz * fy - Gamzzz * fz + + return + + end subroutine xcov_deriv + +!-------------------------------------------------------------------- +! Gram-Schmidt orthonormal in Cartesin coordinate +! V1 = [ x, y, z ] +! V2 = [-y, x, ZEO] +! V3 = [xz,yz,-(x^2+y^2)] +! V1 -> V1 / sqrt(W11) +! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) +! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) +! W_ij = g_ab * Vi^a * Vj^b +! it is metric, not tilde metric +! V1 first +!-------------------------------------------------------------------- + + subroutine get_triad0(ex, X, Y, Z, ep4phi, & + gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) +! tilted metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: norm + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz + + real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 + integer::i,j,k + +!~~~~~~ + + gxx = gxxi * ep4phi + gxy = gxyi * ep4phi + gxz = gxzi * ep4phi + gyy = gyyi * ep4phi + gyz = gyzi * ep4phi + gzz = gzzi * ep4phi + +! initialize U, V, W vetors + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + + enddo + enddo + enddo + +! Gram-Schmidt orthonormalization + call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx/dsqrt(norm) + vy = vy/dsqrt(norm) + vz = vz/dsqrt(norm) + + call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux - norm*vx + uy = uy - norm*vy + uz = uz - norm*vz + + call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux/dsqrt(norm) + uy = uy/dsqrt(norm) + uz = uz/dsqrt(norm) + + call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*vx + wy = wy - norm*vy + wz = wz - norm*vz + + call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*ux + wy = wy - norm*uy + wz = wz - norm*uz + + call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx/dsqrt(norm) + wy = wy/dsqrt(norm) + wz = wz/dsqrt(norm) + + return + + end subroutine get_triad0 +!-------------------------------------------------------------------- +! Gram-Schmidt orthonormal in Cartesin coordinate +! V1 = [ x, y, z ] +! V2 = [-y, x, ZEO] +! V3 = [xz,yz,-(x^2+y^2)] +! V1 -> V1 / sqrt(W11) +! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) +! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) +! W_ij = g_ab * Vi^a * Vj^b +! it is metric, not tilde metric +! V2 first +!-------------------------------------------------------------------- + + subroutine get_triad1(ex, X, Y, Z, ep4phi, & + gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) +! tilted metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: norm + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz + + real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 + integer::i,j,k + +!~~~~~~ + + gxx = gxxi * ep4phi + gxy = gxyi * ep4phi + gxz = gxzi * ep4phi + gyy = gyyi * ep4phi + gyz = gyzi * ep4phi + gzz = gzzi * ep4phi + +! initialize U, V, W vetors + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + + enddo + enddo + enddo + +! Gram-Schmidt orthonormalization + call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux/dsqrt(norm) + uy = uy/dsqrt(norm) + uz = uz/dsqrt(norm) + + call InnerProd(ex,norm,vx,vy,vz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx - norm*ux + vy = vy - norm*uy + vz = vz - norm*uz + + call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx/dsqrt(norm) + vy = vy/dsqrt(norm) + vz = vz/dsqrt(norm) + + call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*ux + wy = wy - norm*uy + wz = wz - norm*uz + + call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*vx + wy = wy - norm*vy + wz = wz - norm*vz + + call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx/dsqrt(norm) + wy = wy/dsqrt(norm) + wz = wz/dsqrt(norm) + + return + + end subroutine get_triad1 +!-------------------------------------------------------------------- +! Gram-Schmidt orthonormal in Cartesin coordinate +! V1 = [ x, y, z ] +! V2 = [-y, x, ZEO] +! V3 = [xz,yz,-(x^2+y^2)] +! V1 -> V1 / sqrt(W11) +! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) +! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) +! W_ij = g_ab * Vi^a * Vj^b +! it is metric, not tilde metric +! raise V1, then V1 first +!-------------------------------------------------------------------- + + subroutine get_triad2(ex, X, Y, Z, ep4phi, & + gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) +! tilted metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: norm,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz + + real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 + integer::i,j,k + +!~~~~~~ + + gxx = gxxi * ep4phi + gxy = gxyi * ep4phi + gxz = gxzi * ep4phi + gyy = gyyi * ep4phi + gyz = gyzi * ep4phi + gzz = gzzi * ep4phi +! invert metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz +! initialize U, V, W vetors + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + call raise(ex,fx,fy,fz,vx,vy,vz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) +! Gram-Schmidt orthonormalization + call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx/dsqrt(norm) + vy = vy/dsqrt(norm) + vz = vz/dsqrt(norm) + + call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux - norm*vx + uy = uy - norm*vy + uz = uz - norm*vz + + call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux/dsqrt(norm) + uy = uy/dsqrt(norm) + uz = uz/dsqrt(norm) + + call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*vx + wy = wy - norm*vy + wz = wz - norm*vz + + call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*ux + wy = wy - norm*uy + wz = wz - norm*uz + + call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx/dsqrt(norm) + wy = wy/dsqrt(norm) + wz = wz/dsqrt(norm) + + return + + end subroutine get_triad2 +!***********for shell********************* +!-------------------------------------------------------------------- +! Gram-Schmidt orthonormal in Cartesin coordinate +! V1 = [ x, y, z ] +! V2 = [-y, x, ZEO] +! V3 = [xz,yz,-(x^2+y^2)] +! V1 -> V1 / sqrt(W11) +! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) +! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) +! W_ij = g_ab * Vi^a * Vj^b +! it is metric, not tilde metric +! V1 first +!-------------------------------------------------------------------- + + subroutine get_triad0_ss(ex, X, Y, Z, ep4phi, & + gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) +! tilted metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: norm + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz + + real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + +!~~~~~~ + + gxx = gxxi * ep4phi + gxy = gxyi * ep4phi + gxz = gxzi * ep4phi + gyy = gyyi * ep4phi + gyz = gyzi * ep4phi + gzz = gzzi * ep4phi + +! initialize U, V, W vetors + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + + enddo + enddo + enddo + +! Gram-Schmidt orthonormalization + call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx/dsqrt(norm) + vy = vy/dsqrt(norm) + vz = vz/dsqrt(norm) + + call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux - norm*vx + uy = uy - norm*vy + uz = uz - norm*vz + + call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux/dsqrt(norm) + uy = uy/dsqrt(norm) + uz = uz/dsqrt(norm) + + call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*vx + wy = wy - norm*vy + wz = wz - norm*vz + + call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*ux + wy = wy - norm*uy + wz = wz - norm*uz + + call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx/dsqrt(norm) + wy = wy/dsqrt(norm) + wz = wz/dsqrt(norm) + + return + + end subroutine get_triad0_ss +!-------------------------------------------------------------------- +! Gram-Schmidt orthonormal in Cartesin coordinate +! V1 = [ x, y, z ] +! V2 = [-y, x, ZEO] +! V3 = [xz,yz,-(x^2+y^2)] +! V1 -> V1 / sqrt(W11) +! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) +! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) +! W_ij = g_ab * Vi^a * Vj^b +! it is metric, not tilde metric +! V2 first +!-------------------------------------------------------------------- + + subroutine get_triad1_ss(ex, X, Y, Z, ep4phi, & + gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) +! tilted metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: norm + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz + + real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + +!~~~~~~ + + gxx = gxxi * ep4phi + gxy = gxyi * ep4phi + gxz = gxzi * ep4phi + gyy = gyyi * ep4phi + gyz = gyzi * ep4phi + gzz = gzzi * ep4phi + +! initialize U, V, W vetors + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + + enddo + enddo + enddo + +! Gram-Schmidt orthonormalization + call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux/dsqrt(norm) + uy = uy/dsqrt(norm) + uz = uz/dsqrt(norm) + + call InnerProd(ex,norm,vx,vy,vz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx - norm*ux + vy = vy - norm*uy + vz = vz - norm*uz + + call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx/dsqrt(norm) + vy = vy/dsqrt(norm) + vz = vz/dsqrt(norm) + + call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*ux + wy = wy - norm*uy + wz = wz - norm*uz + + call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*vx + wy = wy - norm*vy + wz = wz - norm*vz + + call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx/dsqrt(norm) + wy = wy/dsqrt(norm) + wz = wz/dsqrt(norm) + + return + + end subroutine get_triad1_ss +!-------------------------------------------------------------------- +! Gram-Schmidt orthonormal in Cartesin coordinate +! V1 = [ x, y, z ] +! V2 = [-y, x, ZEO] +! V3 = [xz,yz,-(x^2+y^2)] +! V1 -> V1 / sqrt(W11) +! V2 -> ( V2 - V1 * W12 ) / sqrt(W22) +! V3 -> ( V3 - V1 * W13 - V2 * W23 ) / sqrt(W33) +! W_ij = g_ab * Vi^a * Vj^b +! it is metric, not tilde metric +! raise V1, then V1 first +!-------------------------------------------------------------------- + + subroutine get_triad2_ss(ex, X, Y, Z, ep4phi, & + gxxi,gxyi,gxzi,gyyi,gyzi,gzzi, & + vx,vy,vz,ux,uy,uz,wx,wy,wz) + + implicit none + +!~~~~~~ argument variables + + integer,intent(in ):: ex(1:3) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: ep4phi !exp(4 * phi) +! tilted metric + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxxi,gxyi,gxzi,gyyi,gyzi,gzzi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + +!~~~~~~ local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: norm,fx,fy,fz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz,gupyy,gupyz,gupzz + + real*8,parameter:: ZEO = 0.d0, ONE = 1.d0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + +!~~~~~~ + + gxx = gxxi * ep4phi + gxy = gxyi * ep4phi + gxz = gxzi * ep4phi + gyy = gyyi * ep4phi + gyz = gyzi * ep4phi + gzz = gzzi * ep4phi +! invert metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz +! initialize U, V, W vetors + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + call raise(ex,fx,fy,fz,vx,vy,vz, & + gupxx,gupxy,gupxz,gupyy,gupyz,gupzz) +! Gram-Schmidt orthonormalization + call InnerProd(ex,norm,vx,vy,vz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + vx = vx/dsqrt(norm) + vy = vy/dsqrt(norm) + vz = vz/dsqrt(norm) + + call InnerProd(ex,norm,ux,uy,uz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux - norm*vx + uy = uy - norm*vy + uz = uz - norm*vz + + call InnerProd(ex,norm,ux,uy,uz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + ux = ux/dsqrt(norm) + uy = uy/dsqrt(norm) + uz = uz/dsqrt(norm) + + call InnerProd(ex,norm,wx,wy,wz,vx,vy,vz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*vx + wy = wy - norm*vy + wz = wz - norm*vz + + call InnerProd(ex,norm,wx,wy,wz,ux,uy,uz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx - norm*ux + wy = wy - norm*uy + wz = wz - norm*uz + + call InnerProd(ex,norm,wx,wy,wz,wx,wy,wz,gxx,gxy,gxz,gyy,gyz,gzz) + wx = wx/dsqrt(norm) + wy = wy/dsqrt(norm) + wz = wz/dsqrt(norm) + + return + + end subroutine get_triad2_ss diff --git a/AMSS_NCKU_source/getnpem2.f90 b/AMSS_NCKU_source/Psi4/getnpem2.f90 similarity index 96% rename from AMSS_NCKU_source/getnpem2.f90 rename to AMSS_NCKU_source/Psi4/getnpem2.f90 index d762a67..980fec9 100644 --- a/AMSS_NCKU_source/getnpem2.f90 +++ b/AMSS_NCKU_source/Psi4/getnpem2.f90 @@ -1,1910 +1,1910 @@ - - -#include "macrodef.fh" - -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! -!----------------------------------------------------------------------------- - - subroutine getnpem2(ext, X, Y, Z, & - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Ex,Ey,Ez,Bx,By,Bz, & - Rphi2, Iphi2, & - symmetry) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ext(1:3),symmetry - real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3)) - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi2,Iphi2 - -!~~~~~~> Other variables: - - real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz - real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz - real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 - real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - chi3o2 = dsqrt(chipn1)**3 - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -! v:r; u: phi; w: theta -#if (tetradtype == 0) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - -! E_i - HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 - HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 - HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 - - f = dsqrt(f)**3 -! \sqrt(gamma)r x B - HBx = (vy*Bz - vz*By)*f - HBy = (vz*Bx - vx*Bz)*f - HBz = (vx*By - vy*Bx)*f - -#if (tetradtype == 1) -!set m = (theta + i phi)/sqrt(2) following Sperhake, Eq.(3.2) of PRD 85, 124062(2012) -! m = (w + i u )/sqrt(2) -!the real part of Phi2 - Rphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz -!the imaginary part of Phi2 - Iphi2 = -(HEx-HBx)*ux-(HEy-HBy)*uy-(HEz-HBz)*uz - -#else -!set m = (phi - i theta)/sqrt(2) following Frans,Eq.(8) of PRD 75, 124018(2007) -! m = (u - i w )/sqrt(2) - -!the real part of Phi2 - Rphi2 = (HEx-HBx)*ux+(HEy-HBy)*uy+(HEz-HBz)*uz -!the imaginary part of Phi2 - Iphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz -#endif - - Rphi2 = Rphi2/2.d0 - Iphi2 = Iphi2/2.d0 - - return - - end subroutine getnpem2 -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! for shell -! -!----------------------------------------------------------------------------- - - subroutine getnpem2_ss(ext,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Ex,Ey,Ez,Bx,By,Bz, & - Rphi2, Iphi2, & - symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ext(1:3),symmetry,sst - double precision,intent(in),dimension(ext(1))::crho - double precision,intent(in),dimension(ext(2))::sigma - double precision,intent(in),dimension(ext(3))::R - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: X,Y,Z - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi2,Iphi2 - -!~~~~~~> Other variables: - - real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz - real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz - real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 - real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - chi3o2 = dsqrt(chipn1)**3 - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -! v:r; u: phi; w: theta -#if (tetradtype == 0) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - -! E_i - HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 - HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 - HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 - - f = dsqrt(f)**3 -!set m = (u + iw)/sqrt(2) following Frans, PRD 75, 124018(2007) - -! \sqrt(gamma)r x B - HBx = (vy*Bz - vz*By)*f - HBy = (vz*Bx - vx*Bz)*f - HBz = (vx*By - vy*Bx)*f - -#if (tetradtype == 1) -!set m = (theta + i phi)/sqrt(2) following Sperhake, Eq.(3.2) of PRD 85, 124062(2012) -! m = (w + i u )/sqrt(2) -!the real part of Phi2 - Rphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz -!the imaginary part of Phi2 - Iphi2 = -(HEx-HBx)*ux-(HEy-HBy)*uy-(HEz-HBz)*uz - -#else -!set m = (phi - i theta)/sqrt(2) following Frans,Eq.(8) of PRD 75, 124018(2007) -! m = (u - i w )/sqrt(2) - -!the real part of Phi2 - Rphi2 = (HEx-HBx)*ux+(HEy-HBy)*uy+(HEz-HBz)*uz -!the imaginary part of Phi2 - Iphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz -#endif - - Rphi2 = Rphi2/2.d0 - Iphi2 = Iphi2/2.d0 - - return - - end subroutine getnpem2_ss -!----------------------------------------------------------------------------- -! -! compute the EM wave phi2 -! for BSSN dynamical variables -! for single point -!----------------------------------------------------------------------------- - - subroutine getnpem2_point(X, Y, Z, & - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Ex,Ey,Ez,Bx,By,Bz, & - Rphi2, Iphi2) - - implicit none - -!~~~~~~> Input parameters: - real*8, intent(in ) :: X,Y,Z - real*8, intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz - real*8, intent(out):: Rphi2,Iphi2 - -!~~~~~~> Other variables: - - real*8 :: f,fx,fy,fz - real*8 :: gxx,gyy,gzz - real*8 :: chipn1,chi3o2 - real*8 :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8 :: HEx,HEy,HEz,HBx,HBy,HBz - real*8 :: gupxx,gupxy,gupxz - real*8 :: gupyy,gupyz,gupzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8,parameter::TINYRR=1.d-14 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - chi3o2 = dsqrt(chipn1)**3 - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -! v:r; u: phi; w: theta -#if (tetradtype == 0) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - -! E_i - HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 - HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 - HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 - - f = dsqrt(f)**3 -!set m = (u + iw)/sqrt(2) following Frans, PRD 75, 124018(2007) - -! \sqrt(gamma)r x B - HBx = (vy*Bz - vz*By)*f - HBy = (vz*Bx - vx*Bz)*f - HBz = (vx*By - vy*Bx)*f - -#if (tetradtype == 1) -!set m = (theta + i phi)/sqrt(2) following Sperhake, Eq.(3.2) of PRD 85, 124062(2012) -! m = (w + i u )/sqrt(2) -!the real part of Phi2 - Rphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz -!the imaginary part of Phi2 - Iphi2 = -(HEx-HBx)*ux-(HEy-HBy)*uy-(HEz-HBz)*uz - -#else -!set m = (phi - i theta)/sqrt(2) following Frans,Eq.(8) of PRD 75, 124018(2007) -! m = (u - i w )/sqrt(2) - -!the real part of Phi2 - Rphi2 = (HEx-HBx)*ux+(HEy-HBy)*uy+(HEz-HBz)*uz -!the imaginary part of Phi2 - Iphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz -#endif - - Rphi2 = Rphi2/2.d0 - Iphi2 = Iphi2/2.d0 - - return - - end subroutine getnpem2_point -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! -!----------------------------------------------------------------------------- - - subroutine getnpem1(ext, X, Y, Z, & - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Ex,Ey,Ez,Bx,By,Bz, & - Rphi1, Iphi1, & - symmetry) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ext(1:3),symmetry - real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3)) - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi1,Iphi1 - -!~~~~~~> Other variables: - - real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz - real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz - real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 - real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: sqr2 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - - sqr2 = dsqrt(2.d0) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - chi3o2 = dsqrt(chipn1)**3 - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -#if (tetradtype == 0) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i) - vy(i,j,k) = Y(j) - vz(i,j,k) = Z(k) - endif - if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(k) - wy(i,j,k) = TINYRR*Z(k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(j) - uy(i,j,k) = X(i) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i)*Z(k) - wy(i,j,k) = Y(j)*Z(k) - wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - - f = dsqrt(f)**3 -! E_i - HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 - HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 - HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 - - Rphi1 = HEx*vx+HEy*vy+HEz*vz - -! \sqrt(gamma)u x w (theta x phi) - HBx = (uy*wz - uz*wy)*f - HBy = (uz*wx - ux*wz)*f - HBz = (ux*wy - uy*wx)*f - Iphi1 = HBx*Bx+HBy*By+HBz*Bz - - Rphi1 = Rphi1/2.d0 - Iphi1 = Iphi1/2.d0 - - return - - end subroutine getnpem1 -!----------------------------------------------------------------------------- -! -! compute the Newman-Penrose Weyl scalar Psi4 -! for BSSN dynamical variables -! for shell -! -!----------------------------------------------------------------------------- - - subroutine getnpem1_ss(ext,crho,sigma,R, X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Ex,Ey,Ez,Bx,By,Bz, & - Rphi1, Iphi1, & - symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ext(1:3),symmetry,sst - double precision,intent(in),dimension(ext(1))::crho - double precision,intent(in),dimension(ext(2))::sigma - double precision,intent(in),dimension(ext(3))::R - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: X,Y,Z - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz - real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi1,Iphi1 - -!~~~~~~> Other variables: - - real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz - real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz - real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 - real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: sqr2 - integer::i,j,k - real*8,parameter::TINYRR=1.d-14 - - sqr2 = dsqrt(2.d0) - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - chi3o2 = dsqrt(chipn1)**3 - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -! v:r; u: phi; w: theta -#if (tetradtype == 0) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - do i=1,ext(1) - do j=1,ext(2) - do k=1,ext(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - - f = dsqrt(f)**3 -! E_i - HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 - HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 - HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 - - Rphi1 = HEx*vx+HEy*vy+HEz*vz -! \sqrt(gamma)u x w (theta x phi) - HBx = (uy*wz - uz*wy)*f - HBy = (uz*wx - ux*wz)*f - HBz = (ux*wy - uy*wx)*f - Iphi1 = HBx*Bx+HBy*By+HBz*Bz - - Rphi1 = Rphi1/2.d0 - Iphi1 = Iphi1/2.d0 - - return - - end subroutine getnpem1_ss -!----------------------------------------------------------------------------- -! -! compute the EM wave phi1 -! for BSSN dynamical variables -! for single point -!----------------------------------------------------------------------------- - - subroutine getnpem1_point(X, Y, Z, & - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Ex,Ey,Ez,Bx,By,Bz, & - Rphi1, Iphi1) - - implicit none - -!~~~~~~> Input parameters: - real*8, intent(in ) :: X,Y,Z - real*8, intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz - real*8, intent(out):: Rphi1,Iphi1 - -!~~~~~~> Other variables: - - real*8 :: f,fx,fy,fz - real*8 :: gxx,gyy,gzz - real*8 :: chipn1,chi3o2 - real*8 :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8 :: HEx,HEy,HEz,HBx,HBy,HBz - real*8 :: gupxx,gupxy,gupxz - real*8 :: gupyy,gupyz,gupzz - - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 - real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8,parameter::TINYRR=1.d-14 - - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - chipn1= chi + ONE - chi3o2 = dsqrt(chipn1)**3 - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! initialize U, V, W vetors -! v:r; u: phi; w: theta -#if (tetradtype == 0) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#elif (tetradtype == 1) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - f = 1.d0/chipn1 - - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx - - fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & - gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & - gxz*wz*ux + gyz*wz*uy + gzz*wz*uz - fx = fx*f - ux = ux - fx*wx - uy = uy - fx*wy - uz = uz - fx*wz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - vx = vx - fx*wx - vy = vy - fx*wy - vz = vz - fx*wz - fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & - gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & - gxz*uz*vx + gyz*uz*vy + gzz*uz*vz - fx = fx*f - vx = vx - fx*ux - vy = vy - fx*uy - vz = vz - fx*uz - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx -#elif (tetradtype == 2) - if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then - vx = TINYRR - vy = TINYRR - vz = TINYRR - else - vx = X - vy = Y - vz = Z - endif - if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then - ux = - TINYRR - uy = TINYRR - uz = ZEO - wx = TINYRR*Z - wy = TINYRR*Z - wz = -2*TINYRR*TINYRR - else - ux = - Y - uy = X - uz = ZEO - wx = X*Z - wy = Y*Z - wz = -(X*X + Y*Y) - endif - - fx = vx - fy = vy - fz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - f = 1.d0/chipn1 - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*f) - vx = vx/fx - vy = vy/fx - vz = vz/fx - - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx*f - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx*f) - ux = ux/fx - uy = uy/fx - uz = uz/fx - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx*f - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx*f - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx*f) - wx = wx/fx - wy = wy/fx - wz = wz/fx -#endif - - f = dsqrt(f)**3 -! E_i - HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 - HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 - HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 - - Rphi1 = HEx*vx+HEy*vy+HEz*vz -! \sqrt(gamma)u x w (theta x phi) - HBx = (uy*wz - uz*wy)*f - HBy = (uz*wx - ux*wz)*f - HBz = (ux*wy - uy*wx)*f - Iphi1 = HBx*Bx+HBy*By+HBz*Bz - - Rphi1 = Rphi1/2.d0 - Iphi1 = Iphi1/2.d0 - - return - - end subroutine getnpem1_point + + +#include "macrodef.fh" + +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! +!----------------------------------------------------------------------------- + + subroutine getnpem2(ext, X, Y, Z, & + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Ex,Ey,Ez,Bx,By,Bz, & + Rphi2, Iphi2, & + symmetry) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ext(1:3),symmetry + real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3)) + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi2,Iphi2 + +!~~~~~~> Other variables: + + real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz + real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz + real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 + real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + chi3o2 = dsqrt(chipn1)**3 + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +! v:r; u: phi; w: theta +#if (tetradtype == 0) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + +! E_i + HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 + HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 + HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 + + f = dsqrt(f)**3 +! \sqrt(gamma)r x B + HBx = (vy*Bz - vz*By)*f + HBy = (vz*Bx - vx*Bz)*f + HBz = (vx*By - vy*Bx)*f + +#if (tetradtype == 1) +!set m = (theta + i phi)/sqrt(2) following Sperhake, Eq.(3.2) of PRD 85, 124062(2012) +! m = (w + i u )/sqrt(2) +!the real part of Phi2 + Rphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz +!the imaginary part of Phi2 + Iphi2 = -(HEx-HBx)*ux-(HEy-HBy)*uy-(HEz-HBz)*uz + +#else +!set m = (phi - i theta)/sqrt(2) following Frans,Eq.(8) of PRD 75, 124018(2007) +! m = (u - i w )/sqrt(2) + +!the real part of Phi2 + Rphi2 = (HEx-HBx)*ux+(HEy-HBy)*uy+(HEz-HBz)*uz +!the imaginary part of Phi2 + Iphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz +#endif + + Rphi2 = Rphi2/2.d0 + Iphi2 = Iphi2/2.d0 + + return + + end subroutine getnpem2 +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! for shell +! +!----------------------------------------------------------------------------- + + subroutine getnpem2_ss(ext,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Ex,Ey,Ez,Bx,By,Bz, & + Rphi2, Iphi2, & + symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ext(1:3),symmetry,sst + double precision,intent(in),dimension(ext(1))::crho + double precision,intent(in),dimension(ext(2))::sigma + double precision,intent(in),dimension(ext(3))::R + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: X,Y,Z + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi2,Iphi2 + +!~~~~~~> Other variables: + + real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz + real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz + real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 + real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + chi3o2 = dsqrt(chipn1)**3 + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +! v:r; u: phi; w: theta +#if (tetradtype == 0) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + +! E_i + HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 + HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 + HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 + + f = dsqrt(f)**3 +!set m = (u + iw)/sqrt(2) following Frans, PRD 75, 124018(2007) + +! \sqrt(gamma)r x B + HBx = (vy*Bz - vz*By)*f + HBy = (vz*Bx - vx*Bz)*f + HBz = (vx*By - vy*Bx)*f + +#if (tetradtype == 1) +!set m = (theta + i phi)/sqrt(2) following Sperhake, Eq.(3.2) of PRD 85, 124062(2012) +! m = (w + i u )/sqrt(2) +!the real part of Phi2 + Rphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz +!the imaginary part of Phi2 + Iphi2 = -(HEx-HBx)*ux-(HEy-HBy)*uy-(HEz-HBz)*uz + +#else +!set m = (phi - i theta)/sqrt(2) following Frans,Eq.(8) of PRD 75, 124018(2007) +! m = (u - i w )/sqrt(2) + +!the real part of Phi2 + Rphi2 = (HEx-HBx)*ux+(HEy-HBy)*uy+(HEz-HBz)*uz +!the imaginary part of Phi2 + Iphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz +#endif + + Rphi2 = Rphi2/2.d0 + Iphi2 = Iphi2/2.d0 + + return + + end subroutine getnpem2_ss +!----------------------------------------------------------------------------- +! +! compute the EM wave phi2 +! for BSSN dynamical variables +! for single point +!----------------------------------------------------------------------------- + + subroutine getnpem2_point(X, Y, Z, & + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Ex,Ey,Ez,Bx,By,Bz, & + Rphi2, Iphi2) + + implicit none + +!~~~~~~> Input parameters: + real*8, intent(in ) :: X,Y,Z + real*8, intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz + real*8, intent(out):: Rphi2,Iphi2 + +!~~~~~~> Other variables: + + real*8 :: f,fx,fy,fz + real*8 :: gxx,gyy,gzz + real*8 :: chipn1,chi3o2 + real*8 :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8 :: HEx,HEy,HEz,HBx,HBy,HBz + real*8 :: gupxx,gupxy,gupxz + real*8 :: gupyy,gupyz,gupzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8,parameter::TINYRR=1.d-14 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + chi3o2 = dsqrt(chipn1)**3 + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +! v:r; u: phi; w: theta +#if (tetradtype == 0) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + +! E_i + HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 + HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 + HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 + + f = dsqrt(f)**3 +!set m = (u + iw)/sqrt(2) following Frans, PRD 75, 124018(2007) + +! \sqrt(gamma)r x B + HBx = (vy*Bz - vz*By)*f + HBy = (vz*Bx - vx*Bz)*f + HBz = (vx*By - vy*Bx)*f + +#if (tetradtype == 1) +!set m = (theta + i phi)/sqrt(2) following Sperhake, Eq.(3.2) of PRD 85, 124062(2012) +! m = (w + i u )/sqrt(2) +!the real part of Phi2 + Rphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz +!the imaginary part of Phi2 + Iphi2 = -(HEx-HBx)*ux-(HEy-HBy)*uy-(HEz-HBz)*uz + +#else +!set m = (phi - i theta)/sqrt(2) following Frans,Eq.(8) of PRD 75, 124018(2007) +! m = (u - i w )/sqrt(2) + +!the real part of Phi2 + Rphi2 = (HEx-HBx)*ux+(HEy-HBy)*uy+(HEz-HBz)*uz +!the imaginary part of Phi2 + Iphi2 = (HEx-HBx)*wx+(HEy-HBy)*wy+(HEz-HBz)*wz +#endif + + Rphi2 = Rphi2/2.d0 + Iphi2 = Iphi2/2.d0 + + return + + end subroutine getnpem2_point +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! +!----------------------------------------------------------------------------- + + subroutine getnpem1(ext, X, Y, Z, & + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Ex,Ey,Ez,Bx,By,Bz, & + Rphi1, Iphi1, & + symmetry) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ext(1:3),symmetry + real*8, intent(in ):: X(1:ext(1)),Y(1:ext(2)),Z(1:ext(3)) + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi1,Iphi1 + +!~~~~~~> Other variables: + + real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz + real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz + real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 + real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: sqr2 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + + sqr2 = dsqrt(2.d0) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + chi3o2 = dsqrt(chipn1)**3 + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +#if (tetradtype == 0) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR .and. abs(Z(k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i) + vy(i,j,k) = Y(j) + vz(i,j,k) = Z(k) + endif + if(abs(X(i)) < TINYRR .and. abs(Y(j)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(k) + wy(i,j,k) = TINYRR*Z(k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(j) + uy(i,j,k) = X(i) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i)*Z(k) + wy(i,j,k) = Y(j)*Z(k) + wz(i,j,k) = -(X(i)*X(i) + Y(j)*Y(j)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + + f = dsqrt(f)**3 +! E_i + HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 + HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 + HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 + + Rphi1 = HEx*vx+HEy*vy+HEz*vz + +! \sqrt(gamma)u x w (theta x phi) + HBx = (uy*wz - uz*wy)*f + HBy = (uz*wx - ux*wz)*f + HBz = (ux*wy - uy*wx)*f + Iphi1 = HBx*Bx+HBy*By+HBz*Bz + + Rphi1 = Rphi1/2.d0 + Iphi1 = Iphi1/2.d0 + + return + + end subroutine getnpem1 +!----------------------------------------------------------------------------- +! +! compute the Newman-Penrose Weyl scalar Psi4 +! for BSSN dynamical variables +! for shell +! +!----------------------------------------------------------------------------- + + subroutine getnpem1_ss(ext,crho,sigma,R, X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Ex,Ey,Ez,Bx,By,Bz, & + Rphi1, Iphi1, & + symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ext(1:3),symmetry,sst + double precision,intent(in),dimension(ext(1))::crho + double precision,intent(in),dimension(ext(2))::sigma + double precision,intent(in),dimension(ext(3))::R + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: X,Y,Z + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ext(1),ext(2),ext(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ext(1),ext(2),ext(3)),intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz + real*8, dimension(ext(1),ext(2),ext(3)), intent(out):: Rphi1,Iphi1 + +!~~~~~~> Other variables: + + real*8, dimension(ext(1),ext(2),ext(3)) :: f,fx,fy,fz + real*8, dimension(ext(1),ext(2),ext(3)) :: gxx,gyy,gzz + real*8, dimension(ext(1),ext(2),ext(3)) :: chipn1,chi3o2 + real*8, dimension(ext(1),ext(2),ext(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ext(1),ext(2),ext(3)) :: HEx,HEy,HEz,HBx,HBy,HBz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ext(1),ext(2),ext(3)) :: gupyy,gupyz,gupzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: sqr2 + integer::i,j,k + real*8,parameter::TINYRR=1.d-14 + + sqr2 = dsqrt(2.d0) + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + chi3o2 = dsqrt(chipn1)**3 + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +! v:r; u: phi; w: theta +#if (tetradtype == 0) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + do i=1,ext(1) + do j=1,ext(2) + do k=1,ext(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + + f = dsqrt(f)**3 +! E_i + HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 + HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 + HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 + + Rphi1 = HEx*vx+HEy*vy+HEz*vz +! \sqrt(gamma)u x w (theta x phi) + HBx = (uy*wz - uz*wy)*f + HBy = (uz*wx - ux*wz)*f + HBz = (ux*wy - uy*wx)*f + Iphi1 = HBx*Bx+HBy*By+HBz*Bz + + Rphi1 = Rphi1/2.d0 + Iphi1 = Iphi1/2.d0 + + return + + end subroutine getnpem1_ss +!----------------------------------------------------------------------------- +! +! compute the EM wave phi1 +! for BSSN dynamical variables +! for single point +!----------------------------------------------------------------------------- + + subroutine getnpem1_point(X, Y, Z, & + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Ex,Ey,Ez,Bx,By,Bz, & + Rphi1, Iphi1) + + implicit none + +!~~~~~~> Input parameters: + real*8, intent(in ) :: X,Y,Z + real*8, intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, intent(in ) :: chi,Ex,Ey,Ez,Bx,By,Bz + real*8, intent(out):: Rphi1,Iphi1 + +!~~~~~~> Other variables: + + real*8 :: f,fx,fy,fz + real*8 :: gxx,gyy,gzz + real*8 :: chipn1,chi3o2 + real*8 :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8 :: HEx,HEy,HEz,HBx,HBy,HBz + real*8 :: gupxx,gupxy,gupxz + real*8 :: gupyy,gupyz,gupzz + + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO = 2.d0 + real*8, parameter :: F1o3 = 1.d0/3.d0, FOUR = 4.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8,parameter::TINYRR=1.d-14 + + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + chipn1= chi + ONE + chi3o2 = dsqrt(chipn1)**3 + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! initialize U, V, W vetors +! v:r; u: phi; w: theta +#if (tetradtype == 0) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#elif (tetradtype == 1) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + f = 1.d0/chipn1 + + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx + + fx = gxx*wx*ux + gxy*wx*uy + gxz*wx*uz + & + gxy*wy*ux + gyy*wy*uy + gyz*wy*uz + & + gxz*wz*ux + gyz*wz*uy + gzz*wz*uz + fx = fx*f + ux = ux - fx*wx + uy = uy - fx*wy + uz = uz - fx*wz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + vx = vx - fx*wx + vy = vy - fx*wy + vz = vz - fx*wz + fx = gxx*ux*vx + gxy*ux*vy + gxz*ux*vz + & + gxy*uy*vx + gyy*uy*vy + gyz*uy*vz + & + gxz*uz*vx + gyz*uz*vy + gzz*uz*vz + fx = fx*f + vx = vx - fx*ux + vy = vy - fx*uy + vz = vz - fx*uz + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx +#elif (tetradtype == 2) + if(abs(X) < TINYRR .and. abs(Y) < TINYRR .and. abs(Z) < TINYRR)then + vx = TINYRR + vy = TINYRR + vz = TINYRR + else + vx = X + vy = Y + vz = Z + endif + if(abs(X) < TINYRR .and. abs(Y) < TINYRR)then + ux = - TINYRR + uy = TINYRR + uz = ZEO + wx = TINYRR*Z + wy = TINYRR*Z + wz = -2*TINYRR*TINYRR + else + ux = - Y + uy = X + uz = ZEO + wx = X*Z + wy = Y*Z + wz = -(X*X + Y*Y) + endif + + fx = vx + fy = vy + fz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + f = 1.d0/chipn1 + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*f) + vx = vx/fx + vy = vy/fx + vz = vz/fx + + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx*f + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx*f) + ux = ux/fx + uy = uy/fx + uz = uz/fx + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx*f + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx*f + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx*f) + wx = wx/fx + wy = wy/fx + wz = wz/fx +#endif + + f = dsqrt(f)**3 +! E_i + HEx = (gxx*Ex+gxy*Ey+gxz*Ez)*chipn1 + HEy = (gxy*Ex+gyy*Ey+gyz*Ez)*chipn1 + HEz = (gxz*Ex+gyz*Ey+gzz*Ez)*chipn1 + + Rphi1 = HEx*vx+HEy*vy+HEz*vz +! \sqrt(gamma)u x w (theta x phi) + HBx = (uy*wz - uz*wy)*f + HBy = (uz*wx - ux*wz)*f + HBz = (ux*wy - uy*wx)*f + Iphi1 = HBx*Bx+HBy*By+HBz*Bz + + Rphi1 = Rphi1/2.d0 + Iphi1 = Iphi1/2.d0 + + return + + end subroutine getnpem1_point diff --git a/AMSS_NCKU_source/getnpem2.h b/AMSS_NCKU_source/Psi4/getnpem2.h similarity index 97% rename from AMSS_NCKU_source/getnpem2.h rename to AMSS_NCKU_source/Psi4/getnpem2.h index 54057cd..88e098e 100644 --- a/AMSS_NCKU_source/getnpem2.h +++ b/AMSS_NCKU_source/Psi4/getnpem2.h @@ -1,90 +1,90 @@ - -#ifndef GETNPEM2_H -#define GETNPEM2_H - -#ifdef fortran1 -#define f_getnpem2 getnpem2 -#define f_getnpem2_point getnpem2_point -#define f_getnpem1_point getnpem1_point -#define f_getnpem2_ss getnpem2_ss -#define f_getnpem1 getnpem1 -#define f_getnpem1_ss getnpem1_ss -#endif -#ifdef fortran2 -#define f_getnpem2 GETNPEM2 -#define f_getnpem2_point GETNPEM2_POINT -#define f_getnpem1_point GETNPEM1_POINT -#define f_getnpem2_ss GETNPEM2_SS -#define f_getnpem1 GETNPEM1 -#define f_getnpem1_ss GETNPEM1_SS -#endif -#ifdef fortran3 -#define f_getnpem2 getnpem2_ -#define f_getnpem2_point getnpem2_point_ -#define f_getnpem1_point getnpem1_point_ -#define f_getnpem2_ss getnpem2_ss_ -#define f_getnpem1 getnpem1_ -#define f_getnpem1_ss getnpem1_ss_ -#endif - -extern "C" -{ - void f_getnpem2(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &); -} - -extern "C" -{ - void f_getnpem2_point(double &, double &, double &, - double &, double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &); -} - -extern "C" -{ - void f_getnpem2_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &, int &); -} - -extern "C" -{ - void f_getnpem1(int *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &); -} - -extern "C" -{ - void f_getnpem1_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, int &, int &); -} - -extern "C" -{ - void f_getnpem1_point(double &, double &, double &, - double &, double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &); -} - -#endif /* GETNPEM2_H */ + +#ifndef GETNPEM2_H +#define GETNPEM2_H + +#ifdef fortran1 +#define f_getnpem2 getnpem2 +#define f_getnpem2_point getnpem2_point +#define f_getnpem1_point getnpem1_point +#define f_getnpem2_ss getnpem2_ss +#define f_getnpem1 getnpem1 +#define f_getnpem1_ss getnpem1_ss +#endif +#ifdef fortran2 +#define f_getnpem2 GETNPEM2 +#define f_getnpem2_point GETNPEM2_POINT +#define f_getnpem1_point GETNPEM1_POINT +#define f_getnpem2_ss GETNPEM2_SS +#define f_getnpem1 GETNPEM1 +#define f_getnpem1_ss GETNPEM1_SS +#endif +#ifdef fortran3 +#define f_getnpem2 getnpem2_ +#define f_getnpem2_point getnpem2_point_ +#define f_getnpem1_point getnpem1_point_ +#define f_getnpem2_ss getnpem2_ss_ +#define f_getnpem1 getnpem1_ +#define f_getnpem1_ss getnpem1_ss_ +#endif + +extern "C" +{ + void f_getnpem2(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &); +} + +extern "C" +{ + void f_getnpem2_point(double &, double &, double &, + double &, double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &); +} + +extern "C" +{ + void f_getnpem2_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &, int &); +} + +extern "C" +{ + void f_getnpem1(int *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &); +} + +extern "C" +{ + void f_getnpem1_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, int &, int &); +} + +extern "C" +{ + void f_getnpem1_point(double &, double &, double &, + double &, double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &); +} + +#endif /* GETNPEM2_H */ diff --git a/AMSS_NCKU_source/ricci_gamma.f90 b/AMSS_NCKU_source/Psi4/ricci_gamma.f90 similarity index 98% rename from AMSS_NCKU_source/ricci_gamma.f90 rename to AMSS_NCKU_source/Psi4/ricci_gamma.f90 index 24ed7f0..608a119 100644 --- a/AMSS_NCKU_source/ricci_gamma.f90 +++ b/AMSS_NCKU_source/Psi4/ricci_gamma.f90 @@ -1,908 +1,908 @@ - - subroutine ricci_gamma(ex, X, Y, Z, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8 :: dX, dY, dZ - real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) - - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - - call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,0) - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - call fdderivs(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,ANTI,ANTI ,Symmetry,0) - Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) - -! Add chi part to Ricci tensor: - - Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO - - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - - return - - end subroutine ricci_gamma -!---------------------------------------------------------------------------- - subroutine ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,Lev,sst) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) - - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - - call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - call fdderivs_shc(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) - -! Add chi part to Ricci tensor: - - Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO - - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - - return - - end subroutine ricci_gamma_ss + + subroutine ricci_gamma(ex, X, Y, Z, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8 :: dX, dY, dZ + real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) + + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + + call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,0) + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + call fdderivs(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,ANTI,ANTI ,Symmetry,0) + Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,0) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) + +! Add chi part to Ricci tensor: + + Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO + + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + + return + + end subroutine ricci_gamma +!---------------------------------------------------------------------------- + subroutine ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,Lev,sst) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8, parameter :: ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: HALF = 0.5D0, F2o3 = 2.d0/3.d0, F3o2 = 1.5d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) + + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + + call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + call fdderivs_shc(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) + +! Add chi part to Ricci tensor: + + Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO + + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + + return + + end subroutine ricci_gamma_ss diff --git a/AMSS_NCKU_source/ricci_gamma.h b/AMSS_NCKU_source/Psi4/ricci_gamma.h similarity index 97% rename from AMSS_NCKU_source/ricci_gamma.h rename to AMSS_NCKU_source/Psi4/ricci_gamma.h index 585fe0b..a48184b 100644 --- a/AMSS_NCKU_source/ricci_gamma.h +++ b/AMSS_NCKU_source/Psi4/ricci_gamma.h @@ -1,48 +1,48 @@ - -#ifndef RICCI_GAMMA_H -#define RICCI_GAMMA_H - -#ifdef fortran1 -#define f_ricci_gamma ricci_gamma -#define f_ricci_gamma_ss ricci_gamma_ss -#endif -#ifdef fortran2 -#define f_ricci_gamma RICCI_GAMMA -#define f_ricci_gamma_ss RICCI_GAMMA_SS -#endif -#ifdef fortran3 -#define f_ricci_gamma ricci_gamma_ -#define f_ricci_gamma_ss ricci_gamma_ss_ -#endif -extern "C" -{ - void f_ricci_gamma(int *, double *, double *, double *, - double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - int &); -} - -extern "C" -{ - void f_ricci_gamma_ss(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - int &, int &, int &); -} -#endif /* RICCI_GAMMA_H */ + +#ifndef RICCI_GAMMA_H +#define RICCI_GAMMA_H + +#ifdef fortran1 +#define f_ricci_gamma ricci_gamma +#define f_ricci_gamma_ss ricci_gamma_ss +#endif +#ifdef fortran2 +#define f_ricci_gamma RICCI_GAMMA +#define f_ricci_gamma_ss RICCI_GAMMA_SS +#endif +#ifdef fortran3 +#define f_ricci_gamma ricci_gamma_ +#define f_ricci_gamma_ss ricci_gamma_ss_ +#endif +extern "C" +{ + void f_ricci_gamma(int *, double *, double *, double *, + double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + int &); +} + +extern "C" +{ + void f_ricci_gamma_ss(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + int &, int &, int &); +} +#endif /* RICCI_GAMMA_H */ diff --git a/AMSS_NCKU_source/DataCT.C b/AMSS_NCKU_source/Read_and_Write/DataCT.C similarity index 96% rename from AMSS_NCKU_source/DataCT.C rename to AMSS_NCKU_source/Read_and_Write/DataCT.C index 1079039..7f55671 100644 --- a/AMSS_NCKU_source/DataCT.C +++ b/AMSS_NCKU_source/Read_and_Write/DataCT.C @@ -1,283 +1,283 @@ - -//----------------------------------------------------------------------- -// Read binary files and do fancy things with them... -//----------------------------------------------------------------------- -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include "microdef.fh" - -int main(int argc, char *argv[]) -{ - // - // USE: DataCT flag file1 [ file2 ] - // - // where: - flag can be XY,XZ,YZ - // - void set_fname(char *fname); - - if (argc < 3) - { - cout << "\aUsage: DataCT flag binaryfile1 [ binaryfile2 ] \n " - << " where: - flag can be XY,XZ,YZ" - << endl; - exit(1); - } - ifstream infile1; - infile1.open(argv[2]); - if (!infile1) - { - cerr << "\a Can't open " << argv[2] << " for input." << endl; - exit(1); - } - - /* read properties of the binary file */ - double time; - int nx, ny, nz; - double xmin, xmax, ymin, ymax, zmin, zmax; - infile1.seekg(0, ios::beg); - infile1.read((char *)&time, sizeof(double)); - infile1.read((char *)&nx, sizeof(int)); - infile1.read((char *)&ny, sizeof(int)); - infile1.read((char *)&nz, sizeof(int)); - infile1.read((char *)&xmin, sizeof(double)); - infile1.read((char *)&xmax, sizeof(double)); - infile1.read((char *)&ymin, sizeof(double)); - infile1.read((char *)&ymax, sizeof(double)); - infile1.read((char *)&zmin, sizeof(double)); - infile1.read((char *)&zmax, sizeof(double)); - - /* get rid of any 4 character suffix */ - set_fname(argv[2]); - - /* sanity check */ - if (nx != ny || nx != nz) - { - cout << "\n" - << endl; - cout << " nx, ny and nz do not agree! Using a symmetry?... "; - cout << "\n" - << endl; - } - - cout << "\n Reading file : " << argv[2] << endl; - cout << "\n Time : " << time << endl; - cout << " Dimensions : " << setw(16) << nx << setw(16) << ny << setw(16) << nz << endl; - cout << " xmin, xmax : " << setw(16) << xmin << setw(16) << xmax << endl; - cout << " ymin, ymax : " << setw(16) << ymin << setw(16) << ymax << endl; - cout << " zmin, zmax : " << setw(16) << zmin << setw(16) << zmax << endl; - cout << "\n"; - - double *data; - data = new double[nx * ny * nz]; - int i = 0, j = 0, k = 0; - infile1.read((char *)data, nx * ny * nz * sizeof(double)); - infile1.close(); - // - // - // if second file given, open second file and subtract from first one! - // - // - if (argc == 4) - { - infile1.open(argv[3]); - if (!infile1) - { - cerr << "\a Can't open " << argv[3] << " for input." << endl; - exit(1); - } - double *indata; - indata = new double[nx * ny * nz]; - // read in header - infile1.seekg(0, ios::beg); - int nxin, nyin, nzin; - infile1.read((char *)&time, sizeof(double)); - infile1.read((char *)&nxin, sizeof(int)); - infile1.read((char *)&nyin, sizeof(int)); - infile1.read((char *)&nzin, sizeof(int)); - infile1.read((char *)&xmin, sizeof(double)); - infile1.read((char *)&xmax, sizeof(double)); - infile1.read((char *)&ymin, sizeof(double)); - infile1.read((char *)&ymax, sizeof(double)); - infile1.read((char *)&zmin, sizeof(double)); - infile1.read((char *)&zmax, sizeof(double)); - if (nxin != nx || nyin != ny || nzin != nz) - { - cerr << "\a Number of indices do not agree! " << endl; - exit(1); - } - cout << " Comparing with data at time " << time << "\n" - << endl; - infile1.read((char *)indata, nx * ny * nz * sizeof(double)); - infile1.close(); - for (i = 0; i < nx * ny * nz; i++) - data[i] -= indata[i]; - } - - double *X, *Y, *Z; - X = new double[nx]; - Y = new double[ny]; - Z = new double[nz]; - double dd; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (xmax - xmin) / (nx - 1); - for (i = 0; i < nx; i++) - X[i] = xmin + i * dd; - dd = (ymax - ymin) / (ny - 1); - for (j = 0; j < ny; j++) - Y[j] = ymin + j * dd; - dd = (zmax - zmin) / (nz - 1); - for (k = 0; k < nz; k++) - Z[k] = zmin + k * dd; -#else -#ifdef Cell - dd = (xmax - xmin) / nx; - for (i = 0; i < nx; i++) - X[i] = xmin + (i + 0.5) * dd; - dd = (ymax - ymin) / ny; - for (j = 0; j < ny; j++) - Y[j] = ymin + (j + 0.5) * dd; - dd = (zmax - zmin) / nz; - for (k = 0; k < nz; k++) - Z[k] = zmin + (k + 0.5) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - - int ext[3]; - ext[0] = nx; - ext[1] = ny; - ext[2] = nz; - void writefile(int *ext, double *XX, double *YY, double *ZZ, double *datain, - char *filename, const char *flag); - writefile(ext, X, Y, Z, data, argv[2], argv[1]); - - delete[] data; - delete[] X; - delete[] Y; - delete[] Z; -} - -/*-----------------------------------*/ -/* get rid of any 4 character suffix */ -/*-----------------------------------*/ -void set_fname(char *fname) -{ - int len = strlen(fname) - 4; - char *n_fname; - n_fname = new char[len]; - - for (int i = 0; i < len; ++i) - { - n_fname[i] = fname[i]; - // cout << n_fname[i] << " " << i << endl; - } - n_fname[len] = '\0'; - - // cout << "n_fname: " << n_fname << " fname: " << fname << ", " - // << len << endl; - - strcpy(fname, n_fname); /* Send back the old pointer */ - delete n_fname; -} -//|---------------------------------------------------------------------------- -// writefile -//|---------------------------------------------------------------------------- -void writefile(int *ext, double *XX, double *YY, double *ZZ, double *datain, - char *filename, const char *flag) -{ - int nx = ext[0], ny = ext[1], nz = ext[2]; - int i, j, k; - char filename_h[50]; - //|--->open out put file - ofstream outfile; - - if (!strcmp(flag, "YZ")) - { - for (i = 0; i < nx; i++) - { - sprintf(filename_h, "%s_%d.dat", filename, i); - outfile.open(filename_h); - outfile << "# CT along X at " << i << endl; - for (k = 0; k < nz; k++) - { - for (j = 0; j < ny; j++) - { - outfile << setw(10) << setprecision(10) << YY[j] << " " - << setw(10) << setprecision(10) << ZZ[k] << " " - << datain[i + j * nx + k * nx * ny] << " " - << endl; - } - outfile << "\n"; /* blanck line for gnuplot */ - } - outfile.close(); - } - } - else if (!strcmp(flag, "XZ")) - { - for (j = 0; j < ny; j++) - { - sprintf(filename_h, "%s_%d.dat", filename, j); - outfile.open(filename_h); - outfile << "# CT along Y at " << j << endl; - for (k = 0; k < nz; k++) - { - for (i = 0; i < nx; i++) - { - outfile << setw(10) << setprecision(10) << XX[i] << " " - << setw(10) << setprecision(10) << ZZ[k] << " " - << datain[i + j * nx + k * nx * ny] << " " - << endl; - } - outfile << "\n"; /* blanck line for gnuplot */ - } - outfile.close(); - } - } - else if (!strcmp(flag, "XY")) - { - for (k = 0; k < nz; k++) - { - sprintf(filename_h, "%s_%d.dat", filename, k); - outfile.open(filename_h); - outfile << "# CT along Z at " << k << endl; - for (j = 0; j < ny; j++) - { - for (i = 0; i < nx; i++) - { - outfile << setw(10) << setprecision(10) << XX[i] << " " - << setw(10) << setprecision(10) << YY[j] << " " - << datain[i + j * nx + k * nx * ny] << " " - << endl; - } - outfile << "\n"; /* blanck line for gnuplot */ - } - outfile.close(); - } - } - else - { - cout << "In output_data: not recognized flag-->" << flag << endl; - exit(0); - } -} + +//----------------------------------------------------------------------- +// Read binary files and do fancy things with them... +//----------------------------------------------------------------------- +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include "microdef.fh" + +int main(int argc, char *argv[]) +{ + // + // USE: DataCT flag file1 [ file2 ] + // + // where: - flag can be XY,XZ,YZ + // + void set_fname(char *fname); + + if (argc < 3) + { + cout << "\aUsage: DataCT flag binaryfile1 [ binaryfile2 ] \n " + << " where: - flag can be XY,XZ,YZ" + << endl; + exit(1); + } + ifstream infile1; + infile1.open(argv[2]); + if (!infile1) + { + cerr << "\a Can't open " << argv[2] << " for input." << endl; + exit(1); + } + + /* read properties of the binary file */ + double time; + int nx, ny, nz; + double xmin, xmax, ymin, ymax, zmin, zmax; + infile1.seekg(0, ios::beg); + infile1.read((char *)&time, sizeof(double)); + infile1.read((char *)&nx, sizeof(int)); + infile1.read((char *)&ny, sizeof(int)); + infile1.read((char *)&nz, sizeof(int)); + infile1.read((char *)&xmin, sizeof(double)); + infile1.read((char *)&xmax, sizeof(double)); + infile1.read((char *)&ymin, sizeof(double)); + infile1.read((char *)&ymax, sizeof(double)); + infile1.read((char *)&zmin, sizeof(double)); + infile1.read((char *)&zmax, sizeof(double)); + + /* get rid of any 4 character suffix */ + set_fname(argv[2]); + + /* sanity check */ + if (nx != ny || nx != nz) + { + cout << "\n" + << endl; + cout << " nx, ny and nz do not agree! Using a symmetry?... "; + cout << "\n" + << endl; + } + + cout << "\n Reading file : " << argv[2] << endl; + cout << "\n Time : " << time << endl; + cout << " Dimensions : " << setw(16) << nx << setw(16) << ny << setw(16) << nz << endl; + cout << " xmin, xmax : " << setw(16) << xmin << setw(16) << xmax << endl; + cout << " ymin, ymax : " << setw(16) << ymin << setw(16) << ymax << endl; + cout << " zmin, zmax : " << setw(16) << zmin << setw(16) << zmax << endl; + cout << "\n"; + + double *data; + data = new double[nx * ny * nz]; + int i = 0, j = 0, k = 0; + infile1.read((char *)data, nx * ny * nz * sizeof(double)); + infile1.close(); + // + // + // if second file given, open second file and subtract from first one! + // + // + if (argc == 4) + { + infile1.open(argv[3]); + if (!infile1) + { + cerr << "\a Can't open " << argv[3] << " for input." << endl; + exit(1); + } + double *indata; + indata = new double[nx * ny * nz]; + // read in header + infile1.seekg(0, ios::beg); + int nxin, nyin, nzin; + infile1.read((char *)&time, sizeof(double)); + infile1.read((char *)&nxin, sizeof(int)); + infile1.read((char *)&nyin, sizeof(int)); + infile1.read((char *)&nzin, sizeof(int)); + infile1.read((char *)&xmin, sizeof(double)); + infile1.read((char *)&xmax, sizeof(double)); + infile1.read((char *)&ymin, sizeof(double)); + infile1.read((char *)&ymax, sizeof(double)); + infile1.read((char *)&zmin, sizeof(double)); + infile1.read((char *)&zmax, sizeof(double)); + if (nxin != nx || nyin != ny || nzin != nz) + { + cerr << "\a Number of indices do not agree! " << endl; + exit(1); + } + cout << " Comparing with data at time " << time << "\n" + << endl; + infile1.read((char *)indata, nx * ny * nz * sizeof(double)); + infile1.close(); + for (i = 0; i < nx * ny * nz; i++) + data[i] -= indata[i]; + } + + double *X, *Y, *Z; + X = new double[nx]; + Y = new double[ny]; + Z = new double[nz]; + double dd; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (xmax - xmin) / (nx - 1); + for (i = 0; i < nx; i++) + X[i] = xmin + i * dd; + dd = (ymax - ymin) / (ny - 1); + for (j = 0; j < ny; j++) + Y[j] = ymin + j * dd; + dd = (zmax - zmin) / (nz - 1); + for (k = 0; k < nz; k++) + Z[k] = zmin + k * dd; +#else +#ifdef Cell + dd = (xmax - xmin) / nx; + for (i = 0; i < nx; i++) + X[i] = xmin + (i + 0.5) * dd; + dd = (ymax - ymin) / ny; + for (j = 0; j < ny; j++) + Y[j] = ymin + (j + 0.5) * dd; + dd = (zmax - zmin) / nz; + for (k = 0; k < nz; k++) + Z[k] = zmin + (k + 0.5) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + + int ext[3]; + ext[0] = nx; + ext[1] = ny; + ext[2] = nz; + void writefile(int *ext, double *XX, double *YY, double *ZZ, double *datain, + char *filename, const char *flag); + writefile(ext, X, Y, Z, data, argv[2], argv[1]); + + delete[] data; + delete[] X; + delete[] Y; + delete[] Z; +} + +/*-----------------------------------*/ +/* get rid of any 4 character suffix */ +/*-----------------------------------*/ +void set_fname(char *fname) +{ + int len = strlen(fname) - 4; + char *n_fname; + n_fname = new char[len]; + + for (int i = 0; i < len; ++i) + { + n_fname[i] = fname[i]; + // cout << n_fname[i] << " " << i << endl; + } + n_fname[len] = '\0'; + + // cout << "n_fname: " << n_fname << " fname: " << fname << ", " + // << len << endl; + + strcpy(fname, n_fname); /* Send back the old pointer */ + delete n_fname; +} +//|---------------------------------------------------------------------------- +// writefile +//|---------------------------------------------------------------------------- +void writefile(int *ext, double *XX, double *YY, double *ZZ, double *datain, + char *filename, const char *flag) +{ + int nx = ext[0], ny = ext[1], nz = ext[2]; + int i, j, k; + char filename_h[50]; + //|--->open out put file + ofstream outfile; + + if (!strcmp(flag, "YZ")) + { + for (i = 0; i < nx; i++) + { + sprintf(filename_h, "%s_%d.dat", filename, i); + outfile.open(filename_h); + outfile << "# CT along X at " << i << endl; + for (k = 0; k < nz; k++) + { + for (j = 0; j < ny; j++) + { + outfile << setw(10) << setprecision(10) << YY[j] << " " + << setw(10) << setprecision(10) << ZZ[k] << " " + << datain[i + j * nx + k * nx * ny] << " " + << endl; + } + outfile << "\n"; /* blanck line for gnuplot */ + } + outfile.close(); + } + } + else if (!strcmp(flag, "XZ")) + { + for (j = 0; j < ny; j++) + { + sprintf(filename_h, "%s_%d.dat", filename, j); + outfile.open(filename_h); + outfile << "# CT along Y at " << j << endl; + for (k = 0; k < nz; k++) + { + for (i = 0; i < nx; i++) + { + outfile << setw(10) << setprecision(10) << XX[i] << " " + << setw(10) << setprecision(10) << ZZ[k] << " " + << datain[i + j * nx + k * nx * ny] << " " + << endl; + } + outfile << "\n"; /* blanck line for gnuplot */ + } + outfile.close(); + } + } + else if (!strcmp(flag, "XY")) + { + for (k = 0; k < nz; k++) + { + sprintf(filename_h, "%s_%d.dat", filename, k); + outfile.open(filename_h); + outfile << "# CT along Z at " << k << endl; + for (j = 0; j < ny; j++) + { + for (i = 0; i < nx; i++) + { + outfile << setw(10) << setprecision(10) << XX[i] << " " + << setw(10) << setprecision(10) << YY[j] << " " + << datain[i + j * nx + k * nx * ny] << " " + << endl; + } + outfile << "\n"; /* blanck line for gnuplot */ + } + outfile.close(); + } + } + else + { + cout << "In output_data: not recognized flag-->" << flag << endl; + exit(0); + } +} diff --git a/AMSS_NCKU_source/tool.C b/AMSS_NCKU_source/Read_and_Write/tool.C similarity index 96% rename from AMSS_NCKU_source/tool.C rename to AMSS_NCKU_source/Read_and_Write/tool.C index d43ed46..717f26a 100644 --- a/AMSS_NCKU_source/tool.C +++ b/AMSS_NCKU_source/Read_and_Write/tool.C @@ -1,51 +1,51 @@ -#include -#include -// #include< -using namespace std; -/*void printss(int * a,int * b,int *c){ - int a1 = *a; - int b1 = *b; - int c1 = *c; - printf("%d,%d,%d\n",1,2,3); - printf("%d,%d,%d\n",a1,b1,c1); -}*/ -int main() -{ - ifstream fin; - ofstream fout; - fin.open("tool_input.txt"); - fout.open("tool_output.txt"); - - // ifstream fin1; - // fin1.open("input1.txt"); - char buf[20]; - char buf1[20]; - - while (fin >> buf) - { - // fin1>>buf1; - // fout<<"if("<[buf][i] != cg_gpu->[buf][i]){is_match = false; break;} - fout << "delta = cg->fgfs[" << buf << "][i] - cg_gpu->fgfs[" << buf << "][i];" << endl; - fout << "if(delta >1e-12 || delta < -1e-12){is_match = false; break;}" << endl; - } - /*int para = 167; - for(int i = para;ifgfs["< +#include +// #include< +using namespace std; +/*void printss(int * a,int * b,int *c){ + int a1 = *a; + int b1 = *b; + int c1 = *c; + printf("%d,%d,%d\n",1,2,3); + printf("%d,%d,%d\n",a1,b1,c1); +}*/ +int main() +{ + ifstream fin; + ofstream fout; + fin.open("tool_input.txt"); + fout.open("tool_output.txt"); + + // ifstream fin1; + // fin1.open("input1.txt"); + char buf[20]; + char buf1[20]; + + while (fin >> buf) + { + // fin1>>buf1; + // fout<<"if("<[buf][i] != cg_gpu->[buf][i]){is_match = false; break;} + fout << "delta = cg->fgfs[" << buf << "][i] - cg_gpu->fgfs[" << buf << "][i];" << endl; + fout << "if(delta >1e-12 || delta < -1e-12){is_match = false; break;}" << endl; + } + /*int para = 167; + for(int i = para;ifgfs["< -#include -#include -#include "macrodef.h" -extern "C" -{ -#ifdef fortran1 - void writefile_f -#endif -#ifdef fortran2 - void WRITEFILE_F -#endif -#ifdef fortran3 - void - writefile_f_ -#endif - (int &filetag, double *matrix, int &msize) - { - char fname[32]; - char ftag[32]; - // itoa(filetag,ftag,10); - sprintf(ftag, "%d", filetag); - strcpy(fname, "matrix_f.out"); - strcat(fname, ftag); - - /*printf("-------------called-------------"); - printf(fname); - printf("\n"); - printf("int tag %d\n",filetag); - printf("int msize %d\n",msize); - printf(ftag);*/ - - printf("int msize %d\n", msize); - - FILE *fp; - fp = fopen(fname, "wb"); - // char buffer[1024]; - // buffer[1023]='\0'; - // int bsize; - - if (fp == NULL) - { - printf("Open file failed."); - exit(0); - } - - // msize = sizeof(double) * msize; - fwrite(matrix, sizeof(double), msize, fp); - - fclose(fp); - // return 0; - } -} +#include +#include +#include +#include "macrodef.h" +extern "C" +{ +#ifdef fortran1 + void writefile_f +#endif +#ifdef fortran2 + void WRITEFILE_F +#endif +#ifdef fortran3 + void + writefile_f_ +#endif + (int &filetag, double *matrix, int &msize) + { + char fname[32]; + char ftag[32]; + // itoa(filetag,ftag,10); + sprintf(ftag, "%d", filetag); + strcpy(fname, "matrix_f.out"); + strcat(fname, ftag); + + /*printf("-------------called-------------"); + printf(fname); + printf("\n"); + printf("int tag %d\n",filetag); + printf("int msize %d\n",msize); + printf(ftag);*/ + + printf("int msize %d\n", msize); + + FILE *fp; + fp = fopen(fname, "wb"); + // char buffer[1024]; + // buffer[1023]='\0'; + // int bsize; + + if (fp == NULL) + { + printf("Open file failed."); + exit(0); + } + + // msize = sizeof(double) * msize; + fwrite(matrix, sizeof(double), msize, fp); + + fclose(fp); + // return 0; + } +} diff --git a/AMSS_NCKU_source/rungekutta4_rout.f90 b/AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout.f90 similarity index 94% rename from AMSS_NCKU_source/rungekutta4_rout.f90 rename to AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout.f90 index 1156c8c..5adc370 100644 --- a/AMSS_NCKU_source/rungekutta4_rout.f90 +++ b/AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout.f90 @@ -1,246 +1,246 @@ -!----------------------------------------------------------------------------- -! $Id: rungekutta4_rout.f90,v 1.6 2012/12/26 11:47:43 zjcao Exp $ -! Carry out 4th-order Runge-Kutta method -!----------------------------------------------------------------------------- -! rk4 for scalar - subroutine rungekutta4_scalar(dT,f0,f1,f_rhs,RK4) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: RK4 - real*8 ,intent(in):: dT,f0 - real*8 ,intent(inout):: f1,f_rhs - -!~~~~~~% Local parameter - - real*8, parameter :: F1o6=1.d0/6.d0, HLF=5.d-1, TWO=2.d0 - - if( RK4 == 0 ) then - - f1 = f0 + HLF * dT * f_rhs - - elseif(RK4 == 1 ) then - - f_rhs = f_rhs + TWO * f1 - f1 = f0 + HLF * dT * f1 - - elseif(RK4 == 2 ) then - - f_rhs = f_rhs + TWO * f1 - f1 = f0 + dT * f1 - - elseif( RK4 == 3 ) then - - f1 = f0 +F1o6 * dT *(f1 + f_rhs) - - else - - write(*,*) "rungekutta4_scalar: something is wrong in RK4 counting!!" - stop - - endif - - return - - end subroutine rungekutta4_scalar -!~~~~~~~~~~~~~~~~~~ -! rk4 for complex scalar - subroutine rungekutta4_cplxscalar(dT,f0,f1,f_rhs,RK4) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: RK4 - real*8 ,intent(in):: dT - double complex ,intent(in):: f0 - double complex ,intent(inout):: f1,f_rhs - -!~~~~~~% Local parameter - - real*8, parameter :: F1o6=1.d0/6.d0, HLF=5.d-1, TWO=2.d0 - - if( RK4 == 0 ) then - - f1 = f0 + HLF * dT * f_rhs - - elseif(RK4 == 1 ) then - - f_rhs = f_rhs + TWO * f1 - f1 = f0 + HLF * dT * f1 - - elseif(RK4 == 2 ) then - - f_rhs = f_rhs + TWO * f1 - f1 = f0 + dT * f1 - - elseif( RK4 == 3 ) then - - f1 = f0 +F1o6 * dT *(f1 + f_rhs) - - else - - write(*,*) "rungekutta4_cplxscalar: something is wrong in RK4 counting!!" - stop - - endif - - return - - end subroutine rungekutta4_cplxscalar -!~~~~~~~~~~~~~~~~~~ - subroutine rungekutta4_rout(ex,dT,f0,f1,f_rhs,RK4) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: ex(1:3),RK4 - real*8 ,intent(in):: dT - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f0 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f1 - -!~~~~~~% Local parameter - - real*8, parameter :: F1o6=1.d0/6.d0, HLF=5.d-1, TWO=2.d0 - - if( RK4 == 0 ) then - - f1 = f0 + HLF * dT * f_rhs - - elseif(RK4 == 1 ) then - - f_rhs = f_rhs + TWO * f1 - - f1 = f0 + HLF * dT * f1 - - elseif(RK4 == 2 ) then - - f_rhs = f_rhs + TWO * f1 - - f1 = f0 + dT * f1 - - elseif( RK4 == 3 ) then - - f1 = f0 +F1o6 * dT *(f1 + f_rhs) - - else - - write(*,*) "rungekutta4_rout: something is wrong in RK4 counting!!" - stop - - endif - - return - - end subroutine rungekutta4_rout -!----------------------------------------------------------------------------- -! icn for scalar - subroutine icn_scalar(dT,f0,f1,f_rhs,RK4) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: RK4 - real*8 ,intent(in):: dT,f0 - real*8 ,intent(inout):: f1,f_rhs - -!~~~~~~% Local parameter - - real*8, parameter :: HLF=5.d-1 - - if( RK4 == 0 ) then - - f1 = f0 + dT * f_rhs - - else - - f1 = f0 + HLF * dT * (f1+f_rhs) - - endif - - return - - end subroutine icn_scalar -!~~~~~~~~~~~~~~~~~~ -! icn for complex scalar - subroutine icn_cplxscalar(dT,f0,f1,f_rhs,RK4) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: RK4 - real*8 ,intent(in):: dT - double complex ,intent(in):: f0 - double complex ,intent(inout):: f1,f_rhs - -!~~~~~~% Local parameter - - real*8, parameter :: HLF=5.d-1 - - if( RK4 == 0 ) then - - f1 = f0 + dT * f_rhs - - else - - f1 = f0 + HLF * dT * (f1+f_rhs) - - endif - - return - - end subroutine icn_cplxscalar -!~~~~~~~~~~~~~~~~~~ - subroutine icn_rout(ex,dT,f0,f1,f_rhs,RK4) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: ex(1:3),RK4 - real*8 ,intent(in):: dT - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f0 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f1 - -!~~~~~~% Local parameter - - real*8, parameter :: HLF=5.d-1 - - if( RK4 == 0 ) then - - f1 = f0 + dT * f_rhs - - else - - f1 = f0 + HLF * dT * (f1+f_rhs) - - endif - - return - - end subroutine icn_rout -!~~~~~~~~~~~~~~~~~~ - subroutine euler_rout(ex,dT,f0,f1,f_rhs) - - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: ex(1:3) - real*8 ,intent(in):: dT - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f0 - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) ::f1 - - f1 = f0 + dT * f_rhs - - return - - end subroutine euler_rout +!----------------------------------------------------------------------------- +! $Id: rungekutta4_rout.f90,v 1.6 2012/12/26 11:47:43 zjcao Exp $ +! Carry out 4th-order Runge-Kutta method +!----------------------------------------------------------------------------- +! rk4 for scalar + subroutine rungekutta4_scalar(dT,f0,f1,f_rhs,RK4) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: RK4 + real*8 ,intent(in):: dT,f0 + real*8 ,intent(inout):: f1,f_rhs + +!~~~~~~% Local parameter + + real*8, parameter :: F1o6=1.d0/6.d0, HLF=5.d-1, TWO=2.d0 + + if( RK4 == 0 ) then + + f1 = f0 + HLF * dT * f_rhs + + elseif(RK4 == 1 ) then + + f_rhs = f_rhs + TWO * f1 + f1 = f0 + HLF * dT * f1 + + elseif(RK4 == 2 ) then + + f_rhs = f_rhs + TWO * f1 + f1 = f0 + dT * f1 + + elseif( RK4 == 3 ) then + + f1 = f0 +F1o6 * dT *(f1 + f_rhs) + + else + + write(*,*) "rungekutta4_scalar: something is wrong in RK4 counting!!" + stop + + endif + + return + + end subroutine rungekutta4_scalar +!~~~~~~~~~~~~~~~~~~ +! rk4 for complex scalar + subroutine rungekutta4_cplxscalar(dT,f0,f1,f_rhs,RK4) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: RK4 + real*8 ,intent(in):: dT + double complex ,intent(in):: f0 + double complex ,intent(inout):: f1,f_rhs + +!~~~~~~% Local parameter + + real*8, parameter :: F1o6=1.d0/6.d0, HLF=5.d-1, TWO=2.d0 + + if( RK4 == 0 ) then + + f1 = f0 + HLF * dT * f_rhs + + elseif(RK4 == 1 ) then + + f_rhs = f_rhs + TWO * f1 + f1 = f0 + HLF * dT * f1 + + elseif(RK4 == 2 ) then + + f_rhs = f_rhs + TWO * f1 + f1 = f0 + dT * f1 + + elseif( RK4 == 3 ) then + + f1 = f0 +F1o6 * dT *(f1 + f_rhs) + + else + + write(*,*) "rungekutta4_cplxscalar: something is wrong in RK4 counting!!" + stop + + endif + + return + + end subroutine rungekutta4_cplxscalar +!~~~~~~~~~~~~~~~~~~ + subroutine rungekutta4_rout(ex,dT,f0,f1,f_rhs,RK4) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: ex(1:3),RK4 + real*8 ,intent(in):: dT + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f0 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f1 + +!~~~~~~% Local parameter + + real*8, parameter :: F1o6=1.d0/6.d0, HLF=5.d-1, TWO=2.d0 + + if( RK4 == 0 ) then + + f1 = f0 + HLF * dT * f_rhs + + elseif(RK4 == 1 ) then + + f_rhs = f_rhs + TWO * f1 + + f1 = f0 + HLF * dT * f1 + + elseif(RK4 == 2 ) then + + f_rhs = f_rhs + TWO * f1 + + f1 = f0 + dT * f1 + + elseif( RK4 == 3 ) then + + f1 = f0 +F1o6 * dT *(f1 + f_rhs) + + else + + write(*,*) "rungekutta4_rout: something is wrong in RK4 counting!!" + stop + + endif + + return + + end subroutine rungekutta4_rout +!----------------------------------------------------------------------------- +! icn for scalar + subroutine icn_scalar(dT,f0,f1,f_rhs,RK4) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: RK4 + real*8 ,intent(in):: dT,f0 + real*8 ,intent(inout):: f1,f_rhs + +!~~~~~~% Local parameter + + real*8, parameter :: HLF=5.d-1 + + if( RK4 == 0 ) then + + f1 = f0 + dT * f_rhs + + else + + f1 = f0 + HLF * dT * (f1+f_rhs) + + endif + + return + + end subroutine icn_scalar +!~~~~~~~~~~~~~~~~~~ +! icn for complex scalar + subroutine icn_cplxscalar(dT,f0,f1,f_rhs,RK4) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: RK4 + real*8 ,intent(in):: dT + double complex ,intent(in):: f0 + double complex ,intent(inout):: f1,f_rhs + +!~~~~~~% Local parameter + + real*8, parameter :: HLF=5.d-1 + + if( RK4 == 0 ) then + + f1 = f0 + dT * f_rhs + + else + + f1 = f0 + HLF * dT * (f1+f_rhs) + + endif + + return + + end subroutine icn_cplxscalar +!~~~~~~~~~~~~~~~~~~ + subroutine icn_rout(ex,dT,f0,f1,f_rhs,RK4) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: ex(1:3),RK4 + real*8 ,intent(in):: dT + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f0 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::f1 + +!~~~~~~% Local parameter + + real*8, parameter :: HLF=5.d-1 + + if( RK4 == 0 ) then + + f1 = f0 + dT * f_rhs + + else + + f1 = f0 + HLF * dT * (f1+f_rhs) + + endif + + return + + end subroutine icn_rout +!~~~~~~~~~~~~~~~~~~ + subroutine euler_rout(ex,dT,f0,f1,f_rhs) + + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: ex(1:3) + real*8 ,intent(in):: dT + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f0 + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) ::f_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) ::f1 + + f1 = f0 + dT * f_rhs + + return + + end subroutine euler_rout diff --git a/AMSS_NCKU_source/rungekutta4_rout.h b/AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout.h similarity index 95% rename from AMSS_NCKU_source/rungekutta4_rout.h rename to AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout.h index 1ae2e1e..00a78b2 100644 --- a/AMSS_NCKU_source/rungekutta4_rout.h +++ b/AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout.h @@ -1,57 +1,57 @@ - -#ifndef RUNGEKUTTA4_H -#define RUNGEKUTTA4_H - -#ifdef fortran1 -#define f_euler_rout euler_rout -#define f_rungekutta4_rout rungekutta4_rout -#define f_rungekutta4_scalar rungekutta4_scalar -#define f_icn_rout icn_rout -#define f_icn_scalar icn_scalar -#endif -#ifdef fortran2 -#define f_euler_rout EULER_ROUT -#define f_rungekutta4_rout RUNGEKUTTA4_ROUT -#define f_rungekutta4_scalar RUNGEKUTTA4_SCALAR -#define f_icn_rout ICN_ROUT -#define f_icn_scalar ICN_SCALAR -#endif -#ifdef fortran3 -#define f_euler_rout euler_rout_ -#define f_rungekutta4_rout rungekutta4_rout_ -#define f_rungekutta4_scalar rungekutta4_scalar_ -#define f_icn_rout icn_rout_ -#define f_icn_scalar icn_scalar_ -#endif - -extern "C" -{ - void f_rungekutta4_scalar(double &, double &, double &, double &, int &); -} - -extern "C" -{ - int f_rungekutta4_rout(int *, double &, - double *, double *, double *, - int &); -} - -extern "C" -{ - void f_icn_scalar(double &, double &, double &, double &, int &); -} - -extern "C" -{ - int f_icn_rout(int *, double &, - double *, double *, double *, - int &); -} - -extern "C" -{ - int f_euler_rout(int *, double &, - double *, double *, double *); -} - -#endif /* RUNGEKUTTA4_H */ + +#ifndef RUNGEKUTTA4_H +#define RUNGEKUTTA4_H + +#ifdef fortran1 +#define f_euler_rout euler_rout +#define f_rungekutta4_rout rungekutta4_rout +#define f_rungekutta4_scalar rungekutta4_scalar +#define f_icn_rout icn_rout +#define f_icn_scalar icn_scalar +#endif +#ifdef fortran2 +#define f_euler_rout EULER_ROUT +#define f_rungekutta4_rout RUNGEKUTTA4_ROUT +#define f_rungekutta4_scalar RUNGEKUTTA4_SCALAR +#define f_icn_rout ICN_ROUT +#define f_icn_scalar ICN_SCALAR +#endif +#ifdef fortran3 +#define f_euler_rout euler_rout_ +#define f_rungekutta4_rout rungekutta4_rout_ +#define f_rungekutta4_scalar rungekutta4_scalar_ +#define f_icn_rout icn_rout_ +#define f_icn_scalar icn_scalar_ +#endif + +extern "C" +{ + void f_rungekutta4_scalar(double &, double &, double &, double &, int &); +} + +extern "C" +{ + int f_rungekutta4_rout(int *, double &, + double *, double *, double *, + int &); +} + +extern "C" +{ + void f_icn_scalar(double &, double &, double &, double &, int &); +} + +extern "C" +{ + int f_icn_rout(int *, double &, + double *, double *, double *, + int &); +} + +extern "C" +{ + int f_euler_rout(int *, double &, + double *, double *, double *); +} + +#endif /* RUNGEKUTTA4_H */ diff --git a/AMSS_NCKU_source/rungekutta4_rout_c.C b/AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout_c.C similarity index 100% rename from AMSS_NCKU_source/rungekutta4_rout_c.C rename to AMSS_NCKU_source/Runge_Kutta/rungekutta4_rout_c.C diff --git a/AMSS_NCKU_source/Set_Rho_ADM.f90 b/AMSS_NCKU_source/Scalar/Set_Rho_ADM.f90 similarity index 96% rename from AMSS_NCKU_source/Set_Rho_ADM.f90 rename to AMSS_NCKU_source/Scalar/Set_Rho_ADM.f90 index 4e486bf..41c6c39 100644 --- a/AMSS_NCKU_source/Set_Rho_ADM.f90 +++ b/AMSS_NCKU_source/Scalar/Set_Rho_ADM.f90 @@ -1,271 +1,271 @@ - -! define scalar field distribution and potential in F(R) scalar-tensor theory -! 1: Case C of 1112.3928, V=0 -! 2: shell with a2^2*phi0/(1+a2^2), f(R) = R+a2*R^2 induced V -! 3: ground state of Schrodinger-Newton system, f(R) = R+a2*R^2 induced V -! 4: a2 = oo and \phi = \phi_0*0.5*(tanh((r+r_0)/\sigma)-tanh((r-r_0)/\sigma)) -! 5: shell with phi0*dexp(-(r-r0)**2/sigma), V = 0 - -! original way, manually define the preprocessor macro -! #define CC 2 -! the new way, define according to the preprocessor macro in "macrodef.fh" -#include "macrodef.fh" -#define CC EScalar_CC - -subroutine setparameters(a2,r0,phi0,sigma,l2) -implicit none -real*8,intent(out) :: a2,r0,phi0,sigma,l2 - -! original way: read in parameters one by one -! call seta2(a2) -! call setphi0(phi0) - -! new way: read in all parameters at once -call set_escalar_parameter(a2, phi0, r0, sigma, l2) - -! r0=120.d0 -! sigma=8.d0 -! l2=1.d4 - -! write(*,*) -! write(*,*) " Set_Rho_ADM.f90 a2 = ", a2 -! write(*,*) " Set_Rho_ADM.f90 phi0 = ", phi0 -! write(*,*) " Set_Rho_ADM.f90 r0 = ", r0 -! write(*,*) " Set_Rho_ADM.f90 sigma0 = ", sigma -! write(*,*) " Set_Rho_ADM.f90 l2 = ", l2 -! write(*,*) - -return - -end subroutine setparameters -!=================================================================== -function phi(X,Y,Z) result(gont) -implicit none - -double precision,intent(in)::X -double precision,intent(in)::Y -double precision,intent(in)::Z -real*8 :: gont - -real*8 ::r -real*8 :: a2,r0,phi0,sigma,l2 - - call setparameters(a2,r0,phi0,sigma,l2) - r=dsqrt(X*X+Y*Y+Z*Z) -#if ( CC == 1) -! configuration 1 - gont = phi0*dtanh((r-r0)/sigma) -#elif ( CC == 2) -! configuration 2 - phi0 = a2**2*phi0/(1+a2**2) - gont = phi0*dexp(-(r-r0)**2/sigma) -#elif ( CC == 3) - gont = (0.0481646d0*dexp(-0.0581545d0*(r-1.8039d-8)*(r-1.8039d-8)/l2) & - +0.298408d0*dexp(-0.111412d0*(r+9.6741d-9)*(r+9.6741d-9)/l2)+ & - 0.42755d0*dexp(-0.207156d0*(r-1.09822d-8)*(r-1.09822d-8)/l2)+ & - 0.204229d0*dexp(-0.37742d0*(r+2.13778d-8)*(r+2.13778d-8)/l2)+ & - 0.021649d0*dexp(-0.68406d0*(r-8.78608d-8)*(r-8.78608d-8)/l2))/l2 -#elif ( CC == 4) -! configuration 4, a2 = oo - phi0 = 0.5d0*phi0 - gont = phi0*(dtanh((r+r0)/sigma)-dtanh((r-r0)/sigma)) -#elif ( CC == 5) -! configuration 5 - gont = phi0*dexp(-(r-r0)**2/sigma) -#endif - -return - -end function phi - -! d phi/dr -function dphi(X,Y,Z) result(gont) -implicit none - -double precision,intent(in)::X -double precision,intent(in)::Y -double precision,intent(in)::Z -real*8 :: gont - -real*8 ::r -real*8 :: a2,r0,phi0,sigma,l2 - - call setparameters(a2,r0,phi0,sigma,l2) - r=dsqrt(X*X+Y*Y+Z*Z) -#if ( CC == 1) -! configuration 1 - gont = phi0/sigma*(1-(dtanh((r-r0)/sigma))**2) -#elif ( CC == 2) -! configuration 2 - phi0 = a2**2*phi0/(1+a2**2) - gont = -2.d0*phi0*(r-r0)/sigma*exp(-(r-r0)**2/sigma) -#elif ( CC == 3) - gont = (-0.5601976461d-2*(r-0.18039d-7)/l2*dexp(-0.581545d-1*(r-0.18039d-7)**2/l2) & - -0.6649246419d-1*(r+0.96741d-8)/l2*dexp(-0.111412d0*(r+.96741e-8)**2/l2) & - -0.1771390956d0*(r-0.109822d-7)/l2*dexp(-0.207156d0*(r-0.109822d-7)**2/l2) & - -0.1541602184d0*(r+0.213778d-7)/l2*dexp(-0.37742d0*(r+0.213778d-7)**2/l2) & - -0.2961842988d-1*(r-0.878608d-7)/l2*dexp(-0.68406*(r-0.878608d-7)**2/l2))/l2 -#elif ( CC == 4) -! configuration 4, a2 = oo - phi0 = 0.5d0*phi0 - gont = phi0*((1-dtanh((r+r0)/sigma)**2)/sigma- & - (1-dtanh((r-r0)/sigma)**2)/sigma) -#elif ( CC == 5) -! configuration 5 - gont = -2.d0*phi0*(r-r0)/sigma*exp(-(r-r0)**2/sigma) -#endif - -return - -end function dphi -!================================================================== -function potential(X,Y,Z) result(gont) -implicit none - -double precision,intent(in)::X -double precision,intent(in)::Y -double precision,intent(in)::Z -real*8 :: gont - -real*8 :: phi -real*8 :: PI,v - -real*8 :: a2,r0,phi0,sigma,l2 - -#if ( CC == 1 || CC == 4 || CC == 5) - gont = 0.d0 - -#elif ( CC == 2 || CC == 3) - call setparameters(a2,r0,phi0,sigma,l2) - PI = dacos(-1.d0) - - v = phi(X,Y,Z) - - gont = dexp(-8.d0*dsqrt(PI/3)*v)*(1-dexp(4*dsqrt(PI/3)*v))**2/32/PI/a2 -#endif - -return - -end function potential -!================================================================== -!Note this part is for evolution -!not just for initial configuration - -!f(R) potential F=R+a_2R^2 -subroutine frpotential(ex,Sphi,V,dVdSphi) - -implicit none - -integer,intent(in ):: ex(1:3) -real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi -real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: V,dVdSphi - -real*8 :: a2,r0,phi0,sigma,l2 -real*8, parameter :: Four = 4.d0, TWO = 2.d0,ONE = 1.d0,ZEO=0.d0 -real*8 :: PI - - PI = dacos(-ONE) - -#if ( CC == 1 || CC == 4 || CC == 5) - V = ZEO - dVdSphi = ZEO -#elif ( CC == 2 || CC == 3) - call setparameters(a2,r0,phi0,sigma,l2) - V = dexp(-8.d0*dsqrt(PI/3)*Sphi)*(1-dexp(4*dsqrt(PI/3)*Sphi))**2/32/PI/a2 - dVdSphi = 1.d0/a2/1.2d1*dsqrt(3.d0/PI)*dexp(-8.d0*dsqrt(PI/3.d0)*Sphi)*(-1+dexp(4*dsqrt(Pi/3)*Sphi)) -#endif - -return - -end subroutine frpotential -!================================================================== -!f(R) potential F=R+a_2R^2 -!fprim(R) = 1+2*a_2*R -subroutine frfprim(ex,RR,fprim) - -implicit none - -integer,intent(in ):: ex(1:3) -real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RR -real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: fprim - -real*8 :: a2,r0,phi0,sigma,l2 -real*8, parameter :: ONE=1.d0, TWO = 2.d0 - -#if ( CC == 1 || CC == 4 || CC == 5) - fprim = ONE -#elif ( CC == 2 || CC == 3) - call setparameters(a2,r0,phi0,sigma,l2) - fprim = ONE+TWO*a2*RR -#endif - -return - -end subroutine frfprim -!================================================================== -subroutine set_rho_adm2(ex,rho,X,Y,Z) - -implicit none -! argument variables -integer,intent(in)::ex -double precision,intent(in),dimension(ex)::X -double precision,intent(in),dimension(ex)::Y -double precision,intent(in),dimension(ex)::Z -double precision,intent(out),dimension(ex)::rho - -integer :: i -real*8 :: dphi - - do i=1,ex - ! rho(i) = dphi(X,Y,Z) - rho(i) = dphi(X(i),Y(i),Z(i)) - rho(i) = rho(i)*rho(i) - enddo - - return - -end subroutine set_rho_adm2 - -subroutine set_rho_adm1(ex,rho,X,Y,Z) - -implicit none -! argument variables -integer,intent(in)::ex -double precision,intent(in),dimension(ex)::X -double precision,intent(in),dimension(ex)::Y -double precision,intent(in),dimension(ex)::Z -double precision,intent(out),dimension(ex)::rho - -real*8 :: potential -integer :: i - - do i=1,ex - rho(i) = potential(X(i),Y(i),Z(i)) - enddo - - return - -end subroutine set_rho_adm1 - -subroutine set_rho_adm(ex,rho,X,Y,Z) - -implicit none -! argument variables -integer,intent(in)::ex -double precision,intent(in),dimension(ex)::X -double precision,intent(in),dimension(ex)::Y -double precision,intent(in),dimension(ex)::Z -! in psivac, out rho_adm -double precision,intent(inout),dimension(ex)::rho - -double precision,dimension(ex)::rho1,rho2 - - call set_rho_adm1(ex,rho1,X,Y,Z) - call set_rho_adm2(ex,rho2,X,Y,Z) - - rho = rho**4 - rho = rho**2*rho1+rho*rho2 - - return - -end subroutine set_rho_adm + +! define scalar field distribution and potential in F(R) scalar-tensor theory +! 1: Case C of 1112.3928, V=0 +! 2: shell with a2^2*phi0/(1+a2^2), f(R) = R+a2*R^2 induced V +! 3: ground state of Schrodinger-Newton system, f(R) = R+a2*R^2 induced V +! 4: a2 = oo and \phi = \phi_0*0.5*(tanh((r+r_0)/\sigma)-tanh((r-r_0)/\sigma)) +! 5: shell with phi0*dexp(-(r-r0)**2/sigma), V = 0 + +! original way, manually define the preprocessor macro +! #define CC 2 +! the new way, define according to the preprocessor macro in "macrodef.fh" +#include "macrodef.fh" +#define CC EScalar_CC + +subroutine setparameters(a2,r0,phi0,sigma,l2) +implicit none +real*8,intent(out) :: a2,r0,phi0,sigma,l2 + +! original way: read in parameters one by one +! call seta2(a2) +! call setphi0(phi0) + +! new way: read in all parameters at once +call set_escalar_parameter(a2, phi0, r0, sigma, l2) + +! r0=120.d0 +! sigma=8.d0 +! l2=1.d4 + +! write(*,*) +! write(*,*) " Set_Rho_ADM.f90 a2 = ", a2 +! write(*,*) " Set_Rho_ADM.f90 phi0 = ", phi0 +! write(*,*) " Set_Rho_ADM.f90 r0 = ", r0 +! write(*,*) " Set_Rho_ADM.f90 sigma0 = ", sigma +! write(*,*) " Set_Rho_ADM.f90 l2 = ", l2 +! write(*,*) + +return + +end subroutine setparameters +!=================================================================== +function phi(X,Y,Z) result(gont) +implicit none + +double precision,intent(in)::X +double precision,intent(in)::Y +double precision,intent(in)::Z +real*8 :: gont + +real*8 ::r +real*8 :: a2,r0,phi0,sigma,l2 + + call setparameters(a2,r0,phi0,sigma,l2) + r=dsqrt(X*X+Y*Y+Z*Z) +#if ( CC == 1) +! configuration 1 + gont = phi0*dtanh((r-r0)/sigma) +#elif ( CC == 2) +! configuration 2 + phi0 = a2**2*phi0/(1+a2**2) + gont = phi0*dexp(-(r-r0)**2/sigma) +#elif ( CC == 3) + gont = (0.0481646d0*dexp(-0.0581545d0*(r-1.8039d-8)*(r-1.8039d-8)/l2) & + +0.298408d0*dexp(-0.111412d0*(r+9.6741d-9)*(r+9.6741d-9)/l2)+ & + 0.42755d0*dexp(-0.207156d0*(r-1.09822d-8)*(r-1.09822d-8)/l2)+ & + 0.204229d0*dexp(-0.37742d0*(r+2.13778d-8)*(r+2.13778d-8)/l2)+ & + 0.021649d0*dexp(-0.68406d0*(r-8.78608d-8)*(r-8.78608d-8)/l2))/l2 +#elif ( CC == 4) +! configuration 4, a2 = oo + phi0 = 0.5d0*phi0 + gont = phi0*(dtanh((r+r0)/sigma)-dtanh((r-r0)/sigma)) +#elif ( CC == 5) +! configuration 5 + gont = phi0*dexp(-(r-r0)**2/sigma) +#endif + +return + +end function phi + +! d phi/dr +function dphi(X,Y,Z) result(gont) +implicit none + +double precision,intent(in)::X +double precision,intent(in)::Y +double precision,intent(in)::Z +real*8 :: gont + +real*8 ::r +real*8 :: a2,r0,phi0,sigma,l2 + + call setparameters(a2,r0,phi0,sigma,l2) + r=dsqrt(X*X+Y*Y+Z*Z) +#if ( CC == 1) +! configuration 1 + gont = phi0/sigma*(1-(dtanh((r-r0)/sigma))**2) +#elif ( CC == 2) +! configuration 2 + phi0 = a2**2*phi0/(1+a2**2) + gont = -2.d0*phi0*(r-r0)/sigma*exp(-(r-r0)**2/sigma) +#elif ( CC == 3) + gont = (-0.5601976461d-2*(r-0.18039d-7)/l2*dexp(-0.581545d-1*(r-0.18039d-7)**2/l2) & + -0.6649246419d-1*(r+0.96741d-8)/l2*dexp(-0.111412d0*(r+.96741e-8)**2/l2) & + -0.1771390956d0*(r-0.109822d-7)/l2*dexp(-0.207156d0*(r-0.109822d-7)**2/l2) & + -0.1541602184d0*(r+0.213778d-7)/l2*dexp(-0.37742d0*(r+0.213778d-7)**2/l2) & + -0.2961842988d-1*(r-0.878608d-7)/l2*dexp(-0.68406*(r-0.878608d-7)**2/l2))/l2 +#elif ( CC == 4) +! configuration 4, a2 = oo + phi0 = 0.5d0*phi0 + gont = phi0*((1-dtanh((r+r0)/sigma)**2)/sigma- & + (1-dtanh((r-r0)/sigma)**2)/sigma) +#elif ( CC == 5) +! configuration 5 + gont = -2.d0*phi0*(r-r0)/sigma*exp(-(r-r0)**2/sigma) +#endif + +return + +end function dphi +!================================================================== +function potential(X,Y,Z) result(gont) +implicit none + +double precision,intent(in)::X +double precision,intent(in)::Y +double precision,intent(in)::Z +real*8 :: gont + +real*8 :: phi +real*8 :: PI,v + +real*8 :: a2,r0,phi0,sigma,l2 + +#if ( CC == 1 || CC == 4 || CC == 5) + gont = 0.d0 + +#elif ( CC == 2 || CC == 3) + call setparameters(a2,r0,phi0,sigma,l2) + PI = dacos(-1.d0) + + v = phi(X,Y,Z) + + gont = dexp(-8.d0*dsqrt(PI/3)*v)*(1-dexp(4*dsqrt(PI/3)*v))**2/32/PI/a2 +#endif + +return + +end function potential +!================================================================== +!Note this part is for evolution +!not just for initial configuration + +!f(R) potential F=R+a_2R^2 +subroutine frpotential(ex,Sphi,V,dVdSphi) + +implicit none + +integer,intent(in ):: ex(1:3) +real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi +real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: V,dVdSphi + +real*8 :: a2,r0,phi0,sigma,l2 +real*8, parameter :: Four = 4.d0, TWO = 2.d0,ONE = 1.d0,ZEO=0.d0 +real*8 :: PI + + PI = dacos(-ONE) + +#if ( CC == 1 || CC == 4 || CC == 5) + V = ZEO + dVdSphi = ZEO +#elif ( CC == 2 || CC == 3) + call setparameters(a2,r0,phi0,sigma,l2) + V = dexp(-8.d0*dsqrt(PI/3)*Sphi)*(1-dexp(4*dsqrt(PI/3)*Sphi))**2/32/PI/a2 + dVdSphi = 1.d0/a2/1.2d1*dsqrt(3.d0/PI)*dexp(-8.d0*dsqrt(PI/3.d0)*Sphi)*(-1+dexp(4*dsqrt(Pi/3)*Sphi)) +#endif + +return + +end subroutine frpotential +!================================================================== +!f(R) potential F=R+a_2R^2 +!fprim(R) = 1+2*a_2*R +subroutine frfprim(ex,RR,fprim) + +implicit none + +integer,intent(in ):: ex(1:3) +real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: RR +real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: fprim + +real*8 :: a2,r0,phi0,sigma,l2 +real*8, parameter :: ONE=1.d0, TWO = 2.d0 + +#if ( CC == 1 || CC == 4 || CC == 5) + fprim = ONE +#elif ( CC == 2 || CC == 3) + call setparameters(a2,r0,phi0,sigma,l2) + fprim = ONE+TWO*a2*RR +#endif + +return + +end subroutine frfprim +!================================================================== +subroutine set_rho_adm2(ex,rho,X,Y,Z) + +implicit none +! argument variables +integer,intent(in)::ex +double precision,intent(in),dimension(ex)::X +double precision,intent(in),dimension(ex)::Y +double precision,intent(in),dimension(ex)::Z +double precision,intent(out),dimension(ex)::rho + +integer :: i +real*8 :: dphi + + do i=1,ex + ! rho(i) = dphi(X,Y,Z) + rho(i) = dphi(X(i),Y(i),Z(i)) + rho(i) = rho(i)*rho(i) + enddo + + return + +end subroutine set_rho_adm2 + +subroutine set_rho_adm1(ex,rho,X,Y,Z) + +implicit none +! argument variables +integer,intent(in)::ex +double precision,intent(in),dimension(ex)::X +double precision,intent(in),dimension(ex)::Y +double precision,intent(in),dimension(ex)::Z +double precision,intent(out),dimension(ex)::rho + +real*8 :: potential +integer :: i + + do i=1,ex + rho(i) = potential(X(i),Y(i),Z(i)) + enddo + + return + +end subroutine set_rho_adm1 + +subroutine set_rho_adm(ex,rho,X,Y,Z) + +implicit none +! argument variables +integer,intent(in)::ex +double precision,intent(in),dimension(ex)::X +double precision,intent(in),dimension(ex)::Y +double precision,intent(in),dimension(ex)::Z +! in psivac, out rho_adm +double precision,intent(inout),dimension(ex)::rho + +double precision,dimension(ex)::rho1,rho2 + + call set_rho_adm1(ex,rho1,X,Y,Z) + call set_rho_adm2(ex,rho2,X,Y,Z) + + rho = rho**4 + rho = rho**2*rho1+rho*rho2 + + return + +end subroutine set_rho_adm diff --git a/AMSS_NCKU_source/bssnEScalar_class.C b/AMSS_NCKU_source/Scalar/bssnEScalar_class.C similarity index 97% rename from AMSS_NCKU_source/bssnEScalar_class.C rename to AMSS_NCKU_source/Scalar/bssnEScalar_class.C index c1e71cd..e54df25 100644 --- a/AMSS_NCKU_source/bssnEScalar_class.C +++ b/AMSS_NCKU_source/Scalar/bssnEScalar_class.C @@ -1,2477 +1,2477 @@ - -#ifdef newc -#include -#include -#include -using namespace std; -#else -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "misc.h" -#include "Ansorg.h" -#include "fmisc.h" -#include "Parallel.h" -#include "bssnEScalar_class.h" -#include "bssn_rhs.h" -#include "initial_puncture.h" -#include "enforce_algebra.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" -#include "getnp4.h" -#include "shellfunctions.h" -#include "parameters.h" - -#ifdef With_AHF -#include "derivatives.h" -#include "myglobal.h" -#endif - -//================================================================================================ - -// Define bssnEScalar_class - -// It inherits some members and methods from the parent class bssn_class and modifies others. -// The modified members and methods are defined below (and in the header bssnEScalar_class.h). -// The remaining members are inherited from the parent class bssn_class (declared in bssn_class.h). - -//================================================================================================ - -bssnEScalar_class::bssnEScalar_class(double Couranti, double StartTimei, double TotalTimei, - double DumpTimei, double d2DumpTimei, - double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, - double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi) - : bssn_class(Couranti, StartTimei, TotalTimei, - DumpTimei, d2DumpTimei, CheckTimei, AnasTimei, - Symmetryi, checkruni, checkfilenamei, numepssi, numepsbi, numepshi, - a_levi, maxli, decni, maxrexi, drexi) -{ - // setup Monitors - { - char str[50]; - stringstream a_stream; - a_stream.setf(ios::left); - a_stream.str(""); - a_stream << setw(15) << "# time x y z maxs"; - MaxScalar_Monitor = new monitor("bssn_maxs.dat", myrank, a_stream.str()); - // myrank has been setup in bssn_class.C - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function initializes the class - -//================================================================================================ - -void bssnEScalar_class::Initialize() -{ - Sphio = new var("Sphio", ngfs++, 1, 1, 1); - Spio = new var("Spio", ngfs++, 1, 1, 1); - Sphi0 = new var("Sphi0", ngfs++, 1, 1, 1); - Spi0 = new var("Spi0", ngfs++, 1, 1, 1); - Sphi = new var("Sphi", ngfs++, 1, 1, 1); - Spi = new var("Spi", ngfs++, 1, 1, 1); - Sphi1 = new var("Sphi1", ngfs++, 1, 1, 1); - Spi1 = new var("Spi1", ngfs++, 1, 1, 1); - Sphi_rhs = new var("Sphi_rhs", ngfs++, 1, 1, 1); - Spi_rhs = new var("Spi_rhs", ngfs++, 1, 1, 1); - - // constraint violation monitor variables - Cons_fR = new var("Cons_fR", ngfs++, 1, 1, 1); - - if (myrank == 0) - cout << "you have setted " << ngfs << " grid functions." << endl; - - OldStateList->insert(Sphio); - OldStateList->insert(Spio); - StateList->insert(Sphi0); - StateList->insert(Spi0); - RHSList->insert(Sphi_rhs); - RHSList->insert(Spi_rhs); - SynchList_pre->insert(Sphi); - SynchList_pre->insert(Spi); - SynchList_cor->insert(Sphi1); - SynchList_cor->insert(Spi1); - - ConstraintList->insert(Cons_Gz); - - DumpList->insert(Sphi0); - DumpList->insert(Spi0); - DumpList->insert(Cons_fR); - - CheckPoint->addvariablelist(StateList); - CheckPoint->addvariablelist(OldStateList); - - - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - // read parameter from file - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - - GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); - if (checkrun) - CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); - else - GH->compose_cgh(nprocs); - -#ifdef WithShell - SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); - if (!checkrun) - SH->matchcheck(GH->PatL[0]); - SH->compose_sh(nprocs); - SH->setupcordtrans(); - SH->Dump_xyz(0, 0, 1); - SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); - - if (checkrun) - CheckPoint->readcheck_sh(SH, myrank); -#endif - - double h = GH->PatL[0]->data->blb->data->getdX(0); - for (int i = 1; i < dim; i++) - h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); - dT = Courant * h; - - if (checkrun) - { - CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); - } - else - { - PhysTime = StartTime; - Setup_Black_Hole_position(); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// Destructor: free allocated variables - -//================================================================================================ - -bssnEScalar_class::~bssnEScalar_class() -{ - delete Sphio; - delete Spio; - delete Sphi0; - delete Spi0; - delete Sphi; - delete Spi; - delete Sphi1; - delete Spi1; - delete Sphi_rhs; - delete Spi_rhs; - - delete Cons_fR; - - delete MaxScalar_Monitor; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function reads TwoPuncture initial data produced by the Ansorg solver - -//================================================================================================ - -// Read initial data solved by Ansorg, PRD 70, 064011 (2004) - -void bssnEScalar_class::Read_Ansorg() -{ - if (!checkrun) - { - if (myrank == 0) - cout << "Read initial data from Ansorg's solver," - << " please be sure the input parameters for black holes are puncture parameters!!" - << endl; - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " - << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom = new double[3 * BH_NM]; - Spin = new double[3 * BH_NM]; - Mass = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - int order = 6; - Ansorg read_ansorg("Ansorg.psid", order); - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); - - f_get_ansorg_nbhs_escalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - Mass, Porg_here, Pmom, Spin, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - for (int k = 0; k < cg->shape[2]; k++) - for (int j = 0; j < cg->shape[1]; j++) - for (int i = 0; i < cg->shape[0]; i++) - cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = - read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); - - f_get_ansorg_nbhs_ss_escalar(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - Mass, Porg_here, Pmom, Spin, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -#endif - - delete[] Porg_here; - // dump read_in initial data - // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function reads initial data produced by Pablo Galaviz's Olliptic program - -//================================================================================================ - -// Read initial data solved by Pablo's Olliptic Phys.Rev.D 82 024005 (2010) - -void bssnEScalar_class::Read_Pablo() -{ - if (!checkrun) - { - if (myrank == 0) - cout << "Read initial data from Pablo's solver," - << " please be sure the input parameters for black holes are puncture parameters!!" - << endl; - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - int BH_NM; - double *Porg_here; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - { - BH_NM = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - Porg_here = new double[3 * BH_NM]; - Pmom = new double[3 * BH_NM]; - Spin = new double[3 * BH_NM]; - Mass = new double[BH_NM]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename - << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_NM) - { - if (skey == "Mass") - Mass[sind] = atof(sval.c_str()); - else if (skey == "Porgx") - Porg_here[sind * 3] = atof(sval.c_str()); - else if (skey == "Porgy") - Porg_here[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Porgz") - Porg_here[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Spinx") - Spin[sind * 3] = atof(sval.c_str()); - else if (skey == "Spiny") - Spin[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Spinz") - Spin[sind * 3 + 2] = atof(sval.c_str()); - else if (skey == "Pmomx") - Pmom[sind * 3] = atof(sval.c_str()); - else if (skey == "Pmomy") - Pmom[sind * 3 + 1] = atof(sval.c_str()); - else if (skey == "Pmomz") - Pmom[sind * 3 + 2] = atof(sval.c_str()); - } - } - inf.close(); - } - bool flag = false; - int DIM = dim; - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - int grd = 0; - while (Pp) - { - double *databuffer = (double *)malloc(sizeof(double) - * Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]); - if (!databuffer) - { - cout << "bssnEScalar_class::Read_Pablo: on node# " << myrank - << ", out of memory when reading Pablo's data in" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - char filename[100]; - sprintf(filename, "Lev%02d-%02d.mgid_m", lev, grd); - if (read_Pablo_file((int *)Pp->data->shape, databuffer, filename)) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[phi0->sgfn], - Pp->data->bbox, Pp->data->bbox + DIM, Pp->data->shape, databuffer, - cg->bbox, cg->bbox + DIM); - - f_get_ansorg_nbhs_escalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - Mass, Porg_here, Pmom, Spin, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - } - else - { - sprintf(filename, "Lev%02d-%02d.mgid", lev, grd); - if (myrank == 0) - write_Pablo_file((int *)Pp->data->shape, - Pp->data->bbox[0], Pp->data->bbox[3], - Pp->data->bbox[1], Pp->data->bbox[4], - Pp->data->bbox[2], Pp->data->bbox[5], - filename); - flag = true; - } - free(databuffer); - Pp = Pp->next; - grd++; - } - } - -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - double *databuffer = (double *)malloc(sizeof(double) * Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]); - if (!databuffer) - { - cout << "bssnEScalar_class::Read_Pablo: on node# " << myrank << ", out of memory when reading Pablo's data in" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - char filename[100], shn[10]; - SH->shellname(shn, Pp->data->sst); - sprintf(filename, "LevSH-%s.mgid_m", shn); - if (read_Pablo_file((int *)Pp->data->shape, databuffer, filename)) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[phi0->sgfn], - Pp->data->bbox, Pp->data->bbox + DIM, Pp->data->shape, databuffer, - cg->bbox, cg->bbox + DIM); - - f_get_ansorg_nbhs_ss_escalar(cg->shape, - cg->fgfs[Pp->data->fngfs + ShellPatch::gx], - cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - Mass, Porg_here, Pmom, Spin, BH_NM); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - } - else - { - sprintf(filename, "LevSH-%s.mgid", shn); - if (myrank == 0) - SH->write_Pablo_file_ss((int *)Pp->data->shape, - Pp->data->bbox[0], Pp->data->bbox[3], - Pp->data->bbox[1], Pp->data->bbox[4], - Pp->data->bbox[2], Pp->data->bbox[5], - filename, Pp->data->sst); - flag = true; - } - free(databuffer); - Pp = Pp->next; - } -#endif - - delete[] Porg_here; - if (flag && myrank == 0) - MPI_Abort(MPI_COMM_WORLD, 1); - // dump read_in initial data - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); - SH->Dump_Data(StateList, 0, PhysTime, dT); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function configures a single time-step evolution - -//================================================================================================ - -void bssnEScalar_class::Step(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_bssn_escalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff_EScalar(lev, dT_lev); - } - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_bssn_escalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } - -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes the gravitational-wave scalar Psi4 - -//================================================================================================ - -void bssnEScalar_class::Compute_Psi4(int lev) -{ - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (Psi4type == 0) - // the input arguments Gamma^i_jk and R_ij do not need synch, because we do not need to derivate them - f_getnp4scalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry); -#elif (Psi4type == 1) - f_getnp4oldscalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry); -#else -#error "not recognized Psi4type" -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - -#ifdef WithShell - // ShellPatch part - if (lev == 0) - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { -#if (Psi4type == 0) - f_getnp4scalar_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry, Pp->data->sst); -#elif (Psi4type == 1) - f_getnp4oldscalar_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], - Symmetry, Pp->data->sst); -#else -#error "not recognized Psi4type" -#endif - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } -#endif - - MyList *DG_List = new MyList(Rpsi4); - DG_List->insert(Ipsi4); - Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); -#ifdef WithShell - if (lev == 0) - { - SH->Synch(DG_List, Symmetry); - } -#endif - DG_List->clearList(); -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function analyzes and inspects scalar field data - -//================================================================================================ - -void bssnEScalar_class::AnalysisStuff_EScalar(int lev, double dT_lev) -{ - LastAnas += dT_lev; - - if (lev > 0) - { - cout << "AnalysisStuff_EScala only supports level 0, but lev = " << lev << endl; - - AnalysisStuff(lev, dT_lev); - - return; - } - - if (LastAnas >= AnasTime) - { - MyList *DG_List = new MyList(Sphi0); - double XX[3], maxs[1]; - - double XXh[3], maxsh[1]; - for (int levh = GH->levels - 1; levh >= 0; levh--) - { - MyList *Pp = GH->PatL[levh]; - - maxsh[0] = -1; // for sure be rewriten - while (Pp) - { - double XXhh[3], maxshh[1]; - Pp->data->Find_Maximum(DG_List, XXhh, maxshh); - if (maxsh[0] < maxshh[0]) - { - for (int i = 0; i < 3; i++) - XXh[i] = XXhh[i]; - maxsh[0] = maxshh[0]; - } - Pp = Pp->next; - } - - if (levh == GH->levels - 1) - { - for (int i = 0; i < 3; i++) - XX[i] = XXh[i]; - maxs[0] = maxsh[0]; - } - else if (maxs[0] < maxsh[0]) - { - bool fg = true; - Pp = GH->PatL[levh + 1]; - - while (Pp && fg) - { - if (Pp->data->Find_Point(XXh)) - fg = false; // we only take finner level - Pp = Pp->next; - } - if (fg) - { - for (int i = 0; i < 3; i++) - XX[i] = XXh[i]; - maxs[0] = maxsh[0]; - } - } - } - -#ifdef WithShell - SH->Find_Maximum(DG_List, XXh, maxsh); - - if (maxs[0] < maxsh[0]) - { - bool fg = true; - MyList *Pp = GH->PatL[0]; - - while (Pp && fg) - { - if (Pp->data->Find_Point(XXh)) - fg = false; - Pp = Pp->next; - } - if (fg) - { - for (int i = 0; i < 3; i++) - XX[i] = XXh[i]; - maxs[0] = maxsh[0]; - } - } -#endif - - double RD[4]; - for (int i = 0; i < 3; i++) - RD[i] = XX[i]; - RD[3] = maxs[0]; - MaxScalar_Monitor->writefile(PhysTime, 4, RD); - - DG_List->clearList(); - } - - AnalysisStuff(lev, dT_lev); // LastAnas need and only need control here - - LastAnas = 0; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function interpolates constraint data - -//================================================================================================ - -void bssnEScalar_class::Interp_Constraint() -{ - // we do not support a_lev != 0 yet. - if (a_lev > 0) - return; - - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (lev > 0) - f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Cons_fR->sgfn]); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - // ShellPatch part - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Cons_fR->sgfn]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - - SH->Synch(ConstraintList, Symmetry); -#endif - // interpolate - double *x1, *y1, *z1; - const int n = 1000; - double lmax, lmin, dd; - lmin = 0; -#ifdef WithShell - lmax = SH->Rrange[1]; -#else - lmax = GH->bbox[0][0][4]; -#endif -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (lmax - lmin) / (n - 1); -#else -#ifdef Cell - dd = (lmax - lmin) / n; -#else -#error Not define Vertex nor Cell -#endif -#endif - x1 = new double[n]; - y1 = new double[n]; - z1 = new double[n]; - for (int i = 0; i < n; i++) - { - x1[i] = 0; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y1[i] = lmin + i * dd; -#else -#ifdef Cell - y1[i] = lmin + (i + 0.5) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - z1[i] = 0; - } - - int InList = 0; - - MyList *varl = ConstraintList; - while (varl) - { - InList++; - varl = varl->next; - } - double *shellf; - shellf = new double[n * InList]; - for (int i = 0; i < n; i++) - { - double XX[3]; - XX[0] = x1[i]; - XX[1] = y1[i]; - XX[2] = z1[i]; - bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#ifdef WithShell - if (!fg) - fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#endif - if (!fg && myrank == 0) - { - cout << "bssn_class::Interp_Constraint meets wrong" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - ofstream outfile; - char filename[50]; - sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); - // 0.5 for round off - - outfile.open(filename); - outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, fR_Res, ...." << endl; - for (int i = 0; i < n; i++) - { - outfile << setw(10) << setprecision(10) << y1[i]; - for (int j = 0; j < InList; j++) - outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; - outfile << endl; - } - - delete[] shellf; -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function computes and outputs constraint violations - -//================================================================================================ - -void bssnEScalar_class::Constraint_Out() -{ - // Use the same variables as in the parent class here - // Otherwise the correct time will not be passed - LastConsOut += dT * pow(0.5, Mymax(0, trfls)); - - if (LastConsOut >= AnasTime) - // Constraint violation - { - // recompute least the constraint data lost for moved new grid - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (lev > 0) - f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Cons_fR->sgfn]); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - // ShellPatch part - { - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - int fngfs = Pp->data->fngfs; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Cons_fR->sgfn]); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - - SH->Synch(ConstraintList, Symmetry); -#endif - - double ConV[8]; - -#ifdef WithShell - ConV[0] = SH->L2Norm(Cons_Ham); - ConV[1] = SH->L2Norm(Cons_Px); - ConV[2] = SH->L2Norm(Cons_Py); - ConV[3] = SH->L2Norm(Cons_Pz); - ConV[4] = SH->L2Norm(Cons_Gx); - ConV[5] = SH->L2Norm(Cons_Gy); - ConV[6] = SH->L2Norm(Cons_Gz); - ConV[7] = SH->L2Norm(Cons_fR); - ConVMonitor->writefile(PhysTime, 8, ConV); -#endif - for (int levi = 0; levi < GH->levels; levi++) - { - ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham); - ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px); - ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py); - ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz); - ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx); - ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy); - ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz); - ConV[7] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_fR); - ConVMonitor->writefile(PhysTime, 8, ConV); - /* - if(fabs(ConV[0])<0.00001) - { - MyList * DG_List=new MyList(Cons_Ham); - DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); - DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); - Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); - DG_List->clearList(); - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } - */ - } - - LastConsOut = 0; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// Read scalar-tensor theory parameters -// Modified by Xiaoqu -// Read multiple values at once -// Original function read values one by one (tedious) - -//================================================================================================ - -extern "C" -{ - -#ifdef fortran1 - void set_escalar_parameter -#endif -#ifdef fortran2 - void SET_ESCALAR_PARAMETER -#endif -#ifdef fortran3 - void set_escalar_parameter_ -#endif - - (double &a2, double &phi0, double &r0, double &sigma0, double &l2) - { - - static bool file_status = true; - // Use a static boolean to avoid re-reading the parameter file - // This kind of variable appears to be shared; once read, other processes remember its state - // After reading the parameter file, `file_status` is automatically set to false - - static double aa2; - static double ll2; - static double pphi0; - static double rr0; - static double ssigma0; - - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - // read parameter from file - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - - if (file_status) - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << " for inputing information of EScalar" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "FR" && skey == "a2") - aa2 = atof(sval.c_str()); - else if (sgrp == "FR" && skey == "l2") - ll2 = atof(sval.c_str()); - else if (sgrp == "FR" && skey == "phi0") - pphi0 = atof(sval.c_str()); - else if (sgrp == "FR" && skey == "r0") - rr0 = atof(sval.c_str()); - else if (sgrp == "FR" && skey == "sigma0") - ssigma0 = atof(sval.c_str()); - } - - inf.close(); // if not closed, it will fail when you try to open it next time. - - // After reading the parameter file, `file_status` is set to false - file_status = false; - - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << endl; - cout << " you have set a2 = " << aa2 << endl; - cout << " you have set l2 = " << ll2 << endl; - cout << " you have set phi0 = " << pphi0 << endl; - cout << " you have set r0 = " << rr0 << endl; - cout << " you have set sigma0 = " << ssigma0 << endl; - cout << endl; - } - } - - a2 = aa2; - phi0 = pphi0; - r0 = rr0; - sigma0 = ssigma0; - l2 = ll2; - } -} - - -// Original function read values one by one (tedious) - -extern "C" -{ - -#ifdef fortran1 - void seta2 -#endif -#ifdef fortran2 - void SETA2 -#endif -#ifdef fortran3 - void - seta2_ -#endif - (double &a2) - { - static bool fga2 = true; - static double aa2; - - if (fga2) - { - char s[1000], *t; - FILE *fp; - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - fp = fopen(pname, "r"); - if (!fp) - { - cout << "could not open " << pname << " for reading a2" << endl; - } - while (fgets(s, 1000, fp)) - { - t = strstr(s, "FR::a2 "); - if (t == s) - { - sscanf(s + 8, "%lf", &aa2); - break; - } - } - - fclose(fp); // if not closed, it will fail when you try to open it next time. - fga2 = false; - - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - printf("you have set a2 = %0.4lg\n", aa2); - } - } - - a2 = aa2; - } -} - -extern "C" -{ - -#ifdef fortran1 - void setphi0 -#endif -#ifdef fortran2 - void SETPHI0 -#endif -#ifdef fortran3 - void - setphi0_ -#endif - (double &phi0) - { - static bool fgphi0 = true; - static double pphi0; - - if (fgphi0) - { - char s[1000], *t; - FILE *fp; - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - fp = fopen(pname, "r"); - if (!fp) - { - cout << "could not open " << pname << " for reading phi0" << endl; - } - while (fgets(s, 1000, fp)) - { - t = strstr(s, "FR::phi0 "); - if (t == s) - { - sscanf(s + 10, "%lf", &pphi0); - break; - } - } - - fclose(fp); // if not closed, it will fail when you try to open it next time. - fgphi0 = false; - - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - printf("you have set phi0 = %0.4lg\n", pphi0); - } - } - - phi0 = pphi0; - } -} - -//================================================================================================ - + +#ifdef newc +#include +#include +#include +using namespace std; +#else +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "misc.h" +#include "Ansorg.h" +#include "fmisc.h" +#include "Parallel.h" +#include "bssnEScalar_class.h" +#include "bssn_rhs.h" +#include "initial_puncture.h" +#include "enforce_algebra.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" +#include "getnp4.h" +#include "shellfunctions.h" +#include "parameters.h" + +#ifdef With_AHF +#include "derivatives.h" +#include "myglobal.h" +#endif + +//================================================================================================ + +// Define bssnEScalar_class + +// It inherits some members and methods from the parent class bssn_class and modifies others. +// The modified members and methods are defined below (and in the header bssnEScalar_class.h). +// The remaining members are inherited from the parent class bssn_class (declared in bssn_class.h). + +//================================================================================================ + +bssnEScalar_class::bssnEScalar_class(double Couranti, double StartTimei, double TotalTimei, + double DumpTimei, double d2DumpTimei, + double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, + double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi) + : bssn_class(Couranti, StartTimei, TotalTimei, + DumpTimei, d2DumpTimei, CheckTimei, AnasTimei, + Symmetryi, checkruni, checkfilenamei, numepssi, numepsbi, numepshi, + a_levi, maxli, decni, maxrexi, drexi) +{ + // setup Monitors + { + char str[50]; + stringstream a_stream; + a_stream.setf(ios::left); + a_stream.str(""); + a_stream << setw(15) << "# time x y z maxs"; + MaxScalar_Monitor = new monitor("bssn_maxs.dat", myrank, a_stream.str()); + // myrank has been setup in bssn_class.C + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function initializes the class + +//================================================================================================ + +void bssnEScalar_class::Initialize() +{ + Sphio = new var("Sphio", ngfs++, 1, 1, 1); + Spio = new var("Spio", ngfs++, 1, 1, 1); + Sphi0 = new var("Sphi0", ngfs++, 1, 1, 1); + Spi0 = new var("Spi0", ngfs++, 1, 1, 1); + Sphi = new var("Sphi", ngfs++, 1, 1, 1); + Spi = new var("Spi", ngfs++, 1, 1, 1); + Sphi1 = new var("Sphi1", ngfs++, 1, 1, 1); + Spi1 = new var("Spi1", ngfs++, 1, 1, 1); + Sphi_rhs = new var("Sphi_rhs", ngfs++, 1, 1, 1); + Spi_rhs = new var("Spi_rhs", ngfs++, 1, 1, 1); + + // constraint violation monitor variables + Cons_fR = new var("Cons_fR", ngfs++, 1, 1, 1); + + if (myrank == 0) + cout << "you have setted " << ngfs << " grid functions." << endl; + + OldStateList->insert(Sphio); + OldStateList->insert(Spio); + StateList->insert(Sphi0); + StateList->insert(Spi0); + RHSList->insert(Sphi_rhs); + RHSList->insert(Spi_rhs); + SynchList_pre->insert(Sphi); + SynchList_pre->insert(Spi); + SynchList_cor->insert(Sphi1); + SynchList_cor->insert(Spi1); + + ConstraintList->insert(Cons_Gz); + + DumpList->insert(Sphi0); + DumpList->insert(Spi0); + DumpList->insert(Cons_fR); + + CheckPoint->addvariablelist(StateList); + CheckPoint->addvariablelist(OldStateList); + + + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + // read parameter from file + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + + GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); + if (checkrun) + CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); + else + GH->compose_cgh(nprocs); + +#ifdef WithShell + SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); + if (!checkrun) + SH->matchcheck(GH->PatL[0]); + SH->compose_sh(nprocs); + SH->setupcordtrans(); + SH->Dump_xyz(0, 0, 1); + SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); + + if (checkrun) + CheckPoint->readcheck_sh(SH, myrank); +#endif + + double h = GH->PatL[0]->data->blb->data->getdX(0); + for (int i = 1; i < dim; i++) + h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); + dT = Courant * h; + + if (checkrun) + { + CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); + } + else + { + PhysTime = StartTime; + Setup_Black_Hole_position(); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// Destructor: free allocated variables + +//================================================================================================ + +bssnEScalar_class::~bssnEScalar_class() +{ + delete Sphio; + delete Spio; + delete Sphi0; + delete Spi0; + delete Sphi; + delete Spi; + delete Sphi1; + delete Spi1; + delete Sphi_rhs; + delete Spi_rhs; + + delete Cons_fR; + + delete MaxScalar_Monitor; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function reads TwoPuncture initial data produced by the Ansorg solver + +//================================================================================================ + +// Read initial data solved by Ansorg, PRD 70, 064011 (2004) + +void bssnEScalar_class::Read_Ansorg() +{ + if (!checkrun) + { + if (myrank == 0) + cout << "Read initial data from Ansorg's solver," + << " please be sure the input parameters for black holes are puncture parameters!!" + << endl; + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " + << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom = new double[3 * BH_NM]; + Spin = new double[3 * BH_NM]; + Mass = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + int order = 6; + Ansorg read_ansorg("Ansorg.psid", order); + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->X[0][i], cg->X[1][j], cg->X[2][k]); + + f_get_ansorg_nbhs_escalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + Mass, Porg_here, Pmom, Spin, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + for (int k = 0; k < cg->shape[2]; k++) + for (int j = 0; j < cg->shape[1]; j++) + for (int i = 0; i < cg->shape[0]; i++) + cg->fgfs[phi0->sgfn][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]] = + read_ansorg.ps_u_at_xyz(cg->fgfs[Pp->data->fngfs + ShellPatch::gx][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz][i + j * cg->shape[0] + k * cg->shape[0] * cg->shape[1]]); + + f_get_ansorg_nbhs_ss_escalar(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + Mass, Porg_here, Pmom, Spin, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +#endif + + delete[] Porg_here; + // dump read_in initial data + // for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function reads initial data produced by Pablo Galaviz's Olliptic program + +//================================================================================================ + +// Read initial data solved by Pablo's Olliptic Phys.Rev.D 82 024005 (2010) + +void bssnEScalar_class::Read_Pablo() +{ + if (!checkrun) + { + if (myrank == 0) + cout << "Read initial data from Pablo's solver," + << " please be sure the input parameters for black holes are puncture parameters!!" + << endl; + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + int BH_NM; + double *Porg_here; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + { + BH_NM = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + Porg_here = new double[3 * BH_NM]; + Pmom = new double[3 * BH_NM]; + Spin = new double[3 * BH_NM]; + Mass = new double[BH_NM]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename + << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_NM) + { + if (skey == "Mass") + Mass[sind] = atof(sval.c_str()); + else if (skey == "Porgx") + Porg_here[sind * 3] = atof(sval.c_str()); + else if (skey == "Porgy") + Porg_here[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Porgz") + Porg_here[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Spinx") + Spin[sind * 3] = atof(sval.c_str()); + else if (skey == "Spiny") + Spin[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Spinz") + Spin[sind * 3 + 2] = atof(sval.c_str()); + else if (skey == "Pmomx") + Pmom[sind * 3] = atof(sval.c_str()); + else if (skey == "Pmomy") + Pmom[sind * 3 + 1] = atof(sval.c_str()); + else if (skey == "Pmomz") + Pmom[sind * 3 + 2] = atof(sval.c_str()); + } + } + inf.close(); + } + bool flag = false; + int DIM = dim; + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + int grd = 0; + while (Pp) + { + double *databuffer = (double *)malloc(sizeof(double) + * Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]); + if (!databuffer) + { + cout << "bssnEScalar_class::Read_Pablo: on node# " << myrank + << ", out of memory when reading Pablo's data in" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + char filename[100]; + sprintf(filename, "Lev%02d-%02d.mgid_m", lev, grd); + if (read_Pablo_file((int *)Pp->data->shape, databuffer, filename)) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[phi0->sgfn], + Pp->data->bbox, Pp->data->bbox + DIM, Pp->data->shape, databuffer, + cg->bbox, cg->bbox + DIM); + + f_get_ansorg_nbhs_escalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + Mass, Porg_here, Pmom, Spin, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + } + else + { + sprintf(filename, "Lev%02d-%02d.mgid", lev, grd); + if (myrank == 0) + write_Pablo_file((int *)Pp->data->shape, + Pp->data->bbox[0], Pp->data->bbox[3], + Pp->data->bbox[1], Pp->data->bbox[4], + Pp->data->bbox[2], Pp->data->bbox[5], + filename); + flag = true; + } + free(databuffer); + Pp = Pp->next; + grd++; + } + } + +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + double *databuffer = (double *)malloc(sizeof(double) * Pp->data->shape[0] * Pp->data->shape[1] * Pp->data->shape[2]); + if (!databuffer) + { + cout << "bssnEScalar_class::Read_Pablo: on node# " << myrank << ", out of memory when reading Pablo's data in" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + char filename[100], shn[10]; + SH->shellname(shn, Pp->data->sst); + sprintf(filename, "LevSH-%s.mgid_m", shn); + if (read_Pablo_file((int *)Pp->data->shape, databuffer, filename)) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_copy(DIM, cg->bbox, cg->bbox + DIM, cg->shape, cg->fgfs[phi0->sgfn], + Pp->data->bbox, Pp->data->bbox + DIM, Pp->data->shape, databuffer, + cg->bbox, cg->bbox + DIM); + + f_get_ansorg_nbhs_ss_escalar(cg->shape, + cg->fgfs[Pp->data->fngfs + ShellPatch::gx], + cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + Mass, Porg_here, Pmom, Spin, BH_NM); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + } + else + { + sprintf(filename, "LevSH-%s.mgid", shn); + if (myrank == 0) + SH->write_Pablo_file_ss((int *)Pp->data->shape, + Pp->data->bbox[0], Pp->data->bbox[3], + Pp->data->bbox[1], Pp->data->bbox[4], + Pp->data->bbox[2], Pp->data->bbox[5], + filename, Pp->data->sst); + flag = true; + } + free(databuffer); + Pp = Pp->next; + } +#endif + + delete[] Porg_here; + if (flag && myrank == 0) + MPI_Abort(MPI_COMM_WORLD, 1); + // dump read_in initial data + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT); + SH->Dump_Data(StateList, 0, PhysTime, dT); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function configures a single time-step evolution + +//================================================================================================ + +void bssnEScalar_class::Step(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_bssn_escalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff_EScalar(lev, dT_lev); + } + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_bssn_escalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } + +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes the gravitational-wave scalar Psi4 + +//================================================================================================ + +void bssnEScalar_class::Compute_Psi4(int lev) +{ + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (Psi4type == 0) + // the input arguments Gamma^i_jk and R_ij do not need synch, because we do not need to derivate them + f_getnp4scalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry); +#elif (Psi4type == 1) + f_getnp4oldscalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry); +#else +#error "not recognized Psi4type" +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + +#ifdef WithShell + // ShellPatch part + if (lev == 0) + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { +#if (Psi4type == 0) + f_getnp4scalar_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry, Pp->data->sst); +#elif (Psi4type == 1) + f_getnp4oldscalar_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[Rpsi4->sgfn], cg->fgfs[Ipsi4->sgfn], + Symmetry, Pp->data->sst); +#else +#error "not recognized Psi4type" +#endif + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } +#endif + + MyList *DG_List = new MyList(Rpsi4); + DG_List->insert(Ipsi4); + Parallel::Sync(GH->PatL[lev], DG_List, Symmetry); +#ifdef WithShell + if (lev == 0) + { + SH->Synch(DG_List, Symmetry); + } +#endif + DG_List->clearList(); +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function analyzes and inspects scalar field data + +//================================================================================================ + +void bssnEScalar_class::AnalysisStuff_EScalar(int lev, double dT_lev) +{ + LastAnas += dT_lev; + + if (lev > 0) + { + cout << "AnalysisStuff_EScala only supports level 0, but lev = " << lev << endl; + + AnalysisStuff(lev, dT_lev); + + return; + } + + if (LastAnas >= AnasTime) + { + MyList *DG_List = new MyList(Sphi0); + double XX[3], maxs[1]; + + double XXh[3], maxsh[1]; + for (int levh = GH->levels - 1; levh >= 0; levh--) + { + MyList *Pp = GH->PatL[levh]; + + maxsh[0] = -1; // for sure be rewriten + while (Pp) + { + double XXhh[3], maxshh[1]; + Pp->data->Find_Maximum(DG_List, XXhh, maxshh); + if (maxsh[0] < maxshh[0]) + { + for (int i = 0; i < 3; i++) + XXh[i] = XXhh[i]; + maxsh[0] = maxshh[0]; + } + Pp = Pp->next; + } + + if (levh == GH->levels - 1) + { + for (int i = 0; i < 3; i++) + XX[i] = XXh[i]; + maxs[0] = maxsh[0]; + } + else if (maxs[0] < maxsh[0]) + { + bool fg = true; + Pp = GH->PatL[levh + 1]; + + while (Pp && fg) + { + if (Pp->data->Find_Point(XXh)) + fg = false; // we only take finner level + Pp = Pp->next; + } + if (fg) + { + for (int i = 0; i < 3; i++) + XX[i] = XXh[i]; + maxs[0] = maxsh[0]; + } + } + } + +#ifdef WithShell + SH->Find_Maximum(DG_List, XXh, maxsh); + + if (maxs[0] < maxsh[0]) + { + bool fg = true; + MyList *Pp = GH->PatL[0]; + + while (Pp && fg) + { + if (Pp->data->Find_Point(XXh)) + fg = false; + Pp = Pp->next; + } + if (fg) + { + for (int i = 0; i < 3; i++) + XX[i] = XXh[i]; + maxs[0] = maxsh[0]; + } + } +#endif + + double RD[4]; + for (int i = 0; i < 3; i++) + RD[i] = XX[i]; + RD[3] = maxs[0]; + MaxScalar_Monitor->writefile(PhysTime, 4, RD); + + DG_List->clearList(); + } + + AnalysisStuff(lev, dT_lev); // LastAnas need and only need control here + + LastAnas = 0; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function interpolates constraint data + +//================================================================================================ + +void bssnEScalar_class::Interp_Constraint() +{ + // we do not support a_lev != 0 yet. + if (a_lev > 0) + return; + + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (lev > 0) + f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Cons_fR->sgfn]); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + // ShellPatch part + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Cons_fR->sgfn]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + + SH->Synch(ConstraintList, Symmetry); +#endif + // interpolate + double *x1, *y1, *z1; + const int n = 1000; + double lmax, lmin, dd; + lmin = 0; +#ifdef WithShell + lmax = SH->Rrange[1]; +#else + lmax = GH->bbox[0][0][4]; +#endif +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (lmax - lmin) / (n - 1); +#else +#ifdef Cell + dd = (lmax - lmin) / n; +#else +#error Not define Vertex nor Cell +#endif +#endif + x1 = new double[n]; + y1 = new double[n]; + z1 = new double[n]; + for (int i = 0; i < n; i++) + { + x1[i] = 0; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y1[i] = lmin + i * dd; +#else +#ifdef Cell + y1[i] = lmin + (i + 0.5) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + z1[i] = 0; + } + + int InList = 0; + + MyList *varl = ConstraintList; + while (varl) + { + InList++; + varl = varl->next; + } + double *shellf; + shellf = new double[n * InList]; + for (int i = 0; i < n; i++) + { + double XX[3]; + XX[0] = x1[i]; + XX[1] = y1[i]; + XX[2] = z1[i]; + bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#ifdef WithShell + if (!fg) + fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#endif + if (!fg && myrank == 0) + { + cout << "bssn_class::Interp_Constraint meets wrong" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + ofstream outfile; + char filename[50]; + sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); + // 0.5 for round off + + outfile.open(filename); + outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, fR_Res, ...." << endl; + for (int i = 0; i < n; i++) + { + outfile << setw(10) << setprecision(10) << y1[i]; + for (int j = 0; j < InList; j++) + outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; + outfile << endl; + } + + delete[] shellf; +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function computes and outputs constraint violations + +//================================================================================================ + +void bssnEScalar_class::Constraint_Out() +{ + // Use the same variables as in the parent class here + // Otherwise the correct time will not be passed + LastConsOut += dT * pow(0.5, Mymax(0, trfls)); + + if (LastConsOut >= AnasTime) + // Constraint violation + { + // recompute least the constraint data lost for moved new grid + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (lev > 0) + f_compute_rhs_bssn_escalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Cons_fR->sgfn]); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + // ShellPatch part + { + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + int fngfs = Pp->data->fngfs; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_compute_constraint_fr(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sphi0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Cons_fR->sgfn]); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + + SH->Synch(ConstraintList, Symmetry); +#endif + + double ConV[8]; + +#ifdef WithShell + ConV[0] = SH->L2Norm(Cons_Ham); + ConV[1] = SH->L2Norm(Cons_Px); + ConV[2] = SH->L2Norm(Cons_Py); + ConV[3] = SH->L2Norm(Cons_Pz); + ConV[4] = SH->L2Norm(Cons_Gx); + ConV[5] = SH->L2Norm(Cons_Gy); + ConV[6] = SH->L2Norm(Cons_Gz); + ConV[7] = SH->L2Norm(Cons_fR); + ConVMonitor->writefile(PhysTime, 8, ConV); +#endif + for (int levi = 0; levi < GH->levels; levi++) + { + ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham); + ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px); + ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py); + ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz); + ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx); + ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy); + ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz); + ConV[7] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_fR); + ConVMonitor->writefile(PhysTime, 8, ConV); + /* + if(fabs(ConV[0])<0.00001) + { + MyList * DG_List=new MyList(Cons_Ham); + DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); + DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); + Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); + DG_List->clearList(); + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } + */ + } + + LastConsOut = 0; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// Read scalar-tensor theory parameters +// Modified by Xiaoqu +// Read multiple values at once +// Original function read values one by one (tedious) + +//================================================================================================ + +extern "C" +{ + +#ifdef fortran1 + void set_escalar_parameter +#endif +#ifdef fortran2 + void SET_ESCALAR_PARAMETER +#endif +#ifdef fortran3 + void set_escalar_parameter_ +#endif + + (double &a2, double &phi0, double &r0, double &sigma0, double &l2) + { + + static bool file_status = true; + // Use a static boolean to avoid re-reading the parameter file + // This kind of variable appears to be shared; once read, other processes remember its state + // After reading the parameter file, `file_status` is automatically set to false + + static double aa2; + static double ll2; + static double pphi0; + static double rr0; + static double ssigma0; + + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + // read parameter from file + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + + if (file_status) + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << " for inputing information of EScalar" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "FR" && skey == "a2") + aa2 = atof(sval.c_str()); + else if (sgrp == "FR" && skey == "l2") + ll2 = atof(sval.c_str()); + else if (sgrp == "FR" && skey == "phi0") + pphi0 = atof(sval.c_str()); + else if (sgrp == "FR" && skey == "r0") + rr0 = atof(sval.c_str()); + else if (sgrp == "FR" && skey == "sigma0") + ssigma0 = atof(sval.c_str()); + } + + inf.close(); // if not closed, it will fail when you try to open it next time. + + // After reading the parameter file, `file_status` is set to false + file_status = false; + + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << endl; + cout << " you have set a2 = " << aa2 << endl; + cout << " you have set l2 = " << ll2 << endl; + cout << " you have set phi0 = " << pphi0 << endl; + cout << " you have set r0 = " << rr0 << endl; + cout << " you have set sigma0 = " << ssigma0 << endl; + cout << endl; + } + } + + a2 = aa2; + phi0 = pphi0; + r0 = rr0; + sigma0 = ssigma0; + l2 = ll2; + } +} + + +// Original function read values one by one (tedious) + +extern "C" +{ + +#ifdef fortran1 + void seta2 +#endif +#ifdef fortran2 + void SETA2 +#endif +#ifdef fortran3 + void + seta2_ +#endif + (double &a2) + { + static bool fga2 = true; + static double aa2; + + if (fga2) + { + char s[1000], *t; + FILE *fp; + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + fp = fopen(pname, "r"); + if (!fp) + { + cout << "could not open " << pname << " for reading a2" << endl; + } + while (fgets(s, 1000, fp)) + { + t = strstr(s, "FR::a2 "); + if (t == s) + { + sscanf(s + 8, "%lf", &aa2); + break; + } + } + + fclose(fp); // if not closed, it will fail when you try to open it next time. + fga2 = false; + + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + printf("you have set a2 = %0.4lg\n", aa2); + } + } + + a2 = aa2; + } +} + +extern "C" +{ + +#ifdef fortran1 + void setphi0 +#endif +#ifdef fortran2 + void SETPHI0 +#endif +#ifdef fortran3 + void + setphi0_ +#endif + (double &phi0) + { + static bool fgphi0 = true; + static double pphi0; + + if (fgphi0) + { + char s[1000], *t; + FILE *fp; + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + fp = fopen(pname, "r"); + if (!fp) + { + cout << "could not open " << pname << " for reading phi0" << endl; + } + while (fgets(s, 1000, fp)) + { + t = strstr(s, "FR::phi0 "); + if (t == s) + { + sscanf(s + 10, "%lf", &pphi0); + break; + } + } + + fclose(fp); // if not closed, it will fail when you try to open it next time. + fgphi0 = false; + + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + printf("you have set phi0 = %0.4lg\n", pphi0); + } + } + + phi0 = pphi0; + } +} + +//================================================================================================ + diff --git a/AMSS_NCKU_source/bssnEScalar_class.h b/AMSS_NCKU_source/Scalar/bssnEScalar_class.h similarity index 95% rename from AMSS_NCKU_source/bssnEScalar_class.h rename to AMSS_NCKU_source/Scalar/bssnEScalar_class.h index 3e26005..296b81d 100644 --- a/AMSS_NCKU_source/bssnEScalar_class.h +++ b/AMSS_NCKU_source/Scalar/bssnEScalar_class.h @@ -1,70 +1,70 @@ - -#ifndef BSSNESCALAR_CLASS_H -#define BSSNESCALAR_CLASS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "cgh.h" -#include "ShellPatch.h" -#include "misc.h" -#include "var.h" -#include "MyList.h" -#include "monitor.h" -#include "surface_integral.h" - -#include "macrodef.h" - -#ifdef USE_GPU -#include "bssn_gpu_class.h" -#else -#include "bssn_class.h" -#endif - -class bssnEScalar_class : public bssn_class -{ -public: - bssnEScalar_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi); - ~bssnEScalar_class(); - - void Initialize(); - void Read_Ansorg(); - void Read_Pablo(); - void Compute_Psi4(int lev); - void Step(int lev, int YN); - void AnalysisStuff_EScalar(int lev, double dT_lev); - void Interp_Constraint(); - void Constraint_Out(); - -protected: - var *Sphio, *Spio; - var *Sphi0, *Spi0; - var *Sphi, *Spi; - var *Sphi1, *Spi1; - var *Sphi_rhs, *Spi_rhs; - - var *Cons_fR; - - monitor *MaxScalar_Monitor; -}; - -#endif /* BSSNESCALAR_CLASS_H */ - + +#ifndef BSSNESCALAR_CLASS_H +#define BSSNESCALAR_CLASS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "cgh.h" +#include "ShellPatch.h" +#include "misc.h" +#include "var.h" +#include "MyList.h" +#include "monitor.h" +#include "surface_integral.h" + +#include "macrodef.h" + +#ifdef USE_GPU +#include "bssn_gpu_class.h" +#else +#include "bssn_class.h" +#endif + +class bssnEScalar_class : public bssn_class +{ +public: + bssnEScalar_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi); + ~bssnEScalar_class(); + + void Initialize(); + void Read_Ansorg(); + void Read_Pablo(); + void Compute_Psi4(int lev); + void Step(int lev, int YN); + void AnalysisStuff_EScalar(int lev, double dT_lev); + void Interp_Constraint(); + void Constraint_Out(); + +protected: + var *Sphio, *Spio; + var *Sphi0, *Spi0; + var *Sphi, *Spi; + var *Sphi1, *Spi1; + var *Sphi_rhs, *Spi_rhs; + + var *Cons_fR; + + monitor *MaxScalar_Monitor; +}; + +#endif /* BSSNESCALAR_CLASS_H */ + diff --git a/AMSS_NCKU_source/bssnEScalar_rhs.f90 b/AMSS_NCKU_source/Scalar/bssnEScalar_rhs.f90 similarity index 98% rename from AMSS_NCKU_source/bssnEScalar_rhs.f90 rename to AMSS_NCKU_source/Scalar/bssnEScalar_rhs.f90 index 79327c7..3dc139f 100644 --- a/AMSS_NCKU_source/bssnEScalar_rhs.f90 +++ b/AMSS_NCKU_source/Scalar/bssnEScalar_rhs.f90 @@ -1,2311 +1,2311 @@ - - -!! note that the potential for scalar field in F(R) gravity -!! is defined in the file Set_Rho_ADM.f90 - -#include "macrodef.fh" - -! rhs for scalar and GR variables -! here we consider vacuum spacetime only - function compute_rhs_bssn_escalar(ex, T,X, Y, Z, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - Sphi , Spi , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - Sphi_rhs , Spi_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, & - Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry,Lev,eps,co) result(gont) -! calculate constraint violation when co=0 - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,co - real*8, intent(in ):: T - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8,intent(in) :: eps - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ZEO=0.d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - double precision,parameter::FF = 0.75d0,eta=2.d0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - real*8, parameter :: F16=1.6d1,F8=8.d0 - - integer :: i,j,k - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) & - +sum(Sphi)+sum(Spi) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" - if(sum(Sphi).ne.sum(Sphi))write(*,*)"bssn.f90: find NaN in Sphi" - if(sum(Spi).ne.sum(Spi))write(*,*)"bssn.f90: find NaN in Spi" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - - div_beta = betaxx + betayy + betazz - - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - - chi_rhs = F2o3 *chin1*( alpn1 * trK - div_beta ) !rhs for chi - - call fderivs(ex,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -#if 1 - Sphi_rhs = alpn1 * Spi !rhs for Scalar phi -!rhs for Spi - call fderivs(ex,Sphi,Kx,Ky,Kz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - call fdderivs(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - Spi_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - & - ((Gamx+(gupxx*chix+gupxy*chiy+gupxz*chiz)/TWO/chin1)*Kx & - + (Gamy+(gupxy*chix+gupyy*chiy+gupyz*chiz)/TWO/chin1)*Ky & - + (Gamz+(gupxz*chix+gupyz*chiy+gupzz*chiz)/TWO/chin1)*Kz) - Spi_rhs = Spi_rhs*alpn1 + & - (gupxx*Lapx*Kx + gupxy*Lapx*Ky + gupxz*Lapx*Kz& - +gupxy*Lapy*Kx + gupyy*Lapy*Ky + gupyz*Lapy*Kz& - +gupxz*Lapz*Kx + gupyz*Lapz*Ky + gupzz*Lapz*Kz) - - call frpotential(ex,Sphi,f,S) - Spi_rhs = Spi_rhs*chin1 + alpn1*(trK*Spi - S) -! matter content of scalar field T_ab - rho = chin1*((gupxx * Kx * Kx + gupyy * Ky * Ky + gupzz * Kz * Kz)/TWO + & - gupxy * Kx * Ky + gupxz * Kx * Kz + gupyz * Ky * Kz ) & - + Spi*Spi/TWO+f - Sx = -Spi*Kx - Sy = -Spi*Ky - Sz = -Spi*Kz - f = (rho - Spi*Spi)/chin1 - Sxx = Kx*Kx-f*gxx - Sxy = Kx*Ky-f*gxy - Sxz = Kx*Kz-f*gxz - Syy = Ky*Ky-f*gyy - Syz = Ky*Kz-f*gyz - Szz = Kz*Kz-f*gzz -#else - rho = ZEO - Sx = ZEO - Sy = ZEO - Sz = ZEO - Sxx = ZEO - Sxy = ZEO - Sxz = ZEO - Syy = ZEO - Syz = ZEO - Szz = ZEO -#endif - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - - if(co == 0)then -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gamx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gamy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gamz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - endif - - gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & - TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) - - gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & - TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) - - gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & - TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) - - gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & - gxx * betaxy + gxz * betazy + & - gyy * betayx + gyz * betazx & - - gxy * betazz - - gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & - gxy * betaxz + gyy * betayz + & - gxz * betaxy + gzz * betazy & - - gyz * betaxx - - gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & - gxx * betaxz + gxy * betayz + & - gyz * betayx + gzz * betazx & - - gxz * betayy !rhs for gij - -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) -! Raise indices of \tilde A_{ij} and store in R_ij - - Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & - TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) - - Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & - TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) - - Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & - TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) - - Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & - (gupxx * gupyy + gupxy * gupxy)* Axy + & - (gupxx * gupyz + gupxz * gupxy)* Axz + & - (gupxy * gupyz + gupxz * gupyy)* Ayz - - Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & - (gupxx * gupyz + gupxy * gupxz)* Axy + & - (gupxx * gupzz + gupxz * gupxz)* Axz + & - (gupxy * gupzz + gupxz * gupyz)* Ayz - - Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & - (gupxy * gupyz + gupyy * gupxz)* Axy + & - (gupxy * gupzz + gupyz * gupxz)* Axz + & - (gupyy * gupzz + gupyz * gupyz)* Ayz - -! Right hand side for Gam^i without shift terms... - call fderivs(ex,trK,Kx,Ky,Kz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - - Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & - gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & - TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) - - Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & - gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & - TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) - - Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & - gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & - TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) - - call fdderivs(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,& - X,Y,Z,ANTI,SYM, SYM ,Symmetry,Lev) - call fdderivs(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,& - X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) - call fdderivs(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,& - X,Y,Z,SYM ,SYM, ANTI,Symmetry,Lev) - - fxx = gxxx + gxyy + gxzz - fxy = gxyx + gyyy + gyzz - fxz = gxzx + gyzy + gzzz - - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - - call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,Lev) - call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) - call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,Lev) - - Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & - Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & - F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & - gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & - TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) - - Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & - Gamxa * betayx - Gamya * betayy - Gamza * betayz + & - F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & - gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & - TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) - - Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & - Gamxa * betazx - Gamya * betazy - Gamza * betazz + & - F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & - gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & - TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - call fdderivs(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI, ANTI,SYM ,symmetry,Lev) - Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI ,SYM ,ANTI,symmetry,Lev) - Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,ANTI ,ANTI,symmetry,Lev) - Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) -! Add chi part to Ricci tensor: - - Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO - -! now prepare to get physical second kind of connection - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - -! covariant second derivatives of the lapse respect to physical metric - call fdderivs(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM,SYM,SYM,symmetry,Lev) - - fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz - fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz - fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz - fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz - fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz - fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz - -! mater content only appears in the right hand side of trK and A_ij which are -! comming now -! store D^i D_i Lap in trK_rhs upto chi - trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) -! Add lapse and S_ij parts to Ricci tensor: - - fxx = alpn1 * (Rxx - EIGHT * PI * Sxx) - fxx - fxy = alpn1 * (Rxy - EIGHT * PI * Sxy) - fxy - fxz = alpn1 * (Rxz - EIGHT * PI * Sxz) - fxz - fyy = alpn1 * (Ryy - EIGHT * PI * Syy) - fyy - fyz = alpn1 * (Ryz - EIGHT * PI * Syz) - fyz - fzz = alpn1 * (Rzz - EIGHT * PI * Szz) - fzz - -! Compute trace-free part (note: chi^-1 and chi cancel!): - - f = F1o3 *( gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) ) - - Axx_rhs = fxx - gxx * f - Ayy_rhs = fyy - gyy * f - Azz_rhs = fzz - gzz * f - Axy_rhs = fxy - gxy * f - Axz_rhs = fxz - gxz * f - Ayz_rhs = fyz - gyz * f - -! Now: store A_il A^l_j into fij: - - fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) - fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) - fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) - fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy *(Axx * Ayy + Axy * Axy) + & - gupxz *(Axx * Ayz + Axz * Axy) + & - gupyz *(Axy * Ayz + Axz * Ayy) - fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy *(Axx * Ayz + Axy * Axz) + & - gupxz *(Axx * Azz + Axz * Axz) + & - gupyz *(Axy * Azz + Axz * Ayz) - fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy *(Axy * Ayz + Ayy * Axz) + & - gupxz *(Axy * Azz + Ayz * Axz) + & - gupyz *(Ayy * Azz + Ayz * Ayz) - - f = chin1 -! store D^i D_i Lap in trK_rhs - trK_rhs = f*trK_rhs - - Axx_rhs = f * Axx_rhs+ alpn1 * (trK * Axx - TWO * fxx) + & - TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx )- & - F2o3 * Axx * div_beta - - Ayy_rhs = f * Ayy_rhs+ alpn1 * (trK * Ayy - TWO * fyy) + & - TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy )- & - F2o3 * Ayy * div_beta - - Azz_rhs = f * Azz_rhs+ alpn1 * (trK * Azz - TWO * fzz) + & - TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz )- & - F2o3 * Azz * div_beta - - Axy_rhs = f * Axy_rhs+ alpn1 *( trK * Axy - TWO * fxy )+ & - Axx * betaxy + Axz * betazy + & - Ayy * betayx + Ayz * betazx + & - F1o3 * Axy * div_beta - Axy * betazz - - Ayz_rhs = f * Ayz_rhs+ alpn1 *( trK * Ayz - TWO * fyz )+ & - Axy * betaxz + Ayy * betayz + & - Axz * betaxy + Azz * betazy + & - F1o3 * Ayz * div_beta - Ayz * betaxx - - Axz_rhs = f * Axz_rhs+ alpn1 *( trK * Axz - TWO * fxz )+ & - Axx * betaxz + Axy * betayz + & - Ayz * betayx + Azz * betazx + & - F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij - -! Compute trace of S_ij - - S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & - TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) - - trK_rhs = - trK_rhs + alpn1 *( F1o3 * trK * trK + & - gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & - FOUR * PI * ( rho + S )) !rhs for trK - -!!!! gauge variable part - - Lap_rhs = -TWO*alpn1*trK - - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term part - - call lopsided(ex,X,Y,Z,gxx,gxx_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,gxy,gxy_rhs,betax,betay,betaz,Symmetry,AAS) - call lopsided(ex,X,Y,Z,gxz,gxz_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ex,X,Y,Z,gyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ex,X,Y,Z,gzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS) - call lopsided(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA) -!! - call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) - - call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) -#if 1 -!! - call lopsided(ex,X,Y,Z,Sphi,Sphi_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Spi , Spi_rhs,betax,betay,betaz,Symmetry,SSS) -#endif - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,dxx,gxx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,dyy,gyy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,dzz,gzz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) - - call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) - -#if 1 - call kodis(ex,X,Y,Z,Sphi,Sphi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Spi ,Spi_rhs ,SSS,Symmetry,eps) -#endif - endif - -#if 0 - Sphi_rhs = ZEO - Spi_rhs = ZEO -#endif - - if(co == 0)then -! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho - -! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) - call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) - call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) - call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - -movx_Res = movx_Res - F2o3*Kx - F8*PI*sx -movy_Res = movy_Res - F2o3*Ky - F8*PI*sy -movz_Res = movz_Res - F2o3*Kz - F8*PI*sz - endif - - gont = 0 - - return - - end function compute_rhs_bssn_escalar -!! for shell part - function compute_rhs_bssn_escalar_ss(ex, T,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - Sphi , Spi , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - Sphi_rhs , Spi_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - ham_Res, movx_Res, movy_Res, movz_Res, & - Gmx_Res, Gmy_Res, Gmz_Res, & - Symmetry,Lev,eps,sst,co) result(gont) -! calculate constraint violation when co=0 - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co - real*8, intent(in ):: T - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8,intent(in) :: eps - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ZEO=0.d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - double precision,parameter::FF = 0.75d0,eta=2.d0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - real*8, parameter :: F16=1.6d1,F8=8.d0 - - integer :: i,j,k - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) & - +sum(Sphi)+sum(Spi) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" - if(sum(Sphi).ne.sum(Sphi))write(*,*)"bssn.f90: find NaN in Sphi" - if(sum(Spi).ne.sum(Spi))write(*,*)"bssn.f90: find NaN in Spi" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = crho(2) - crho(1) - dY = sigma(2) - sigma(1) - dZ = R(2) - R(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - div_beta = betaxx + betayy + betazz - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - chi_rhs = F2o3 *chin1*( alpn1 * trK - div_beta ) !rhs for chi - - call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz - -#if 1 - Sphi_rhs = alpn1 * Spi !rhs for Scalar phi -!rhs for Spi - call fderivs_shc(ex,Sphi,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fdderivs_shc(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Spi_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - & - ((Gamx+(gupxx*chix+gupxy*chiy+gupxz*chiz)/TWO/chin1)*Kx & - + (Gamy+(gupxy*chix+gupyy*chiy+gupyz*chiz)/TWO/chin1)*Ky & - + (Gamz+(gupxz*chix+gupyz*chiy+gupzz*chiz)/TWO/chin1)*Kz) - Spi_rhs = Spi_rhs*alpn1 + & - (gupxx*Lapx*Kx + gupxy*Lapx*Ky + gupxz*Lapx*Kz& - +gupxy*Lapy*Kx + gupyy*Lapy*Ky + gupyz*Lapy*Kz& - +gupxz*Lapz*Kx + gupyz*Lapz*Ky + gupzz*Lapz*Kz) - - call frpotential(ex,Sphi,f,S) - Spi_rhs = Spi_rhs*chin1 + alpn1*(trK*Spi - S) -! matter content of scalar field T_ab - rho = chin1*((gupxx * Kx * Kx + gupyy * Ky * Ky + gupzz * Kz * Kz)/TWO + & - gupxy * Kx * Ky + gupxz * Kx * Kz + gupyz * Ky * Kz ) & - + Spi*Spi/TWO+f - Sx = -Spi*Kx - Sy = -Spi*Ky - Sz = -Spi*Kz - f = (rho - Spi*Spi)/chin1 - Sxx = Kx*Kx-f*gxx - Sxy = Kx*Ky-f*gxy - Sxz = Kx*Kz-f*gxz - Syy = Ky*Ky-f*gyy - Syz = Ky*Kz-f*gyz - Szz = Kz*Kz-f*gzz -#else - rho = ZEO - Sx = ZEO - Sy = ZEO - Sz = ZEO - Sxx = ZEO - Sxy = ZEO - Sxz = ZEO - Syy = ZEO - Syz = ZEO - Szz = ZEO -#endif - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - if(co == 0)then -! Gam^i_Res = Gam^i + gup^ij_,j - Gmx_Res = Gamx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& - +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& - +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& - +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmy_Res = Gamy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& - +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& - +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& - +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& - +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& - +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& - +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - Gmz_Res = Gamz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& - +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& - +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& - +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& - +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& - +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& - +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& - +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& - +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) - endif - - gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & - TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) - - gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & - TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) - - gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & - TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) - - gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & - gxx * betaxy + gxz * betazy + & - gyy * betayx + gyz * betazx & - - gxy * betazz - - gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & - gxy * betaxz + gyy * betayz + & - gxz * betaxy + gzz * betazy & - - gyz * betaxx - - gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & - gxx * betaxz + gxy * betayz + & - gyz * betayx + gzz * betazx & - - gxz * betayy !rhs for gij - -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) -! Raise indices of \tilde A_{ij} and store in R_ij - - Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & - TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) - - Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & - TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) - - Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & - TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) - - Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & - (gupxx * gupyy + gupxy * gupxy)* Axy + & - (gupxx * gupyz + gupxz * gupxy)* Axz + & - (gupxy * gupyz + gupxz * gupyy)* Ayz - - Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & - (gupxx * gupyz + gupxy * gupxz)* Axy + & - (gupxx * gupzz + gupxz * gupxz)* Axz + & - (gupxy * gupzz + gupxz * gupyz)* Ayz - - Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & - (gupxy * gupyz + gupyy * gupxz)* Axy + & - (gupxy * gupzz + gupyz * gupxz)* Axz + & - (gupyy * gupzz + gupyz * gupyz)* Ayz - -! Right hand side for Gam^i without shift terms... - call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & - gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & - TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) - - Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & - gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & - TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) - - Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & - gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & - TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) - - call fdderivs_shc(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = gxxx + gxyy + gxzz - fxy = gxyx + gyyy + gyzz - fxz = gxzx + gyzy + gzzz - - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - - call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & - Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & - F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & - gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & - TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) - - Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & - Gamxa * betayx - Gamya * betayy - Gamza * betayz + & - F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & - gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & - TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) - - Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & - Gamxa * betazx - Gamya * betazy - Gamza * betazz + & - F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & - gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & - TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - call fdderivs_shc(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - call fdderivs_shc(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) -! Add chi part to Ricci tensor: - - Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO - -! now prepare to get physical second kind of connection - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - -! covariant second derivatives of the lapse respect to physical metric - call fdderivs_shc(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz - fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz - fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz - fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz - fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz - fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz - -! mater content only appears in the right hand side of trK and A_ij which are -! comming now -! store D^i D_i Lap in trK_rhs upto chi - trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) -! Add lapse and S_ij parts to Ricci tensor: - - fxx = alpn1 * (Rxx - EIGHT * PI * Sxx) - fxx - fxy = alpn1 * (Rxy - EIGHT * PI * Sxy) - fxy - fxz = alpn1 * (Rxz - EIGHT * PI * Sxz) - fxz - fyy = alpn1 * (Ryy - EIGHT * PI * Syy) - fyy - fyz = alpn1 * (Ryz - EIGHT * PI * Syz) - fyz - fzz = alpn1 * (Rzz - EIGHT * PI * Szz) - fzz - -! Compute trace-free part (note: chi^-1 and chi cancel!): - - f = F1o3 *( gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) ) - - Axx_rhs = fxx - gxx * f - Ayy_rhs = fyy - gyy * f - Azz_rhs = fzz - gzz * f - Axy_rhs = fxy - gxy * f - Axz_rhs = fxz - gxz * f - Ayz_rhs = fyz - gyz * f - -! Now: store A_il A^l_j into fij: - - fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) - fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) - fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) - fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy *(Axx * Ayy + Axy * Axy) + & - gupxz *(Axx * Ayz + Axz * Axy) + & - gupyz *(Axy * Ayz + Axz * Ayy) - fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy *(Axx * Ayz + Axy * Axz) + & - gupxz *(Axx * Azz + Axz * Axz) + & - gupyz *(Axy * Azz + Axz * Ayz) - fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy *(Axy * Ayz + Ayy * Axz) + & - gupxz *(Axy * Azz + Ayz * Axz) + & - gupyz *(Ayy * Azz + Ayz * Ayz) - - f = chin1 -! store D^i D_i Lap in trK_rhs - trK_rhs = f*trK_rhs - - Axx_rhs = f * Axx_rhs+ alpn1 * (trK * Axx - TWO * fxx) + & - TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx )- & - F2o3 * Axx * div_beta - - Ayy_rhs = f * Ayy_rhs+ alpn1 * (trK * Ayy - TWO * fyy) + & - TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy )- & - F2o3 * Ayy * div_beta - - Azz_rhs = f * Azz_rhs+ alpn1 * (trK * Azz - TWO * fzz) + & - TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz )- & - F2o3 * Azz * div_beta - - Axy_rhs = f * Axy_rhs+ alpn1 *( trK * Axy - TWO * fxy )+ & - Axx * betaxy + Axz * betazy + & - Ayy * betayx + Ayz * betazx + & - F1o3 * Axy * div_beta - Axy * betazz - - Ayz_rhs = f * Ayz_rhs+ alpn1 *( trK * Ayz - TWO * fyz )+ & - Axy * betaxz + Ayy * betayz + & - Axz * betaxy + Azz * betazy + & - F1o3 * Ayz * div_beta - Ayz * betaxx - - Axz_rhs = f * Axz_rhs+ alpn1 *( trK * Axz - TWO * fxz )+ & - Axx * betaxz + Axy * betayz + & - Ayz * betayx + Azz * betazx + & - F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij - -! Compute trace of S_ij - - S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & - TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) - - trK_rhs = - trK_rhs + alpn1 *( F1o3 * trK * trK + & - gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & - FOUR * PI * ( rho + S )) !rhs for trK - -!!!! gauge variable part - - Lap_rhs = -TWO*alpn1*trK - - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term part -!g_ij - call fderivs_shc(ex,dxx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxx_rhs = gxx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gxy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxy_rhs = gxy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gxz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxz_rhs = gxz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dyy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gyy_rhs = gyy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gyz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gyz_rhs = gyz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dzz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gzz_rhs = gzz_rhs + betax*fxx+betay*fxy+betaz*fxz -!A_ij - call fderivs_shc(ex,Axx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axx_rhs = Axx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Axy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axy_rhs = Axy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Axz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axz_rhs = Axz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Ayy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Ayy_rhs = Ayy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Ayz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Ayz_rhs = Ayz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Azz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Azz_rhs = Azz_rhs + betax*fxx+betay*fxy+betaz*fxz -!chi and trK - call fderivs_shc(ex,chi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - chi_rhs = chi_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,trK,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - trK_rhs = trK_rhs + betax*fxx+betay*fxy+betaz*fxz -!Gam^i - call fderivs_shc(ex,Gamx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamx_rhs = Gamx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Gamy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamy_rhs = Gamy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Gamz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamz_rhs = Gamz_rhs + betax*fxx+betay*fxy+betaz*fxz -!gauge variables - call fderivs_shc(ex,Lap,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Lap_rhs = Lap_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betax,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betax_rhs = betax_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betay,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betay_rhs = betay_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betaz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betaz_rhs = betaz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfx_rhs = dtSfx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfy_rhs = dtSfy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfz_rhs = dtSfz_rhs + betax*fxx+betay*fxy+betaz*fxz -#if 1 -!! - call fderivs_shc(ex,Sphi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Sphi_rhs = Sphi_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Spi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Spi_rhs = Spi_rhs + betax*fxx+betay*fxy+betaz*fxz -#endif - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,dxx,gxx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,dyy,gyy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,dzz,gzz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) - - call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) - -#if 1 - call kodis(ex,X,Y,Z,Sphi,Sphi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Spi ,Spi_rhs ,SSS,Symmetry,eps) -#endif - endif - -#if 0 - Sphi_rhs = ZEO - Spi_rhs = ZEO -#endif - - if(co == 0)then -! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & - TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) - - ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho - -! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - - call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 -movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz -movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz -movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz - -movx_Res = movx_Res - F2o3*Kx - F8*PI*sx -movy_Res = movy_Res - F2o3*Ky - F8*PI*sy -movz_Res = movz_Res - F2o3*Kz - F8*PI*sz - endif - - gont = 0 - - return - - end function compute_rhs_bssn_escalar_ss -!----------------------------------------------------------------------------- -! -! compute constraint introduced by dynamical equation reduction of fR -! this routine is valid for both box and shell -! -!----------------------------------------------------------------------------- - - subroutine compute_constraint_fr(ex, X, Y, Z, & - chi, trK, rho, Sphi,& - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Sxx,Sxy,Sxz,Syy,Syz,Szz,& - Cons_fr) - - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,rho,Sphi -! physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! matter - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Sxx,Sxy,Sxz,Syy,Syz,Szz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Cons_fr - -! 4D Ricci scalar - real*8, dimension(ex(1),ex(2),ex(3)) :: RR - real*8,parameter :: ONE=1.d0,THR=3.d0,FOU=4.d0 - real*8 :: PI - - PI = dacos(-ONE) - - call get4ricciscalar(ex, X, Y, Z, & - chi, trK, rho, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Sxx,Sxy,Sxz,Syy,Syz,Szz,& - RR) - call frfprim(ex,RR,Cons_fr) - - Cons_fr = Sphi-dsqrt(THR/PI)/FOU*dlog(Cons_fr) - - return - - end subroutine compute_constraint_fr + + +!! note that the potential for scalar field in F(R) gravity +!! is defined in the file Set_Rho_ADM.f90 + +#include "macrodef.fh" + +! rhs for scalar and GR variables +! here we consider vacuum spacetime only + function compute_rhs_bssn_escalar(ex, T,X, Y, Z, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + Sphi , Spi , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + Sphi_rhs , Spi_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, & + Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry,Lev,eps,co) result(gont) +! calculate constraint violation when co=0 + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,co + real*8, intent(in ):: T + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8,intent(in) :: eps + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ZEO=0.d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + double precision,parameter::FF = 0.75d0,eta=2.d0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + real*8, parameter :: F16=1.6d1,F8=8.d0 + + integer :: i,j,k + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) & + +sum(Sphi)+sum(Spi) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" + if(sum(Sphi).ne.sum(Sphi))write(*,*)"bssn.f90: find NaN in Sphi" + if(sum(Spi).ne.sum(Spi))write(*,*)"bssn.f90: find NaN in Spi" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + + div_beta = betaxx + betayy + betazz + + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) + + chi_rhs = F2o3 *chin1*( alpn1 * trK - div_beta ) !rhs for chi + + call fderivs(ex,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +#if 1 + Sphi_rhs = alpn1 * Spi !rhs for Scalar phi +!rhs for Spi + call fderivs(ex,Sphi,Kx,Ky,Kz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + call fdderivs(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + Spi_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - & + ((Gamx+(gupxx*chix+gupxy*chiy+gupxz*chiz)/TWO/chin1)*Kx & + + (Gamy+(gupxy*chix+gupyy*chiy+gupyz*chiz)/TWO/chin1)*Ky & + + (Gamz+(gupxz*chix+gupyz*chiy+gupzz*chiz)/TWO/chin1)*Kz) + Spi_rhs = Spi_rhs*alpn1 + & + (gupxx*Lapx*Kx + gupxy*Lapx*Ky + gupxz*Lapx*Kz& + +gupxy*Lapy*Kx + gupyy*Lapy*Ky + gupyz*Lapy*Kz& + +gupxz*Lapz*Kx + gupyz*Lapz*Ky + gupzz*Lapz*Kz) + + call frpotential(ex,Sphi,f,S) + Spi_rhs = Spi_rhs*chin1 + alpn1*(trK*Spi - S) +! matter content of scalar field T_ab + rho = chin1*((gupxx * Kx * Kx + gupyy * Ky * Ky + gupzz * Kz * Kz)/TWO + & + gupxy * Kx * Ky + gupxz * Kx * Kz + gupyz * Ky * Kz ) & + + Spi*Spi/TWO+f + Sx = -Spi*Kx + Sy = -Spi*Ky + Sz = -Spi*Kz + f = (rho - Spi*Spi)/chin1 + Sxx = Kx*Kx-f*gxx + Sxy = Kx*Ky-f*gxy + Sxz = Kx*Kz-f*gxz + Syy = Ky*Ky-f*gyy + Syz = Ky*Kz-f*gyz + Szz = Kz*Kz-f*gzz +#else + rho = ZEO + Sx = ZEO + Sy = ZEO + Sz = ZEO + Sxx = ZEO + Sxy = ZEO + Sxz = ZEO + Syy = ZEO + Syz = ZEO + Szz = ZEO +#endif + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + + if(co == 0)then +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gamx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gamy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gamz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + endif + + gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & + TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) + + gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & + TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) + + gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & + TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) + + gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & + gxx * betaxy + gxz * betazy + & + gyy * betayx + gyz * betazx & + - gxy * betazz + + gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & + gxy * betaxz + gyy * betayz + & + gxz * betaxy + gzz * betazy & + - gyz * betaxx + + gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & + gxx * betaxz + gxy * betayz + & + gyz * betayx + gzz * betazx & + - gxz * betayy !rhs for gij + +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) +! Raise indices of \tilde A_{ij} and store in R_ij + + Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & + TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) + + Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & + TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) + + Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & + TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) + + Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & + (gupxx * gupyy + gupxy * gupxy)* Axy + & + (gupxx * gupyz + gupxz * gupxy)* Axz + & + (gupxy * gupyz + gupxz * gupyy)* Ayz + + Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & + (gupxx * gupyz + gupxy * gupxz)* Axy + & + (gupxx * gupzz + gupxz * gupxz)* Axz + & + (gupxy * gupzz + gupxz * gupyz)* Ayz + + Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & + (gupxy * gupyz + gupyy * gupxz)* Axy + & + (gupxy * gupzz + gupyz * gupxz)* Axz + & + (gupyy * gupzz + gupyz * gupyz)* Ayz + +! Right hand side for Gam^i without shift terms... + call fderivs(ex,trK,Kx,Ky,Kz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) + + Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & + gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & + TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) + + Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & + gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & + TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) + + Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & + gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & + TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) + + call fdderivs(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,& + X,Y,Z,ANTI,SYM, SYM ,Symmetry,Lev) + call fdderivs(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,& + X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) + call fdderivs(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,& + X,Y,Z,SYM ,SYM, ANTI,Symmetry,Lev) + + fxx = gxxx + gxyy + gxzz + fxy = gxyx + gyyy + gyzz + fxz = gxzx + gyzy + gzzz + + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + + call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,Lev) + call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) + call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,Lev) + + Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & + Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & + F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & + gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & + TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) + + Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & + Gamxa * betayx - Gamya * betayy - Gamza * betayz + & + F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & + gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & + TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) + + Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & + Gamxa * betazx - Gamya * betazy - Gamza * betazz + & + F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & + gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & + TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + call fdderivs(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI, ANTI,SYM ,symmetry,Lev) + Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,ANTI ,SYM ,ANTI,symmetry,Lev) + Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,ANTI ,ANTI,symmetry,Lev) + Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) +! Add chi part to Ricci tensor: + + Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO + +! now prepare to get physical second kind of connection + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + +! covariant second derivatives of the lapse respect to physical metric + call fdderivs(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM,SYM,SYM,symmetry,Lev) + + fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz + fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz + fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz + fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz + fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz + fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz + +! mater content only appears in the right hand side of trK and A_ij which are +! comming now +! store D^i D_i Lap in trK_rhs upto chi + trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) +! Add lapse and S_ij parts to Ricci tensor: + + fxx = alpn1 * (Rxx - EIGHT * PI * Sxx) - fxx + fxy = alpn1 * (Rxy - EIGHT * PI * Sxy) - fxy + fxz = alpn1 * (Rxz - EIGHT * PI * Sxz) - fxz + fyy = alpn1 * (Ryy - EIGHT * PI * Syy) - fyy + fyz = alpn1 * (Ryz - EIGHT * PI * Syz) - fyz + fzz = alpn1 * (Rzz - EIGHT * PI * Szz) - fzz + +! Compute trace-free part (note: chi^-1 and chi cancel!): + + f = F1o3 *( gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) ) + + Axx_rhs = fxx - gxx * f + Ayy_rhs = fyy - gyy * f + Azz_rhs = fzz - gzz * f + Axy_rhs = fxy - gxy * f + Axz_rhs = fxz - gxz * f + Ayz_rhs = fyz - gyz * f + +! Now: store A_il A^l_j into fij: + + fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) + fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) + fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) + fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy *(Axx * Ayy + Axy * Axy) + & + gupxz *(Axx * Ayz + Axz * Axy) + & + gupyz *(Axy * Ayz + Axz * Ayy) + fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy *(Axx * Ayz + Axy * Axz) + & + gupxz *(Axx * Azz + Axz * Axz) + & + gupyz *(Axy * Azz + Axz * Ayz) + fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy *(Axy * Ayz + Ayy * Axz) + & + gupxz *(Axy * Azz + Ayz * Axz) + & + gupyz *(Ayy * Azz + Ayz * Ayz) + + f = chin1 +! store D^i D_i Lap in trK_rhs + trK_rhs = f*trK_rhs + + Axx_rhs = f * Axx_rhs+ alpn1 * (trK * Axx - TWO * fxx) + & + TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx )- & + F2o3 * Axx * div_beta + + Ayy_rhs = f * Ayy_rhs+ alpn1 * (trK * Ayy - TWO * fyy) + & + TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy )- & + F2o3 * Ayy * div_beta + + Azz_rhs = f * Azz_rhs+ alpn1 * (trK * Azz - TWO * fzz) + & + TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz )- & + F2o3 * Azz * div_beta + + Axy_rhs = f * Axy_rhs+ alpn1 *( trK * Axy - TWO * fxy )+ & + Axx * betaxy + Axz * betazy + & + Ayy * betayx + Ayz * betazx + & + F1o3 * Axy * div_beta - Axy * betazz + + Ayz_rhs = f * Ayz_rhs+ alpn1 *( trK * Ayz - TWO * fyz )+ & + Axy * betaxz + Ayy * betayz + & + Axz * betaxy + Azz * betazy + & + F1o3 * Ayz * div_beta - Ayz * betaxx + + Axz_rhs = f * Axz_rhs+ alpn1 *( trK * Axz - TWO * fxz )+ & + Axx * betaxz + Axy * betayz + & + Ayz * betayx + Azz * betazx + & + F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij + +! Compute trace of S_ij + + S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & + TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) + + trK_rhs = - trK_rhs + alpn1 *( F1o3 * trK * trK + & + gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & + FOUR * PI * ( rho + S )) !rhs for trK + +!!!! gauge variable part + + Lap_rhs = -TWO*alpn1*trK + + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term part + + call lopsided(ex,X,Y,Z,gxx,gxx_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,gxy,gxy_rhs,betax,betay,betaz,Symmetry,AAS) + call lopsided(ex,X,Y,Z,gxz,gxz_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ex,X,Y,Z,gyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ex,X,Y,Z,gzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS) + call lopsided(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA) +!! + call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) + + call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) +#if 1 +!! + call lopsided(ex,X,Y,Z,Sphi,Sphi_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Spi , Spi_rhs,betax,betay,betaz,Symmetry,SSS) +#endif + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,dxx,gxx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,dyy,gyy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,dzz,gzz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) + + call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) + +#if 1 + call kodis(ex,X,Y,Z,Sphi,Sphi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Spi ,Spi_rhs ,SSS,Symmetry,eps) +#endif + endif + +#if 0 + Sphi_rhs = ZEO + Spi_rhs = ZEO +#endif + + if(co == 0)then +! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho + +! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,0) + call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,0) + call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,0) + call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,0) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + +movx_Res = movx_Res - F2o3*Kx - F8*PI*sx +movy_Res = movy_Res - F2o3*Ky - F8*PI*sy +movz_Res = movz_Res - F2o3*Kz - F8*PI*sz + endif + + gont = 0 + + return + + end function compute_rhs_bssn_escalar +!! for shell part + function compute_rhs_bssn_escalar_ss(ex, T,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + Sphi , Spi , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + Sphi_rhs , Spi_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + ham_Res, movx_Res, movy_Res, movz_Res, & + Gmx_Res, Gmy_Res, Gmz_Res, & + Symmetry,Lev,eps,sst,co) result(gont) +! calculate constraint violation when co=0 + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co + real*8, intent(in ):: T + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8,intent(in) :: eps + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: ham_Res, movx_Res, movy_Res, movz_Res + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gmx_Res, Gmy_Res, Gmz_Res +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ZEO=0.d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + double precision,parameter::FF = 0.75d0,eta=2.d0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + real*8, parameter :: F16=1.6d1,F8=8.d0 + + integer :: i,j,k + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz) & + +sum(Sphi)+sum(Spi) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"bssn.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"bssn.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"bssn.f90: find NaN in dxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"bssn.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"bssn.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"bssn.f90: find NaN in dyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"bssn.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"bssn.f90: find NaN in dzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"bssn.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"bssn.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"bssn.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"bssn.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"bssn.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"bssn.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"bssn.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"bssn.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"bssn.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"bssn.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"bssn.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"bssn.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"bssn.f90: find NaN in betaz" + if(sum(Sphi).ne.sum(Sphi))write(*,*)"bssn.f90: find NaN in Sphi" + if(sum(Spi).ne.sum(Spi))write(*,*)"bssn.f90: find NaN in Spi" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = crho(2) - crho(1) + dY = sigma(2) - sigma(1) + dZ = R(2) - R(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + div_beta = betaxx + betayy + betazz + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + chi_rhs = F2o3 *chin1*( alpn1 * trK - div_beta ) !rhs for chi + + call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz + +#if 1 + Sphi_rhs = alpn1 * Spi !rhs for Scalar phi +!rhs for Spi + call fderivs_shc(ex,Sphi,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fdderivs_shc(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Spi_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO - & + ((Gamx+(gupxx*chix+gupxy*chiy+gupxz*chiz)/TWO/chin1)*Kx & + + (Gamy+(gupxy*chix+gupyy*chiy+gupyz*chiz)/TWO/chin1)*Ky & + + (Gamz+(gupxz*chix+gupyz*chiy+gupzz*chiz)/TWO/chin1)*Kz) + Spi_rhs = Spi_rhs*alpn1 + & + (gupxx*Lapx*Kx + gupxy*Lapx*Ky + gupxz*Lapx*Kz& + +gupxy*Lapy*Kx + gupyy*Lapy*Ky + gupyz*Lapy*Kz& + +gupxz*Lapz*Kx + gupyz*Lapz*Ky + gupzz*Lapz*Kz) + + call frpotential(ex,Sphi,f,S) + Spi_rhs = Spi_rhs*chin1 + alpn1*(trK*Spi - S) +! matter content of scalar field T_ab + rho = chin1*((gupxx * Kx * Kx + gupyy * Ky * Ky + gupzz * Kz * Kz)/TWO + & + gupxy * Kx * Ky + gupxz * Kx * Kz + gupyz * Ky * Kz ) & + + Spi*Spi/TWO+f + Sx = -Spi*Kx + Sy = -Spi*Ky + Sz = -Spi*Kz + f = (rho - Spi*Spi)/chin1 + Sxx = Kx*Kx-f*gxx + Sxy = Kx*Ky-f*gxy + Sxz = Kx*Kz-f*gxz + Syy = Ky*Ky-f*gyy + Syz = Ky*Kz-f*gyz + Szz = Kz*Kz-f*gzz +#else + rho = ZEO + Sx = ZEO + Sy = ZEO + Sz = ZEO + Sxx = ZEO + Sxy = ZEO + Sxz = ZEO + Syy = ZEO + Syz = ZEO + Szz = ZEO +#endif + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + if(co == 0)then +! Gam^i_Res = Gam^i + gup^ij_,j + Gmx_Res = Gamx - (gupxx*(gupxx*gxxx+gupxy*gxyx+gupxz*gxzx)& + +gupxy*(gupxx*gxyx+gupxy*gyyx+gupxz*gyzx)& + +gupxz*(gupxx*gxzx+gupxy*gyzx+gupxz*gzzx)& + +gupxx*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupxy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupxz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxx*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupxy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupxz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmy_Res = Gamy - (gupxx*(gupxy*gxxx+gupyy*gxyx+gupyz*gxzx)& + +gupxy*(gupxy*gxyx+gupyy*gyyx+gupyz*gyzx)& + +gupxz*(gupxy*gxzx+gupyy*gyzx+gupyz*gzzx)& + +gupxy*(gupxy*gxxy+gupyy*gxyy+gupyz*gxzy)& + +gupyy*(gupxy*gxyy+gupyy*gyyy+gupyz*gyzy)& + +gupyz*(gupxy*gxzy+gupyy*gyzy+gupyz*gzzy)& + +gupxy*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyy*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupyz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + Gmz_Res = Gamz - (gupxx*(gupxz*gxxx+gupyz*gxyx+gupzz*gxzx)& + +gupxy*(gupxz*gxyx+gupyz*gyyx+gupzz*gyzx)& + +gupxz*(gupxz*gxzx+gupyz*gyzx+gupzz*gzzx)& + +gupxy*(gupxz*gxxy+gupyz*gxyy+gupzz*gxzy)& + +gupyy*(gupxz*gxyy+gupyz*gyyy+gupzz*gyzy)& + +gupyz*(gupxz*gxzy+gupyz*gyzy+gupzz*gzzy)& + +gupxz*(gupxz*gxxz+gupyz*gxyz+gupzz*gxzz)& + +gupyz*(gupxz*gxyz+gupyz*gyyz+gupzz*gyzz)& + +gupzz*(gupxz*gxzz+gupyz*gyzz+gupzz*gzzz)) + endif + + gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & + TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) + + gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & + TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) + + gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & + TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) + + gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & + gxx * betaxy + gxz * betazy + & + gyy * betayx + gyz * betazx & + - gxy * betazz + + gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & + gxy * betaxz + gyy * betayz + & + gxz * betaxy + gzz * betazy & + - gyz * betaxx + + gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & + gxx * betaxz + gxy * betayz + & + gyz * betayx + gzz * betazx & + - gxz * betayy !rhs for gij + +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) +! Raise indices of \tilde A_{ij} and store in R_ij + + Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & + TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) + + Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & + TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) + + Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & + TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) + + Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & + (gupxx * gupyy + gupxy * gupxy)* Axy + & + (gupxx * gupyz + gupxz * gupxy)* Axz + & + (gupxy * gupyz + gupxz * gupyy)* Ayz + + Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & + (gupxx * gupyz + gupxy * gupxz)* Axy + & + (gupxx * gupzz + gupxz * gupxz)* Axz + & + (gupxy * gupzz + gupxz * gupyz)* Ayz + + Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & + (gupxy * gupyz + gupyy * gupxz)* Axy + & + (gupxy * gupzz + gupyz * gupxz)* Axz + & + (gupyy * gupzz + gupyz * gupyz)* Ayz + +! Right hand side for Gam^i without shift terms... + call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & + gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & + TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) + + Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & + gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & + TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) + + Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & + gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & + TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) + + call fdderivs_shc(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = gxxx + gxyy + gxzz + fxy = gxyx + gyyy + gyzz + fxz = gxzx + gyzy + gzzz + + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + + call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & + Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & + F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & + gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & + TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) + + Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & + Gamxa * betayx - Gamya * betayy - Gamza * betayz + & + F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & + gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & + TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) + + Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & + Gamxa * betazx - Gamya * betazy - Gamza * betazz + & + F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & + gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & + TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + call fdderivs_shc(ex,dxx,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxx = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,dyy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Ryy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,dzz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rzz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gxy,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxy = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gxz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Rxz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + call fdderivs_shc(ex,gyz,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Ryz = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) +! Add chi part to Ricci tensor: + + Rxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + Ryy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + Rzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + Rxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + Rxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + Ryz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO + +! now prepare to get physical second kind of connection + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + +! covariant second derivatives of the lapse respect to physical metric + call fdderivs_shc(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz + fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz + fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz + fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz + fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz + fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz + +! mater content only appears in the right hand side of trK and A_ij which are +! comming now +! store D^i D_i Lap in trK_rhs upto chi + trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) +! Add lapse and S_ij parts to Ricci tensor: + + fxx = alpn1 * (Rxx - EIGHT * PI * Sxx) - fxx + fxy = alpn1 * (Rxy - EIGHT * PI * Sxy) - fxy + fxz = alpn1 * (Rxz - EIGHT * PI * Sxz) - fxz + fyy = alpn1 * (Ryy - EIGHT * PI * Syy) - fyy + fyz = alpn1 * (Ryz - EIGHT * PI * Syz) - fyz + fzz = alpn1 * (Rzz - EIGHT * PI * Szz) - fzz + +! Compute trace-free part (note: chi^-1 and chi cancel!): + + f = F1o3 *( gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) ) + + Axx_rhs = fxx - gxx * f + Ayy_rhs = fyy - gyy * f + Azz_rhs = fzz - gzz * f + Axy_rhs = fxy - gxy * f + Axz_rhs = fxz - gxz * f + Ayz_rhs = fyz - gyz * f + +! Now: store A_il A^l_j into fij: + + fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) + fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) + fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) + fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy *(Axx * Ayy + Axy * Axy) + & + gupxz *(Axx * Ayz + Axz * Axy) + & + gupyz *(Axy * Ayz + Axz * Ayy) + fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy *(Axx * Ayz + Axy * Axz) + & + gupxz *(Axx * Azz + Axz * Axz) + & + gupyz *(Axy * Azz + Axz * Ayz) + fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy *(Axy * Ayz + Ayy * Axz) + & + gupxz *(Axy * Azz + Ayz * Axz) + & + gupyz *(Ayy * Azz + Ayz * Ayz) + + f = chin1 +! store D^i D_i Lap in trK_rhs + trK_rhs = f*trK_rhs + + Axx_rhs = f * Axx_rhs+ alpn1 * (trK * Axx - TWO * fxx) + & + TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx )- & + F2o3 * Axx * div_beta + + Ayy_rhs = f * Ayy_rhs+ alpn1 * (trK * Ayy - TWO * fyy) + & + TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy )- & + F2o3 * Ayy * div_beta + + Azz_rhs = f * Azz_rhs+ alpn1 * (trK * Azz - TWO * fzz) + & + TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz )- & + F2o3 * Azz * div_beta + + Axy_rhs = f * Axy_rhs+ alpn1 *( trK * Axy - TWO * fxy )+ & + Axx * betaxy + Axz * betazy + & + Ayy * betayx + Ayz * betazx + & + F1o3 * Axy * div_beta - Axy * betazz + + Ayz_rhs = f * Ayz_rhs+ alpn1 *( trK * Ayz - TWO * fyz )+ & + Axy * betaxz + Ayy * betayz + & + Axz * betaxy + Azz * betazy + & + F1o3 * Ayz * div_beta - Ayz * betaxx + + Axz_rhs = f * Axz_rhs+ alpn1 *( trK * Axz - TWO * fxz )+ & + Axx * betaxz + Axy * betayz + & + Ayz * betayx + Azz * betazx + & + F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij + +! Compute trace of S_ij + + S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & + TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) + + trK_rhs = - trK_rhs + alpn1 *( F1o3 * trK * trK + & + gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & + FOUR * PI * ( rho + S )) !rhs for trK + +!!!! gauge variable part + + Lap_rhs = -TWO*alpn1*trK + + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term part +!g_ij + call fderivs_shc(ex,dxx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxx_rhs = gxx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gxy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxy_rhs = gxy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gxz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxz_rhs = gxz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dyy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gyy_rhs = gyy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gyz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gyz_rhs = gyz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dzz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gzz_rhs = gzz_rhs + betax*fxx+betay*fxy+betaz*fxz +!A_ij + call fderivs_shc(ex,Axx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axx_rhs = Axx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Axy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axy_rhs = Axy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Axz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axz_rhs = Axz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Ayy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Ayy_rhs = Ayy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Ayz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Ayz_rhs = Ayz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Azz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Azz_rhs = Azz_rhs + betax*fxx+betay*fxy+betaz*fxz +!chi and trK + call fderivs_shc(ex,chi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + chi_rhs = chi_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,trK,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + trK_rhs = trK_rhs + betax*fxx+betay*fxy+betaz*fxz +!Gam^i + call fderivs_shc(ex,Gamx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamx_rhs = Gamx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Gamy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamy_rhs = Gamy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Gamz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamz_rhs = Gamz_rhs + betax*fxx+betay*fxy+betaz*fxz +!gauge variables + call fderivs_shc(ex,Lap,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Lap_rhs = Lap_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betax,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betax_rhs = betax_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betay,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betay_rhs = betay_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betaz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betaz_rhs = betaz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfx_rhs = dtSfx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfy_rhs = dtSfy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfz_rhs = dtSfz_rhs + betax*fxx+betay*fxy+betaz*fxz +#if 1 +!! + call fderivs_shc(ex,Sphi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Sphi_rhs = Sphi_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Spi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Spi_rhs = Spi_rhs + betax*fxx+betay*fxy+betaz*fxz +#endif + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,dxx,gxx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,dyy,gyy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,dzz,gzz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) + + call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) + +#if 1 + call kodis(ex,X,Y,Z,Sphi,Sphi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Spi ,Spi_rhs ,SSS,Symmetry,eps) +#endif + endif + +#if 0 + Sphi_rhs = ZEO + Spi_rhs = ZEO +#endif + + if(co == 0)then +! ham_Res = trR + 2/3 * K^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + ham_Res = gupxx * Rxx + gupyy * Ryy + gupzz * Rzz + & + TWO* ( gupxy * Rxy + gupxz * Rxz + gupyz * Ryz ) + + ham_Res = chin1*ham_Res + F2o3 * trK * trK -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho + +! mov_Res_j = gupkj*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + + call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 +movx_Res = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz +movy_Res = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz +movz_Res = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz + +movx_Res = movx_Res - F2o3*Kx - F8*PI*sx +movy_Res = movy_Res - F2o3*Ky - F8*PI*sy +movz_Res = movz_Res - F2o3*Kz - F8*PI*sz + endif + + gont = 0 + + return + + end function compute_rhs_bssn_escalar_ss +!----------------------------------------------------------------------------- +! +! compute constraint introduced by dynamical equation reduction of fR +! this routine is valid for both box and shell +! +!----------------------------------------------------------------------------- + + subroutine compute_constraint_fr(ex, X, Y, Z, & + chi, trK, rho, Sphi,& + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Sxx,Sxy,Sxz,Syy,Syz,Szz,& + Cons_fr) + + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,rho,Sphi +! physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! matter + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: Sxx,Sxy,Sxz,Syy,Syz,Szz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out):: Cons_fr + +! 4D Ricci scalar + real*8, dimension(ex(1),ex(2),ex(3)) :: RR + real*8,parameter :: ONE=1.d0,THR=3.d0,FOU=4.d0 + real*8 :: PI + + PI = dacos(-ONE) + + call get4ricciscalar(ex, X, Y, Z, & + chi, trK, rho, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Sxx,Sxy,Sxz,Syy,Syz,Szz,& + RR) + call frfprim(ex,RR,Cons_fr) + + Cons_fr = Sphi-dsqrt(THR/PI)/FOU*dlog(Cons_fr) + + return + + end subroutine compute_constraint_fr diff --git a/AMSS_NCKU_source/scalar_class.C b/AMSS_NCKU_source/Scalar/scalar_class.C similarity index 97% rename from AMSS_NCKU_source/scalar_class.C rename to AMSS_NCKU_source/Scalar/scalar_class.C index d0cdec0..986fe18 100644 --- a/AMSS_NCKU_source/scalar_class.C +++ b/AMSS_NCKU_source/Scalar/scalar_class.C @@ -1,1195 +1,1195 @@ - -#ifdef newc -#include -#include -#include -using namespace std; -#else -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "misc.h" -#include "fmisc.h" -#include "Parallel.h" -#include "scalar_class.h" -#include "scalar_rhs.h" -#include "initial_scalar.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" -#include "shellfunctions.h" -#include "parameters.h" - -scalar_class::scalar_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, - int a_levi) : Courant(Couranti), StartTime(StartTimei), TotalTime(TotalTimei), DumpTime(DumpTimei), CheckTime(CheckTimei), AnasTime(AnasTimei), - Symmetry(Symmetryi), checkrun(checkruni), numepss(numepssi), numepsb(numepsbi), - a_lev(a_levi) -{ - int nprocs; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - if (checkrun) - { - } - else - { - PhysTime = StartTime; - } - // setup Monitors - { - stringstream a_stream; - a_stream.setf(ios::left); - a_stream << "# Error log information"; - ErrorMonitor = new monitor("Error.log", myrank, a_stream.str()); - } - - trfls = 0; - // read parameter from file - { - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "SCALAR" && skey == "time refinement start from level") - trfls = atoi(sval.c_str()); - } - inf.close(); - } - // echo read-in information - if (myrank == 0) - { - cout << "time refinement start from level #" << trfls << endl; - } - - strcpy(checkfilename, checkfilenamei); - - int ngfs = 0; - Sphio = new var("Sphio", ngfs++, 1, 1, 1); - Spio = new var("Spio", ngfs++, 1, 1, 1); - Sphi0 = new var("Sphi0", ngfs++, 1, 1, 1); - Spi0 = new var("Spi0", ngfs++, 1, 1, 1); - Sphi = new var("Sphi", ngfs++, 1, 1, 1); - Spi = new var("Spi", ngfs++, 1, 1, 1); - Sphi1 = new var("Sphi1", ngfs++, 1, 1, 1); - Spi1 = new var("Spi1", ngfs++, 1, 1, 1); - Sphi_rhs = new var("Sphi_rhs", ngfs++, 1, 1, 1); - Spi_rhs = new var("Spi_rhs", ngfs++, 1, 1, 1); - - if (myrank == 0) - cout << "you have setted " << ngfs << " grid functions." << endl; - - OldStateList = new MyList(Sphio); - OldStateList->insert(Spio); - - StateList = new MyList(Sphi0); - StateList->insert(Spi0); - - RHSList = new MyList(Sphi_rhs); - RHSList->insert(Spi_rhs); - - SynchList_pre = new MyList(Sphi); - SynchList_pre->insert(Spi); - - SynchList_cor = new MyList(Sphi1); - SynchList_cor->insert(Spi1); - - DumpList = new MyList(Sphi0); - DumpList->insert(Spi0); - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); - GH->compose_cgh(nprocs); -#ifdef WithShell - SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); - SH->matchcheck(GH->PatL[0]); - SH->compose_sh(nprocs); - // SH->compose_shr(nprocs); //sh is faster than shr - SH->setupcordtrans(); - SH->Dump_xyz(0, 0, 1); - SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); -#else - SH = 0; -#endif - - double h = GH->PatL[0]->data->blb->data->getdX(0); - for (int i = 1; i < dim; i++) - h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); - dT = Courant * h; -} -scalar_class::~scalar_class() -{ - StateList->clearList(); - RHSList->clearList(); - OldStateList->clearList(); - SynchList_pre->clearList(); - SynchList_cor->clearList(); - DumpList->clearList(); - - delete Sphio; - delete Spio; - delete Sphi0; - delete Spi0; - delete Sphi; - delete Spi; - delete Sphi1; - delete Spi1; - delete Sphi_rhs; - delete Spi_rhs; - - delete GH; -#ifdef WithShell - delete SH; -#endif - - delete ErrorMonitor; -} -void scalar_class::Setup_Initial_Data() -{ - if (checkrun) - { - } - else - { - char filename[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - double R0, WD, A; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "Can not open parameter file " << filename << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "SCALAR") - { - if (skey == "center of Gauss") - R0 = atof(sval.c_str()); - else if (skey == "width of Gauss") - WD = atof(sval.c_str()); - else if (skey == "amplitude of Gauss") - A = atof(sval.c_str()); - } - } - inf.close(); - } - // echo read-in information - if (myrank == 0) - { - cout << "Setup initial scalar with Gauss profile " << A << "*exp[-(r-" << R0 << ")^2/2/" << WD << "^2]" << endl; - } - // set initial data - for (int lev = 0; lev < GH->levels; lev++) - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_scalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], R0, WD, A); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } - } - - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT); -#ifdef WithShell - // ShellPatch part - MyList *Pp = SH->PatL; - while (Pp) - { - MyList *BL = Pp->data->blb; - while (BL) - { - Block *cg = BL->data; - if (myrank == cg->rank) - { - f_get_initial_scalar_sh(cg->shape, cg->fgfs[Pp->data->fngfs + ShellPatch::gx], cg->fgfs[Pp->data->fngfs + ShellPatch::gy], - cg->fgfs[Pp->data->fngfs + ShellPatch::gz], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], R0, WD, A); - } - if (BL == Pp->data->ble) - break; - BL = BL->next; - } - Pp = Pp->next; - } -// dump read_in initial data -// SH->Synch(GH->PatL[0],StateList,Symmetry); -// for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); -// SH->Dump_Data(StateList,0,PhysTime,dT); -// exit(0); -#endif - } -} -void scalar_class::Evolve(int Steps) -{ - clock_t prev_clock, curr_clock; - double LastDump = 0.0, LastCheck = 0.0; - LastAnas = 0; - - double dT_mon = dT * pow(0.5, Mymax(0, trfls)); - - for (int ncount = 1; ncount < Steps + 1; ncount++) - { - if (myrank == 0) - curr_clock = clock(); - RecursiveStep(0); - - LastDump += dT_mon; - LastCheck += dT_mon; - - if (LastDump >= DumpTime) - { - for (int lev = 0; lev < GH->levels; lev++) - Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT_mon); -#ifdef WithShell - SH->Dump_Data(DumpList, 0, PhysTime, dT_mon); -#endif - LastDump = 0; - } - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Timestep # " << ncount << ": integrating to time: " << PhysTime - << " Computer used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - if (PhysTime >= TotalTime) - break; - } -} -void scalar_class::RecursiveStep(int lev) -{ - int NoIterations = 1, YN; - if (lev <= trfls) - NoIterations = 1; - else - NoIterations = 2; - - for (int i = 0; i < NoIterations; i++) - { - // if(myrank==0) cout<<"level now = "<bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[Sphi0->sgfn], - cg->fgfs[Spi0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // if(lev==1) Parallel::Dump_Data(GH->PatL[lev],RHSList,0,PhysTime,dT_lev); - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (f_compute_rhs_scalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - Symmetry, lev, ndeps, sPp->data->sst)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - } -#endif - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - if (LastAnas >= AnasTime) - { - - LastAnas = 0; - } - LastAnas += dT_lev; - } - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (f_compute_rhs_scalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], - cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], - Symmetry, lev, ndeps)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[Sphi0->sgfn], - cg->fgfs[Spi0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (f_compute_rhs_scalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], - cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], - Symmetry, lev, ndeps, sPp->data->sst)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - } -#endif - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - } - } - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - } -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif -} -#else -// for check, using Euler method -void scalar_class::Step(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (f_compute_rhs_scalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - Symmetry, lev, ndeps)) - { - cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_euler_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn]); - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, cg->fgfs[Sphi0->sgfn], - cg->fgfs[Spi0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, - Symmetry, cor); - - varl0 = varl0->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // if(lev==1) Parallel::Dump_Data(GH->PatL[lev],RHSList,0,PhysTime,dT_lev); - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - if (f_compute_rhs_scalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], - cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], - Symmetry, lev, ndeps, sPp->data->sst)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // euler step and boundary - { - MyList *varl0 = StateList, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_euler_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn]); - - varl0 = varl0->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - } -#endif - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; - } - } -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif -} -#endif -void scalar_class::RestrictProlong(int lev, int YN, bool BB) -{ - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, Symmetry); - - Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); - - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); - Pp = Pp->next; - } - Ppc = Ppc->next; - } - } - else // no time refinement levels and for all same time levels - { - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); - - Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); - - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); - Pp = Pp->next; - } - Ppc = Ppc->next; - } - } - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - } -} -void scalar_class::ProlongRestrict(int lev, int YN, bool BB) -{ - if (lev > 0) - { - MyList *Pp, *Ppc; - if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level - { - Pp = GH->PatL[lev - 1]; - while (Pp) - { - if (BB) - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - else - Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, - SynchList_pre, 0); // use SynchList_pre as temporal storage space - Pp = Pp->next; - } - - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); - Pp = Pp->next; - } - Ppc = Ppc->next; - } - } - else // no time refinement levels and for all same time levels - { - Ppc = GH->PatL[lev - 1]; - while (Ppc) - { - Pp = GH->PatL[lev]; - while (Pp) - { - Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); - Pp = Pp->next; - } - Ppc = Ppc->next; - } - - Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); - - Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); - } - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - } -} + +#ifdef newc +#include +#include +#include +using namespace std; +#else +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "misc.h" +#include "fmisc.h" +#include "Parallel.h" +#include "scalar_class.h" +#include "scalar_rhs.h" +#include "initial_scalar.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" +#include "shellfunctions.h" +#include "parameters.h" + +scalar_class::scalar_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, + int a_levi) : Courant(Couranti), StartTime(StartTimei), TotalTime(TotalTimei), DumpTime(DumpTimei), CheckTime(CheckTimei), AnasTime(AnasTimei), + Symmetry(Symmetryi), checkrun(checkruni), numepss(numepssi), numepsb(numepsbi), + a_lev(a_levi) +{ + int nprocs; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + if (checkrun) + { + } + else + { + PhysTime = StartTime; + } + // setup Monitors + { + stringstream a_stream; + a_stream.setf(ios::left); + a_stream << "# Error log information"; + ErrorMonitor = new monitor("Error.log", myrank, a_stream.str()); + } + + trfls = 0; + // read parameter from file + { + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "SCALAR" && skey == "time refinement start from level") + trfls = atoi(sval.c_str()); + } + inf.close(); + } + // echo read-in information + if (myrank == 0) + { + cout << "time refinement start from level #" << trfls << endl; + } + + strcpy(checkfilename, checkfilenamei); + + int ngfs = 0; + Sphio = new var("Sphio", ngfs++, 1, 1, 1); + Spio = new var("Spio", ngfs++, 1, 1, 1); + Sphi0 = new var("Sphi0", ngfs++, 1, 1, 1); + Spi0 = new var("Spi0", ngfs++, 1, 1, 1); + Sphi = new var("Sphi", ngfs++, 1, 1, 1); + Spi = new var("Spi", ngfs++, 1, 1, 1); + Sphi1 = new var("Sphi1", ngfs++, 1, 1, 1); + Spi1 = new var("Spi1", ngfs++, 1, 1, 1); + Sphi_rhs = new var("Sphi_rhs", ngfs++, 1, 1, 1); + Spi_rhs = new var("Spi_rhs", ngfs++, 1, 1, 1); + + if (myrank == 0) + cout << "you have setted " << ngfs << " grid functions." << endl; + + OldStateList = new MyList(Sphio); + OldStateList->insert(Spio); + + StateList = new MyList(Sphi0); + StateList->insert(Spi0); + + RHSList = new MyList(Sphi_rhs); + RHSList->insert(Spi_rhs); + + SynchList_pre = new MyList(Sphi); + SynchList_pre->insert(Spi); + + SynchList_cor = new MyList(Sphi1); + SynchList_cor->insert(Spi1); + + DumpList = new MyList(Sphi0); + DumpList->insert(Spi0); + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); + GH->compose_cgh(nprocs); +#ifdef WithShell + SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); + SH->matchcheck(GH->PatL[0]); + SH->compose_sh(nprocs); + // SH->compose_shr(nprocs); //sh is faster than shr + SH->setupcordtrans(); + SH->Dump_xyz(0, 0, 1); + SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); +#else + SH = 0; +#endif + + double h = GH->PatL[0]->data->blb->data->getdX(0); + for (int i = 1; i < dim; i++) + h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); + dT = Courant * h; +} +scalar_class::~scalar_class() +{ + StateList->clearList(); + RHSList->clearList(); + OldStateList->clearList(); + SynchList_pre->clearList(); + SynchList_cor->clearList(); + DumpList->clearList(); + + delete Sphio; + delete Spio; + delete Sphi0; + delete Spi0; + delete Sphi; + delete Spi; + delete Sphi1; + delete Spi1; + delete Sphi_rhs; + delete Spi_rhs; + + delete GH; +#ifdef WithShell + delete SH; +#endif + + delete ErrorMonitor; +} +void scalar_class::Setup_Initial_Data() +{ + if (checkrun) + { + } + else + { + char filename[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + double R0, WD, A; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "Can not open parameter file " << filename << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "SCALAR") + { + if (skey == "center of Gauss") + R0 = atof(sval.c_str()); + else if (skey == "width of Gauss") + WD = atof(sval.c_str()); + else if (skey == "amplitude of Gauss") + A = atof(sval.c_str()); + } + } + inf.close(); + } + // echo read-in information + if (myrank == 0) + { + cout << "Setup initial scalar with Gauss profile " << A << "*exp[-(r-" << R0 << ")^2/2/" << WD << "^2]" << endl; + } + // set initial data + for (int lev = 0; lev < GH->levels; lev++) + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_scalar(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], R0, WD, A); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } + } + + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT); +#ifdef WithShell + // ShellPatch part + MyList *Pp = SH->PatL; + while (Pp) + { + MyList *BL = Pp->data->blb; + while (BL) + { + Block *cg = BL->data; + if (myrank == cg->rank) + { + f_get_initial_scalar_sh(cg->shape, cg->fgfs[Pp->data->fngfs + ShellPatch::gx], cg->fgfs[Pp->data->fngfs + ShellPatch::gy], + cg->fgfs[Pp->data->fngfs + ShellPatch::gz], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], R0, WD, A); + } + if (BL == Pp->data->ble) + break; + BL = BL->next; + } + Pp = Pp->next; + } +// dump read_in initial data +// SH->Synch(GH->PatL[0],StateList,Symmetry); +// for(int lev=0;levlevels;lev++) Parallel::Dump_Data(GH->PatL[lev],StateList,0,PhysTime,dT); +// SH->Dump_Data(StateList,0,PhysTime,dT); +// exit(0); +#endif + } +} +void scalar_class::Evolve(int Steps) +{ + clock_t prev_clock, curr_clock; + double LastDump = 0.0, LastCheck = 0.0; + LastAnas = 0; + + double dT_mon = dT * pow(0.5, Mymax(0, trfls)); + + for (int ncount = 1; ncount < Steps + 1; ncount++) + { + if (myrank == 0) + curr_clock = clock(); + RecursiveStep(0); + + LastDump += dT_mon; + LastCheck += dT_mon; + + if (LastDump >= DumpTime) + { + for (int lev = 0; lev < GH->levels; lev++) + Parallel::Dump_Data(GH->PatL[lev], DumpList, 0, PhysTime, dT_mon); +#ifdef WithShell + SH->Dump_Data(DumpList, 0, PhysTime, dT_mon); +#endif + LastDump = 0; + } + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Timestep # " << ncount << ": integrating to time: " << PhysTime + << " Computer used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + if (PhysTime >= TotalTime) + break; + } +} +void scalar_class::RecursiveStep(int lev) +{ + int NoIterations = 1, YN; + if (lev <= trfls) + NoIterations = 1; + else + NoIterations = 2; + + for (int i = 0; i < NoIterations; i++) + { + // if(myrank==0) cout<<"level now = "<bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[Sphi0->sgfn], + cg->fgfs[Spi0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // if(lev==1) Parallel::Dump_Data(GH->PatL[lev],RHSList,0,PhysTime,dT_lev); + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (f_compute_rhs_scalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + Symmetry, lev, ndeps, sPp->data->sst)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + } +#endif + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + if (LastAnas >= AnasTime) + { + + LastAnas = 0; + } + LastAnas += dT_lev; + } + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (f_compute_rhs_scalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], + cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], + Symmetry, lev, ndeps)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[Sphi0->sgfn], + cg->fgfs[Spi0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count << " variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (f_compute_rhs_scalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[Sphi->sgfn], cg->fgfs[Spi->sgfn], + cg->fgfs[Sphi1->sgfn], cg->fgfs[Spi1->sgfn], + Symmetry, lev, ndeps, sPp->data->sst)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + } +#endif + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + } + } + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + } +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif +} +#else +// for check, using Euler method +void scalar_class::Step(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (f_compute_rhs_scalar(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + Symmetry, lev, ndeps)) + { + cout << "find NaN in domain: (" << cg->bbox[0] << ":" << cg->bbox[3] << "," << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_euler_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn]); + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, cg->fgfs[Sphi0->sgfn], + cg->fgfs[Spi0->sgfn], cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], varl0->data->SoA, + Symmetry, cor); + + varl0 = varl0->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // if(lev==1) Parallel::Dump_Data(GH->PatL[lev],RHSList,0,PhysTime,dT_lev); + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + if (f_compute_rhs_scalar_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[Sphi0->sgfn], cg->fgfs[Spi0->sgfn], + cg->fgfs[Sphi_rhs->sgfn], cg->fgfs[Spi_rhs->sgfn], + Symmetry, lev, ndeps, sPp->data->sst)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // euler step and boundary + { + MyList *varl0 = StateList, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl0->data->sgfn], varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_euler_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn]); + + varl0 = varl0->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + } +#endif + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) << " seconds! " << endl; + } + } +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif +} +#endif +void scalar_class::RestrictProlong(int lev, int YN, bool BB) +{ + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, SynchList_pre, Symmetry); + + Parallel::Sync(GH->PatL[lev - 1], SynchList_pre, Symmetry); + + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); + Pp = Pp->next; + } + Ppc = Ppc->next; + } + } + else // no time refinement levels and for all same time levels + { + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); + + Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); + + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); + Pp = Pp->next; + } + Ppc = Ppc->next; + } + } + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + } +} +void scalar_class::ProlongRestrict(int lev, int YN, bool BB) +{ + if (lev > 0) + { + MyList *Pp, *Ppc; + if (lev > trfls && YN == 0) // time refinement levels and for intermediat time level + { + Pp = GH->PatL[lev - 1]; + while (Pp) + { + if (BB) + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, SynchList_cor, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + else + Parallel::prepare_inter_time_level(Pp->data, StateList, OldStateList, + SynchList_pre, 0); // use SynchList_pre as temporal storage space + Pp = Pp->next; + } + + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, SynchList_pre, SynchList_cor, Symmetry); + Pp = Pp->next; + } + Ppc = Ppc->next; + } + } + else // no time refinement levels and for all same time levels + { + Ppc = GH->PatL[lev - 1]; + while (Ppc) + { + Pp = GH->PatL[lev]; + while (Pp) + { + Parallel::OutBdLow2Hi(Ppc->data, Pp->data, StateList, SynchList_cor, Symmetry); + Pp = Pp->next; + } + Ppc = Ppc->next; + } + + Parallel::Restrict(GH->PatL[lev - 1], GH->PatL[lev], SynchList_cor, StateList, Symmetry); + + Parallel::Sync(GH->PatL[lev - 1], StateList, Symmetry); + } + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + } +} diff --git a/AMSS_NCKU_source/scalar_class.h b/AMSS_NCKU_source/Scalar/scalar_class.h similarity index 95% rename from AMSS_NCKU_source/scalar_class.h rename to AMSS_NCKU_source/Scalar/scalar_class.h index aab5aa4..1f949b3 100644 --- a/AMSS_NCKU_source/scalar_class.h +++ b/AMSS_NCKU_source/Scalar/scalar_class.h @@ -1,75 +1,75 @@ - -#ifndef SCALAR_CLASS_H -#define SCALAR_CLASS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "cgh.h" -#include "ShellPatch.h" -#include "misc.h" -#include "var.h" -#include "MyList.h" -#include "monitor.h" - -class scalar_class -{ -protected: - int myrank; - cgh *GH; - ShellPatch *SH; - double PhysTime; - - int checkrun; - char checkfilename[50]; - int Steps; - double StartTime, TotalTime; - double AnasTime, DumpTime, CheckTime; - double LastAnas; - double Courant; - double numepss, numepsb; - int Symmetry; - int trfls, a_lev; - - double dT; - - var *Sphio, *Spio; - var *Sphi0, *Spi0; - var *Sphi, *Spi; - var *Sphi1, *Spi1; - var *Sphi_rhs, *Spi_rhs; - - MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; - MyList *OldStateList, *DumpList, *CheckList; - - monitor *ErrorMonitor; - -public: - scalar_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, - int a_levi); - ~scalar_class(); - void Setup_Initial_Data(); - void Evolve(int Steps); - void RecursiveStep(int lev); - void Step(int lev, int YN); - void RestrictProlong(int lev, int YN, bool BB); - void ProlongRestrict(int lev, int YN, bool BB); -}; -#endif /* SCALAR_CLASS_H */ + +#ifndef SCALAR_CLASS_H +#define SCALAR_CLASS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "cgh.h" +#include "ShellPatch.h" +#include "misc.h" +#include "var.h" +#include "MyList.h" +#include "monitor.h" + +class scalar_class +{ +protected: + int myrank; + cgh *GH; + ShellPatch *SH; + double PhysTime; + + int checkrun; + char checkfilename[50]; + int Steps; + double StartTime, TotalTime; + double AnasTime, DumpTime, CheckTime; + double LastAnas; + double Courant; + double numepss, numepsb; + int Symmetry; + int trfls, a_lev; + + double dT; + + var *Sphio, *Spio; + var *Sphi0, *Spi0; + var *Sphi, *Spi; + var *Sphi1, *Spi1; + var *Sphi_rhs, *Spi_rhs; + + MyList *StateList, *SynchList_pre, *SynchList_cor, *RHSList; + MyList *OldStateList, *DumpList, *CheckList; + + monitor *ErrorMonitor; + +public: + scalar_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, + int a_levi); + ~scalar_class(); + void Setup_Initial_Data(); + void Evolve(int Steps); + void RecursiveStep(int lev); + void Step(int lev, int YN); + void RestrictProlong(int lev, int YN, bool BB); + void ProlongRestrict(int lev, int YN, bool BB); +}; +#endif /* SCALAR_CLASS_H */ diff --git a/AMSS_NCKU_source/scalar_rhs.f90 b/AMSS_NCKU_source/Scalar/scalar_rhs.f90 similarity index 97% rename from AMSS_NCKU_source/scalar_rhs.f90 rename to AMSS_NCKU_source/Scalar/scalar_rhs.f90 index 43c5e2f..cbccf81 100644 --- a/AMSS_NCKU_source/scalar_rhs.f90 +++ b/AMSS_NCKU_source/Scalar/scalar_rhs.f90 @@ -1,155 +1,155 @@ - -! PIN==0: standard scalar wave -! PIN==1: \block phi = \eta(dphi,dphi) -#define PIN 0 - - function compute_rhs_scalar(ex, T, X, Y, Z, & - Sphi,Spi,Sphi_rhs,Spi_rhs, & - Symmetry,Lev,eps) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev - real*8, intent(in ):: T,X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: fxx,fxy,fxz,fyy,fyz,fzz - real*8,dimension(3) ::SSS - real*8, parameter :: HALF = 0.5d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: tt - -!!! sanity check - tt = sum(Sphi)+sum(Spi) - if(tt.ne.tt) then - if(sum(Sphi).ne.sum(Sphi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar find NaN in Sphi" - if(sum(Spi).ne.sum(Spi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar find NaN in Spi" - gont = 1 - return - endif - - Sphi_rhs = Spi !rhs for phi - -#if (PIN == 0) - call fdderivs(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - Spi_rhs = fxx + fyy + fzz -#elif (PIN == 1) - call fdderivs(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - Spi_rhs = Spi*Spi + fxx + fyy + fzz - call fderivs(ex,Sphi,fxx,fyy,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - Spi_rhs = Spi_rhs - (fxx*fxx+fyy*fyy+fzz*fzz) -#endif - if(eps>0)then -! usual Kreiss-Oliger dissipation - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - call kodis(ex,X,Y,Z,Sphi,Sphi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Spi,Spi_rhs,SSS,Symmetry,eps) - endif - - gont = 0 - - return - - end function compute_rhs_scalar -! for shell - function compute_rhs_scalar_ss(ex, T,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - Sphi,Spi,Sphi_rhs,Spi_rhs, & - Symmetry,Lev,eps,sst) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst - real*8, intent(in ):: T - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: fxx,fxy,fxz,fyy,fyz,fzz - real*8,dimension(3) ::SSS - real*8, parameter :: HALF = 0.5d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8 :: tt - -!!! sanity check - tt = sum(Sphi)+sum(Spi) - if(tt.ne.tt) then - if(sum(Sphi).ne.sum(Sphi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar_ss find NaN in Sphi" - if(sum(Spi).ne.sum(Spi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar_ss find NaN in Spi" - gont = 1 - return - endif - - Sphi_rhs = Spi !rhs for phi - -#if (PIN == 0) - call fdderivs_shc(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - Spi_rhs = fxx+fyy+fzz -#elif (PIN == 1) - call fdderivs_shc(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - Spi_rhs = Spi*Spi + fxx + fyy + fzz - call fderivs_shc(ex,Sphi,fxx,fyy,fzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Spi_rhs = Spi_rhs - (fxx*fxx+fyy*fyy+fzz*fzz) -#endif - - if(eps>0)then -! usual Kreiss-Oliger dissipation - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - call kodis_sh(ex,crho,sigma,R,Sphi,Sphi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Spi,Spi_rhs,SSS,Symmetry,eps,sst) - endif - - gont = 0 - - return - - end function compute_rhs_scalar_ss + +! PIN==0: standard scalar wave +! PIN==1: \block phi = \eta(dphi,dphi) +#define PIN 0 + + function compute_rhs_scalar(ex, T, X, Y, Z, & + Sphi,Spi,Sphi_rhs,Spi_rhs, & + Symmetry,Lev,eps) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev + real*8, intent(in ):: T,X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: fxx,fxy,fxz,fyy,fyz,fzz + real*8,dimension(3) ::SSS + real*8, parameter :: HALF = 0.5d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: tt + +!!! sanity check + tt = sum(Sphi)+sum(Spi) + if(tt.ne.tt) then + if(sum(Sphi).ne.sum(Sphi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar find NaN in Sphi" + if(sum(Spi).ne.sum(Spi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar find NaN in Spi" + gont = 1 + return + endif + + Sphi_rhs = Spi !rhs for phi + +#if (PIN == 0) + call fdderivs(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + Spi_rhs = fxx + fyy + fzz +#elif (PIN == 1) + call fdderivs(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + Spi_rhs = Spi*Spi + fxx + fyy + fzz + call fderivs(ex,Sphi,fxx,fyy,fzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + Spi_rhs = Spi_rhs - (fxx*fxx+fyy*fyy+fzz*fzz) +#endif + if(eps>0)then +! usual Kreiss-Oliger dissipation + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + call kodis(ex,X,Y,Z,Sphi,Sphi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Spi,Spi_rhs,SSS,Symmetry,eps) + endif + + gont = 0 + + return + + end function compute_rhs_scalar +! for shell + function compute_rhs_scalar_ss(ex, T,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + Sphi,Spi,Sphi_rhs,Spi_rhs, & + Symmetry,Lev,eps,sst) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst + real*8, intent(in ):: T + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sphi,Spi + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Sphi_rhs,Spi_rhs + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: fxx,fxy,fxz,fyy,fyz,fzz + real*8,dimension(3) ::SSS + real*8, parameter :: HALF = 0.5d0, ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8 :: tt + +!!! sanity check + tt = sum(Sphi)+sum(Spi) + if(tt.ne.tt) then + if(sum(Sphi).ne.sum(Sphi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar_ss find NaN in Sphi" + if(sum(Spi).ne.sum(Spi))write(*,*)"scalar_rhs.f90:compute_rhs_scalar_ss find NaN in Spi" + gont = 1 + return + endif + + Sphi_rhs = Spi !rhs for phi + +#if (PIN == 0) + call fdderivs_shc(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + Spi_rhs = fxx+fyy+fzz +#elif (PIN == 1) + call fdderivs_shc(ex,Sphi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + Spi_rhs = Spi*Spi + fxx + fyy + fzz + call fderivs_shc(ex,Sphi,fxx,fyy,fzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Spi_rhs = Spi_rhs - (fxx*fxx+fyy*fyy+fzz*fzz) +#endif + + if(eps>0)then +! usual Kreiss-Oliger dissipation + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + call kodis_sh(ex,crho,sigma,R,Sphi,Sphi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Spi,Spi_rhs,SSS,Symmetry,eps,sst) + endif + + gont = 0 + + return + + end function compute_rhs_scalar_ss diff --git a/AMSS_NCKU_source/scalar_rhs.h b/AMSS_NCKU_source/Scalar/scalar_rhs.h similarity index 97% rename from AMSS_NCKU_source/scalar_rhs.h rename to AMSS_NCKU_source/Scalar/scalar_rhs.h index 492d137..e27b9e3 100644 --- a/AMSS_NCKU_source/scalar_rhs.h +++ b/AMSS_NCKU_source/Scalar/scalar_rhs.h @@ -1,39 +1,39 @@ - -#ifndef SCALAR_RHS_H -#define SCALAR_RHS_H - -#ifdef fortran1 -#define f_compute_rhs_scalar compute_rhs_scalar -#define f_compute_rhs_scalar_ss compute_rhs_scalar_ss -#endif -#ifdef fortran2 -#define f_compute_rhs_scalar COMPUTE_RHS_SCALAR -#define f_compute_rhs_scalar_ss COMPUTE_RHS_SCALAR_SS -#endif -#ifdef fortran3 -#define f_compute_rhs_scalar compute_rhs_scalar_ -#define f_compute_rhs_scalar_ss compute_rhs_scalar_ss_ -#endif -extern "C" -{ - int f_compute_rhs_scalar(int *, double &, double *, double *, double *, // ex,T,X,Y,Z - double *, double *, // Sphi,Spi - double *, double *, // Sphi_rhs,Spi_rhs - int &, int &, double &); -} - -extern "C" -{ - int f_compute_rhs_scalar_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R - double *, double *, double *, // X,Y,Z - double *, double *, double *, // drhodx,drhody,drhodz - double *, double *, double *, // dsigmadx,dsigmady,dsigmadz - double *, double *, double *, // dRdx,dRdy,dRdz - double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double *, double *, // Sphi,Spi - double *, double *, // Sphi_rhs,Spi_rhs - int &, int &, double &, int &); -} -#endif /* SCALAR_RHS_H */ + +#ifndef SCALAR_RHS_H +#define SCALAR_RHS_H + +#ifdef fortran1 +#define f_compute_rhs_scalar compute_rhs_scalar +#define f_compute_rhs_scalar_ss compute_rhs_scalar_ss +#endif +#ifdef fortran2 +#define f_compute_rhs_scalar COMPUTE_RHS_SCALAR +#define f_compute_rhs_scalar_ss COMPUTE_RHS_SCALAR_SS +#endif +#ifdef fortran3 +#define f_compute_rhs_scalar compute_rhs_scalar_ +#define f_compute_rhs_scalar_ss compute_rhs_scalar_ss_ +#endif +extern "C" +{ + int f_compute_rhs_scalar(int *, double &, double *, double *, double *, // ex,T,X,Y,Z + double *, double *, // Sphi,Spi + double *, double *, // Sphi_rhs,Spi_rhs + int &, int &, double &); +} + +extern "C" +{ + int f_compute_rhs_scalar_ss(int *, double &, double *, double *, double *, // ex,T,rho,sigma,R + double *, double *, double *, // X,Y,Z + double *, double *, double *, // drhodx,drhody,drhodz + double *, double *, double *, // dsigmadx,dsigmady,dsigmadz + double *, double *, double *, // dRdx,dRdy,dRdz + double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double *, double *, // Sphi,Spi + double *, double *, // Sphi_rhs,Spi_rhs + int &, int &, double &, int &); +} +#endif /* SCALAR_RHS_H */ diff --git a/AMSS_NCKU_source/scalarwaves.C b/AMSS_NCKU_source/Scalar/scalarwaves.C similarity index 96% rename from AMSS_NCKU_source/scalarwaves.C rename to AMSS_NCKU_source/Scalar/scalarwaves.C index 9f465d9..3ba7827 100644 --- a/AMSS_NCKU_source/scalarwaves.C +++ b/AMSS_NCKU_source/Scalar/scalarwaves.C @@ -1,213 +1,213 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "misc.h" -#include "microdef.h" -#include "scalar_class.h" - -//======================================= -int main(int argc, char *argv[]) -{ - int myrank = 0, nprocs = 1; - MPI_Init(&argc, &argv); - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int checkrun; - char checkfilename[50]; - int Steps; - double StartTime, TotalTime; - double AnasTime, DumpTime, d2DumpTime, CheckTime; - double Courant; - double numepss, numepsb, numepsh; - int Symmetry; - int a_lev, maxl, decn; - double maxrex, drex; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "checkrun") - checkrun = atoi(sval.c_str()); - else if (skey == "checkfile") - strcpy(checkfilename, sval.c_str()); - else if (skey == "Steps") - Steps = atoi(sval.c_str()); - else if (skey == "StartTime") - StartTime = atof(sval.c_str()); - else if (skey == "TotalTime") - TotalTime = atof(sval.c_str()); - else if (skey == "DumpTime") - DumpTime = atof(sval.c_str()); - else if (skey == "d2DumpTime") - d2DumpTime = atof(sval.c_str()); - else if (skey == "CheckTime") - CheckTime = atof(sval.c_str()); - else if (skey == "AnalysisTime") - AnasTime = atof(sval.c_str()); - else if (skey == "Courant") - Courant = atof(sval.c_str()); - else if (skey == "Symmetry") - Symmetry = atoi(sval.c_str()); - else if (skey == "small dissipation") - numepss = atof(sval.c_str()); - else if (skey == "big dissipation") - numepsb = atof(sval.c_str()); - else if (skey == "shell dissipation") - numepsh = atof(sval.c_str()); - else if (skey == "Analysis Level") - a_lev = atoi(sval.c_str()); - else if (skey == "Max mode l") - maxl = atoi(sval.c_str()); - else if (skey == "detector number") - decn = atoi(sval.c_str()); - else if (skey == "farest detector position") - maxrex = atof(sval.c_str()); - else if (skey == "detector distance") - drex = atof(sval.c_str()); - } - } - inf.close(); - } - // echo parameters - if (myrank == 0) - { - cout << "///////////////////////////////////////////////////////////////" << endl; -#ifdef Cell - cout << "Cell center numerical grid structure" << endl; -#endif -#ifdef Vertex - cout << "Vertex center numerical grid structure" << endl; -#endif - if (checkrun) - cout << " checked run" << endl; - else - cout << " new run" << endl; - cout << " simulation with cpu numbers = " << nprocs << endl; - cout << " simulation time = (" << StartTime << ", " << TotalTime << ")" << endl; - cout << "simulation steps for this run = " << Steps << endl; - cout << " Courant number = " << Courant << endl; - cout << " ghost zone = " << ghost_width << endl; - cout << " buffer zone = " << buffer_width << endl; - switch (Symmetry) - { - case 0: - cout << " Symmetry setting: No_Symmetry" << endl; - break; - case 1: - cout << " Symmetry setting: Equatorial" << endl; - break; - case 2: - cout << " Symmetry setting: Octant" << endl; - break; - default: - cout << "OOOOps, not supported Symmetry setting!" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - cout << "Courant = " << Courant << endl; - cout << "artificial dissipation for shell patches = " << numepsh << endl; - cout << "artificial dissipation for fixed levels = " << numepsb << endl; - cout << "artificial dissipation for moving levels = " << numepss << endl; - cout << "Dumpt Time = " << DumpTime << endl; - cout << "Check Time = " << CheckTime << endl; - cout << "Analysis Time = " << AnasTime << endl; - cout << "Analysis level = " << a_lev << endl; - cout << "checkfile = " << checkfilename << endl; - switch (ghost_width) - { - case 2: - cout << "second order finite difference is used" << endl; - break; - case 3: - cout << "fourth order finite difference is used" << endl; - break; - case 4: - cout << "sixth order finite difference is used" << endl; - break; - case 5: - cout << "eighth order finite difference is used" << endl; - break; - default: - cout << "Why are you using ghost width = " << ghost_width << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - cout << "///////////////////////////////////////////////////////////////" << endl; - } - //===========================the computation body==================================================== - scalar_class *ADM; - - ADM = new scalar_class(Courant, StartTime, TotalTime, DumpTime, CheckTime, AnasTime, - Symmetry, checkrun, checkfilename, numepss, numepsb, - a_lev); - - ADM->Setup_Initial_Data(); - - ADM->Evolve(Steps); - - delete ADM; - //=======================caculation done============================================================= - if (myrank == 0) - cout << "===============================================================" << endl; - if (myrank == 0) - cout << "Simulation is successfully done!!" << endl; - MPI_Finalize(); - - exit(0); -} + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "misc.h" +#include "microdef.h" +#include "scalar_class.h" + +//======================================= +int main(int argc, char *argv[]) +{ + int myrank = 0, nprocs = 1; + MPI_Init(&argc, &argv); + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int checkrun; + char checkfilename[50]; + int Steps; + double StartTime, TotalTime; + double AnasTime, DumpTime, d2DumpTime, CheckTime; + double Courant; + double numepss, numepsb, numepsh; + int Symmetry; + int a_lev, maxl, decn; + double maxrex, drex; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "checkrun") + checkrun = atoi(sval.c_str()); + else if (skey == "checkfile") + strcpy(checkfilename, sval.c_str()); + else if (skey == "Steps") + Steps = atoi(sval.c_str()); + else if (skey == "StartTime") + StartTime = atof(sval.c_str()); + else if (skey == "TotalTime") + TotalTime = atof(sval.c_str()); + else if (skey == "DumpTime") + DumpTime = atof(sval.c_str()); + else if (skey == "d2DumpTime") + d2DumpTime = atof(sval.c_str()); + else if (skey == "CheckTime") + CheckTime = atof(sval.c_str()); + else if (skey == "AnalysisTime") + AnasTime = atof(sval.c_str()); + else if (skey == "Courant") + Courant = atof(sval.c_str()); + else if (skey == "Symmetry") + Symmetry = atoi(sval.c_str()); + else if (skey == "small dissipation") + numepss = atof(sval.c_str()); + else if (skey == "big dissipation") + numepsb = atof(sval.c_str()); + else if (skey == "shell dissipation") + numepsh = atof(sval.c_str()); + else if (skey == "Analysis Level") + a_lev = atoi(sval.c_str()); + else if (skey == "Max mode l") + maxl = atoi(sval.c_str()); + else if (skey == "detector number") + decn = atoi(sval.c_str()); + else if (skey == "farest detector position") + maxrex = atof(sval.c_str()); + else if (skey == "detector distance") + drex = atof(sval.c_str()); + } + } + inf.close(); + } + // echo parameters + if (myrank == 0) + { + cout << "///////////////////////////////////////////////////////////////" << endl; +#ifdef Cell + cout << "Cell center numerical grid structure" << endl; +#endif +#ifdef Vertex + cout << "Vertex center numerical grid structure" << endl; +#endif + if (checkrun) + cout << " checked run" << endl; + else + cout << " new run" << endl; + cout << " simulation with cpu numbers = " << nprocs << endl; + cout << " simulation time = (" << StartTime << ", " << TotalTime << ")" << endl; + cout << "simulation steps for this run = " << Steps << endl; + cout << " Courant number = " << Courant << endl; + cout << " ghost zone = " << ghost_width << endl; + cout << " buffer zone = " << buffer_width << endl; + switch (Symmetry) + { + case 0: + cout << " Symmetry setting: No_Symmetry" << endl; + break; + case 1: + cout << " Symmetry setting: Equatorial" << endl; + break; + case 2: + cout << " Symmetry setting: Octant" << endl; + break; + default: + cout << "OOOOps, not supported Symmetry setting!" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + cout << "Courant = " << Courant << endl; + cout << "artificial dissipation for shell patches = " << numepsh << endl; + cout << "artificial dissipation for fixed levels = " << numepsb << endl; + cout << "artificial dissipation for moving levels = " << numepss << endl; + cout << "Dumpt Time = " << DumpTime << endl; + cout << "Check Time = " << CheckTime << endl; + cout << "Analysis Time = " << AnasTime << endl; + cout << "Analysis level = " << a_lev << endl; + cout << "checkfile = " << checkfilename << endl; + switch (ghost_width) + { + case 2: + cout << "second order finite difference is used" << endl; + break; + case 3: + cout << "fourth order finite difference is used" << endl; + break; + case 4: + cout << "sixth order finite difference is used" << endl; + break; + case 5: + cout << "eighth order finite difference is used" << endl; + break; + default: + cout << "Why are you using ghost width = " << ghost_width << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + cout << "///////////////////////////////////////////////////////////////" << endl; + } + //===========================the computation body==================================================== + scalar_class *ADM; + + ADM = new scalar_class(Courant, StartTime, TotalTime, DumpTime, CheckTime, AnasTime, + Symmetry, checkrun, checkfilename, numepss, numepsb, + a_lev); + + ADM->Setup_Initial_Data(); + + ADM->Evolve(Steps); + + delete ADM; + //=======================caculation done============================================================= + if (myrank == 0) + cout << "===============================================================" << endl; + if (myrank == 0) + cout << "Simulation is successfully done!!" << endl; + MPI_Finalize(); + + exit(0); +} diff --git a/AMSS_NCKU_source/ShellPatch.C b/AMSS_NCKU_source/Shell_Patch/ShellPatch.C similarity index 96% rename from AMSS_NCKU_source/ShellPatch.C rename to AMSS_NCKU_source/Shell_Patch/ShellPatch.C index 2f092d5..0b339d7 100644 --- a/AMSS_NCKU_source/ShellPatch.C +++ b/AMSS_NCKU_source/Shell_Patch/ShellPatch.C @@ -1,3474 +1,3474 @@ - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "ShellPatch.h" -#include "Parallel.h" -#include "fmisc.h" -#include "misc.h" -#include "shellfunctions.h" -#include "parameters.h" - -#define PI M_PI - -// x x x x x o * -// * o x x x x x -// each side contribute an overlap points -// so we need half of that -#define overghost ((ghost_width + 1) / 2 + ghost_width) - -ss_patch::ss_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ingfs(ingfsi), fngfs(fngfsi), myrank(myranki), blb(0), ble(0) -{ - for (int i = 0; i < dim; i++) - { - shape[i] = shapei[i]; - bbox[i] = bboxi[i]; - bbox[i + dim] = bboxi[i + dim]; - } -} -ss_patch::~ss_patch() -{ - MyList *bg; - while (blb) - { - if (blb == ble) - break; - bg = (blb->next) ? blb->next : 0; - delete blb->data; - delete blb; - blb = bg; - } - if (ble) - { - delete ble->data; - delete ble; - } - blb = ble = 0; -} -// bulk part for given Block within given patch, without extension -MyList *ss_patch::build_bulk_gsl(Block *bp) -{ - MyList *gs = 0; - - gs = new MyList; - gs->data = new Parallel::gridseg; - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; - gs->data->llb[i] = (feq(bp->bbox[i], bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = bp; - gs->next = 0; - - return gs; -} -// collect all ghost grid segments or blocks for given patch -MyList *ss_patch::build_ghost_gsl() -{ - MyList *cgsl = 0, *gs, *gsb; - MyList *BP = blb; - while (BP) - { - gs = new MyList; - gs->data = new Parallel::gridseg; - - for (int i = 0; i < dim; i++) - { - gs->data->llb[i] = BP->data->bbox[i]; - gs->data->uub[i] = BP->data->bbox[dim + i]; - gs->data->shape[i] = BP->data->shape[i]; - } - gs->data->Bg = BP->data; - gs->next = 0; - - gsb = build_bulk_gsl(BP->data); - - if (!cgsl) - cgsl = Parallel::gs_subtract(gs, gsb); - else - cgsl->catList(Parallel::gs_subtract(gs, gsb)); - - gsb->destroyList(); - gs->destroyList(); - - if (BP == ble) - break; - BP = BP->next; - } - - return cgsl; -} -// collect all grid segments or blocks without ghost for given patch -// special for Sync usage, so we do not need consider missing points -MyList *ss_patch::build_owned_gsl0(int rank_in) -{ - MyList *cgsl = 0, *gs; - MyList *BP = blb; - while (BP) - { - Block *bp = BP->data; - if (bp->rank == rank_in) - { - if (!cgsl) - { - cgsl = gs = new MyList; - gs->data = new Parallel::gridseg; - } - else - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - - for (int i = 0; i < dim; i++) - { - double DH = bp->getdX(i); - gs->data->uub[i] = (feq(bp->bbox[dim + i], bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; - gs->data->llb[i] = (feq(bp->bbox[i], bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; -#else -#ifdef Cell - gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); -#else -#error Not define Vertex nor Cell -#endif -#endif - } - gs->data->Bg = BP->data; - gs->next = 0; - } - - if (BP == ble) - break; - BP = BP->next; - } - - return cgsl; -} -void ss_patch::Sync(MyList *VarList, int Symmetry) -{ - int cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - - MyList *dst; - MyList **src, **transfer_src, **transfer_dst; - src = new MyList *[cpusize]; - transfer_src = new MyList *[cpusize]; - transfer_dst = new MyList *[cpusize]; - - dst = build_ghost_gsl(); // ghost region only - for (int node = 0; node < cpusize; node++) - { - src[node] = build_owned_gsl0(node); // for the part without ghost points and do not extend - Parallel::build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node - } - - Parallel::transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); - - if (dst) - dst->destroyList(); - for (int node = 0; node < cpusize; node++) - { - if (src[node]) - src[node]->destroyList(); - if (transfer_src[node]) - transfer_src[node]->destroyList(); - if (transfer_dst[node]) - transfer_dst[node]->destroyList(); - } - - delete[] src; - delete[] transfer_src; - delete[] transfer_dst; -} -//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -void xp_patch::setupcordtrans() -{ - MyList *BP = blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_xp_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); - f_xpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); - } - if (BP == ble) - break; - BP = BP->next; - } -} -void xm_patch::setupcordtrans() -{ - MyList *BP = blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_xm_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); - f_xpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); - } - if (BP == ble) - break; - BP = BP->next; - } -} -void yp_patch::setupcordtrans() -{ - MyList *BP = blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_yp_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); - f_ypm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); - } - if (BP == ble) - break; - BP = BP->next; - } -} -void ym_patch::setupcordtrans() -{ - MyList *BP = blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_ym_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); - f_ypm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); - } - if (BP == ble) - break; - BP = BP->next; - } -} -void zp_patch::setupcordtrans() -{ - MyList *BP = blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_zp_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); - f_zpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); - } - if (BP == ble) - break; - BP = BP->next; - } -} -void zm_patch::setupcordtrans() -{ - MyList *BP = blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_zm_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); - f_zpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); - } - if (BP == ble) - break; - BP = BP->next; - } -} -ShellPatch::ShellPatch(int ingfsi, int fngfsi, char *filename, int Symmetry, int myranki, monitor *ErrorMonitor) : ingfs(ingfsi), fngfs(fngfsi), myrank(myranki), PatL(0) -{ - int shapei[dim]; - double Rrangei[2]; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of Shell patches" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN") - { - if (skey == "Shell shape") - shapei[sind] = atof(sval.c_str()); - else if (skey == "Shell R range") - Rrangei[sind] = atof(sval.c_str()); - } - } - inf.close(); - } - - for (int i = 0; i < dim; i++) - { - shape[i] = shapei[i]; -// we always assume the input parameter is in cell center style -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - shape[i] = shape[i] + 1; -#endif - } - // change from cardisian r to local corrdinate r - Rrange[0] = getR(Rrangei[0]); - Rrange[1] = getR(Rrangei[1]); - - if (myrank == 0) - { - cout << endl; - cout << " shell's range: [" << Rrange[0] << ":" << Rrange[1] << "]" << endl - << " shape: " << shape[2] << endl - << " resolution: [" << getdX(0) << "," << getdX(1) << "," << getdX(2) << "]" << endl; - } - // extend buffer points for lower boundary - Rrange[0] -= buffer_width * getdX(2); - shape[2] += buffer_width; - - // extend ghost_width points at lower boundary for double cover region - // in input.par we do not ask shell and box have over lap - Rrange[0] -= ghost_width * getdX(2); - shape[2] += ghost_width; - -// extend buffer points for upper boundary if CPBC is used -#ifdef CPBC - - Rrange[1] += CPBC_ghost_width * getdX(2); - shape[2] += CPBC_ghost_width; - -#endif - - double bbox[2 * dim]; - int shape_here[dim]; - bbox[2] = Rrange[0]; - bbox[5] = Rrange[1]; - shape_here[2] = shape[2]; - - switch (Symmetry) - { - case 0: - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] + 2 * overghost; - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new xp_patch(ingfs, fngfs, shape_here, bbox, myrank); - PatL->insert(new xm_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new ym_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new zp_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new zm_patch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - case 1: - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] + 2 * overghost; - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new zp_patch(ingfs, fngfs, shape_here, bbox, myrank); - shape_here[0] = shape[0] + 2 * overghost; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - shape_here[1] = (shape[1] + 1) / 2 + overghost; -#else -#ifdef Cell - shape_here[1] = shape[1] / 2 + overghost; -#else -#error Not define Vertex nor Cell -#endif -#endif - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = 0; - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL->insert(new xp_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_patch(ingfs, fngfs, shape_here, bbox, myrank)); - bbox[0] = -PI / 4 - overghost * getdX(0); - bbox[1] = -PI / 4 - overghost * getdX(1); - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = 0; - PatL->insert(new xm_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new ym_patch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - case 2: -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - for (int i = 0; i < 2; i++) - shape_here[i] = (shape[i] + 1) / 2 + overghost; -#else -#ifdef Cell - for (int i = 0; i < 2; i++) - shape_here[i] = shape[i] / 2 + overghost; -#else -#error Not define Vertex nor Cell -#endif -#endif - bbox[0] = 0; - bbox[1] = 0; - bbox[3] = PI / 4 + overghost * getdX(0); - bbox[4] = PI / 4 + overghost * getdX(1); - PatL = new MyList; - PatL->data = new zp_patch(ingfs, fngfs, shape_here, bbox, myrank); - PatL->insert(new xp_patch(ingfs, fngfs, shape_here, bbox, myrank)); - PatL->insert(new yp_patch(ingfs, fngfs, shape_here, bbox, myrank)); - break; - default: - cout << "not recognized Symmetry type" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } -} -ShellPatch::~ShellPatch() -{ - int nprocs = 1; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - for (int node = 0; node < nprocs; node++) - { - if (ss_src[node]) - destroypsuList(ss_src[node]); - if (ss_dst[node]) - destroypsuList(ss_dst[node]); - if (csatc_src[node]) - destroypsuList(csatc_src[node]); - if (csatc_dst[node]) - destroypsuList(csatc_dst[node]); - if (csats_src[node]) - destroypsuList(csats_src[node]); - if (csats_dst[node]) - destroypsuList(csats_dst[node]); - } - - delete[] ss_src; - delete[] ss_dst; - delete[] csatc_src; - delete[] csatc_dst; - delete[] csats_src; - delete[] csats_dst; - - while (PatL) - { - ss_patch *sPp = PatL->data; - MyList *bg; - while (sPp->blb) - { - if (sPp->blb == sPp->ble) - break; - bg = (sPp->blb->next) ? sPp->blb->next : 0; - delete sPp->blb->data; - delete sPp->blb; - sPp->blb = bg; - } - if (sPp->ble) - { - delete sPp->ble->data; - delete sPp->ble; - } - sPp->blb = sPp->ble = 0; - PatL = PatL->next; - } - PatL->destroyList(); -} -void ShellPatch::destroypsuList(MyList *ct) -{ - MyList *n; - while (ct) - { - n = ct->next; - if (ct->data->coef) - { - delete[] ct->data->coef; - delete[] ct->data->sind; - } - delete ct->data; - delete ct; - ct = n; - } -} -double ShellPatch::getR(double r) -{ - double A = 1, B = 0, r0 = 0, eps = 1; - f_shellcordpar(A, B, r0, eps); - double f = A * (r - r0) + B * sqrt(1 + (r - r0) * (r - r0) / eps); - return f + A * r0 - B * sqrt(1 + r0 * r0 / eps); -} -double ShellPatch::getsr(double R) -{ - double A = 1, B = 0, r0 = 0, eps = 1; - f_shellcordpar(A, B, r0, eps); - double f = R + B; - return r0 + (A * f - B * sqrt(A * A + (f * f - B * B) / eps)) / (A * A - B * B / eps); -} -MyList *ShellPatch::compose_sh(int cpusize, int nodes) -{ -#ifdef USE_GPU_DIVIDE - double cpu_part, gpu_part; - map::iterator iter; - iter = parameters::dou_par.find("cpu part"); - if (iter != parameters::dou_par.end()) - { - cpu_part = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "cpu part") - cpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); - } - iter = parameters::dou_par.find("gpu part"); - if (iter != parameters::dou_par.end()) - { - gpu_part = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "gpu part") - gpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); - } - - if (nodes == 0) - nodes = cpusize / 2; -#else - if (nodes == 0) - nodes = cpusize; -#endif - - if (dim != 3) - { - cout << "distrivute: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - // checkPatch(); - - bool periodic = false; - MyList *BlL = 0; - - int split_size, min_size, block_size = 0; - - int min_width = 2 * Mymax(ghost_width, buffer_width); - int nxyz[dim], mmin_width[dim], min_shape[dim]; - - MyList *PLi = PatL; - for (int i = 0; i < dim; i++) - min_shape[i] = PLi->data->shape[i]; - PLi = PLi->next; - while (PLi) - { - ss_patch *PP = PLi->data; - for (int i = 0; i < dim; i++) - min_shape[i] = Mymin(min_shape[i], PP->shape[i]); - PLi = PLi->next; - } - - for (int i = 0; i < dim; i++) - mmin_width[i] = Mymin(min_width, min_shape[i]); - - min_size = mmin_width[0]; - for (int i = 1; i < dim; i++) - min_size = min_size * mmin_width[i]; - - PLi = PatL; - while (PLi) - { - ss_patch *PP = PLi->data; - // PP->checkPatch(true); - int bs = PP->shape[0]; - for (int i = 1; i < dim; i++) - bs = bs * PP->shape[i]; - block_size = block_size + bs; - PLi = PLi->next; - } - split_size = Mymax(min_size, block_size / nodes); - split_size = Mymax(1, split_size); - - int n_rank = 0; - PLi = PatL; - int reacpu = 0; - while (PLi) - { - ss_patch *PP = PLi->data; - - reacpu += Parallel::partition3(nxyz, split_size, mmin_width, nodes, PP->shape); - - Block *ng, *ng0; - int shape_here[dim], ibbox_here[2 * dim]; - double bbox_here[2 * dim], dd; - - // ibbox : 0,...N-1 - for (int i = 0; i < nxyz[0]; i++) - for (int j = 0; j < nxyz[1]; j++) - for (int k = 0; k < nxyz[2]; k++) - { - ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; - ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; - ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; - ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; - ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; - - if (periodic) - { - ibbox_here[0] = ibbox_here[0] - ghost_width; - ibbox_here[3] = ibbox_here[3] + ghost_width; - ibbox_here[1] = ibbox_here[1] - ghost_width; - ibbox_here[4] = ibbox_here[4] + ghost_width; - ibbox_here[2] = ibbox_here[2] - ghost_width; - ibbox_here[5] = ibbox_here[5] + ghost_width; - } - else - { - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); - ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); - ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); - } - - shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; - shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; - shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); - bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; - bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; -#else -#ifdef Cell - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; - bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; - bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - -#ifdef USE_GPU_DIVIDE - { - const int pices = 2; - double picef[pices]; - picef[0] = cpu_part; - picef[1] = gpu_part; - int shape_res[dim * pices]; - double bbox_res[2 * dim * pices]; - misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_width); - ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfs, fngfs + dRdzz + 1, 0, 0); // delete through KillBlocks - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks - - for (int i = 1; i < pices; i++) - { - ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfs, fngfs + dRdzz + 1, 0, i); // delete through KillBlocks - // ng->checkBlock(); - BlL->insert(ng); - } - } -#else - ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs + dRdzz + 1, 0); // delete through KillBlocks - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks -#endif - if (n_rank == cpusize) - n_rank = 0; - - // set PP->blb - if (i == 0 && j == 0 && k == 0) - { - MyList *Bp = BlL; - while (Bp->data != ng0) - Bp = Bp->next; // ng0 is the first of the pices list - PP->blb = Bp; - } - } - // set PP->ble - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; // ng is the last of the pices list - PP->ble = Bp; - } - PLi = PLi->next; - } - if (reacpu < nodes * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "ShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} -// distribute data only along r direction -MyList *ShellPatch::compose_shr(int cpusize, int nodes) -{ -#ifdef USE_GPU_DIVIDE - double cpu_part, gpu_part; - map::iterator iter; - iter = parameters::dou_par.find("cpu part"); - if (iter != parameters::dou_par.end()) - { - cpu_part = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "cpu part") - cpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); - } - iter = parameters::dou_par.find("gpu part"); - if (iter != parameters::dou_par.end()) - { - gpu_part = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "gpu part") - gpu_part = atof(sval.c_str()); - } - } - inf.close(); - - parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); - } - - if (nodes == 0) - nodes = cpusize / 2; -#else - if (nodes == 0) - nodes = cpusize; -#endif - - if (dim != 3) - { - cout << "ShellPatch::compose_shr: now we only support 3-dimension" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - // checkPatch(); - - bool periodic = false; - MyList *BlL = 0; - - int min_size = 2 * Mymax(ghost_width, buffer_width); - int nxyz[dim]; - - MyList *PLi; - - PLi = PatL; - int reacpu = 0; - while (PLi) - { - // make sure the block with the same r range locate at the same cpu - int n_rank = 0; - ss_patch *PP = PLi->data; - - reacpu += Parallel::partition1(nxyz[2], min_size, min_size, nodes, PP->shape[2]); - nxyz[0] = nxyz[1] = 1; - - Block *ng, *ng0; - int shape_here[dim], ibbox_here[2 * dim]; - double bbox_here[2 * dim], dd; - - // ibbox : 0,...N-1 - for (int i = 0; i < nxyz[0]; i++) - for (int j = 0; j < nxyz[1]; j++) - for (int k = 0; k < nxyz[2]; k++) - { - ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; - ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; - ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; - ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; - ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; - ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; - - if (periodic) - { - ibbox_here[0] = ibbox_here[0] - ghost_width; - ibbox_here[3] = ibbox_here[3] + ghost_width; - ibbox_here[1] = ibbox_here[1] - ghost_width; - ibbox_here[4] = ibbox_here[4] + ghost_width; - ibbox_here[2] = ibbox_here[2] - ghost_width; - ibbox_here[5] = ibbox_here[5] + ghost_width; - } - else - { - ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); - ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); - ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); - ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); - ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); - ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); - } - - shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; - shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; - shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); - bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; - bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); - bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; - bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); - bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; - bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; -#else -#ifdef Cell - dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; - bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; - bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; - - dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; - bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; - bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; - - dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; - bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; - bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - -#ifdef USE_GPU_DIVIDE - { - const int pices = 2; - double picef[pices]; - picef[0] = cpu_part; - picef[1] = gpu_part; - int shape_res[dim * pices]; - double bbox_res[2 * dim * pices]; - misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_size); - ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfs, fngfs + dRdzz + 1, 0, 0); // delete through KillBlocks - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks - - for (int i = 1; i < pices; i++) - { - ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfs, fngfs + dRdzz + 1, 0, i); // delete through KillBlocks - // ng->checkBlock(); - BlL->insert(ng); - } - } -#else - ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs + dRdzz + 1, 0); // delete through KillBlocks - // ng->checkBlock(); - if (BlL) - BlL->insert(ng); - else - BlL = new MyList(ng); // delete through KillBlocks -#endif - if (n_rank == cpusize) - n_rank = 0; - - // set PP->blb - if (i == 0 && j == 0 && k == 0) - { - MyList *Bp = BlL; - while (Bp->data != ng0) - Bp = Bp->next; // ng0 is the first of the pices list - PP->blb = Bp; - } - } - // set PP->ble - { - MyList *Bp = BlL; - while (Bp->data != ng) - Bp = Bp->next; // ng is the last of the pices list - PP->ble = Bp; - } - PLi = PLi->next; - } - if (reacpu < nodes * 2 / 3) - { - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "ShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; - } - - return BlL; -} -void ShellPatch::getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) -{ - double r; - r = sqrt(x * x + y * y + z * z); - lz = getR(r); - if (fabs(x) <= z && fabs(y) <= z) - { - sst = 0; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(x) <= -z && fabs(y) <= -z) - { - sst = 1; - lx = atan(x / z); - ly = atan(y / z); - } - else if (fabs(y) <= x && fabs(z) <= x) - { - sst = 2; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(y) <= -x && fabs(z) <= -x) - { - sst = 3; - lx = atan(y / x); - ly = atan(z / x); - } - else if (fabs(x) <= y && fabs(z) <= y) - { - sst = 4; - lx = atan(x / y); - ly = atan(z / y); - } - else if (fabs(x) <= -y && fabs(z) <= -y) - { - sst = 5; - lx = atan(x / y); - ly = atan(z / y); - } - else - { - cout << "ShellPatch::getlocalpox should not come here, something wrong" << endl; - } -} -void ShellPatch::getlocalpoxsst(double x, double y, double z, int sst, double &lx, double &ly, double &lz) -{ - double r; - r = sqrt(x * x + y * y + z * z); - lz = getR(r); - switch (sst) - { - case -1: - lx = x; - ly = y; - lz = z; - break; - case 0: - lx = atan(x / z); - ly = atan(y / z); - break; - case 1: - lx = atan(x / z); - ly = atan(y / z); - break; - case 2: - lx = atan(y / x); - ly = atan(z / x); - break; - case 3: - lx = atan(y / x); - ly = atan(z / x); - break; - case 4: - lx = atan(x / y); - ly = atan(z / y); - break; - case 5: - lx = atan(x / y); - ly = atan(z / y); - break; - default: - cout << "ShellPatch::getlocalpoxsst should not come here, something wrong" << endl; - } -} -void ShellPatch::getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz) -{ - double r = getsr(lz); - switch (sst) - { - case 0: - x = tan(lx); - y = tan(ly); - z = r / sqrt(1 + x * x + y * y); - x = z * x; - y = z * y; - break; - case 1: - x = tan(lx); - y = tan(ly); - z = -r / sqrt(1 + x * x + y * y); - x = z * x; - y = z * y; - break; - case 2: - y = tan(lx); - z = tan(ly); - x = r / sqrt(1 + z * z + y * y); - y = x * y; - z = x * z; - break; - case 3: - y = tan(lx); - z = tan(ly); - x = -r / sqrt(1 + z * z + y * y); - y = x * y; - z = x * z; - break; - case 4: - x = tan(lx); - z = tan(ly); - y = r / sqrt(1 + x * x + z * z); - x = y * x; - z = y * z; - break; - case 5: - x = tan(lx); - z = tan(ly); - y = -r / sqrt(1 + x * x + z * z); - x = y * x; - z = y * z; - break; - } -} -// from to -// dumyd refer to 'from' -int ShellPatch::getdumydimension(int acsst, int posst) // -1 means no dumy dimension -{ - int dms; - if (acsst == -1 || posst == -1) - return -1; - switch (acsst) - { - case 0: - case 1: - switch (posst) - { - case 0: - case 1: - cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - case 2: - case 3: - return 0; - case 4: - case 5: - return 1; - default: - cout << "error in ShellPatch::getdumydimension: posst = " << posst << endl; - return -1; - } - case 2: - case 3: - switch (posst) - { - case 0: - case 1: - return 1; - case 2: - case 3: - cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - case 4: - case 5: - return 0; - default: - cout << "error in ShellPatch::getdumydimension: posst = " << posst << endl; - return -1; - } - case 4: - case 5: - switch (posst) - { - case 0: - case 1: - return 1; - case 2: - case 3: - return 0; - case 4: - case 5: - cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; - return -1; - default: - cout << "error in ShellPatch::getdumydimension: posst = " << posst << endl; - return -1; - } - default: - cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << endl; - return -1; - } -} -// used by _dst construction, so these x,y,z must coinside with grid point -// we have considered ghost points now -void ShellPatch::prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], - MyList *Ppi, double CDH[dim], MyList *pss) -{ - int n_dst = 0; - MyList *sPp = sPpi; - MyList *Pp = Ppi; - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz; - - if (pss->data->tsst >= 0) - { - getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, - lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == pss->data->tsst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - { - for (int j = 0; j < dim; j++) - { - llb[j] = Bg->bbox[j]; - uub[j] = Bg->bbox[j + dim]; - } - - if (lx > llb[0] - 0.1 * DH[0] && lx < uub[0] + 0.1 * DH[0] && - ly > llb[1] - 0.1 * DH[1] && ly < uub[1] + 0.1 * DH[1] && - lz > llb[2] - 0.1 * DH[2] && lz < uub[2] + 0.1 * DH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = 0; - for (int i = 0; i < dim; i++) - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = pss->data->ssst; - ps->data->tsst = sPp->data->sst; - ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); - ps->data->Bg = Bg; - ps->data->coef = 0; - ps->data->sind = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - n_dst++; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - } - else - { - if (pss->data->tsst != -1) - cout << "somthing is wrong in ShellPatch::prolongpointstru" << endl; - lx = pss->data->gpox[0]; - ly = pss->data->gpox[1]; - lz = pss->data->gpox[2]; - while (Pp) - { - Bgl = Pp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - { - for (int j = 0; j < dim; j++) - { - llb[j] = Bg->bbox[j]; - uub[j] = Bg->bbox[j + dim]; - } - - if (lx > llb[0] - 0.1 * CDH[0] && lx < uub[0] + 0.1 * CDH[0] && - ly > llb[1] - 0.1 * CDH[1] && ly < uub[1] + 0.1 * CDH[1] && - lz > llb[2] - 0.1 * CDH[2] && lz < uub[2] + 0.1 * CDH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = 0; - for (int i = 0; i < dim; i++) - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = pss->data->ssst; - ps->data->tsst = -1; - ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); - ps->data->Bg = Bg; - ps->data->coef = 0; - ps->data->sind = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - n_dst++; - } - } - if (Bgl == Pp->data->ble) - break; - Bgl = Bgl->next; - } - Pp = Pp->next; - } - } - // if n_dst > 0, that's because of ghost_points - if (n_dst == 0) - { - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - cout << "ShellPatch::prolongpointstru fail to find target Block for pointstru:" << endl; - check_pointstrul(pss, true); - if (Pp == Ppi) - { - getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, - lx, ly, lz); - if (myrank == 0) - cout << "sst = " << pss->data->tsst << ", lx,ly,lz = " << lx << "," << ly << "," << lz << endl; - checkBlock(pss->data->tsst); - } - else - { - Pp = Ppi; - while (Pp) - { - Pp->data->checkBlock(); - Pp = Pp->next; - } - } - if (myrank == 0) - MPI_Abort(MPI_COMM_WORLD, 1); - } - else - { - MyList *ts = 0; - for (int i = 1; i < n_dst; i++) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->next = (i == n_dst - 1) ? pss->next : 0; - for (int i = 0; i < dim; i++) - { - ps->data->gpox[i] = pss->data->gpox[i]; - ps->data->lpox[i] = pss->data->lpox[i]; - } - ps->data->ssst = pss->data->ssst; - ps->data->tsst = pss->data->tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->Bg = pss->data->Bg; - ps->data->coef = 0; - ps->data->sind = 0; - if (ts) - ts->catList(ps); - else - ts = ps; - } - if (ts) - pss->next = ts; - } -} -// used by _src construction, so these x,y,z do not coinside with grid point -bool ShellPatch::prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in) -{ - MyList *Bgl; - Block *Bg; - double llb[dim], uub[dim]; - double lx, ly, lz; - - if (ssyn) - { - int sst; - getlocalpox(x, y, z, sst, lx, ly, lz); - while (sPp) - { - if (sPp->data->sst == sst) - { - Bgl = sPp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < 2; j++) - { - if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) - llb[j] = -PI / 4; - else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * DH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) - uub[j] = PI / 4; - else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; - } - if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) - llb[2] = Bg->bbox[2]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; -#else -#ifdef Cell - else - llb[2] = Bg->bbox[2] + ghost_width * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) - uub[2] = Bg->bbox[dim + 2]; - else - uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; - if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && - ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && - lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| - // ^ - // so for ^ point may miss for vertext center, so we use 0.0001 - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = x; - ps->data->gpox[1] = y; - ps->data->gpox[2] = z; - ps->data->lpox[0] = lx; - ps->data->lpox[1] = ly; - ps->data->lpox[2] = lz; - ps->data->ssst = sPp->data->sst; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == sPp->data->ble) - break; - Bgl = Bgl->next; - } - } - sPp = sPp->next; - } - } - else - { - while (Pp) - { - Bgl = Pp->data->blb; - while (Bgl) - { - Bg = Bgl->data; - if (Bg->rank == rank_in) - { - for (int j = 0; j < dim; j++) - { - if (feq(Bg->bbox[j], Pp->data->bbox[j], CDH[j] / 2)) - llb[j] = Bg->bbox[j]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - llb[j] = Bg->bbox[j] + (ghost_width - 1) * CDH[j]; -#else -#ifdef Cell - else - llb[j] = Bg->bbox[j] + ghost_width * CDH[j]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (feq(Bg->bbox[dim + j], Pp->data->bbox[dim + j], CDH[j] / 2)) - uub[j] = Bg->bbox[dim + j]; - else - uub[j] = Bg->bbox[dim + j] - ghost_width * CDH[j]; - } - if (x > llb[0] - 0.0001 * CDH[0] && x < uub[0] + 0.0001 * CDH[0] && - y > llb[1] - 0.0001 * CDH[1] && y < uub[1] + 0.0001 * CDH[1] && - z > llb[2] - 0.0001 * CDH[2] && z < uub[2] + 0.0001 * CDH[2]) - { - MyList *ps = new MyList; - ps->data = new pointstru; - ps->data->Bg = Bg; - ps->data->gpox[0] = x; - ps->data->gpox[1] = y; - ps->data->gpox[2] = z; - ps->data->lpox[0] = x; - ps->data->lpox[1] = y; - ps->data->lpox[2] = z; - ps->data->ssst = -1; - ps->data->tsst = tsst; - ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); - ps->data->coef = 0; - ps->data->sind = 0; - ps->next = 0; - if (psul) - psul->catList(ps); - else - psul = ps; - return true; - } - } - if (Bgl == Pp->data->ble) - break; - Bgl = Bgl->next; - } - Pp = Pp->next; - } - } - - return false; -} - -// setup interpatch interpolation stuffs -void ShellPatch::setupintintstuff(int cpusize, MyList *CPatL, int Symmetry) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) { - cout << endl; - cout << " ShellPatch::setup interpatch interpolation stuffs begines..." << endl; - } - - ss_src = new MyList *[cpusize]; - ss_dst = new MyList *[cpusize]; - csatc_src = new MyList *[cpusize]; - csatc_dst = new MyList *[cpusize]; - csats_src = new MyList *[cpusize]; - csats_dst = new MyList *[cpusize]; - - MyList *ps, *ts; - MyList *sPp; - MyList *Bgl; - MyList *Pp; - Block *Bg; - double CDH[dim], DH[dim], llb[dim], uub[dim]; - double x, y, z; - - for (int i = 0; i < dim; i++) - { - CDH[i] = CPatL->data->getdX(i); - DH[i] = getdX(i); - } - - for (int i = 0; i < cpusize; i++) - { - ss_src[i] = 0; - csatc_src[i] = 0; - csats_src[i] = 0; - ss_dst[i] = 0; - csatc_dst[i] = 0; - csats_dst[i] = 0; - } - - sPp = PatL; - while (sPp) - { - for (int iz = 0; iz < sPp->data->shape[2]; iz++) - for (int is = 0; is < sPp->data->shape[1]; is++) - for (int ir = 0; ir < sPp->data->shape[0]; ir++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = sPp->data->bbox[0] + ir * DH[0]; - y = sPp->data->bbox[1] + is * DH[1]; - z = sPp->data->bbox[2] + iz * DH[2]; -#else -#ifdef Cell - x = sPp->data->bbox[0] + (ir + 0.5) * DH[0]; - y = sPp->data->bbox[1] + (is + 0.5) * DH[1]; - z = sPp->data->bbox[2] + (iz + 0.5) * DH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (z < sPp->data->bbox[2] + (SC_width + 0.0001) * DH[2]) - { - double gx, gy, gz; - getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); - bool flag = false; - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(csats_src[i], false, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); - if (flag) - break; - } - if (!flag) - { - CPatL->data->checkBlock(); - if (myrank == 0) - { - cout << "ShellPatch::prolongpointstru fail to find cardisian source point for" << endl; - cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; - cout << "x,y,z = " << gx << "," << gy << "," << gz << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - // else if(x<-PI/4-(overghost-ghost_width-0.0001)*DH[0] || x>PI/4+(overghost-ghost_width-0.0001)*DH[0] || - // y<-PI/4-(overghost-ghost_width-0.0001)*DH[1] || y>PI/4+(overghost-ghost_width-0.0001)*DH[1] ) //0.0001 is for vertex center - if (x < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[0] || x > PI / 4 + (overghost - ghost_width - 0.0001) * DH[0] || - y < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[1] || y > PI / 4 + (overghost - ghost_width - 0.0001) * DH[1]) - { - double gx, gy, gz; - getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); - bool flag = false; - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(ss_src[i], true, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); - if (flag) - break; - } - if (!flag) - { - if (myrank == 0) - { - cout << "ShellPatch::prolongpointstru fail to find shell source point for" << endl; - cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; - if (sPp->data->sst == -1) - cout << "your angular resolution for shell is too coarse?" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - sPp = sPp->next; - } - if (myrank == 0) - cout << " ShellPatch::setup interpatch interpolation stuffs ss_src completes" << endl; - - Pp = CPatL; - while (Pp) - { - double llb[dim], uub[dim]; - if (Symmetry > 0) - llb[2] = Pp->data->bbox[2] - 0.0001 * CDH[2]; - else - llb[2] = Pp->data->bbox[2] + (CS_width + 0.0001) * CDH[2]; - uub[2] = Pp->data->bbox[dim + 2] - (CS_width + 0.0001) * CDH[2]; - for (int j = 0; j < 2; j++) - { - if (Symmetry > 1) - llb[j] = Pp->data->bbox[j] - 0.0001 * CDH[j]; - else - llb[j] = Pp->data->bbox[j] + (CS_width + 0.0001) * CDH[j]; - uub[j] = Pp->data->bbox[dim + j] - (CS_width + 0.0001) * CDH[j]; - } - for (int iz = 0; iz < Pp->data->shape[2]; iz++) - for (int iy = 0; iy < Pp->data->shape[1]; iy++) - for (int ix = 0; ix < Pp->data->shape[0]; ix++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - x = Pp->data->bbox[0] + ix * CDH[0]; - y = Pp->data->bbox[1] + iy * CDH[1]; - z = Pp->data->bbox[2] + iz * CDH[2]; -#else -#ifdef Cell - x = Pp->data->bbox[0] + (ix + 0.5) * CDH[0]; - y = Pp->data->bbox[1] + (iy + 0.5) * CDH[1]; - z = Pp->data->bbox[2] + (iz + 0.5) * CDH[2]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (x < llb[0] || x > uub[0] || - y < llb[1] || y > uub[1] || - z < llb[2] || z > uub[2]) - { - int sst; - double lx, ly, lz; - bool flag = false; - getlocalpox(x, y, z, sst, lx, ly, lz); - for (int i = 0; i < cpusize; i++) - { - flag = prolongpointstru(csatc_src[i], true, -1, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i); - if (flag) - break; - } - if (!flag) - { - if (myrank == 0) - { - cout << "ShellPatch::prolongpointstru fail to find shell source point for" << endl; - cout << "sst = -1, x,y,z = " << x << "," << y << "," << z << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - } - } - Pp = Pp->next; - } - if (myrank == 0) - cout << " ShellPatch::setup interpatch interpolation stuffs csatc_src and csats_src completes" << endl; - - for (int i = 0; i < cpusize; i++) - { - ps = ss_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(ss_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - - ps = csatc_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(csatc_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - ps = csats_src[i]; - while (ps) - { - ts = ps->next; - prolongpointstru(csats_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here - ps = ts; - } - } - if (myrank == 0) - cout << " ShellPatch::ssetup interpatch interpolation stuffs ss_dst and csatc_dst, csats_dst complete" << endl; - - /* - for(int i=0;inext; - ts=ts->next; - } - } - exit(0); - */ -} - -void ShellPatch::setupcordtrans() -{ - MyList *PP = PatL; - while (PP) - { - PP->data->setupcordtrans(); - PP = PP->next; - } -} - -void ShellPatch::checkPatch() -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << " belong to Shell Patchs " << endl; - MyList *Pp = PatL; - while (Pp) - { - cout << " shape: ["; - for (int i = 0; i < dim; i++) - { - cout << Pp->data->shape[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << " range:" << "("; - for (int i = 0; i < dim; i++) - { - cout << Pp->data->bbox[i] << ":" << Pp->data->bbox[dim + i]; - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - Pp = Pp->next; - } - } -} - -void ShellPatch::checkBlock(int sst) -{ - if (myrank == 0) - { - cout << "checking shell patch sst = " << sst << endl; - MyList *Pp = PatL; - while (Pp) - { - if (Pp->data->sst == sst) - { - MyList *BP = Pp->data->blb; - while (BP) - { - BP->data->checkBlock(); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - } - Pp = Pp->next; - } - } -} - -double ShellPatch::getdX(int dir) -{ - if (dir < 0 || dir >= dim) - { - cout << "ShellPatch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double h; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (shape[dir] == 1) - { - cout << "ShellPatch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - if (dir < 2) - h = PI / 2 / (shape[dir] - 1); - else - h = (Rrange[1] - Rrange[0]) / (shape[dir] - 1); -#else -#ifdef Cell - if (dir < 2) - h = PI / 2 / shape[dir]; - else - h = (Rrange[1] - Rrange[0]) / shape[dir]; -#else -#error Not define Vertex nor Cell -#endif -#endif - return h; -} - -void ShellPatch::shellname(char *sn, int i) -{ - switch (i) - { - case 0: - sprintf(sn, "zp"); - return; - case 1: - sprintf(sn, "zm"); - return; - case 2: - sprintf(sn, "xp"); - return; - case 3: - sprintf(sn, "xm"); - return; - case 4: - sprintf(sn, "yp"); - return; - case 5: - sprintf(sn, "ym"); - return; - } -} -// Now we dump the data including overlap points -void ShellPatch::Dump_xyz(char *tag, double time, double dT) -{ - MyList *PP = PatL; - while (PP) - { - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); - if (!databuffer) - { - cout << "ShellPatch::Dump_xyz: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - for (int DumpList = fngfs + gx; DumpList <= fngfs + gz; DumpList++) - { - MyList *Bp = PP->data->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[DumpList], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[DumpList], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->data->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - - string out_dir; - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - char filename[100]; - char sn[3]; - shellname(sn, PP->data->sst); - switch (DumpList - fngfs) - { - case gx: - if (tag) - sprintf(filename, "%s/%s_LevSH-%s_x_%05d.bin", out_dir.c_str(), tag, sn, ncount); - else - sprintf(filename, "%s/LevSH-%s_x_%05d.bin", out_dir.c_str(), sn, ncount); - break; - case gy: - if (tag) - sprintf(filename, "%s/%s_LevSH-%s_y_%05d.bin", out_dir.c_str(), tag, sn, ncount); - else - sprintf(filename, "%s/LevSH-%s_y_%05d.bin", out_dir.c_str(), sn, ncount); - break; - case gz: - if (tag) - sprintf(filename, "%s/%s_LevSH-%s_z_%05d.bin", out_dir.c_str(), tag, sn, ncount); - else - sprintf(filename, "%s/LevSH-%s_z_%05d.bin", out_dir.c_str(), sn, ncount); - break; - } - - Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], - PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], - PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); - } - } - - if (myrank == 0) - free(databuffer); - - PP = PP->next; - } -} - -void ShellPatch::Dump_Data(MyList *DumpListi, char *tag, double time, double dT) -{ - MyList *PP = PatL; - while (PP) - { - // round at 4 and 5 - int ncount = int(time / dT + 0.5); - - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); - if (!databuffer) - { - cout << "ShellPatch::Dump_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *DumpList = DumpListi; - while (DumpList) - { - var *VP = DumpList->data; - - MyList *Bp = PP->data->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->data->ble) - break; - Bp = Bp->next; - } - if (myrank == 0) - { - - string out_dir; - map::iterator iter; - iter = parameters::str_par.find("output dir"); - if (iter != parameters::str_par.end()) - { - out_dir = iter->second; - } - else - { - // read parameter from file - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "ABE") - { - if (skey == "output dir") - out_dir = sval; - } - } - inf.close(); - - parameters::str_par.insert(map::value_type("output dir", out_dir)); - } - - char filename[100]; - char sn[3]; - shellname(sn, PP->data->sst); - if (tag) - sprintf(filename, "%s/%s_LevSH-%s_%s_%05d.bin", out_dir.c_str(), tag, sn, VP->name, ncount); - else - sprintf(filename, "%s/LevSH-%s_%s_%05d.bin", out_dir.c_str(), sn, VP->name, ncount); - - Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], - PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], - PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); - } - DumpList = DumpList->next; - } - - if (myrank == 0) - free(databuffer); - - PP = PP->next; - } -} - -double *ShellPatch::Collect_Data(ss_patch *PP, var *VP) -{ - MPI_Status sta; - int DIM = 3; - double llb[3], uub[3]; - double DX, DY, DZ; - - double *databuffer = 0; - if (myrank == 0) - { - databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); - if (!databuffer) - { - cout << "ShellPatch::Collect_Data: out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - MyList *Bp = PP->blb; - while (Bp) - { - Block *BP = Bp->data; - if (BP->rank == 0 && myrank == 0) - { - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); - } - else - { - int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); - if (myrank == 0) - { - double *bufferhere = (double *)malloc(sizeof(double) * nnn); - if (!bufferhere) - { - cout << "on node#" << myrank << ", out of memory when dumping data." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); - DX = BP->getdX(0); - DY = BP->getdX(1); - DZ = BP->getdX(2); - llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; - llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; - llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; - uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; - uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; - uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; - f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); - free(bufferhere); - } - else if (myrank == BP->rank) - { - MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); - } - } - if (Bp == PP->ble) - break; - Bp = Bp->next; - } - - return databuffer; -} - -void ShellPatch::intertransfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry) -{ - int myrank, cpusize; - MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int node; - - MPI_Request *reqs; - MPI_Status *stats; - reqs = new MPI_Request[2 * cpusize]; - stats = new MPI_Status[2 * cpusize]; - int req_no = 0; - - double **send_data, **rec_data; - send_data = new double *[cpusize]; - rec_data = new double *[cpusize]; - int length; - - for (node = 0; node < cpusize; node++) - { - send_data[node] = rec_data[node] = 0; - if (node == myrank) - { - if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 1" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(rec_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - } - } - else - { - // send from this cpu to cpu#node - if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry)) - { - send_data[node] = new double[length]; - if (!send_data[node]) - { - cout << "out of memory when new in short transfer, place 2" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - interdata_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); - MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - // receive from cpu#node to this cpu - if (length = interdata_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry)) - { - rec_data[node] = new double[length]; - if (!rec_data[node]) - { - cout << "out of memory when new in short transfer, place 3" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); - } - } - } - // wait for all requests to complete - MPI_Waitall(req_no, reqs, stats); - - for (node = 0; node < cpusize; node++) - if (rec_data[node]) - interdata_packer(rec_data[node], src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); - - for (node = 0; node < cpusize; node++) - { - if (send_data[node]) - delete[] send_data[node]; - if (rec_data[node]) - delete[] rec_data[node]; - } - - delete[] reqs; - delete[] stats; - delete[] send_data; - delete[] rec_data; -} -// PACK: prepare target data in 'data' -// UNPACK: copy target data from 'data' to corresponding numerical grids -int ShellPatch::interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int DIM = dim; - int ordn = 2 * ghost_width; - - if (dir != PACK && dir != UNPACK) - { - cout << "error dir " << dir << " for data_packer " << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - int size_out = 0; - - if (!src || !dst) - return size_out; - - MyList *varls, *varld; - - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - varls = varls->next; - varld = varld->next; - } - - if (varls || varld) - { - cout << "error in short data packer, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - while (src && dst) - { - if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || - (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) - { - varls = VarLists; - varld = VarListd; - while (varls && varld) - { - if (data) - { - if (dir == PACK) - { - /* - f_global_interp(src->data->Bg->shape,src->data->Bg->X[0],src->data->Bg->X[1],src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn],data[size_out], - src->data->lpox[0],src->data->lpox[1],src->data->lpox[2],ordn,varls->data->SoA,Symmetry); - */ - int DIMh = (src->data->dumyd == -1) ? dim : 1; - if (src->data->coef == 0) - { - src->data->coef = new double[ordn * DIMh]; - src->data->sind = new int[dim]; - if (DIMh == 3) - { - for (int i = 0; i < DIMh; i++) - { - double dd = src->data->Bg->getdX(i); - // 0.001 instead of 0.4 makes the point locate more center - src->data->sind[i] = int((src->data->lpox[i] - src->data->Bg->X[i][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = src->data->Bg->X[i][0] + (src->data->sind[i] + j) * dd; - src->data->coef[i * ordn + j] = 1; - for (int k = 0; k < j; k++) - { - h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; - src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; - src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); - } - } - } - } - else - { - int actd = 1 - src->data->dumyd; - double dd = src->data->Bg->getdX(actd); - src->data->sind[0] = int((src->data->lpox[actd] - src->data->Bg->X[actd][0]) / dd) - ordn / 2 + 1; - double h1, h2; - for (int j = 0; j < ordn; j++) - { - h1 = src->data->Bg->X[actd][0] + (src->data->sind[0] + j) * dd; - src->data->coef[j] = 1; - for (int k = 0; k < j; k++) - { - h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; - src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); - } - for (int k = j + 1; k < ordn; k++) - { - h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; - src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); - } - } - src->data->sind[2] = int((src->data->lpox[2] - src->data->Bg->X[2][0]) / src->data->Bg->getdX(2) + 0.001); - if (!feq(src->data->Bg->X[2][src->data->sind[2]], src->data->lpox[2], src->data->Bg->getdX(2) / 2000)) - cout << "error in ShellPatch::interdata_packer point = " << src->data->lpox[2] << " != grid " << src->data->Bg->X[2][src->data->sind[2]] << endl; - src->data->sind[1] = int((src->data->lpox[src->data->dumyd] - src->data->Bg->X[src->data->dumyd][0]) / - src->data->Bg->getdX(src->data->dumyd) + - 0.001); - if (!feq(src->data->Bg->X[src->data->dumyd][src->data->sind[1]], src->data->lpox[src->data->dumyd], src->data->Bg->getdX(src->data->dumyd) / 2000)) - cout << "error in ShellPatch::interdata_packer for dumy dimension point = " - << src->data->lpox[src->data->dumyd] << " != grid " << src->data->Bg->X[src->data->dumyd][src->data->sind[1]] << endl; - } - } - // interpolate - switch (DIMh) - { - case 3: - f_global_interpind(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst); - break; - case 2: - f_global_interpind2d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst); - break; - case 1: - f_global_interpind1d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], - src->data->Bg->fgfs[varls->data->sgfn], data[size_out], - src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, - src->data->sind, src->data->coef, src->data->ssst, src->data->dumyd); - break; - default: - cout << "ShellPatch::interdata_packer: not recognized DIM = " << DIMh << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - if (dir == UNPACK) // from target data to corresponding grid - f_pointcopy(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], - dst->data->lpox[0], dst->data->lpox[1], dst->data->lpox[2], data[size_out]); - } - size_out += 1; - varls = varls->next; - varld = varld->next; - } - } - dst = dst->next; - src = src->next; - } - - return size_out; -} -void ShellPatch::Synch(MyList *VarList, int Symmetry) -{ - MyList *Pp = PatL; - while (Pp) - { - Pp->data->Sync(VarList, Symmetry); - Pp = Pp->next; - } - - intertransfer(ss_src, ss_dst, VarList, VarList, Symmetry); -} - -void ShellPatch::CS_Inter(MyList *VarList, int Symmetry) -{ - // fill shell first - intertransfer(csats_src, csats_dst, VarList, VarList, Symmetry); - // fill box then - intertransfer(csatc_src, csatc_dst, VarList, VarList, Symmetry); -} - -void ShellPatch::check_pointstrul(MyList *pp, bool first_only) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - if (!pp) - cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; - else - cout << "checking check_pointstrul..." << endl; - while (pp) - { - if (pp->data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - if (first_only) - return; - pp = pp->next; - } - } -} - -void ShellPatch::check_pointstrul2(MyList *pp, int first_last_only) -{ - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - if (!pp) - cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; - else - cout << "checking check_pointstrul..." << endl; - while (pp) - { - if (first_last_only == 2) - { - if (pp->next == 0) - { - if (pp->data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - } - } - else - { - if (pp->data->Bg) - cout << "on node#" << pp->data->Bg->rank << endl; - else - cout << "virtual pointstru" << endl; - cout << "source sst = " << pp->data->ssst << endl; - cout << "target sst = " << pp->data->tsst << endl; - cout << "dumy dimension = " << pp->data->dumyd << endl; - cout << "global coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->gpox[i] << ","; - else - cout << pp->data->gpox[i] << ")" << endl; - } - cout << "local coordinates: ("; - for (int i = 0; i < dim; i++) - { - if (i < dim - 1) - cout << pp->data->lpox[i] << ","; - else - cout << pp->data->lpox[i] << ")" << endl; - } - if (first_last_only == 1) - return; - } - pp = pp->next; - } - } -} - -void ShellPatch::matchcheck(MyList *CPatL) -{ - double cbd = CPatL->data->bbox[dim]; - for (int i = 1; i < dim; i++) - cbd = Mymin(cbd, CPatL->data->bbox[dim + i]); - cbd = cbd - getsr(Rrange[0]); - double dr, dc; - dc = CPatL->data->getdX(0); - dr = getdX(2); - for (int i = 1; i < dim; i++) - { - dc = Mymax(dc, CPatL->data->getdX(i)); - // dr = Mymax(dr,getdX(i)); - } - - int ir, ic; - ir = int(cbd / dr); - ic = int(cbd / dc); - if (Mymin(ir, ic) < 3 * ghost_width) // 3 because we need 1 for double cover region - { - int myrank = 0; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << "Shell Patches insert too shallow:" << endl; - cout << "distantance between these two boundaries is " << cbd << ", spatial step is " << Mymax(dc, dr) << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -} - -void ShellPatch::Interp_Points(MyList *VarList, - int NN, double **XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry) -{ - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[NN * num_var]; - memset(shellf, 0, sizeof(double) * NN * num_var); - - // we use weight to monitor code, later some day we can move it for optimization - int *weight; - weight = new int[NN]; - memset(weight, 0, sizeof(int) * NN); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - int sst; - getlocalpox(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); - - MyList *sPp = PatL; - while (sPp->data->sst != sst) - sPp = sPp->next; - - if (myrank == 0 && ((!sPp) || pox[2] < Rrange[0] || pox[2] > Rrange[1])) - { - cout << "ShellPatch::Interp_Points: point ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k][j]; - if (k < dim - 1) - cout << ","; - else - cout << ") is out of the ShellPatch." << endl; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (!sPp) - return; - - MyList *Bp = sPp->data->blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -// -// because of getlocalpox, pox will not goes into overghost region of ss_patch -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp_ss(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry, sst); - varl = varl->next; - k++; - } - weight[j] = 1; - } - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - } - - MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - int *Weight; - Weight = new int[NN]; - MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - - for (int i = 0; i < NN; i++) - { - if (Weight[i] > 1) - { - if (myrank == 0) - cout << "WARNING: ShellPatch::Interp_Points meets multiple weight" << endl; - for (int j = 0; j < num_var; j++) - Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; - } - else if (Weight[i] == 0 && myrank == 0) - { - cout << "ERROR: ShellPatch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j][i]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on ShellPatch (" << Rrange[0] << "," << Rrange[1] << endl; - - cout << "splited domains:" << endl; - MyList *sPp = PatL; - while (sPp) - { - char sn[3]; - shellname(sn, sPp->data->sst); - cout << "ss_patch " << sn << ":" << endl; - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - delete[] shellf; - delete[] weight; - delete[] Weight; - delete[] DH; - delete[] llb; - delete[] uub; -} - -bool ShellPatch::Interp_One_Point(MyList *VarList, - double *XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry) -{ - const int NN = 1; - // NOTE: we do not Synchnize variables here, make sure of that before calling this routine - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int ordn = 2 * ghost_width; - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf; - shellf = new double[NN * num_var]; - memset(shellf, 0, sizeof(double) * NN * num_var); - - // we use weight to monitor code, later some day we can move it for optimization - int *weight; - weight = new int[NN]; - memset(weight, 0, sizeof(int) * NN); - - double *DH, *llb, *uub; - DH = new double[dim]; - - for (int i = 0; i < dim; i++) - { - DH[i] = getdX(i); - } - llb = new double[dim]; - uub = new double[dim]; - - for (int j = 0; j < NN; j++) // run along points - { - double pox[dim]; - int sst; - getlocalpox(XX[0], XX[1], XX[2], sst, pox[0], pox[1], pox[2]); - - MyList *sPp = PatL; - while (sPp->data->sst != sst) - sPp = sPp->next; - - if ((!sPp) || pox[2] < Rrange[0] || pox[2] > Rrange[1]) - { - if (myrank == 0) - { - cout << "ShellPatch::Interp_One_Point: point ("; - for (int k = 0; k < dim; k++) - { - cout << XX[k]; - if (k < dim - 1) - cout << ","; - else - cout << ") is out of the ShellPatch." << endl; - } - } - return false; - } - - MyList *Bp = sPp->data->blb; - bool notfind = true; - while (notfind && Bp) // run along Blocks - { - Block *BP = Bp->data; - - bool flag = true; - for (int i = 0; i < dim; i++) - { -// NOTE: our dividing structure is (exclude ghost) -// -1 0 -// 1 2 -// so (0,1) does not belong to any part for vertex structure -// here we put (0,0.5) to left part and (0.5,1) to right part -// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all -// -// because of getlocalpox, pox will not goes into overghost region of ss_patch -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) - { - flag = false; - break; - } - } - - if (flag) - { - notfind = false; - if (myrank == BP->rank) - { - //---> interpolation - varl = VarList; - int k = 0; - while (varl) // run along variables - { - f_global_interp_ss(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], - pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry, sst); - varl = varl->next; - k++; - } - weight[j] = 1; - } - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - } - - MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - int *Weight; - Weight = new int[NN]; - MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - - for (int i = 0; i < NN; i++) - { - if (Weight[i] > 1) - { - if (myrank == 0) - cout << "WARNING: ShellPatch::Interp_Points meets multiple weight" << endl; - for (int j = 0; j < num_var; j++) - Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; - } - else if (Weight[i] == 0 && myrank == 0) - { - cout << "ERROR: ShellPatch::Interp_Points fails to find point ("; - for (int j = 0; j < dim; j++) - { - cout << XX[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")"; - } - cout << " on ShellPatch (" << Rrange[0] << "," << Rrange[1] << endl; - - cout << "splited domains:" << endl; - MyList *sPp = PatL; - while (sPp) - { - char sn[3]; - shellname(sn, sPp->data->sst); - cout << "ss_patch " << sn << ":" << endl; - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *BP = Bp->data; - - for (int i = 0; i < dim; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; -#else -#ifdef Cell - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; - uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - cout << "("; - for (int j = 0; j < dim; j++) - { - cout << llb[j] << ":" << uub[j]; - if (j < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - delete[] shellf; - delete[] weight; - delete[] Weight; - delete[] DH; - delete[] llb; - delete[] uub; - - return true; -} - -void ShellPatch::write_Pablo_file_ss(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, - char *filename, int sst) -{ - int nx = ext[0], ny = ext[1], nz = ext[2]; - int i, j, k; - double *X, *Y, *Z; - X = new double[nx]; - Y = new double[ny]; - Z = new double[nz]; - double dX, dY, dZ; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dX = (xmax - xmin) / (nx - 1); - for (i = 0; i < nx; i++) - X[i] = xmin + i * dX; - dY = (ymax - ymin) / (ny - 1); - for (j = 0; j < ny; j++) - Y[j] = ymin + j * dY; - dZ = (zmax - zmin) / (nz - 1); - for (k = 0; k < nz; k++) - Z[k] = zmin + k * dZ; -#else -#ifdef Cell - dX = (xmax - xmin) / nx; - for (i = 0; i < nx; i++) - X[i] = xmin + (i + 0.5) * dX; - dY = (ymax - ymin) / ny; - for (j = 0; j < ny; j++) - Y[j] = ymin + (j + 0.5) * dY; - dZ = (zmax - zmin) / nz; - for (k = 0; k < nz; k++) - Z[k] = zmin + (k + 0.5) * dZ; -#else -#error Not define Vertex nor Cell -#endif -#endif - //|--->open out put file - ofstream outfile; - outfile.open(filename); - if (!outfile) - { - cout << "bssn_class: write_Pablo_file can't open " << filename << " for output." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double gx, gy, gz; - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - for (k = 0; k < nz; k++) - for (j = 0; j < ny; j++) - for (i = 0; i < nx; i++) - { - getglobalpox(gx, gy, gz, sst, X[i], Y[j], Z[k]); - outfile << gx << " " << gy << " " << gz << " " - << 0 << endl; - } - outfile.close(); - - delete[] X; - delete[] Y; - delete[] Z; -} - + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "ShellPatch.h" +#include "Parallel.h" +#include "fmisc.h" +#include "misc.h" +#include "shellfunctions.h" +#include "parameters.h" + +#define PI M_PI + +// x x x x x o * +// * o x x x x x +// each side contribute an overlap points +// so we need half of that +#define overghost ((ghost_width + 1) / 2 + ghost_width) + +ss_patch::ss_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ingfs(ingfsi), fngfs(fngfsi), myrank(myranki), blb(0), ble(0) +{ + for (int i = 0; i < dim; i++) + { + shape[i] = shapei[i]; + bbox[i] = bboxi[i]; + bbox[i + dim] = bboxi[i + dim]; + } +} +ss_patch::~ss_patch() +{ + MyList *bg; + while (blb) + { + if (blb == ble) + break; + bg = (blb->next) ? blb->next : 0; + delete blb->data; + delete blb; + blb = bg; + } + if (ble) + { + delete ble->data; + delete ble; + } + blb = ble = 0; +} +// bulk part for given Block within given patch, without extension +MyList *ss_patch::build_bulk_gsl(Block *bp) +{ + MyList *gs = 0; + + gs = new MyList; + gs->data = new Parallel::gridseg; + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; + gs->data->llb[i] = (feq(bp->bbox[i], bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = bp; + gs->next = 0; + + return gs; +} +// collect all ghost grid segments or blocks for given patch +MyList *ss_patch::build_ghost_gsl() +{ + MyList *cgsl = 0, *gs, *gsb; + MyList *BP = blb; + while (BP) + { + gs = new MyList; + gs->data = new Parallel::gridseg; + + for (int i = 0; i < dim; i++) + { + gs->data->llb[i] = BP->data->bbox[i]; + gs->data->uub[i] = BP->data->bbox[dim + i]; + gs->data->shape[i] = BP->data->shape[i]; + } + gs->data->Bg = BP->data; + gs->next = 0; + + gsb = build_bulk_gsl(BP->data); + + if (!cgsl) + cgsl = Parallel::gs_subtract(gs, gsb); + else + cgsl->catList(Parallel::gs_subtract(gs, gsb)); + + gsb->destroyList(); + gs->destroyList(); + + if (BP == ble) + break; + BP = BP->next; + } + + return cgsl; +} +// collect all grid segments or blocks without ghost for given patch +// special for Sync usage, so we do not need consider missing points +MyList *ss_patch::build_owned_gsl0(int rank_in) +{ + MyList *cgsl = 0, *gs; + MyList *BP = blb; + while (BP) + { + Block *bp = BP->data; + if (bp->rank == rank_in) + { + if (!cgsl) + { + cgsl = gs = new MyList; + gs->data = new Parallel::gridseg; + } + else + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + + for (int i = 0; i < dim; i++) + { + double DH = bp->getdX(i); + gs->data->uub[i] = (feq(bp->bbox[dim + i], bbox[dim + i], DH / 2)) ? bp->bbox[dim + i] : bp->bbox[dim + i] - ghost_width * DH; + gs->data->llb[i] = (feq(bp->bbox[i], bbox[i], DH / 2)) ? bp->bbox[i] : bp->bbox[i] + ghost_width * DH; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4) + 1; +#else +#ifdef Cell + gs->data->shape[i] = int((gs->data->uub[i] - gs->data->llb[i]) / DH + 0.4); +#else +#error Not define Vertex nor Cell +#endif +#endif + } + gs->data->Bg = BP->data; + gs->next = 0; + } + + if (BP == ble) + break; + BP = BP->next; + } + + return cgsl; +} +void ss_patch::Sync(MyList *VarList, int Symmetry) +{ + int cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + + MyList *dst; + MyList **src, **transfer_src, **transfer_dst; + src = new MyList *[cpusize]; + transfer_src = new MyList *[cpusize]; + transfer_dst = new MyList *[cpusize]; + + dst = build_ghost_gsl(); // ghost region only + for (int node = 0; node < cpusize; node++) + { + src[node] = build_owned_gsl0(node); // for the part without ghost points and do not extend + Parallel::build_gstl(src[node], dst, &transfer_src[node], &transfer_dst[node]); // for transfer[node], data locate on cpu#node + } + + Parallel::transfer(transfer_src, transfer_dst, VarList, VarList, Symmetry); + + if (dst) + dst->destroyList(); + for (int node = 0; node < cpusize; node++) + { + if (src[node]) + src[node]->destroyList(); + if (transfer_src[node]) + transfer_src[node]->destroyList(); + if (transfer_dst[node]) + transfer_dst[node]->destroyList(); + } + + delete[] src; + delete[] transfer_src; + delete[] transfer_dst; +} +//~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +void xp_patch::setupcordtrans() +{ + MyList *BP = blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_xp_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); + f_xpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); + } + if (BP == ble) + break; + BP = BP->next; + } +} +void xm_patch::setupcordtrans() +{ + MyList *BP = blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_xm_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); + f_xpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); + } + if (BP == ble) + break; + BP = BP->next; + } +} +void yp_patch::setupcordtrans() +{ + MyList *BP = blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_yp_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); + f_ypm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); + } + if (BP == ble) + break; + BP = BP->next; + } +} +void ym_patch::setupcordtrans() +{ + MyList *BP = blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_ym_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); + f_ypm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); + } + if (BP == ble) + break; + BP = BP->next; + } +} +void zp_patch::setupcordtrans() +{ + MyList *BP = blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_zp_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); + f_zpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); + } + if (BP == ble) + break; + BP = BP->next; + } +} +void zm_patch::setupcordtrans() +{ + MyList *BP = blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_zm_getxyz(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz]); + f_zpm_getjacobian(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], cg->fgfs[fngfs + ShellPatch::gy], cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], cg->fgfs[fngfs + ShellPatch::drhody], cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], cg->fgfs[fngfs + ShellPatch::dsigmady], cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], cg->fgfs[fngfs + ShellPatch::dRdy], cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], cg->fgfs[fngfs + ShellPatch::drhodxy], cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], cg->fgfs[fngfs + ShellPatch::drhodyz], cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], cg->fgfs[fngfs + ShellPatch::dsigmadxy], cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], cg->fgfs[fngfs + ShellPatch::dsigmadyz], cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], cg->fgfs[fngfs + ShellPatch::dRdxy], cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], cg->fgfs[fngfs + ShellPatch::dRdyz], cg->fgfs[fngfs + ShellPatch::dRdzz]); + } + if (BP == ble) + break; + BP = BP->next; + } +} +ShellPatch::ShellPatch(int ingfsi, int fngfsi, char *filename, int Symmetry, int myranki, monitor *ErrorMonitor) : ingfs(ingfsi), fngfs(fngfsi), myrank(myranki), PatL(0) +{ + int shapei[dim]; + double Rrangei[2]; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of Shell patches" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN") + { + if (skey == "Shell shape") + shapei[sind] = atof(sval.c_str()); + else if (skey == "Shell R range") + Rrangei[sind] = atof(sval.c_str()); + } + } + inf.close(); + } + + for (int i = 0; i < dim; i++) + { + shape[i] = shapei[i]; +// we always assume the input parameter is in cell center style +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + shape[i] = shape[i] + 1; +#endif + } + // change from cardisian r to local corrdinate r + Rrange[0] = getR(Rrangei[0]); + Rrange[1] = getR(Rrangei[1]); + + if (myrank == 0) + { + cout << endl; + cout << " shell's range: [" << Rrange[0] << ":" << Rrange[1] << "]" << endl + << " shape: " << shape[2] << endl + << " resolution: [" << getdX(0) << "," << getdX(1) << "," << getdX(2) << "]" << endl; + } + // extend buffer points for lower boundary + Rrange[0] -= buffer_width * getdX(2); + shape[2] += buffer_width; + + // extend ghost_width points at lower boundary for double cover region + // in input.par we do not ask shell and box have over lap + Rrange[0] -= ghost_width * getdX(2); + shape[2] += ghost_width; + +// extend buffer points for upper boundary if CPBC is used +#ifdef CPBC + + Rrange[1] += CPBC_ghost_width * getdX(2); + shape[2] += CPBC_ghost_width; + +#endif + + double bbox[2 * dim]; + int shape_here[dim]; + bbox[2] = Rrange[0]; + bbox[5] = Rrange[1]; + shape_here[2] = shape[2]; + + switch (Symmetry) + { + case 0: + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] + 2 * overghost; + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new xp_patch(ingfs, fngfs, shape_here, bbox, myrank); + PatL->insert(new xm_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new ym_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new zp_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new zm_patch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + case 1: + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] + 2 * overghost; + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new zp_patch(ingfs, fngfs, shape_here, bbox, myrank); + shape_here[0] = shape[0] + 2 * overghost; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + shape_here[1] = (shape[1] + 1) / 2 + overghost; +#else +#ifdef Cell + shape_here[1] = shape[1] / 2 + overghost; +#else +#error Not define Vertex nor Cell +#endif +#endif + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = 0; + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL->insert(new xp_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_patch(ingfs, fngfs, shape_here, bbox, myrank)); + bbox[0] = -PI / 4 - overghost * getdX(0); + bbox[1] = -PI / 4 - overghost * getdX(1); + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = 0; + PatL->insert(new xm_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new ym_patch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + case 2: +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + for (int i = 0; i < 2; i++) + shape_here[i] = (shape[i] + 1) / 2 + overghost; +#else +#ifdef Cell + for (int i = 0; i < 2; i++) + shape_here[i] = shape[i] / 2 + overghost; +#else +#error Not define Vertex nor Cell +#endif +#endif + bbox[0] = 0; + bbox[1] = 0; + bbox[3] = PI / 4 + overghost * getdX(0); + bbox[4] = PI / 4 + overghost * getdX(1); + PatL = new MyList; + PatL->data = new zp_patch(ingfs, fngfs, shape_here, bbox, myrank); + PatL->insert(new xp_patch(ingfs, fngfs, shape_here, bbox, myrank)); + PatL->insert(new yp_patch(ingfs, fngfs, shape_here, bbox, myrank)); + break; + default: + cout << "not recognized Symmetry type" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } +} +ShellPatch::~ShellPatch() +{ + int nprocs = 1; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + for (int node = 0; node < nprocs; node++) + { + if (ss_src[node]) + destroypsuList(ss_src[node]); + if (ss_dst[node]) + destroypsuList(ss_dst[node]); + if (csatc_src[node]) + destroypsuList(csatc_src[node]); + if (csatc_dst[node]) + destroypsuList(csatc_dst[node]); + if (csats_src[node]) + destroypsuList(csats_src[node]); + if (csats_dst[node]) + destroypsuList(csats_dst[node]); + } + + delete[] ss_src; + delete[] ss_dst; + delete[] csatc_src; + delete[] csatc_dst; + delete[] csats_src; + delete[] csats_dst; + + while (PatL) + { + ss_patch *sPp = PatL->data; + MyList *bg; + while (sPp->blb) + { + if (sPp->blb == sPp->ble) + break; + bg = (sPp->blb->next) ? sPp->blb->next : 0; + delete sPp->blb->data; + delete sPp->blb; + sPp->blb = bg; + } + if (sPp->ble) + { + delete sPp->ble->data; + delete sPp->ble; + } + sPp->blb = sPp->ble = 0; + PatL = PatL->next; + } + PatL->destroyList(); +} +void ShellPatch::destroypsuList(MyList *ct) +{ + MyList *n; + while (ct) + { + n = ct->next; + if (ct->data->coef) + { + delete[] ct->data->coef; + delete[] ct->data->sind; + } + delete ct->data; + delete ct; + ct = n; + } +} +double ShellPatch::getR(double r) +{ + double A = 1, B = 0, r0 = 0, eps = 1; + f_shellcordpar(A, B, r0, eps); + double f = A * (r - r0) + B * sqrt(1 + (r - r0) * (r - r0) / eps); + return f + A * r0 - B * sqrt(1 + r0 * r0 / eps); +} +double ShellPatch::getsr(double R) +{ + double A = 1, B = 0, r0 = 0, eps = 1; + f_shellcordpar(A, B, r0, eps); + double f = R + B; + return r0 + (A * f - B * sqrt(A * A + (f * f - B * B) / eps)) / (A * A - B * B / eps); +} +MyList *ShellPatch::compose_sh(int cpusize, int nodes) +{ +#ifdef USE_GPU_DIVIDE + double cpu_part, gpu_part; + map::iterator iter; + iter = parameters::dou_par.find("cpu part"); + if (iter != parameters::dou_par.end()) + { + cpu_part = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "cpu part") + cpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); + } + iter = parameters::dou_par.find("gpu part"); + if (iter != parameters::dou_par.end()) + { + gpu_part = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "gpu part") + gpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); + } + + if (nodes == 0) + nodes = cpusize / 2; +#else + if (nodes == 0) + nodes = cpusize; +#endif + + if (dim != 3) + { + cout << "distrivute: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + // checkPatch(); + + bool periodic = false; + MyList *BlL = 0; + + int split_size, min_size, block_size = 0; + + int min_width = 2 * Mymax(ghost_width, buffer_width); + int nxyz[dim], mmin_width[dim], min_shape[dim]; + + MyList *PLi = PatL; + for (int i = 0; i < dim; i++) + min_shape[i] = PLi->data->shape[i]; + PLi = PLi->next; + while (PLi) + { + ss_patch *PP = PLi->data; + for (int i = 0; i < dim; i++) + min_shape[i] = Mymin(min_shape[i], PP->shape[i]); + PLi = PLi->next; + } + + for (int i = 0; i < dim; i++) + mmin_width[i] = Mymin(min_width, min_shape[i]); + + min_size = mmin_width[0]; + for (int i = 1; i < dim; i++) + min_size = min_size * mmin_width[i]; + + PLi = PatL; + while (PLi) + { + ss_patch *PP = PLi->data; + // PP->checkPatch(true); + int bs = PP->shape[0]; + for (int i = 1; i < dim; i++) + bs = bs * PP->shape[i]; + block_size = block_size + bs; + PLi = PLi->next; + } + split_size = Mymax(min_size, block_size / nodes); + split_size = Mymax(1, split_size); + + int n_rank = 0; + PLi = PatL; + int reacpu = 0; + while (PLi) + { + ss_patch *PP = PLi->data; + + reacpu += Parallel::partition3(nxyz, split_size, mmin_width, nodes, PP->shape); + + Block *ng, *ng0; + int shape_here[dim], ibbox_here[2 * dim]; + double bbox_here[2 * dim], dd; + + // ibbox : 0,...N-1 + for (int i = 0; i < nxyz[0]; i++) + for (int j = 0; j < nxyz[1]; j++) + for (int k = 0; k < nxyz[2]; k++) + { + ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; + ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; + ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; + ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; + ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; + + if (periodic) + { + ibbox_here[0] = ibbox_here[0] - ghost_width; + ibbox_here[3] = ibbox_here[3] + ghost_width; + ibbox_here[1] = ibbox_here[1] - ghost_width; + ibbox_here[4] = ibbox_here[4] + ghost_width; + ibbox_here[2] = ibbox_here[2] - ghost_width; + ibbox_here[5] = ibbox_here[5] + ghost_width; + } + else + { + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); + ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); + ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); + } + + shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; + shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; + shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); + bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; + bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; +#else +#ifdef Cell + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; + bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; + bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + +#ifdef USE_GPU_DIVIDE + { + const int pices = 2; + double picef[pices]; + picef[0] = cpu_part; + picef[1] = gpu_part; + int shape_res[dim * pices]; + double bbox_res[2 * dim * pices]; + misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_width); + ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfs, fngfs + dRdzz + 1, 0, 0); // delete through KillBlocks + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks + + for (int i = 1; i < pices; i++) + { + ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfs, fngfs + dRdzz + 1, 0, i); // delete through KillBlocks + // ng->checkBlock(); + BlL->insert(ng); + } + } +#else + ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs + dRdzz + 1, 0); // delete through KillBlocks + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks +#endif + if (n_rank == cpusize) + n_rank = 0; + + // set PP->blb + if (i == 0 && j == 0 && k == 0) + { + MyList *Bp = BlL; + while (Bp->data != ng0) + Bp = Bp->next; // ng0 is the first of the pices list + PP->blb = Bp; + } + } + // set PP->ble + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; // ng is the last of the pices list + PP->ble = Bp; + } + PLi = PLi->next; + } + if (reacpu < nodes * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "ShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} +// distribute data only along r direction +MyList *ShellPatch::compose_shr(int cpusize, int nodes) +{ +#ifdef USE_GPU_DIVIDE + double cpu_part, gpu_part; + map::iterator iter; + iter = parameters::dou_par.find("cpu part"); + if (iter != parameters::dou_par.end()) + { + cpu_part = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "cpu part") + cpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("cpu part", cpu_part)); + } + iter = parameters::dou_par.find("gpu part"); + if (iter != parameters::dou_par.end()) + { + gpu_part = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "gpu part") + gpu_part = atof(sval.c_str()); + } + } + inf.close(); + + parameters::dou_par.insert(map::value_type("gpu part", gpu_part)); + } + + if (nodes == 0) + nodes = cpusize / 2; +#else + if (nodes == 0) + nodes = cpusize; +#endif + + if (dim != 3) + { + cout << "ShellPatch::compose_shr: now we only support 3-dimension" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + // checkPatch(); + + bool periodic = false; + MyList *BlL = 0; + + int min_size = 2 * Mymax(ghost_width, buffer_width); + int nxyz[dim]; + + MyList *PLi; + + PLi = PatL; + int reacpu = 0; + while (PLi) + { + // make sure the block with the same r range locate at the same cpu + int n_rank = 0; + ss_patch *PP = PLi->data; + + reacpu += Parallel::partition1(nxyz[2], min_size, min_size, nodes, PP->shape[2]); + nxyz[0] = nxyz[1] = 1; + + Block *ng, *ng0; + int shape_here[dim], ibbox_here[2 * dim]; + double bbox_here[2 * dim], dd; + + // ibbox : 0,...N-1 + for (int i = 0; i < nxyz[0]; i++) + for (int j = 0; j < nxyz[1]; j++) + for (int k = 0; k < nxyz[2]; k++) + { + ibbox_here[0] = (PP->shape[0] * i) / nxyz[0]; + ibbox_here[3] = (PP->shape[0] * (i + 1)) / nxyz[0] - 1; + ibbox_here[1] = (PP->shape[1] * j) / nxyz[1]; + ibbox_here[4] = (PP->shape[1] * (j + 1)) / nxyz[1] - 1; + ibbox_here[2] = (PP->shape[2] * k) / nxyz[2]; + ibbox_here[5] = (PP->shape[2] * (k + 1)) / nxyz[2] - 1; + + if (periodic) + { + ibbox_here[0] = ibbox_here[0] - ghost_width; + ibbox_here[3] = ibbox_here[3] + ghost_width; + ibbox_here[1] = ibbox_here[1] - ghost_width; + ibbox_here[4] = ibbox_here[4] + ghost_width; + ibbox_here[2] = ibbox_here[2] - ghost_width; + ibbox_here[5] = ibbox_here[5] + ghost_width; + } + else + { + ibbox_here[0] = Mymax(0, ibbox_here[0] - ghost_width); + ibbox_here[3] = Mymin(PP->shape[0] - 1, ibbox_here[3] + ghost_width); + ibbox_here[1] = Mymax(0, ibbox_here[1] - ghost_width); + ibbox_here[4] = Mymin(PP->shape[1] - 1, ibbox_here[4] + ghost_width); + ibbox_here[2] = Mymax(0, ibbox_here[2] - ghost_width); + ibbox_here[5] = Mymin(PP->shape[2] - 1, ibbox_here[5] + ghost_width); + } + + shape_here[0] = ibbox_here[3] - ibbox_here[0] + 1; + shape_here[1] = ibbox_here[4] - ibbox_here[1] + 1; + shape_here[2] = ibbox_here[5] - ibbox_here[2] + 1; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (PP->bbox[3] - PP->bbox[0]) / (PP->shape[0] - 1); + bbox_here[0] = PP->bbox[0] + ibbox_here[0] * dd; + bbox_here[3] = PP->bbox[0] + ibbox_here[3] * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / (PP->shape[1] - 1); + bbox_here[1] = PP->bbox[1] + ibbox_here[1] * dd; + bbox_here[4] = PP->bbox[1] + ibbox_here[4] * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / (PP->shape[2] - 1); + bbox_here[2] = PP->bbox[2] + ibbox_here[2] * dd; + bbox_here[5] = PP->bbox[2] + ibbox_here[5] * dd; +#else +#ifdef Cell + dd = (PP->bbox[3] - PP->bbox[0]) / PP->shape[0]; + bbox_here[0] = PP->bbox[0] + (ibbox_here[0]) * dd; + bbox_here[3] = PP->bbox[0] + (ibbox_here[3] + 1) * dd; + + dd = (PP->bbox[4] - PP->bbox[1]) / PP->shape[1]; + bbox_here[1] = PP->bbox[1] + (ibbox_here[1]) * dd; + bbox_here[4] = PP->bbox[1] + (ibbox_here[4] + 1) * dd; + + dd = (PP->bbox[5] - PP->bbox[2]) / PP->shape[2]; + bbox_here[2] = PP->bbox[2] + (ibbox_here[2]) * dd; + bbox_here[5] = PP->bbox[2] + (ibbox_here[5] + 1) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + +#ifdef USE_GPU_DIVIDE + { + const int pices = 2; + double picef[pices]; + picef[0] = cpu_part; + picef[1] = gpu_part; + int shape_res[dim * pices]; + double bbox_res[2 * dim * pices]; + misc::dividBlock(dim, shape_here, bbox_here, pices, picef, shape_res, bbox_res, min_size); + ng = ng0 = new Block(dim, shape_res, bbox_res, n_rank++, ingfs, fngfs + dRdzz + 1, 0, 0); // delete through KillBlocks + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks + + for (int i = 1; i < pices; i++) + { + ng = new Block(dim, shape_res + i * dim, bbox_res + i * 2 * dim, n_rank++, ingfs, fngfs + dRdzz + 1, 0, i); // delete through KillBlocks + // ng->checkBlock(); + BlL->insert(ng); + } + } +#else + ng = ng0 = new Block(dim, shape_here, bbox_here, n_rank++, ingfs, fngfs + dRdzz + 1, 0); // delete through KillBlocks + // ng->checkBlock(); + if (BlL) + BlL->insert(ng); + else + BlL = new MyList(ng); // delete through KillBlocks +#endif + if (n_rank == cpusize) + n_rank = 0; + + // set PP->blb + if (i == 0 && j == 0 && k == 0) + { + MyList *Bp = BlL; + while (Bp->data != ng0) + Bp = Bp->next; // ng0 is the first of the pices list + PP->blb = Bp; + } + } + // set PP->ble + { + MyList *Bp = BlL; + while (Bp->data != ng) + Bp = Bp->next; // ng is the last of the pices list + PP->ble = Bp; + } + PLi = PLi->next; + } + if (reacpu < nodes * 2 / 3) + { + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "ShellPatch::distribute CAUSTION: uses essencially " << reacpu << " processors vs " << nodes << " nodes run, your scientific computation scale is not as large as you estimate." << endl; + } + + return BlL; +} +void ShellPatch::getlocalpox(double x, double y, double z, int &sst, double &lx, double &ly, double &lz) +{ + double r; + r = sqrt(x * x + y * y + z * z); + lz = getR(r); + if (fabs(x) <= z && fabs(y) <= z) + { + sst = 0; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(x) <= -z && fabs(y) <= -z) + { + sst = 1; + lx = atan(x / z); + ly = atan(y / z); + } + else if (fabs(y) <= x && fabs(z) <= x) + { + sst = 2; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(y) <= -x && fabs(z) <= -x) + { + sst = 3; + lx = atan(y / x); + ly = atan(z / x); + } + else if (fabs(x) <= y && fabs(z) <= y) + { + sst = 4; + lx = atan(x / y); + ly = atan(z / y); + } + else if (fabs(x) <= -y && fabs(z) <= -y) + { + sst = 5; + lx = atan(x / y); + ly = atan(z / y); + } + else + { + cout << "ShellPatch::getlocalpox should not come here, something wrong" << endl; + } +} +void ShellPatch::getlocalpoxsst(double x, double y, double z, int sst, double &lx, double &ly, double &lz) +{ + double r; + r = sqrt(x * x + y * y + z * z); + lz = getR(r); + switch (sst) + { + case -1: + lx = x; + ly = y; + lz = z; + break; + case 0: + lx = atan(x / z); + ly = atan(y / z); + break; + case 1: + lx = atan(x / z); + ly = atan(y / z); + break; + case 2: + lx = atan(y / x); + ly = atan(z / x); + break; + case 3: + lx = atan(y / x); + ly = atan(z / x); + break; + case 4: + lx = atan(x / y); + ly = atan(z / y); + break; + case 5: + lx = atan(x / y); + ly = atan(z / y); + break; + default: + cout << "ShellPatch::getlocalpoxsst should not come here, something wrong" << endl; + } +} +void ShellPatch::getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz) +{ + double r = getsr(lz); + switch (sst) + { + case 0: + x = tan(lx); + y = tan(ly); + z = r / sqrt(1 + x * x + y * y); + x = z * x; + y = z * y; + break; + case 1: + x = tan(lx); + y = tan(ly); + z = -r / sqrt(1 + x * x + y * y); + x = z * x; + y = z * y; + break; + case 2: + y = tan(lx); + z = tan(ly); + x = r / sqrt(1 + z * z + y * y); + y = x * y; + z = x * z; + break; + case 3: + y = tan(lx); + z = tan(ly); + x = -r / sqrt(1 + z * z + y * y); + y = x * y; + z = x * z; + break; + case 4: + x = tan(lx); + z = tan(ly); + y = r / sqrt(1 + x * x + z * z); + x = y * x; + z = y * z; + break; + case 5: + x = tan(lx); + z = tan(ly); + y = -r / sqrt(1 + x * x + z * z); + x = y * x; + z = y * z; + break; + } +} +// from to +// dumyd refer to 'from' +int ShellPatch::getdumydimension(int acsst, int posst) // -1 means no dumy dimension +{ + int dms; + if (acsst == -1 || posst == -1) + return -1; + switch (acsst) + { + case 0: + case 1: + switch (posst) + { + case 0: + case 1: + cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + case 2: + case 3: + return 0; + case 4: + case 5: + return 1; + default: + cout << "error in ShellPatch::getdumydimension: posst = " << posst << endl; + return -1; + } + case 2: + case 3: + switch (posst) + { + case 0: + case 1: + return 1; + case 2: + case 3: + cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + case 4: + case 5: + return 0; + default: + cout << "error in ShellPatch::getdumydimension: posst = " << posst << endl; + return -1; + } + case 4: + case 5: + switch (posst) + { + case 0: + case 1: + return 1; + case 2: + case 3: + return 0; + case 4: + case 5: + cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << ", posst = " << posst << endl; + return -1; + default: + cout << "error in ShellPatch::getdumydimension: posst = " << posst << endl; + return -1; + } + default: + cout << "error in ShellPatch::getdumydimension: acsst = " << acsst << endl; + return -1; + } +} +// used by _dst construction, so these x,y,z must coinside with grid point +// we have considered ghost points now +void ShellPatch::prolongpointstru(MyList *&psul, MyList *sPpi, double DH[dim], + MyList *Ppi, double CDH[dim], MyList *pss) +{ + int n_dst = 0; + MyList *sPp = sPpi; + MyList *Pp = Ppi; + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz; + + if (pss->data->tsst >= 0) + { + getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, + lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == pss->data->tsst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + { + for (int j = 0; j < dim; j++) + { + llb[j] = Bg->bbox[j]; + uub[j] = Bg->bbox[j + dim]; + } + + if (lx > llb[0] - 0.1 * DH[0] && lx < uub[0] + 0.1 * DH[0] && + ly > llb[1] - 0.1 * DH[1] && ly < uub[1] + 0.1 * DH[1] && + lz > llb[2] - 0.1 * DH[2] && lz < uub[2] + 0.1 * DH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = 0; + for (int i = 0; i < dim; i++) + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = pss->data->ssst; + ps->data->tsst = sPp->data->sst; + ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); + ps->data->Bg = Bg; + ps->data->coef = 0; + ps->data->sind = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + n_dst++; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + } + else + { + if (pss->data->tsst != -1) + cout << "somthing is wrong in ShellPatch::prolongpointstru" << endl; + lx = pss->data->gpox[0]; + ly = pss->data->gpox[1]; + lz = pss->data->gpox[2]; + while (Pp) + { + Bgl = Pp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + { + for (int j = 0; j < dim; j++) + { + llb[j] = Bg->bbox[j]; + uub[j] = Bg->bbox[j + dim]; + } + + if (lx > llb[0] - 0.1 * CDH[0] && lx < uub[0] + 0.1 * CDH[0] && + ly > llb[1] - 0.1 * CDH[1] && ly < uub[1] + 0.1 * CDH[1] && + lz > llb[2] - 0.1 * CDH[2] && lz < uub[2] + 0.1 * CDH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = 0; + for (int i = 0; i < dim; i++) + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = pss->data->ssst; + ps->data->tsst = -1; + ps->data->dumyd = getdumydimension(ps->data->tsst, ps->data->ssst); + ps->data->Bg = Bg; + ps->data->coef = 0; + ps->data->sind = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + n_dst++; + } + } + if (Bgl == Pp->data->ble) + break; + Bgl = Bgl->next; + } + Pp = Pp->next; + } + } + // if n_dst > 0, that's because of ghost_points + if (n_dst == 0) + { + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + cout << "ShellPatch::prolongpointstru fail to find target Block for pointstru:" << endl; + check_pointstrul(pss, true); + if (Pp == Ppi) + { + getlocalpoxsst(pss->data->gpox[0], pss->data->gpox[1], pss->data->gpox[2], pss->data->tsst, + lx, ly, lz); + if (myrank == 0) + cout << "sst = " << pss->data->tsst << ", lx,ly,lz = " << lx << "," << ly << "," << lz << endl; + checkBlock(pss->data->tsst); + } + else + { + Pp = Ppi; + while (Pp) + { + Pp->data->checkBlock(); + Pp = Pp->next; + } + } + if (myrank == 0) + MPI_Abort(MPI_COMM_WORLD, 1); + } + else + { + MyList *ts = 0; + for (int i = 1; i < n_dst; i++) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->next = (i == n_dst - 1) ? pss->next : 0; + for (int i = 0; i < dim; i++) + { + ps->data->gpox[i] = pss->data->gpox[i]; + ps->data->lpox[i] = pss->data->lpox[i]; + } + ps->data->ssst = pss->data->ssst; + ps->data->tsst = pss->data->tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->Bg = pss->data->Bg; + ps->data->coef = 0; + ps->data->sind = 0; + if (ts) + ts->catList(ps); + else + ts = ps; + } + if (ts) + pss->next = ts; + } +} +// used by _src construction, so these x,y,z do not coinside with grid point +bool ShellPatch::prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in) +{ + MyList *Bgl; + Block *Bg; + double llb[dim], uub[dim]; + double lx, ly, lz; + + if (ssyn) + { + int sst; + getlocalpox(x, y, z, sst, lx, ly, lz); + while (sPp) + { + if (sPp->data->sst == sst) + { + Bgl = sPp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < 2; j++) + { + if (feq(Bg->bbox[j], -PI / 4 - overghost * DH[j], DH[j] / 2)) + llb[j] = -PI / 4; + else if (feq(Bg->bbox[j], sPp->data->bbox[j], DH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * DH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * DH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], PI / 4 + overghost * DH[j], DH[j] / 2)) + uub[j] = PI / 4; + else if (feq(Bg->bbox[dim + j], sPp->data->bbox[dim + j], DH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * DH[j]; + } + if (feq(Bg->bbox[2], sPp->data->bbox[2], DH[2] / 2)) + llb[2] = Bg->bbox[2]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[2] = Bg->bbox[2] + (ghost_width - 1) * DH[2]; +#else +#ifdef Cell + else + llb[2] = Bg->bbox[2] + ghost_width * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + 2], sPp->data->bbox[dim + 2], DH[2] / 2)) + uub[2] = Bg->bbox[dim + 2]; + else + uub[2] = Bg->bbox[dim + 2] - ghost_width * DH[2]; + if (lx > llb[0] - 0.0001 * DH[0] && lx < uub[0] + 0.0001 * DH[0] && + ly > llb[1] - 0.0001 * DH[1] && ly < uub[1] + 0.0001 * DH[1] && + lz > llb[2] - 0.0001 * DH[2] && lz < uub[2] + 0.0001 * DH[2]) // even ghost_width-1 the region is like |----|----| + // ^ + // so for ^ point may miss for vertext center, so we use 0.0001 + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = x; + ps->data->gpox[1] = y; + ps->data->gpox[2] = z; + ps->data->lpox[0] = lx; + ps->data->lpox[1] = ly; + ps->data->lpox[2] = lz; + ps->data->ssst = sPp->data->sst; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == sPp->data->ble) + break; + Bgl = Bgl->next; + } + } + sPp = sPp->next; + } + } + else + { + while (Pp) + { + Bgl = Pp->data->blb; + while (Bgl) + { + Bg = Bgl->data; + if (Bg->rank == rank_in) + { + for (int j = 0; j < dim; j++) + { + if (feq(Bg->bbox[j], Pp->data->bbox[j], CDH[j] / 2)) + llb[j] = Bg->bbox[j]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + llb[j] = Bg->bbox[j] + (ghost_width - 1) * CDH[j]; +#else +#ifdef Cell + else + llb[j] = Bg->bbox[j] + ghost_width * CDH[j]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (feq(Bg->bbox[dim + j], Pp->data->bbox[dim + j], CDH[j] / 2)) + uub[j] = Bg->bbox[dim + j]; + else + uub[j] = Bg->bbox[dim + j] - ghost_width * CDH[j]; + } + if (x > llb[0] - 0.0001 * CDH[0] && x < uub[0] + 0.0001 * CDH[0] && + y > llb[1] - 0.0001 * CDH[1] && y < uub[1] + 0.0001 * CDH[1] && + z > llb[2] - 0.0001 * CDH[2] && z < uub[2] + 0.0001 * CDH[2]) + { + MyList *ps = new MyList; + ps->data = new pointstru; + ps->data->Bg = Bg; + ps->data->gpox[0] = x; + ps->data->gpox[1] = y; + ps->data->gpox[2] = z; + ps->data->lpox[0] = x; + ps->data->lpox[1] = y; + ps->data->lpox[2] = z; + ps->data->ssst = -1; + ps->data->tsst = tsst; + ps->data->dumyd = getdumydimension(ps->data->ssst, ps->data->tsst); + ps->data->coef = 0; + ps->data->sind = 0; + ps->next = 0; + if (psul) + psul->catList(ps); + else + psul = ps; + return true; + } + } + if (Bgl == Pp->data->ble) + break; + Bgl = Bgl->next; + } + Pp = Pp->next; + } + } + + return false; +} + +// setup interpatch interpolation stuffs +void ShellPatch::setupintintstuff(int cpusize, MyList *CPatL, int Symmetry) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) { + cout << endl; + cout << " ShellPatch::setup interpatch interpolation stuffs begines..." << endl; + } + + ss_src = new MyList *[cpusize]; + ss_dst = new MyList *[cpusize]; + csatc_src = new MyList *[cpusize]; + csatc_dst = new MyList *[cpusize]; + csats_src = new MyList *[cpusize]; + csats_dst = new MyList *[cpusize]; + + MyList *ps, *ts; + MyList *sPp; + MyList *Bgl; + MyList *Pp; + Block *Bg; + double CDH[dim], DH[dim], llb[dim], uub[dim]; + double x, y, z; + + for (int i = 0; i < dim; i++) + { + CDH[i] = CPatL->data->getdX(i); + DH[i] = getdX(i); + } + + for (int i = 0; i < cpusize; i++) + { + ss_src[i] = 0; + csatc_src[i] = 0; + csats_src[i] = 0; + ss_dst[i] = 0; + csatc_dst[i] = 0; + csats_dst[i] = 0; + } + + sPp = PatL; + while (sPp) + { + for (int iz = 0; iz < sPp->data->shape[2]; iz++) + for (int is = 0; is < sPp->data->shape[1]; is++) + for (int ir = 0; ir < sPp->data->shape[0]; ir++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = sPp->data->bbox[0] + ir * DH[0]; + y = sPp->data->bbox[1] + is * DH[1]; + z = sPp->data->bbox[2] + iz * DH[2]; +#else +#ifdef Cell + x = sPp->data->bbox[0] + (ir + 0.5) * DH[0]; + y = sPp->data->bbox[1] + (is + 0.5) * DH[1]; + z = sPp->data->bbox[2] + (iz + 0.5) * DH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (z < sPp->data->bbox[2] + (SC_width + 0.0001) * DH[2]) + { + double gx, gy, gz; + getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); + bool flag = false; + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(csats_src[i], false, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); + if (flag) + break; + } + if (!flag) + { + CPatL->data->checkBlock(); + if (myrank == 0) + { + cout << "ShellPatch::prolongpointstru fail to find cardisian source point for" << endl; + cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; + cout << "x,y,z = " << gx << "," << gy << "," << gz << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + // else if(x<-PI/4-(overghost-ghost_width-0.0001)*DH[0] || x>PI/4+(overghost-ghost_width-0.0001)*DH[0] || + // y<-PI/4-(overghost-ghost_width-0.0001)*DH[1] || y>PI/4+(overghost-ghost_width-0.0001)*DH[1] ) //0.0001 is for vertex center + if (x < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[0] || x > PI / 4 + (overghost - ghost_width - 0.0001) * DH[0] || + y < -PI / 4 - (overghost - ghost_width - 0.0001) * DH[1] || y > PI / 4 + (overghost - ghost_width - 0.0001) * DH[1]) + { + double gx, gy, gz; + getglobalpox(gx, gy, gz, sPp->data->sst, x, y, z); + bool flag = false; + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(ss_src[i], true, sPp->data->sst, PatL, DH, CPatL, CDH, gx, gy, gz, Symmetry, i); + if (flag) + break; + } + if (!flag) + { + if (myrank == 0) + { + cout << "ShellPatch::prolongpointstru fail to find shell source point for" << endl; + cout << "sst = " << sPp->data->sst << " lx,ly,lz = " << x << "," << y << "," << z << endl; + if (sPp->data->sst == -1) + cout << "your angular resolution for shell is too coarse?" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + sPp = sPp->next; + } + if (myrank == 0) + cout << " ShellPatch::setup interpatch interpolation stuffs ss_src completes" << endl; + + Pp = CPatL; + while (Pp) + { + double llb[dim], uub[dim]; + if (Symmetry > 0) + llb[2] = Pp->data->bbox[2] - 0.0001 * CDH[2]; + else + llb[2] = Pp->data->bbox[2] + (CS_width + 0.0001) * CDH[2]; + uub[2] = Pp->data->bbox[dim + 2] - (CS_width + 0.0001) * CDH[2]; + for (int j = 0; j < 2; j++) + { + if (Symmetry > 1) + llb[j] = Pp->data->bbox[j] - 0.0001 * CDH[j]; + else + llb[j] = Pp->data->bbox[j] + (CS_width + 0.0001) * CDH[j]; + uub[j] = Pp->data->bbox[dim + j] - (CS_width + 0.0001) * CDH[j]; + } + for (int iz = 0; iz < Pp->data->shape[2]; iz++) + for (int iy = 0; iy < Pp->data->shape[1]; iy++) + for (int ix = 0; ix < Pp->data->shape[0]; ix++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + x = Pp->data->bbox[0] + ix * CDH[0]; + y = Pp->data->bbox[1] + iy * CDH[1]; + z = Pp->data->bbox[2] + iz * CDH[2]; +#else +#ifdef Cell + x = Pp->data->bbox[0] + (ix + 0.5) * CDH[0]; + y = Pp->data->bbox[1] + (iy + 0.5) * CDH[1]; + z = Pp->data->bbox[2] + (iz + 0.5) * CDH[2]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (x < llb[0] || x > uub[0] || + y < llb[1] || y > uub[1] || + z < llb[2] || z > uub[2]) + { + int sst; + double lx, ly, lz; + bool flag = false; + getlocalpox(x, y, z, sst, lx, ly, lz); + for (int i = 0; i < cpusize; i++) + { + flag = prolongpointstru(csatc_src[i], true, -1, PatL, DH, CPatL, CDH, x, y, z, Symmetry, i); + if (flag) + break; + } + if (!flag) + { + if (myrank == 0) + { + cout << "ShellPatch::prolongpointstru fail to find shell source point for" << endl; + cout << "sst = -1, x,y,z = " << x << "," << y << "," << z << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + } + } + Pp = Pp->next; + } + if (myrank == 0) + cout << " ShellPatch::setup interpatch interpolation stuffs csatc_src and csats_src completes" << endl; + + for (int i = 0; i < cpusize; i++) + { + ps = ss_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(ss_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + + ps = csatc_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(csatc_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + ps = csats_src[i]; + while (ps) + { + ts = ps->next; + prolongpointstru(csats_dst[i], PatL, DH, CPatL, CDH, ps); // ps may be insterted more here + ps = ts; + } + } + if (myrank == 0) + cout << " ShellPatch::ssetup interpatch interpolation stuffs ss_dst and csatc_dst, csats_dst complete" << endl; + + /* + for(int i=0;inext; + ts=ts->next; + } + } + exit(0); + */ +} + +void ShellPatch::setupcordtrans() +{ + MyList *PP = PatL; + while (PP) + { + PP->data->setupcordtrans(); + PP = PP->next; + } +} + +void ShellPatch::checkPatch() +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << " belong to Shell Patchs " << endl; + MyList *Pp = PatL; + while (Pp) + { + cout << " shape: ["; + for (int i = 0; i < dim; i++) + { + cout << Pp->data->shape[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << " range:" << "("; + for (int i = 0; i < dim; i++) + { + cout << Pp->data->bbox[i] << ":" << Pp->data->bbox[dim + i]; + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + Pp = Pp->next; + } + } +} + +void ShellPatch::checkBlock(int sst) +{ + if (myrank == 0) + { + cout << "checking shell patch sst = " << sst << endl; + MyList *Pp = PatL; + while (Pp) + { + if (Pp->data->sst == sst) + { + MyList *BP = Pp->data->blb; + while (BP) + { + BP->data->checkBlock(); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + } + Pp = Pp->next; + } + } +} + +double ShellPatch::getdX(int dir) +{ + if (dir < 0 || dir >= dim) + { + cout << "ShellPatch::getdX: error input dir = " << dir << ", this Patch has direction (0," << dim - 1 << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double h; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (shape[dir] == 1) + { + cout << "ShellPatch::getdX: for direction " << dir << ", this Patch has only one point. Can not determine dX for vertex center grid." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + if (dir < 2) + h = PI / 2 / (shape[dir] - 1); + else + h = (Rrange[1] - Rrange[0]) / (shape[dir] - 1); +#else +#ifdef Cell + if (dir < 2) + h = PI / 2 / shape[dir]; + else + h = (Rrange[1] - Rrange[0]) / shape[dir]; +#else +#error Not define Vertex nor Cell +#endif +#endif + return h; +} + +void ShellPatch::shellname(char *sn, int i) +{ + switch (i) + { + case 0: + sprintf(sn, "zp"); + return; + case 1: + sprintf(sn, "zm"); + return; + case 2: + sprintf(sn, "xp"); + return; + case 3: + sprintf(sn, "xm"); + return; + case 4: + sprintf(sn, "yp"); + return; + case 5: + sprintf(sn, "ym"); + return; + } +} +// Now we dump the data including overlap points +void ShellPatch::Dump_xyz(char *tag, double time, double dT) +{ + MyList *PP = PatL; + while (PP) + { + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); + if (!databuffer) + { + cout << "ShellPatch::Dump_xyz: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + for (int DumpList = fngfs + gx; DumpList <= fngfs + gz; DumpList++) + { + MyList *Bp = PP->data->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[DumpList], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[DumpList], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->data->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + + string out_dir; + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + char filename[100]; + char sn[3]; + shellname(sn, PP->data->sst); + switch (DumpList - fngfs) + { + case gx: + if (tag) + sprintf(filename, "%s/%s_LevSH-%s_x_%05d.bin", out_dir.c_str(), tag, sn, ncount); + else + sprintf(filename, "%s/LevSH-%s_x_%05d.bin", out_dir.c_str(), sn, ncount); + break; + case gy: + if (tag) + sprintf(filename, "%s/%s_LevSH-%s_y_%05d.bin", out_dir.c_str(), tag, sn, ncount); + else + sprintf(filename, "%s/LevSH-%s_y_%05d.bin", out_dir.c_str(), sn, ncount); + break; + case gz: + if (tag) + sprintf(filename, "%s/%s_LevSH-%s_z_%05d.bin", out_dir.c_str(), tag, sn, ncount); + else + sprintf(filename, "%s/LevSH-%s_z_%05d.bin", out_dir.c_str(), sn, ncount); + break; + } + + Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], + PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], + PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); + } + } + + if (myrank == 0) + free(databuffer); + + PP = PP->next; + } +} + +void ShellPatch::Dump_Data(MyList *DumpListi, char *tag, double time, double dT) +{ + MyList *PP = PatL; + while (PP) + { + // round at 4 and 5 + int ncount = int(time / dT + 0.5); + + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->data->shape[0] * PP->data->shape[1] * PP->data->shape[2]); + if (!databuffer) + { + cout << "ShellPatch::Dump_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *DumpList = DumpListi; + while (DumpList) + { + var *VP = DumpList->data; + + MyList *Bp = PP->data->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->data->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->data->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->data->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->data->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->data->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->data->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->data->bbox, PP->data->bbox + DIM, PP->data->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->data->ble) + break; + Bp = Bp->next; + } + if (myrank == 0) + { + + string out_dir; + map::iterator iter; + iter = parameters::str_par.find("output dir"); + if (iter != parameters::str_par.end()) + { + out_dir = iter->second; + } + else + { + // read parameter from file + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "ABE") + { + if (skey == "output dir") + out_dir = sval; + } + } + inf.close(); + + parameters::str_par.insert(map::value_type("output dir", out_dir)); + } + + char filename[100]; + char sn[3]; + shellname(sn, PP->data->sst); + if (tag) + sprintf(filename, "%s/%s_LevSH-%s_%s_%05d.bin", out_dir.c_str(), tag, sn, VP->name, ncount); + else + sprintf(filename, "%s/LevSH-%s_%s_%05d.bin", out_dir.c_str(), sn, VP->name, ncount); + + Parallel::writefile(time, PP->data->shape[0], PP->data->shape[1], PP->data->shape[2], + PP->data->bbox[0], PP->data->bbox[3], PP->data->bbox[1], PP->data->bbox[4], + PP->data->bbox[2], PP->data->bbox[5], filename, databuffer); + } + DumpList = DumpList->next; + } + + if (myrank == 0) + free(databuffer); + + PP = PP->next; + } +} + +double *ShellPatch::Collect_Data(ss_patch *PP, var *VP) +{ + MPI_Status sta; + int DIM = 3; + double llb[3], uub[3]; + double DX, DY, DZ; + + double *databuffer = 0; + if (myrank == 0) + { + databuffer = (double *)malloc(sizeof(double) * PP->shape[0] * PP->shape[1] * PP->shape[2]); + if (!databuffer) + { + cout << "ShellPatch::Collect_Data: out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + MyList *Bp = PP->blb; + while (Bp) + { + Block *BP = Bp->data; + if (BP->rank == 0 && myrank == 0) + { + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, BP->fgfs[VP->sgfn], llb, uub); + } + else + { + int nnn = (BP->shape[0]) * (BP->shape[1]) * (BP->shape[2]); + if (myrank == 0) + { + double *bufferhere = (double *)malloc(sizeof(double) * nnn); + if (!bufferhere) + { + cout << "on node#" << myrank << ", out of memory when dumping data." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Recv(bufferhere, nnn, MPI_DOUBLE, BP->rank, 0, MPI_COMM_WORLD, &sta); + DX = BP->getdX(0); + DY = BP->getdX(1); + DZ = BP->getdX(2); + llb[0] = (feq(BP->bbox[0], PP->bbox[0], DX / 2)) ? BP->bbox[0] : BP->bbox[0] + ghost_width * DX; + llb[1] = (feq(BP->bbox[1], PP->bbox[1], DY / 2)) ? BP->bbox[1] : BP->bbox[1] + ghost_width * DY; + llb[2] = (feq(BP->bbox[2], PP->bbox[2], DZ / 2)) ? BP->bbox[2] : BP->bbox[2] + ghost_width * DZ; + uub[0] = (feq(BP->bbox[3], PP->bbox[3], DX / 2)) ? BP->bbox[3] : BP->bbox[3] - ghost_width * DX; + uub[1] = (feq(BP->bbox[4], PP->bbox[4], DY / 2)) ? BP->bbox[4] : BP->bbox[4] - ghost_width * DY; + uub[2] = (feq(BP->bbox[5], PP->bbox[5], DZ / 2)) ? BP->bbox[5] : BP->bbox[5] - ghost_width * DZ; + f_copy(DIM, PP->bbox, PP->bbox + DIM, PP->shape, databuffer, BP->bbox, BP->bbox + DIM, BP->shape, bufferhere, llb, uub); + free(bufferhere); + } + else if (myrank == BP->rank) + { + MPI_Send(BP->fgfs[VP->sgfn], nnn, MPI_DOUBLE, 0, 0, MPI_COMM_WORLD); + } + } + if (Bp == PP->ble) + break; + Bp = Bp->next; + } + + return databuffer; +} + +void ShellPatch::intertransfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry) +{ + int myrank, cpusize; + MPI_Comm_size(MPI_COMM_WORLD, &cpusize); + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int node; + + MPI_Request *reqs; + MPI_Status *stats; + reqs = new MPI_Request[2 * cpusize]; + stats = new MPI_Status[2 * cpusize]; + int req_no = 0; + + double **send_data, **rec_data; + send_data = new double *[cpusize]; + rec_data = new double *[cpusize]; + int length; + + for (node = 0; node < cpusize; node++) + { + send_data[node] = rec_data[node] = 0; + if (node == myrank) + { + if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 1" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(rec_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + } + } + else + { + // send from this cpu to cpu#node + if (length = interdata_packer(0, src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry)) + { + send_data[node] = new double[length]; + if (!send_data[node]) + { + cout << "out of memory when new in short transfer, place 2" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + interdata_packer(send_data[node], src[myrank], dst[myrank], node, PACK, VarList1, VarList2, Symmetry); + MPI_Isend((void *)send_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + // receive from cpu#node to this cpu + if (length = interdata_packer(0, src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry)) + { + rec_data[node] = new double[length]; + if (!rec_data[node]) + { + cout << "out of memory when new in short transfer, place 3" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + MPI_Irecv((void *)rec_data[node], length, MPI_DOUBLE, node, 1, MPI_COMM_WORLD, reqs + req_no++); + } + } + } + // wait for all requests to complete + MPI_Waitall(req_no, reqs, stats); + + for (node = 0; node < cpusize; node++) + if (rec_data[node]) + interdata_packer(rec_data[node], src[node], dst[node], node, UNPACK, VarList1, VarList2, Symmetry); + + for (node = 0; node < cpusize; node++) + { + if (send_data[node]) + delete[] send_data[node]; + if (rec_data[node]) + delete[] rec_data[node]; + } + + delete[] reqs; + delete[] stats; + delete[] send_data; + delete[] rec_data; +} +// PACK: prepare target data in 'data' +// UNPACK: copy target data from 'data' to corresponding numerical grids +int ShellPatch::interdata_packer(double *data, MyList *src, MyList *dst, int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, int Symmetry) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int DIM = dim; + int ordn = 2 * ghost_width; + + if (dir != PACK && dir != UNPACK) + { + cout << "error dir " << dir << " for data_packer " << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + int size_out = 0; + + if (!src || !dst) + return size_out; + + MyList *varls, *varld; + + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + varls = varls->next; + varld = varld->next; + } + + if (varls || varld) + { + cout << "error in short data packer, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + while (src && dst) + { + if ((dir == PACK && dst->data->Bg->rank == rank_in && src->data->Bg->rank == myrank) || + (dir == UNPACK && src->data->Bg->rank == rank_in && dst->data->Bg->rank == myrank)) + { + varls = VarLists; + varld = VarListd; + while (varls && varld) + { + if (data) + { + if (dir == PACK) + { + /* + f_global_interp(src->data->Bg->shape,src->data->Bg->X[0],src->data->Bg->X[1],src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn],data[size_out], + src->data->lpox[0],src->data->lpox[1],src->data->lpox[2],ordn,varls->data->SoA,Symmetry); + */ + int DIMh = (src->data->dumyd == -1) ? dim : 1; + if (src->data->coef == 0) + { + src->data->coef = new double[ordn * DIMh]; + src->data->sind = new int[dim]; + if (DIMh == 3) + { + for (int i = 0; i < DIMh; i++) + { + double dd = src->data->Bg->getdX(i); + // 0.001 instead of 0.4 makes the point locate more center + src->data->sind[i] = int((src->data->lpox[i] - src->data->Bg->X[i][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = src->data->Bg->X[i][0] + (src->data->sind[i] + j) * dd; + src->data->coef[i * ordn + j] = 1; + for (int k = 0; k < j; k++) + { + h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; + src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = src->data->Bg->X[i][0] + (src->data->sind[i] + k) * dd; + src->data->coef[i * ordn + j] *= (src->data->lpox[i] - h2) / (h1 - h2); + } + } + } + } + else + { + int actd = 1 - src->data->dumyd; + double dd = src->data->Bg->getdX(actd); + src->data->sind[0] = int((src->data->lpox[actd] - src->data->Bg->X[actd][0]) / dd) - ordn / 2 + 1; + double h1, h2; + for (int j = 0; j < ordn; j++) + { + h1 = src->data->Bg->X[actd][0] + (src->data->sind[0] + j) * dd; + src->data->coef[j] = 1; + for (int k = 0; k < j; k++) + { + h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; + src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); + } + for (int k = j + 1; k < ordn; k++) + { + h2 = src->data->Bg->X[actd][0] + (src->data->sind[0] + k) * dd; + src->data->coef[j] *= (src->data->lpox[actd] - h2) / (h1 - h2); + } + } + src->data->sind[2] = int((src->data->lpox[2] - src->data->Bg->X[2][0]) / src->data->Bg->getdX(2) + 0.001); + if (!feq(src->data->Bg->X[2][src->data->sind[2]], src->data->lpox[2], src->data->Bg->getdX(2) / 2000)) + cout << "error in ShellPatch::interdata_packer point = " << src->data->lpox[2] << " != grid " << src->data->Bg->X[2][src->data->sind[2]] << endl; + src->data->sind[1] = int((src->data->lpox[src->data->dumyd] - src->data->Bg->X[src->data->dumyd][0]) / + src->data->Bg->getdX(src->data->dumyd) + + 0.001); + if (!feq(src->data->Bg->X[src->data->dumyd][src->data->sind[1]], src->data->lpox[src->data->dumyd], src->data->Bg->getdX(src->data->dumyd) / 2000)) + cout << "error in ShellPatch::interdata_packer for dumy dimension point = " + << src->data->lpox[src->data->dumyd] << " != grid " << src->data->Bg->X[src->data->dumyd][src->data->sind[1]] << endl; + } + } + // interpolate + switch (DIMh) + { + case 3: + f_global_interpind(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst); + break; + case 2: + f_global_interpind2d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst); + break; + case 1: + f_global_interpind1d(src->data->Bg->shape, src->data->Bg->X[0], src->data->Bg->X[1], src->data->Bg->X[2], + src->data->Bg->fgfs[varls->data->sgfn], data[size_out], + src->data->lpox[0], src->data->lpox[1], src->data->lpox[2], ordn, varls->data->SoA, Symmetry, + src->data->sind, src->data->coef, src->data->ssst, src->data->dumyd); + break; + default: + cout << "ShellPatch::interdata_packer: not recognized DIM = " << DIMh << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + if (dir == UNPACK) // from target data to corresponding grid + f_pointcopy(DIM, dst->data->Bg->bbox, dst->data->Bg->bbox + dim, dst->data->Bg->shape, dst->data->Bg->fgfs[varld->data->sgfn], + dst->data->lpox[0], dst->data->lpox[1], dst->data->lpox[2], data[size_out]); + } + size_out += 1; + varls = varls->next; + varld = varld->next; + } + } + dst = dst->next; + src = src->next; + } + + return size_out; +} +void ShellPatch::Synch(MyList *VarList, int Symmetry) +{ + MyList *Pp = PatL; + while (Pp) + { + Pp->data->Sync(VarList, Symmetry); + Pp = Pp->next; + } + + intertransfer(ss_src, ss_dst, VarList, VarList, Symmetry); +} + +void ShellPatch::CS_Inter(MyList *VarList, int Symmetry) +{ + // fill shell first + intertransfer(csats_src, csats_dst, VarList, VarList, Symmetry); + // fill box then + intertransfer(csatc_src, csatc_dst, VarList, VarList, Symmetry); +} + +void ShellPatch::check_pointstrul(MyList *pp, bool first_only) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + if (!pp) + cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; + else + cout << "checking check_pointstrul..." << endl; + while (pp) + { + if (pp->data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + if (first_only) + return; + pp = pp->next; + } + } +} + +void ShellPatch::check_pointstrul2(MyList *pp, int first_last_only) +{ + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + if (!pp) + cout << "ShellPatch::check_pointstrul meets empty pointstru" << endl; + else + cout << "checking check_pointstrul..." << endl; + while (pp) + { + if (first_last_only == 2) + { + if (pp->next == 0) + { + if (pp->data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + } + } + else + { + if (pp->data->Bg) + cout << "on node#" << pp->data->Bg->rank << endl; + else + cout << "virtual pointstru" << endl; + cout << "source sst = " << pp->data->ssst << endl; + cout << "target sst = " << pp->data->tsst << endl; + cout << "dumy dimension = " << pp->data->dumyd << endl; + cout << "global coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->gpox[i] << ","; + else + cout << pp->data->gpox[i] << ")" << endl; + } + cout << "local coordinates: ("; + for (int i = 0; i < dim; i++) + { + if (i < dim - 1) + cout << pp->data->lpox[i] << ","; + else + cout << pp->data->lpox[i] << ")" << endl; + } + if (first_last_only == 1) + return; + } + pp = pp->next; + } + } +} + +void ShellPatch::matchcheck(MyList *CPatL) +{ + double cbd = CPatL->data->bbox[dim]; + for (int i = 1; i < dim; i++) + cbd = Mymin(cbd, CPatL->data->bbox[dim + i]); + cbd = cbd - getsr(Rrange[0]); + double dr, dc; + dc = CPatL->data->getdX(0); + dr = getdX(2); + for (int i = 1; i < dim; i++) + { + dc = Mymax(dc, CPatL->data->getdX(i)); + // dr = Mymax(dr,getdX(i)); + } + + int ir, ic; + ir = int(cbd / dr); + ic = int(cbd / dc); + if (Mymin(ir, ic) < 3 * ghost_width) // 3 because we need 1 for double cover region + { + int myrank = 0; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << "Shell Patches insert too shallow:" << endl; + cout << "distantance between these two boundaries is " << cbd << ", spatial step is " << Mymax(dc, dr) << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +} + +void ShellPatch::Interp_Points(MyList *VarList, + int NN, double **XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry) +{ + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[NN * num_var]; + memset(shellf, 0, sizeof(double) * NN * num_var); + + // we use weight to monitor code, later some day we can move it for optimization + int *weight; + weight = new int[NN]; + memset(weight, 0, sizeof(int) * NN); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + int sst; + getlocalpox(XX[0][j], XX[1][j], XX[2][j], sst, pox[0], pox[1], pox[2]); + + MyList *sPp = PatL; + while (sPp->data->sst != sst) + sPp = sPp->next; + + if (myrank == 0 && ((!sPp) || pox[2] < Rrange[0] || pox[2] > Rrange[1])) + { + cout << "ShellPatch::Interp_Points: point ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k][j]; + if (k < dim - 1) + cout << ","; + else + cout << ") is out of the ShellPatch." << endl; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (!sPp) + return; + + MyList *Bp = sPp->data->blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +// +// because of getlocalpox, pox will not goes into overghost region of ss_patch +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp_ss(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry, sst); + varl = varl->next; + k++; + } + weight[j] = 1; + } + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + } + + MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + int *Weight; + Weight = new int[NN]; + MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + + for (int i = 0; i < NN; i++) + { + if (Weight[i] > 1) + { + if (myrank == 0) + cout << "WARNING: ShellPatch::Interp_Points meets multiple weight" << endl; + for (int j = 0; j < num_var; j++) + Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; + } + else if (Weight[i] == 0 && myrank == 0) + { + cout << "ERROR: ShellPatch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j][i]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on ShellPatch (" << Rrange[0] << "," << Rrange[1] << endl; + + cout << "splited domains:" << endl; + MyList *sPp = PatL; + while (sPp) + { + char sn[3]; + shellname(sn, sPp->data->sst); + cout << "ss_patch " << sn << ":" << endl; + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + delete[] shellf; + delete[] weight; + delete[] Weight; + delete[] DH; + delete[] llb; + delete[] uub; +} + +bool ShellPatch::Interp_One_Point(MyList *VarList, + double *XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry) +{ + const int NN = 1; + // NOTE: we do not Synchnize variables here, make sure of that before calling this routine + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int ordn = 2 * ghost_width; + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf; + shellf = new double[NN * num_var]; + memset(shellf, 0, sizeof(double) * NN * num_var); + + // we use weight to monitor code, later some day we can move it for optimization + int *weight; + weight = new int[NN]; + memset(weight, 0, sizeof(int) * NN); + + double *DH, *llb, *uub; + DH = new double[dim]; + + for (int i = 0; i < dim; i++) + { + DH[i] = getdX(i); + } + llb = new double[dim]; + uub = new double[dim]; + + for (int j = 0; j < NN; j++) // run along points + { + double pox[dim]; + int sst; + getlocalpox(XX[0], XX[1], XX[2], sst, pox[0], pox[1], pox[2]); + + MyList *sPp = PatL; + while (sPp->data->sst != sst) + sPp = sPp->next; + + if ((!sPp) || pox[2] < Rrange[0] || pox[2] > Rrange[1]) + { + if (myrank == 0) + { + cout << "ShellPatch::Interp_One_Point: point ("; + for (int k = 0; k < dim; k++) + { + cout << XX[k]; + if (k < dim - 1) + cout << ","; + else + cout << ") is out of the ShellPatch." << endl; + } + } + return false; + } + + MyList *Bp = sPp->data->blb; + bool notfind = true; + while (notfind && Bp) // run along Blocks + { + Block *BP = Bp->data; + + bool flag = true; + for (int i = 0; i < dim; i++) + { +// NOTE: our dividing structure is (exclude ghost) +// -1 0 +// 1 2 +// so (0,1) does not belong to any part for vertex structure +// here we put (0,0.5) to left part and (0.5,1) to right part +// BUT for cell structure the bbox is (-1.5,0.5) and (0.5,2.5), there is no missing region at all +// +// because of getlocalpox, pox will not goes into overghost region of ss_patch +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + if (pox[i] - llb[i] < -DH[i] / 2 || pox[i] - uub[i] > DH[i] / 2) + { + flag = false; + break; + } + } + + if (flag) + { + notfind = false; + if (myrank == BP->rank) + { + //---> interpolation + varl = VarList; + int k = 0; + while (varl) // run along variables + { + f_global_interp_ss(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], shellf[j * num_var + k], + pox[0], pox[1], pox[2], ordn, varl->data->SoA, Symmetry, sst); + varl = varl->next; + k++; + } + weight[j] = 1; + } + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + } + + MPI_Allreduce(shellf, Shellf, NN * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + int *Weight; + Weight = new int[NN]; + MPI_Allreduce(weight, Weight, NN, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + + for (int i = 0; i < NN; i++) + { + if (Weight[i] > 1) + { + if (myrank == 0) + cout << "WARNING: ShellPatch::Interp_Points meets multiple weight" << endl; + for (int j = 0; j < num_var; j++) + Shellf[j + i * num_var] = Shellf[j + i * num_var] / Weight[i]; + } + else if (Weight[i] == 0 && myrank == 0) + { + cout << "ERROR: ShellPatch::Interp_Points fails to find point ("; + for (int j = 0; j < dim; j++) + { + cout << XX[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")"; + } + cout << " on ShellPatch (" << Rrange[0] << "," << Rrange[1] << endl; + + cout << "splited domains:" << endl; + MyList *sPp = PatL; + while (sPp) + { + char sn[3]; + shellname(sn, sPp->data->sst); + cout << "ss_patch " << sn << ":" << endl; + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *BP = Bp->data; + + for (int i = 0; i < dim; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + (ghost_width - 0.5) * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - (ghost_width - 0.5) * DH[i]; +#else +#ifdef Cell + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? BP->bbox[i] : BP->bbox[i] + ghost_width * DH[i]; + uub[i] = (feq(BP->bbox[dim + i], sPp->data->bbox[dim + i], DH[i] / 2)) ? BP->bbox[dim + i] : BP->bbox[dim + i] - ghost_width * DH[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + cout << "("; + for (int j = 0; j < dim; j++) + { + cout << llb[j] << ":" << uub[j]; + if (j < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + delete[] shellf; + delete[] weight; + delete[] Weight; + delete[] DH; + delete[] llb; + delete[] uub; + + return true; +} + +void ShellPatch::write_Pablo_file_ss(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, + char *filename, int sst) +{ + int nx = ext[0], ny = ext[1], nz = ext[2]; + int i, j, k; + double *X, *Y, *Z; + X = new double[nx]; + Y = new double[ny]; + Z = new double[nz]; + double dX, dY, dZ; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dX = (xmax - xmin) / (nx - 1); + for (i = 0; i < nx; i++) + X[i] = xmin + i * dX; + dY = (ymax - ymin) / (ny - 1); + for (j = 0; j < ny; j++) + Y[j] = ymin + j * dY; + dZ = (zmax - zmin) / (nz - 1); + for (k = 0; k < nz; k++) + Z[k] = zmin + k * dZ; +#else +#ifdef Cell + dX = (xmax - xmin) / nx; + for (i = 0; i < nx; i++) + X[i] = xmin + (i + 0.5) * dX; + dY = (ymax - ymin) / ny; + for (j = 0; j < ny; j++) + Y[j] = ymin + (j + 0.5) * dY; + dZ = (zmax - zmin) / nz; + for (k = 0; k < nz; k++) + Z[k] = zmin + (k + 0.5) * dZ; +#else +#error Not define Vertex nor Cell +#endif +#endif + //|--->open out put file + ofstream outfile; + outfile.open(filename); + if (!outfile) + { + cout << "bssn_class: write_Pablo_file can't open " << filename << " for output." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double gx, gy, gz; + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + for (k = 0; k < nz; k++) + for (j = 0; j < ny; j++) + for (i = 0; i < nx; i++) + { + getglobalpox(gx, gy, gz, sst, X[i], Y[j], Z[k]); + outfile << gx << " " << gy << " " << gz << " " + << 0 << endl; + } + outfile.close(); + + delete[] X; + delete[] Y; + delete[] Z; +} + double ShellPatch::L2Norm(var *vf) { double tvf, dtvf = 0; int BDW = overghost; - - MyList *sPp = PatL; - while (sPp) - { - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *cg = Bp->data; - if (myrank == cg->rank) - { - f_l2normhelper(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[vf->sgfn], tvf, BDW); - dtvf += tvf; - } - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - - MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - tvf = sqrt(tvf); + + MyList *sPp = PatL; + while (sPp) + { + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *cg = Bp->data; + if (myrank == cg->rank) + { + f_l2normhelper(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[vf->sgfn], tvf, BDW); + dtvf += tvf; + } + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + + MPI_Allreduce(&dtvf, &tvf, 1, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + tvf = sqrt(tvf); return tvf; } @@ -3513,110 +3513,110 @@ void ShellPatch::L2Norm7(var **vf, double *norms) // find maximum of abstract value, XX store position for maximum, Shellf store maximum themselvs void ShellPatch::Find_Maximum(MyList *VarList, double *XX, double *Shellf) -{ - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double *shellf, *xx; - shellf = new double[num_var]; - xx = new double[3 * num_var]; - for (int i = 0; i < num_var; i++) - shellf[i] = -1; // make sure be rewriten - memset(xx, 0, sizeof(double) * 3 * num_var); - - double *DH; - int *llb, *uub; - DH = new double[3]; - - for (int i = 0; i < 3; i++) - { - DH[i] = getdX(i); - } - - llb = new int[3]; - uub = new int[3]; - - MyList *sPp = PatL; - while (sPp) - { - MyList *Bp = sPp->data->blb; - while (Bp) - { - Block *BP = Bp->data; - - if (myrank == BP->rank) - { - - for (int i = 0; i < 2; i++) - { - llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? 0 : ghost_width; - uub[i] = (feq(BP->bbox[3 + i], sPp->data->bbox[3 + i], DH[i] / 2)) ? 0 : ghost_width; - } - llb[2] = (feq(BP->bbox[2], sPp->data->bbox[2], DH[2] / 2)) ? buffer_width : ghost_width; - uub[2] = (feq(BP->bbox[5], sPp->data->bbox[5], DH[2] / 2)) ? 0 : ghost_width; - - varl = VarList; - int k = 0; - double tmp, tmpx[3]; - while (varl) // run along variables - { - f_find_maximum(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], tmp, tmpx, llb, uub); - if (tmp > shellf[k]) - { - shellf[k] = tmp; - getglobalpox(xx[3 * k], xx[3 * k + 1], xx[3 * k + 2], sPp->data->sst, tmpx[0], tmpx[1], tmpx[2]); - } - varl = varl->next; - k++; - } - } - - if (Bp == sPp->data->ble) - break; - Bp = Bp->next; - } - sPp = sPp->next; - } - - struct mloc - { - double val; - int rank; - }; - - mloc *IN, *OUT; - IN = new mloc[num_var]; - OUT = new mloc[num_var]; - for (int i = 0; i < num_var; i++) - { - IN[i].val = shellf[i]; - IN[i].rank = myrank; - } - - MPI_Allreduce(IN, OUT, num_var, MPI_DOUBLE_INT, MPI_MAXLOC, MPI_COMM_WORLD); - - for (int i = 0; i < num_var; i++) - { - Shellf[i] = OUT[i].val; - if (myrank != OUT[i].rank) - for (int k = 0; k < 3; k++) - xx[3 * i + k] = 0; - } - - MPI_Allreduce(xx, XX, 3 * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - - delete[] IN; - delete[] OUT; - delete[] shellf; - delete[] xx; - delete[] DH; - delete[] llb; - delete[] uub; -} - +{ + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double *shellf, *xx; + shellf = new double[num_var]; + xx = new double[3 * num_var]; + for (int i = 0; i < num_var; i++) + shellf[i] = -1; // make sure be rewriten + memset(xx, 0, sizeof(double) * 3 * num_var); + + double *DH; + int *llb, *uub; + DH = new double[3]; + + for (int i = 0; i < 3; i++) + { + DH[i] = getdX(i); + } + + llb = new int[3]; + uub = new int[3]; + + MyList *sPp = PatL; + while (sPp) + { + MyList *Bp = sPp->data->blb; + while (Bp) + { + Block *BP = Bp->data; + + if (myrank == BP->rank) + { + + for (int i = 0; i < 2; i++) + { + llb[i] = (feq(BP->bbox[i], sPp->data->bbox[i], DH[i] / 2)) ? 0 : ghost_width; + uub[i] = (feq(BP->bbox[3 + i], sPp->data->bbox[3 + i], DH[i] / 2)) ? 0 : ghost_width; + } + llb[2] = (feq(BP->bbox[2], sPp->data->bbox[2], DH[2] / 2)) ? buffer_width : ghost_width; + uub[2] = (feq(BP->bbox[5], sPp->data->bbox[5], DH[2] / 2)) ? 0 : ghost_width; + + varl = VarList; + int k = 0; + double tmp, tmpx[3]; + while (varl) // run along variables + { + f_find_maximum(BP->shape, BP->X[0], BP->X[1], BP->X[2], BP->fgfs[varl->data->sgfn], tmp, tmpx, llb, uub); + if (tmp > shellf[k]) + { + shellf[k] = tmp; + getglobalpox(xx[3 * k], xx[3 * k + 1], xx[3 * k + 2], sPp->data->sst, tmpx[0], tmpx[1], tmpx[2]); + } + varl = varl->next; + k++; + } + } + + if (Bp == sPp->data->ble) + break; + Bp = Bp->next; + } + sPp = sPp->next; + } + + struct mloc + { + double val; + int rank; + }; + + mloc *IN, *OUT; + IN = new mloc[num_var]; + OUT = new mloc[num_var]; + for (int i = 0; i < num_var; i++) + { + IN[i].val = shellf[i]; + IN[i].rank = myrank; + } + + MPI_Allreduce(IN, OUT, num_var, MPI_DOUBLE_INT, MPI_MAXLOC, MPI_COMM_WORLD); + + for (int i = 0; i < num_var; i++) + { + Shellf[i] = OUT[i].val; + if (myrank != OUT[i].rank) + for (int k = 0; k < 3; k++) + xx[3 * i + k] = 0; + } + + MPI_Allreduce(xx, XX, 3 * num_var, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + + delete[] IN; + delete[] OUT; + delete[] shellf; + delete[] xx; + delete[] DH; + delete[] llb; + delete[] uub; +} + diff --git a/AMSS_NCKU_source/ShellPatch.h b/AMSS_NCKU_source/Shell_Patch/ShellPatch.h similarity index 97% rename from AMSS_NCKU_source/ShellPatch.h rename to AMSS_NCKU_source/Shell_Patch/ShellPatch.h index fa93ae1..861f138 100644 --- a/AMSS_NCKU_source/ShellPatch.h +++ b/AMSS_NCKU_source/Shell_Patch/ShellPatch.h @@ -1,205 +1,205 @@ - -#ifndef SHELLPATCH_H -#define SHELLPATCH_H - -#include -#include "MyList.h" -#include "Block.h" -#include "Parallel.h" -#include "var.h" -#include "monitor.h" -#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width - -#if (dim != 3) -#error shellpatch only supports 3 dimensional stuff yet -#endif - -class ss_patch -{ - -public: - int sst; // ss_patch type: 0:zp, 1:zm, 2:xp, 3:xm, 4:yp, 5:ym - int myrank; - int shape[dim]; - double bbox[2 * dim]; // this bbox includes nominal points and overlap points - MyList *blb, *ble; - int ingfs, fngfs; - - ss_patch() {}; - ss_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki); - - ~ss_patch(); - - virtual void setupcordtrans() {}; - void Sync(MyList *VarList, int Symmetry); - MyList *build_bulk_gsl(Block *bp); - MyList *build_ghost_gsl(); - MyList *build_owned_gsl0(int rank_in); -}; - -class xp_patch : public ss_patch -{ -public: - xp_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 2; }; - void setupcordtrans(); -}; - -class xm_patch : public ss_patch -{ -public: - xm_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 3; }; - void setupcordtrans(); -}; -class yp_patch : public ss_patch -{ -public: - yp_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 4; }; - void setupcordtrans(); -}; - -class ym_patch : public ss_patch -{ -public: - ym_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 5; }; - void setupcordtrans(); -}; -class zp_patch : public ss_patch -{ -public: - zp_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 0; }; - void setupcordtrans(); -}; - -class zm_patch : public ss_patch -{ -public: - zm_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 1; }; - void setupcordtrans(); -}; -// Shell Patch system -// for derivatives usage we ask 27 more double type grid functions -// here we use **sngfs corresponding to fngfs to store them: -// drho/dx, drho/dy, drho/dz -// dsigma/dx, dsigma/dy, dsigma/dz -// dR/dx, dR/dy, dR/dz -// drho/dxdx, drho/dxdy, drho/dxdz, drho/dydy, drho/dydz, drho/dzdz -// dsigma/dxdx, dsigma/dxdy, dsigma/dxdz, dsigma/dydy, dsigma/dydz, dsigma/dzdz -// dR/dxdx, dR/dxdy, dR/dxdz, dR/dydy, dR/dydz, dR/dzdz -class ShellPatch -{ - -public: - struct pointstru - { - double gpox[dim]; // global cordinate - double lpox[dim]; // local cordinate - Block *Bg; - int ssst; //-1: cardisian, others as sst of ss_patch source sst - int tsst; //-1: cardisian, others as sst of ss_patch target sst - double *coef; - int *sind; - int dumyd; // the dimension which has common lines, only useful in interdata_packer - //-1: means no dumy dimension at all; 0: means rho; 1: means sigma - }; - - int myrank; - int shape[dim]; // for (rho, sigma, R), for rho and sigma means number of points for every pi/2 - double Rrange[2]; // for Rmin and Rmax - int Symmetry; - int ingfs, fngfs; - - MyList *PatL; - - // we use fngfs+v to reference the variable - enum - { - gx = 0, - gy, - gz, - drhodx, - drhody, - drhodz, - dsigmadx, - dsigmady, - dsigmadz, - dRdx, - dRdy, - dRdz, - drhodxx, - drhodxy, - drhodxz, - drhodyy, - drhodyz, - drhodzz, - dsigmadxx, - dsigmadxy, - dsigmadxz, - dsigmadyy, - dsigmadyz, - dsigmadzz, - dRdxx, - dRdxy, - dRdxz, - dRdyy, - dRdyz, - dRdzz - }; - - MyList **ss_src, **ss_dst; - // at means target - MyList **csatc_src, **csatc_dst; - MyList **csats_src, **csats_dst; - -public: - ShellPatch(int ingfsi, int fngfsi, char *filename, int Symmetry, int myranki, monitor *ErrorMonitor); - - ~ShellPatch(); - - MyList *compose_sh(int cpusize, int nodes = 0); - MyList *compose_shr(int cpusize, int nodes = 0); - void setupcordtrans(); - double getR(double r); - double getsr(double R); - void checkPatch(); - void checkBlock(int sst); - void check_pointstrul(MyList *pp, bool first_only); - void check_pointstrul2(MyList *pp, int first_last_only); - double getdX(int dir); //(rho, sigma, R) - void Dump_xyz(char *tag, double time, double dT); - void Dump_Data(MyList *DumpList, char *tag, double time, double dT); - double *Collect_Data(ss_patch *PP, var *VP); - void getlocalpoxsst(double gx, double gy, double gz, int sst, double &lx, double &ly, double &lz); - void getlocalpox(double gx, double gy, double gz, int &sst, double &lx, double &ly, double &lz); - void getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz); - void prolongpointstru(MyList *&psul, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], MyList *pss); - bool prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], - MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in); - void setupintintstuff(int cpusize, MyList *CPatL, int Symmetry); - void intertransfer(MyList **src, MyList **dst, - MyList *VarList1 /* source */, MyList *VarList2 /*target */, - int Symmetry); - int interdata_packer(double *data, MyList *src, MyList *dst, - int rank_in, int dir, - MyList *VarLists /* source */, MyList *VarListd /* target */, - int Symmetry); - void Synch(MyList *VarList, int Symmetry); - void CS_Inter(MyList *VarList, int Symmetry); - void destroypsuList(MyList *ct); - int getdumydimension(int acsst, int posst); // -1 means no dumy dimension - void matchcheck(MyList *CPatL); - void shellname(char *sn, int i); - void Interp_Points(MyList *VarList, - int NN, double **XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry); - bool Interp_One_Point(MyList *VarList, - double *XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry); + +#ifndef SHELLPATCH_H +#define SHELLPATCH_H + +#include +#include "MyList.h" +#include "Block.h" +#include "Parallel.h" +#include "var.h" +#include "monitor.h" +#include "macrodef.h" //need dim here; Vertex or Cell; ghost_width + +#if (dim != 3) +#error shellpatch only supports 3 dimensional stuff yet +#endif + +class ss_patch +{ + +public: + int sst; // ss_patch type: 0:zp, 1:zm, 2:xp, 3:xm, 4:yp, 5:ym + int myrank; + int shape[dim]; + double bbox[2 * dim]; // this bbox includes nominal points and overlap points + MyList *blb, *ble; + int ingfs, fngfs; + + ss_patch() {}; + ss_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki); + + ~ss_patch(); + + virtual void setupcordtrans() {}; + void Sync(MyList *VarList, int Symmetry); + MyList *build_bulk_gsl(Block *bp); + MyList *build_ghost_gsl(); + MyList *build_owned_gsl0(int rank_in); +}; + +class xp_patch : public ss_patch +{ +public: + xp_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 2; }; + void setupcordtrans(); +}; + +class xm_patch : public ss_patch +{ +public: + xm_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 3; }; + void setupcordtrans(); +}; +class yp_patch : public ss_patch +{ +public: + yp_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 4; }; + void setupcordtrans(); +}; + +class ym_patch : public ss_patch +{ +public: + ym_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 5; }; + void setupcordtrans(); +}; +class zp_patch : public ss_patch +{ +public: + zp_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 0; }; + void setupcordtrans(); +}; + +class zm_patch : public ss_patch +{ +public: + zm_patch(int ingfsi, int fngfsi, int *shapei, double *bboxi, int myranki) : ss_patch(ingfsi, fngfsi, shapei, bboxi, myranki) { sst = 1; }; + void setupcordtrans(); +}; +// Shell Patch system +// for derivatives usage we ask 27 more double type grid functions +// here we use **sngfs corresponding to fngfs to store them: +// drho/dx, drho/dy, drho/dz +// dsigma/dx, dsigma/dy, dsigma/dz +// dR/dx, dR/dy, dR/dz +// drho/dxdx, drho/dxdy, drho/dxdz, drho/dydy, drho/dydz, drho/dzdz +// dsigma/dxdx, dsigma/dxdy, dsigma/dxdz, dsigma/dydy, dsigma/dydz, dsigma/dzdz +// dR/dxdx, dR/dxdy, dR/dxdz, dR/dydy, dR/dydz, dR/dzdz +class ShellPatch +{ + +public: + struct pointstru + { + double gpox[dim]; // global cordinate + double lpox[dim]; // local cordinate + Block *Bg; + int ssst; //-1: cardisian, others as sst of ss_patch source sst + int tsst; //-1: cardisian, others as sst of ss_patch target sst + double *coef; + int *sind; + int dumyd; // the dimension which has common lines, only useful in interdata_packer + //-1: means no dumy dimension at all; 0: means rho; 1: means sigma + }; + + int myrank; + int shape[dim]; // for (rho, sigma, R), for rho and sigma means number of points for every pi/2 + double Rrange[2]; // for Rmin and Rmax + int Symmetry; + int ingfs, fngfs; + + MyList *PatL; + + // we use fngfs+v to reference the variable + enum + { + gx = 0, + gy, + gz, + drhodx, + drhody, + drhodz, + dsigmadx, + dsigmady, + dsigmadz, + dRdx, + dRdy, + dRdz, + drhodxx, + drhodxy, + drhodxz, + drhodyy, + drhodyz, + drhodzz, + dsigmadxx, + dsigmadxy, + dsigmadxz, + dsigmadyy, + dsigmadyz, + dsigmadzz, + dRdxx, + dRdxy, + dRdxz, + dRdyy, + dRdyz, + dRdzz + }; + + MyList **ss_src, **ss_dst; + // at means target + MyList **csatc_src, **csatc_dst; + MyList **csats_src, **csats_dst; + +public: + ShellPatch(int ingfsi, int fngfsi, char *filename, int Symmetry, int myranki, monitor *ErrorMonitor); + + ~ShellPatch(); + + MyList *compose_sh(int cpusize, int nodes = 0); + MyList *compose_shr(int cpusize, int nodes = 0); + void setupcordtrans(); + double getR(double r); + double getsr(double R); + void checkPatch(); + void checkBlock(int sst); + void check_pointstrul(MyList *pp, bool first_only); + void check_pointstrul2(MyList *pp, int first_last_only); + double getdX(int dir); //(rho, sigma, R) + void Dump_xyz(char *tag, double time, double dT); + void Dump_Data(MyList *DumpList, char *tag, double time, double dT); + double *Collect_Data(ss_patch *PP, var *VP); + void getlocalpoxsst(double gx, double gy, double gz, int sst, double &lx, double &ly, double &lz); + void getlocalpox(double gx, double gy, double gz, int &sst, double &lx, double &ly, double &lz); + void getglobalpox(double &x, double &y, double &z, int sst, double lx, double ly, double lz); + void prolongpointstru(MyList *&psul, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], MyList *pss); + bool prolongpointstru(MyList *&psul, bool ssyn, int tsst, MyList *sPp, double DH[dim], + MyList *Pp, double CDH[dim], double x, double y, double z, int Symmetry, int rank_in); + void setupintintstuff(int cpusize, MyList *CPatL, int Symmetry); + void intertransfer(MyList **src, MyList **dst, + MyList *VarList1 /* source */, MyList *VarList2 /*target */, + int Symmetry); + int interdata_packer(double *data, MyList *src, MyList *dst, + int rank_in, int dir, + MyList *VarLists /* source */, MyList *VarListd /* target */, + int Symmetry); + void Synch(MyList *VarList, int Symmetry); + void CS_Inter(MyList *VarList, int Symmetry); + void destroypsuList(MyList *ct); + int getdumydimension(int acsst, int posst); // -1 means no dumy dimension + void matchcheck(MyList *CPatL); + void shellname(char *sn, int i); + void Interp_Points(MyList *VarList, + int NN, double **XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry); + bool Interp_One_Point(MyList *VarList, + double *XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry); void write_Pablo_file_ss(int *ext, double xmin, double xmax, double ymin, double ymax, double zmin, double zmax, char *filename, int sst); double L2Norm(var *vf); void L2Norm7(var **vf, double *norms); void Find_Maximum(MyList *VarList, double *XX, double *Shellf); }; - -#endif /* SHELLPATCH_H */ + +#endif /* SHELLPATCH_H */ diff --git a/AMSS_NCKU_source/shellfunctions.f90 b/AMSS_NCKU_source/Shell_Patch/shellfunctions.f90 similarity index 96% rename from AMSS_NCKU_source/shellfunctions.f90 rename to AMSS_NCKU_source/Shell_Patch/shellfunctions.f90 index a88ea05..c1e0b6c 100644 --- a/AMSS_NCKU_source/shellfunctions.f90 +++ b/AMSS_NCKU_source/Shell_Patch/shellfunctions.f90 @@ -1,723 +1,723 @@ - - -!----------------------------------------------------------------------------------- -! -!Set up approximate puncture initial data for n black holes with lousto's -!formula PRD 77, 024034 (2008) -! -!----------------------------------------------------------------------------------- - - subroutine get_initial_nbhs_sh(ex,X,Y,Z, & - chi, trK, & - gxx, gxy, gxz, gyy, gyz, gzz,& - Axx, Axy, Axz, Ayy, Ayz, Azz,& - Gmx, Gmy, Gmz, & - Lap, Sfx, Sfy, Sfz,& - dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) - - implicit none - -!------= input arguments - - integer,intent(in) :: N - integer, dimension(3), intent(in) :: ex - real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz - real*8, dimension(N), intent(in) :: Mass - real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin - -!------= local variables - real*8,dimension(ex(1),ex(2),ex(3))::psi - integer :: i,j,k,bhi - real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS - real*8 :: nx,ny,nz,rr,tmp - real*8 :: u,u1,u2,u3,u4,u5 - real*8 :: mup,mus,b,ell - real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 - real*8,parameter::TINYRR=1.d-14 - - do k = 1,ex(3) - do j = 1,ex(2) - do i = 1,ex(1) -! black hole 1 - M = mass(1) - nx = x(i,j,k) - Porg(1) - ny = y(i,j,k) - Porg(2) - nz = z(i,j,k) - Porg(3) - Px = Pmom(1) - Py = Pmom(2) - Pz = Pmom(3) - Sx = Spin(1) - Sy = Spin(2) - Sz = Spin(3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2,1,1)-X(1,1,1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 - u4 = -b**2*ell**5 - u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & - u5*tmp - - psi(i,j,k) = ONE + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) -! black hole 2 and 3, ... - do bhi=2,N - M = Mass(bhi) - nx = x(i,j,k) - Porg(3*(bhi-1)+1) - ny = y(i,j,k) - Porg(3*(bhi-1)+2) - nz = z(i,j,k) - Porg(3*(bhi-1)+3) - Px = Pmom(3*(bhi-1)+1) - Py = Pmom(3*(bhi-1)+2) - Pz = Pmom(3*(bhi-1)+3) - Sx = Spin(3*(bhi-1)+1) - Sy = Spin(3*(bhi-1)+2) - Sz = Spin(3*(bhi-1)+3) - - rr = dsqrt(nx*nx+ny*ny+nz*nz) - if(rr.lt.TINYRR) rr=(X(2,1,1)-X(1,1,1))/2.d0 - nx = nx / rr - ny = ny / rr - nz = nz / rr - PP = dsqrt(Px**2 + Py**2 + Pz**2) - if(PP .gt. 0.d0) then - mup = (Px*nx+Py*ny+Pz*nz)/PP - else - mup = 0.0 - endif - SS = dsqrt(Sx**2 + Sy**2 + Sz**2) - if(SS .gt. 0.d0) then - mus = (Sx*nx+Sy*ny+Sz*nz)/SS - else - mus = 0.0 - endif - b = 2.d0*rr/M - ell = 1.d0/(1.d0+b) - - u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) - u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & - +8.4d1*dlog(ell)/b)/4.d1/b**2 - u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 - u4 = -b**2*ell**5 - u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 - - tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz - - u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & - 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & - u5*tmp - - psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr - - tmp = Px * nx + Py * ny + Pz * nz - - Axx(i,j,k) = Axx(i,j,k) + & - (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & - ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayy(i,j,k) = Ayy(i,j,k) + & - (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & - ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - - Azz(i,j,k) = Azz(i,j,k) + & - (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & - ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & - THR / ( rr * rr ) - - Axy(i,j,k) = Axy(i,j,k) + & - (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & - ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Axz(i,j,k) = Axz(i,j,k) + & - (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & - ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & - THR / ( rr * rr ) - - Ayz(i,j,k) = Ayz(i,j,k) + & - (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & - ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & - THR / ( rr * rr ) - enddo - enddo - enddo - enddo - - chi = ONE / psi **4 - ONE - - Lap = ONE / ( psi * psi ) - ONE - -!~~~~~~ tilde Aij = Aij / Psi^6 - psi = psi * psi * psi * psi * psi * psi - - Axx = Axx / psi - Ayy = Ayy / psi - Azz = Azz / psi - Axy = Axy / psi - Axz = Axz / psi - Ayz = Ayz / psi - - gxx = ZEO - gyy = ZEO - gzz = ZEO - gxy = ZEO - gxz = ZEO - gyz = ZEO - - trK = ZEO - - Gmx = ZEO - Gmy = ZEO - Gmz = ZEO - - Sfx = ZEO - Sfy = ZEO - Sfz = ZEO - - dtSfx = ZEO - dtSfy = ZEO - dtSfz = ZEO - - return - - end subroutine get_initial_nbhs_sh -!---------------------------------------------------- -! I use this routine to unify the parameters -subroutine shellcordpar(A,B,r0,eps) -implicit none -! argument variables -double precision,intent(out)::A,B,r0,eps - -A=1.d0 -B=0.d0 -r0=0.d0 -eps=1.d0 - -return - -end subroutine shellcordpar -!---------------------------------------------------- -! R = f(r)-f(0) -subroutine getcartr(ex,R,cartr) -implicit none -! argument variables -integer,intent(in)::ex -double precision,intent(in),dimension(ex)::R -double precision,intent(out),dimension(ex)::cartr - -!~~~~~~ local variables -double precision,dimension(ex)::f -double precision :: A,B,r0,eps - -call shellcordpar(A,B,r0,eps) -f = R+B -cartr = r0+(A*f-B*dsqrt(A*A+(f*f-B*B)/eps))/(A*A-B*B/eps) - -return -end subroutine getcartr -! dR/dr = ... -subroutine getdRdcartr(ex,R,dRdcartr) -implicit none -! argument variables -integer,intent(in)::ex -double precision,intent(in),dimension(ex)::R -double precision,intent(out),dimension(ex)::dRdcartr - -!~~~~~~ local variables -double precision,dimension(ex)::cartr -double precision :: A,B,r0,eps - - call shellcordpar(A,B,r0,eps) - - call getcartr(ex,R,cartr) - dRdcartr = A + B*(cartr-r0)/dsqrt(eps*eps+eps*(cartr-r0)*(cartr-r0)) - -return -end subroutine getdRdcartr -! dR/drdr = ... -subroutine getdRdcartrcartr(ex,R,dRdcartrcartr) -implicit none -! argument variables -integer,intent(in)::ex -double precision,intent(in),dimension(ex)::R -double precision,intent(out),dimension(ex)::dRdcartrcartr - -!~~~~~~ local variables -double precision,dimension(ex)::cartr - -double precision :: A,B,r0,eps - - call shellcordpar(A,B,r0,eps) - - call getcartr(ex,R,cartr) - dRdcartrcartr = B*dsqrt(eps)/(dsqrt(eps+(cartr-r0)*(cartr-r0)))**3 - - return - -end subroutine getdRdcartrcartr - -subroutine zp_getxyz(ex,rho,sigma,R,x,y,z) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1))::tgrho -double precision,dimension(ex(2))::tgsigma -integer :: i,j,k - - call getcartr(ex(3),R,cartr) - tgrho = dtan(rho) - tgsigma = dtan(sigma) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - z(i,j,k) = cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) - x(i,j,k) = z(i,j,k)*tgrho(i) - y(i,j,k) = z(i,j,k)*tgsigma(j) - enddo - enddo - enddo - - return - -end subroutine zp_getxyz - -subroutine zm_getxyz(ex,rho,sigma,R,x,y,z) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1))::tgrho -double precision,dimension(ex(2))::tgsigma -integer :: i,j,k - - call getcartr(ex(3),R,cartr) - tgrho = dtan(rho) - tgsigma = dtan(sigma) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - z(i,j,k) = -cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) - x(i,j,k) = z(i,j,k)*tgrho(i) - y(i,j,k) = z(i,j,k)*tgsigma(j) - enddo - enddo - enddo - - return - -end subroutine zm_getxyz - -subroutine yp_getxyz(ex,rho,sigma,R,x,y,z) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1))::tgrho -double precision,dimension(ex(2))::tgsigma -integer :: i,j,k - - call getcartr(ex(3),R,cartr) - tgrho = dtan(rho) - tgsigma = dtan(sigma) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - y(i,j,k) = cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) - x(i,j,k) = y(i,j,k)*tgrho(i) - z(i,j,k) = y(i,j,k)*tgsigma(j) - enddo - enddo - enddo - - return - -end subroutine yp_getxyz - -subroutine ym_getxyz(ex,rho,sigma,R,x,y,z) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1))::tgrho -double precision,dimension(ex(2))::tgsigma -integer :: i,j,k - - call getcartr(ex(3),R,cartr) - tgrho = dtan(rho) - tgsigma = dtan(sigma) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - y(i,j,k) = -cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) - x(i,j,k) = y(i,j,k)*tgrho(i) - z(i,j,k) = y(i,j,k)*tgsigma(j) - enddo - enddo - enddo - - return - -end subroutine ym_getxyz - -subroutine xp_getxyz(ex,rho,sigma,R,x,y,z) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1))::tgrho -double precision,dimension(ex(2))::tgsigma -integer :: i,j,k - - call getcartr(ex(3),R,cartr) - tgrho = dtan(rho) - tgsigma = dtan(sigma) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - x(i,j,k) = cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) - y(i,j,k) = x(i,j,k)*tgrho(i) - z(i,j,k) = x(i,j,k)*tgsigma(j) - enddo - enddo - enddo - - return - -end subroutine xp_getxyz - -subroutine xm_getxyz(ex,rho,sigma,R,x,y,z) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1))::tgrho -double precision,dimension(ex(2))::tgsigma -integer :: i,j,k - - call getcartr(ex(3),R,cartr) - tgrho = dtan(rho) - tgsigma = dtan(sigma) - - do k=1,ex(3) - do j=1,ex(2) - do i=1,ex(1) - x(i,j,k) = -cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) - y(i,j,k) = x(i,j,k)*tgrho(i) - z(i,j,k) = x(i,j,k)*tgsigma(j) - enddo - enddo - enddo - - return - -end subroutine xm_getxyz -!------------------------------------------------------------------------------------------ -! calculate Jacobians -subroutine xpm_getjacobian(ex,rho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1),ex(2),ex(3))::srt,xxyy,xxzz,dRdcartr,dRdcartrcartr -integer :: i,j,k -real*8,parameter :: ZEO=0.d0 - - xxyy = x*x + y*y - xxzz = x*x + z*z - srt = dsqrt(xxyy + z*z) - call getdRdcartr(ex(3),R,dRdcartr(1,1,:)) - call getdRdcartrcartr(ex(3),R,dRdcartrcartr(1,1,:)) - do k=1,ex(3) - dRdcartr(:,:,k) = dRdcartr(1,1,k) - dRdcartrcartr(:,:,k) = dRdcartrcartr(1,1,k) - enddo - - dRdx = x/srt*dRdcartr - dRdy = y/srt*dRdcartr - dRdz = z/srt*dRdcartr - drhodx = -y/xxyy - drhody = x/xxyy - drhodz = ZEO - dsigmadx = -z/xxzz - dsigmady = ZEO - dsigmadz = x/xxzz - - dRdxx = dRdcartrcartr*x*x/srt/srt+dRdcartr*(y*y+z*z)/srt**3 - dRdxy = dRdcartrcartr*x*y/srt/srt-dRdcartr*( x*y)/srt**3 - dRdxz = dRdcartrcartr*x*z/srt/srt-dRdcartr*( x*z)/srt**3 - dRdyy = dRdcartrcartr*y*y/srt/srt+dRdcartr*(x*x+z*z)/srt**3 - dRdyz = dRdcartrcartr*y*z/srt/srt-dRdcartr*( y*z)/srt**3 - dRdzz = dRdcartrcartr*z*z/srt/srt+dRdcartr*(x*x+y*y)/srt**3 - drhodxx = 2*x*y/xxyy**2 - drhodxy = (-x*x + y*y)/xxyy**2 - drhodxz = ZEO - drhodyy = -drhodxx - drhodyz = ZEO - drhodzz = ZEO - dsigmadxx = (2*x*z)/xxzz**2 - dsigmadxy = ZEO - dsigmadxz = (-x*x + z*z)/xxzz**2 - dsigmadyy = ZEO - dsigmadyz = ZEO - dsigmadzz = -dsigmadxx - - return - -end subroutine xpm_getjacobian -!~~~~ -subroutine ypm_getjacobian(ex,rho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1),ex(2),ex(3))::srt,xxyy,yyzz,dRdcartr,dRdcartrcartr -integer :: i,j,k -real*8,parameter :: ZEO=0.d0 - - xxyy = x*x + y*y - yyzz = y*y + z*z - srt = dsqrt(xxyy + z*z) - call getdRdcartr(ex(3),R,dRdcartr(1,1,:)) - call getdRdcartrcartr(ex(3),R,dRdcartrcartr(1,1,:)) - do k=1,ex(3) - dRdcartr(:,:,k) = dRdcartr(1,1,k) - dRdcartrcartr(:,:,k) = dRdcartrcartr(1,1,k) - enddo - - dRdx = x/srt*dRdcartr - dRdy = y/srt*dRdcartr - dRdz = z/srt*dRdcartr - drhodx = y/xxyy - drhody = -x/xxyy - drhodz = ZEO - dsigmadx = ZEO - dsigmady = -z/yyzz - dsigmadz = y/yyzz - - dRdxx = dRdcartrcartr*x*x/srt/srt+dRdcartr*(y*y+z*z)/srt**3 - dRdxy = dRdcartrcartr*x*y/srt/srt-dRdcartr*( x*y)/srt**3 - dRdxz = dRdcartrcartr*x*z/srt/srt-dRdcartr*( x*z)/srt**3 - dRdyy = dRdcartrcartr*y*y/srt/srt+dRdcartr*(x*x+z*z)/srt**3 - dRdyz = dRdcartrcartr*y*z/srt/srt-dRdcartr*( y*z)/srt**3 - dRdzz = dRdcartrcartr*z*z/srt/srt+dRdcartr*(x*x+y*y)/srt**3 - drhodxx = -2*x*y/xxyy**2 - drhodxy = (x*x - y*y)/xxyy**2 - drhodxz = ZEO - drhodyy = -drhodxx - drhodyz = ZEO - drhodzz = ZEO - dsigmadxx = ZEO - dsigmadxy = ZEO - dsigmadxz = ZEO - dsigmadyy = (2*y*z)/yyzz**2 - dsigmadyz = (-y*y + z*z)/yyzz**2 - dsigmadzz = -dsigmadyy - - return - -end subroutine ypm_getjacobian -!~~~~ -subroutine zpm_getjacobian(ex,rho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - -implicit none -! argument variables -integer,dimension(3),intent(in)::ex -double precision,intent(in),dimension(ex(1))::rho -double precision,intent(in),dimension(ex(2))::sigma -double precision,intent(in),dimension(ex(3))::R -double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz -double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz -!~~~~~~ other variables -double precision,dimension(ex(3))::cartr -double precision,dimension(ex(1),ex(2),ex(3))::srt,xxzz,yyzz,dRdcartr,dRdcartrcartr -integer :: i,j,k -real*8,parameter :: ZEO=0.d0 - - xxzz = x*x + z*z - yyzz = y*y + z*z - srt = dsqrt(xxzz + y*y) - call getdRdcartr(ex(3),R,dRdcartr(1,1,:)) - call getdRdcartrcartr(ex(3),R,dRdcartrcartr(1,1,:)) - do k=1,ex(3) - dRdcartr(:,:,k) = dRdcartr(1,1,k) - dRdcartrcartr(:,:,k) = dRdcartrcartr(1,1,k) - enddo - - dRdx = x/srt*dRdcartr - dRdy = y/srt*dRdcartr - dRdz = z/srt*dRdcartr - drhodx = z/xxzz - drhody = ZEO - drhodz = -x/xxzz - dsigmadx = ZEO - dsigmady = z/yyzz - dsigmadz = -y/yyzz - - dRdxx = dRdcartrcartr*x*x/srt/srt+dRdcartr*(y*y+z*z)/srt**3 - dRdxy = dRdcartrcartr*x*y/srt/srt-dRdcartr*( x*y)/srt**3 - dRdxz = dRdcartrcartr*x*z/srt/srt-dRdcartr*( x*z)/srt**3 - dRdyy = dRdcartrcartr*y*y/srt/srt+dRdcartr*(x*x+z*z)/srt**3 - dRdyz = dRdcartrcartr*y*z/srt/srt-dRdcartr*( y*z)/srt**3 - dRdzz = dRdcartrcartr*z*z/srt/srt+dRdcartr*(x*x+y*y)/srt**3 - drhodxx = -2*x*z/xxzz**2 - drhodxy = ZEO - drhodxz = (x*x - z*z)/xxzz**2 - drhodyy = ZEO - drhodyz = ZEO - drhodzz = -drhodxx - dsigmadxx = ZEO - dsigmadxy = ZEO - dsigmadxz = ZEO - dsigmadyy = -(2*y*z)/yyzz**2 - dsigmadyz = (y*y - z*z)/yyzz**2 - dsigmadzz = -dsigmadyy - - return - -end subroutine zpm_getjacobian + + +!----------------------------------------------------------------------------------- +! +!Set up approximate puncture initial data for n black holes with lousto's +!formula PRD 77, 024034 (2008) +! +!----------------------------------------------------------------------------------- + + subroutine get_initial_nbhs_sh(ex,X,Y,Z, & + chi, trK, & + gxx, gxy, gxz, gyy, gyz, gzz,& + Axx, Axy, Axz, Ayy, Ayz, Azz,& + Gmx, Gmy, Gmz, & + Lap, Sfx, Sfy, Sfz,& + dtSfx,dtSfy,dtSfz,Mass,Porg,Pmom,Spin,N) + + implicit none + +!------= input arguments + + integer,intent(in) :: N + integer, dimension(3), intent(in) :: ex + real*8, dimension(ex(1),ex(2),ex(3)), intent(in) :: X,Y,Z + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: chi + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: gxx,gxy,gxz,gyy,gyz,gzz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: trK,Lap,Sfx,Sfy,Sfz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)), intent(out) :: dtSfx,dtSfy,dtSfz + real*8, dimension(N), intent(in) :: Mass + real*8, dimension(3*N), intent(in) :: Porg,Pmom,Spin + +!------= local variables + real*8,dimension(ex(1),ex(2),ex(3))::psi + integer :: i,j,k,bhi + real*8 :: M,Px,Py,Pz,PP,Sx,Sy,Sz,SS + real*8 :: nx,ny,nz,rr,tmp + real*8 :: u,u1,u2,u3,u4,u5 + real*8 :: mup,mus,b,ell + real*8, parameter :: HLF = 5.d-1, ZEO = 0.d0, ONE = 1.d0, THR = 3.d0 + real*8,parameter::TINYRR=1.d-14 + + do k = 1,ex(3) + do j = 1,ex(2) + do i = 1,ex(1) +! black hole 1 + M = mass(1) + nx = x(i,j,k) - Porg(1) + ny = y(i,j,k) - Porg(2) + nz = z(i,j,k) - Porg(3) + Px = Pmom(1) + Py = Pmom(2) + Pz = Pmom(3) + Sx = Spin(1) + Sy = Spin(2) + Sz = Spin(3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2,1,1)-X(1,1,1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 + u4 = -b**2*ell**5 + u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & + u5*tmp + + psi(i,j,k) = ONE + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) +! black hole 2 and 3, ... + do bhi=2,N + M = Mass(bhi) + nx = x(i,j,k) - Porg(3*(bhi-1)+1) + ny = y(i,j,k) - Porg(3*(bhi-1)+2) + nz = z(i,j,k) - Porg(3*(bhi-1)+3) + Px = Pmom(3*(bhi-1)+1) + Py = Pmom(3*(bhi-1)+2) + Pz = Pmom(3*(bhi-1)+3) + Sx = Spin(3*(bhi-1)+1) + Sy = Spin(3*(bhi-1)+2) + Sz = Spin(3*(bhi-1)+3) + + rr = dsqrt(nx*nx+ny*ny+nz*nz) + if(rr.lt.TINYRR) rr=(X(2,1,1)-X(1,1,1))/2.d0 + nx = nx / rr + ny = ny / rr + nz = nz / rr + PP = dsqrt(Px**2 + Py**2 + Pz**2) + if(PP .gt. 0.d0) then + mup = (Px*nx+Py*ny+Pz*nz)/PP + else + mup = 0.0 + endif + SS = dsqrt(Sx**2 + Sy**2 + Sz**2) + if(SS .gt. 0.d0) then + mus = (Sx*nx+Sy*ny+Sz*nz)/SS + else + mus = 0.0 + endif + b = 2.d0*rr/M + ell = 1.d0/(1.d0+b) + + u1 = 5.d0/8.d0*ell*(1.d0-2.d0*ell+2.d0*ell**2-ell**3+ell**4/5.d0) + u2 = (1.5d1+1.17d2*ell-7.9d1*ell**2+4.3d1*ell**3-1.4d1*ell**4+2.d0*ell**5 & + +8.4d1*dlog(ell)/b)/4.d1/b**2 + u3 = ell+ell**2+ell**3-4.d0*ell**4+2.d0*ell**5 + u4 = -b**2*ell**5 + u5 = b*(1.d0+5.d0*b+1.d1*b**2)*ell**5/8.d1 + + tmp = (Py*Sz-Pz*Sy)*nx + (Pz*Sx-Px*Sz)*ny + (Px*Sy-Py*Sx)*nz + + u = PP**2/M**2*(u1 + u2*(3.d0*mup**2-ONE)) + & + 2.d0*SS**2/5.d0/M**4*(u3 + u4*(3.d0*mus**2-ONE)) + & + u5*tmp + + psi(i,j,k) = psi(i,j,k) + u + HLF*M/rr + + tmp = Px * nx + Py * ny + Pz * nz + + Axx(i,j,k) = Axx(i,j,k) + & + (HLF *( Px * nx + nx * Px - ( ONE - nx * nx )* tmp ) + & + ( nx * Sy * nz - nx * Sz * ny + nx * Sy * nz - nx * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayy(i,j,k) = Ayy(i,j,k) + & + (HLF *( Py * ny + ny * Py - ( ONE - ny * ny )* tmp ) + & + ( ny * Sz * nx - ny * Sx * nz + ny * Sz * nx - ny * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + + Azz(i,j,k) = Azz(i,j,k) + & + (HLF *( Pz * nz + nz * Pz - ( ONE - nz * nz )* tmp ) + & + ( nz * Sx * ny - nz * Sy * nx + nz * Sx * ny - nz * Sy * nx ) / rr ) * & + THR / ( rr * rr ) + + Axy(i,j,k) = Axy(i,j,k) + & + (HLF *( Px * ny + nx * Py + nx * ny * tmp ) + & + ( nx * Sz * nx - nx * Sx * nz + ny * Sy * nz - ny * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Axz(i,j,k) = Axz(i,j,k) + & + (HLF *( Px * nz + nx * Pz + nx * nz * tmp ) + & + ( nx * Sx * ny - nx * Sy * nx + nz * Sy * nz - nz * Sz * ny ) / rr ) * & + THR / ( rr * rr ) + + Ayz(i,j,k) = Ayz(i,j,k) + & + (HLF *( Py * nz + ny * Pz + ny * nz * tmp ) + & + ( ny * Sx * ny - ny * Sy * nx + nz * Sz * nx - nz * Sx * nz ) / rr ) * & + THR / ( rr * rr ) + enddo + enddo + enddo + enddo + + chi = ONE / psi **4 - ONE + + Lap = ONE / ( psi * psi ) - ONE + +!~~~~~~ tilde Aij = Aij / Psi^6 + psi = psi * psi * psi * psi * psi * psi + + Axx = Axx / psi + Ayy = Ayy / psi + Azz = Azz / psi + Axy = Axy / psi + Axz = Axz / psi + Ayz = Ayz / psi + + gxx = ZEO + gyy = ZEO + gzz = ZEO + gxy = ZEO + gxz = ZEO + gyz = ZEO + + trK = ZEO + + Gmx = ZEO + Gmy = ZEO + Gmz = ZEO + + Sfx = ZEO + Sfy = ZEO + Sfz = ZEO + + dtSfx = ZEO + dtSfy = ZEO + dtSfz = ZEO + + return + + end subroutine get_initial_nbhs_sh +!---------------------------------------------------- +! I use this routine to unify the parameters +subroutine shellcordpar(A,B,r0,eps) +implicit none +! argument variables +double precision,intent(out)::A,B,r0,eps + +A=1.d0 +B=0.d0 +r0=0.d0 +eps=1.d0 + +return + +end subroutine shellcordpar +!---------------------------------------------------- +! R = f(r)-f(0) +subroutine getcartr(ex,R,cartr) +implicit none +! argument variables +integer,intent(in)::ex +double precision,intent(in),dimension(ex)::R +double precision,intent(out),dimension(ex)::cartr + +!~~~~~~ local variables +double precision,dimension(ex)::f +double precision :: A,B,r0,eps + +call shellcordpar(A,B,r0,eps) +f = R+B +cartr = r0+(A*f-B*dsqrt(A*A+(f*f-B*B)/eps))/(A*A-B*B/eps) + +return +end subroutine getcartr +! dR/dr = ... +subroutine getdRdcartr(ex,R,dRdcartr) +implicit none +! argument variables +integer,intent(in)::ex +double precision,intent(in),dimension(ex)::R +double precision,intent(out),dimension(ex)::dRdcartr + +!~~~~~~ local variables +double precision,dimension(ex)::cartr +double precision :: A,B,r0,eps + + call shellcordpar(A,B,r0,eps) + + call getcartr(ex,R,cartr) + dRdcartr = A + B*(cartr-r0)/dsqrt(eps*eps+eps*(cartr-r0)*(cartr-r0)) + +return +end subroutine getdRdcartr +! dR/drdr = ... +subroutine getdRdcartrcartr(ex,R,dRdcartrcartr) +implicit none +! argument variables +integer,intent(in)::ex +double precision,intent(in),dimension(ex)::R +double precision,intent(out),dimension(ex)::dRdcartrcartr + +!~~~~~~ local variables +double precision,dimension(ex)::cartr + +double precision :: A,B,r0,eps + + call shellcordpar(A,B,r0,eps) + + call getcartr(ex,R,cartr) + dRdcartrcartr = B*dsqrt(eps)/(dsqrt(eps+(cartr-r0)*(cartr-r0)))**3 + + return + +end subroutine getdRdcartrcartr + +subroutine zp_getxyz(ex,rho,sigma,R,x,y,z) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1))::tgrho +double precision,dimension(ex(2))::tgsigma +integer :: i,j,k + + call getcartr(ex(3),R,cartr) + tgrho = dtan(rho) + tgsigma = dtan(sigma) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + z(i,j,k) = cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) + x(i,j,k) = z(i,j,k)*tgrho(i) + y(i,j,k) = z(i,j,k)*tgsigma(j) + enddo + enddo + enddo + + return + +end subroutine zp_getxyz + +subroutine zm_getxyz(ex,rho,sigma,R,x,y,z) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1))::tgrho +double precision,dimension(ex(2))::tgsigma +integer :: i,j,k + + call getcartr(ex(3),R,cartr) + tgrho = dtan(rho) + tgsigma = dtan(sigma) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + z(i,j,k) = -cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) + x(i,j,k) = z(i,j,k)*tgrho(i) + y(i,j,k) = z(i,j,k)*tgsigma(j) + enddo + enddo + enddo + + return + +end subroutine zm_getxyz + +subroutine yp_getxyz(ex,rho,sigma,R,x,y,z) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1))::tgrho +double precision,dimension(ex(2))::tgsigma +integer :: i,j,k + + call getcartr(ex(3),R,cartr) + tgrho = dtan(rho) + tgsigma = dtan(sigma) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + y(i,j,k) = cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) + x(i,j,k) = y(i,j,k)*tgrho(i) + z(i,j,k) = y(i,j,k)*tgsigma(j) + enddo + enddo + enddo + + return + +end subroutine yp_getxyz + +subroutine ym_getxyz(ex,rho,sigma,R,x,y,z) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1))::tgrho +double precision,dimension(ex(2))::tgsigma +integer :: i,j,k + + call getcartr(ex(3),R,cartr) + tgrho = dtan(rho) + tgsigma = dtan(sigma) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + y(i,j,k) = -cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) + x(i,j,k) = y(i,j,k)*tgrho(i) + z(i,j,k) = y(i,j,k)*tgsigma(j) + enddo + enddo + enddo + + return + +end subroutine ym_getxyz + +subroutine xp_getxyz(ex,rho,sigma,R,x,y,z) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1))::tgrho +double precision,dimension(ex(2))::tgsigma +integer :: i,j,k + + call getcartr(ex(3),R,cartr) + tgrho = dtan(rho) + tgsigma = dtan(sigma) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + x(i,j,k) = cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) + y(i,j,k) = x(i,j,k)*tgrho(i) + z(i,j,k) = x(i,j,k)*tgsigma(j) + enddo + enddo + enddo + + return + +end subroutine xp_getxyz + +subroutine xm_getxyz(ex,rho,sigma,R,x,y,z) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::x,y,z +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1))::tgrho +double precision,dimension(ex(2))::tgsigma +integer :: i,j,k + + call getcartr(ex(3),R,cartr) + tgrho = dtan(rho) + tgsigma = dtan(sigma) + + do k=1,ex(3) + do j=1,ex(2) + do i=1,ex(1) + x(i,j,k) = -cartr(k)/dsqrt(1+tgrho(i)*tgrho(i)+tgsigma(j)*tgsigma(j)) + y(i,j,k) = x(i,j,k)*tgrho(i) + z(i,j,k) = x(i,j,k)*tgsigma(j) + enddo + enddo + enddo + + return + +end subroutine xm_getxyz +!------------------------------------------------------------------------------------------ +! calculate Jacobians +subroutine xpm_getjacobian(ex,rho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1),ex(2),ex(3))::srt,xxyy,xxzz,dRdcartr,dRdcartrcartr +integer :: i,j,k +real*8,parameter :: ZEO=0.d0 + + xxyy = x*x + y*y + xxzz = x*x + z*z + srt = dsqrt(xxyy + z*z) + call getdRdcartr(ex(3),R,dRdcartr(1,1,:)) + call getdRdcartrcartr(ex(3),R,dRdcartrcartr(1,1,:)) + do k=1,ex(3) + dRdcartr(:,:,k) = dRdcartr(1,1,k) + dRdcartrcartr(:,:,k) = dRdcartrcartr(1,1,k) + enddo + + dRdx = x/srt*dRdcartr + dRdy = y/srt*dRdcartr + dRdz = z/srt*dRdcartr + drhodx = -y/xxyy + drhody = x/xxyy + drhodz = ZEO + dsigmadx = -z/xxzz + dsigmady = ZEO + dsigmadz = x/xxzz + + dRdxx = dRdcartrcartr*x*x/srt/srt+dRdcartr*(y*y+z*z)/srt**3 + dRdxy = dRdcartrcartr*x*y/srt/srt-dRdcartr*( x*y)/srt**3 + dRdxz = dRdcartrcartr*x*z/srt/srt-dRdcartr*( x*z)/srt**3 + dRdyy = dRdcartrcartr*y*y/srt/srt+dRdcartr*(x*x+z*z)/srt**3 + dRdyz = dRdcartrcartr*y*z/srt/srt-dRdcartr*( y*z)/srt**3 + dRdzz = dRdcartrcartr*z*z/srt/srt+dRdcartr*(x*x+y*y)/srt**3 + drhodxx = 2*x*y/xxyy**2 + drhodxy = (-x*x + y*y)/xxyy**2 + drhodxz = ZEO + drhodyy = -drhodxx + drhodyz = ZEO + drhodzz = ZEO + dsigmadxx = (2*x*z)/xxzz**2 + dsigmadxy = ZEO + dsigmadxz = (-x*x + z*z)/xxzz**2 + dsigmadyy = ZEO + dsigmadyz = ZEO + dsigmadzz = -dsigmadxx + + return + +end subroutine xpm_getjacobian +!~~~~ +subroutine ypm_getjacobian(ex,rho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1),ex(2),ex(3))::srt,xxyy,yyzz,dRdcartr,dRdcartrcartr +integer :: i,j,k +real*8,parameter :: ZEO=0.d0 + + xxyy = x*x + y*y + yyzz = y*y + z*z + srt = dsqrt(xxyy + z*z) + call getdRdcartr(ex(3),R,dRdcartr(1,1,:)) + call getdRdcartrcartr(ex(3),R,dRdcartrcartr(1,1,:)) + do k=1,ex(3) + dRdcartr(:,:,k) = dRdcartr(1,1,k) + dRdcartrcartr(:,:,k) = dRdcartrcartr(1,1,k) + enddo + + dRdx = x/srt*dRdcartr + dRdy = y/srt*dRdcartr + dRdz = z/srt*dRdcartr + drhodx = y/xxyy + drhody = -x/xxyy + drhodz = ZEO + dsigmadx = ZEO + dsigmady = -z/yyzz + dsigmadz = y/yyzz + + dRdxx = dRdcartrcartr*x*x/srt/srt+dRdcartr*(y*y+z*z)/srt**3 + dRdxy = dRdcartrcartr*x*y/srt/srt-dRdcartr*( x*y)/srt**3 + dRdxz = dRdcartrcartr*x*z/srt/srt-dRdcartr*( x*z)/srt**3 + dRdyy = dRdcartrcartr*y*y/srt/srt+dRdcartr*(x*x+z*z)/srt**3 + dRdyz = dRdcartrcartr*y*z/srt/srt-dRdcartr*( y*z)/srt**3 + dRdzz = dRdcartrcartr*z*z/srt/srt+dRdcartr*(x*x+y*y)/srt**3 + drhodxx = -2*x*y/xxyy**2 + drhodxy = (x*x - y*y)/xxyy**2 + drhodxz = ZEO + drhodyy = -drhodxx + drhodyz = ZEO + drhodzz = ZEO + dsigmadxx = ZEO + dsigmadxy = ZEO + dsigmadxz = ZEO + dsigmadyy = (2*y*z)/yyzz**2 + dsigmadyz = (-y*y + z*z)/yyzz**2 + dsigmadzz = -dsigmadyy + + return + +end subroutine ypm_getjacobian +!~~~~ +subroutine zpm_getjacobian(ex,rho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + +implicit none +! argument variables +integer,dimension(3),intent(in)::ex +double precision,intent(in),dimension(ex(1))::rho +double precision,intent(in),dimension(ex(2))::sigma +double precision,intent(in),dimension(ex(3))::R +double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz +double precision,intent(out),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz +!~~~~~~ other variables +double precision,dimension(ex(3))::cartr +double precision,dimension(ex(1),ex(2),ex(3))::srt,xxzz,yyzz,dRdcartr,dRdcartrcartr +integer :: i,j,k +real*8,parameter :: ZEO=0.d0 + + xxzz = x*x + z*z + yyzz = y*y + z*z + srt = dsqrt(xxzz + y*y) + call getdRdcartr(ex(3),R,dRdcartr(1,1,:)) + call getdRdcartrcartr(ex(3),R,dRdcartrcartr(1,1,:)) + do k=1,ex(3) + dRdcartr(:,:,k) = dRdcartr(1,1,k) + dRdcartrcartr(:,:,k) = dRdcartrcartr(1,1,k) + enddo + + dRdx = x/srt*dRdcartr + dRdy = y/srt*dRdcartr + dRdz = z/srt*dRdcartr + drhodx = z/xxzz + drhody = ZEO + drhodz = -x/xxzz + dsigmadx = ZEO + dsigmady = z/yyzz + dsigmadz = -y/yyzz + + dRdxx = dRdcartrcartr*x*x/srt/srt+dRdcartr*(y*y+z*z)/srt**3 + dRdxy = dRdcartrcartr*x*y/srt/srt-dRdcartr*( x*y)/srt**3 + dRdxz = dRdcartrcartr*x*z/srt/srt-dRdcartr*( x*z)/srt**3 + dRdyy = dRdcartrcartr*y*y/srt/srt+dRdcartr*(x*x+z*z)/srt**3 + dRdyz = dRdcartrcartr*y*z/srt/srt-dRdcartr*( y*z)/srt**3 + dRdzz = dRdcartrcartr*z*z/srt/srt+dRdcartr*(x*x+y*y)/srt**3 + drhodxx = -2*x*z/xxzz**2 + drhodxy = ZEO + drhodxz = (x*x - z*z)/xxzz**2 + drhodyy = ZEO + drhodyz = ZEO + drhodzz = -drhodxx + dsigmadxx = ZEO + dsigmadxy = ZEO + dsigmadxz = ZEO + dsigmadyy = -(2*y*z)/yyzz**2 + dsigmadyz = (y*y - z*z)/yyzz**2 + dsigmadzz = -dsigmadyy + + return + +end subroutine zpm_getjacobian diff --git a/AMSS_NCKU_source/shellfunctions.h b/AMSS_NCKU_source/Shell_Patch/shellfunctions.h similarity index 97% rename from AMSS_NCKU_source/shellfunctions.h rename to AMSS_NCKU_source/Shell_Patch/shellfunctions.h index 7b5f058..99697c2 100644 --- a/AMSS_NCKU_source/shellfunctions.h +++ b/AMSS_NCKU_source/Shell_Patch/shellfunctions.h @@ -1,112 +1,112 @@ - -#ifndef SHELLFUNCTIONS_H -#define SHELLFUNCTIONS_H - -#ifdef fortran1 -#define f_get_initial_nbhs_sh get_initial_nbhs_sh -#define f_xp_getxyz xp_getxyz -#define f_xm_getxyz xm_getxyz -#define f_yp_getxyz yp_getxyz -#define f_ym_getxyz ym_getxyz -#define f_zp_getxyz zp_getxyz -#define f_zm_getxyz zm_getxyz -#define f_xpm_getjacobian xpm_getjacobian -#define f_ypm_getjacobian ypm_getjacobian -#define f_zpm_getjacobian zpm_getjacobian -#define f_shellcordpar shellcordpar -#endif -#ifdef fortran2 -#define f_get_initial_nbhs_sh GET_INITIAL_NBHS_SH -#define f_xp_getxyz XP_GETXYZ -#define f_xm_getxyz XM_GETXYZ -#define f_yp_getxyz YP_GETXYZ -#define f_ym_getxyz YM_GETXYZ -#define f_zp_getxyz ZP_GETXYZ -#define f_zm_getxyz ZM_GETXYZ -#define f_xpm_getjacobian XPM_GETJACOBIAN -#define f_ypm_getjacobian YPM_GETJACOBIAN -#define f_zpm_getjacobian ZPM_GETJACOBIAN -#define f_shellcordpar SHELLCORDPAR -#endif -#ifdef fortran3 -#define f_get_initial_nbhs_sh get_initial_nbhs_sh_ -#define f_xp_getxyz xp_getxyz_ -#define f_xm_getxyz xm_getxyz_ -#define f_yp_getxyz yp_getxyz_ -#define f_ym_getxyz ym_getxyz_ -#define f_zp_getxyz zp_getxyz_ -#define f_zm_getxyz zm_getxyz_ -#define f_xpm_getjacobian xpm_getjacobian_ -#define f_ypm_getjacobian ypm_getjacobian_ -#define f_zpm_getjacobian zpm_getjacobian_ -#define f_shellcordpar shellcordpar_ -#endif - -extern "C" -{ - void f_get_initial_nbhs_sh(int *, double *, double *, double *, - double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, - double *, double *, double *, - double *, double *, double *, double *, int &); -} - -extern "C" -{ - void f_xp_getxyz(int *, double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_xm_getxyz(int *, double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_yp_getxyz(int *, double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_ym_getxyz(int *, double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_zp_getxyz(int *, double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_zm_getxyz(int *, double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_xpm_getjacobian(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_ypm_getjacobian(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} -extern "C" -{ - void f_zpm_getjacobian(int *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *, - double *, double *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_shellcordpar(double &, double &, double &, double &); -} - -#endif /* SHELLFUNCTIONS_H */ + +#ifndef SHELLFUNCTIONS_H +#define SHELLFUNCTIONS_H + +#ifdef fortran1 +#define f_get_initial_nbhs_sh get_initial_nbhs_sh +#define f_xp_getxyz xp_getxyz +#define f_xm_getxyz xm_getxyz +#define f_yp_getxyz yp_getxyz +#define f_ym_getxyz ym_getxyz +#define f_zp_getxyz zp_getxyz +#define f_zm_getxyz zm_getxyz +#define f_xpm_getjacobian xpm_getjacobian +#define f_ypm_getjacobian ypm_getjacobian +#define f_zpm_getjacobian zpm_getjacobian +#define f_shellcordpar shellcordpar +#endif +#ifdef fortran2 +#define f_get_initial_nbhs_sh GET_INITIAL_NBHS_SH +#define f_xp_getxyz XP_GETXYZ +#define f_xm_getxyz XM_GETXYZ +#define f_yp_getxyz YP_GETXYZ +#define f_ym_getxyz YM_GETXYZ +#define f_zp_getxyz ZP_GETXYZ +#define f_zm_getxyz ZM_GETXYZ +#define f_xpm_getjacobian XPM_GETJACOBIAN +#define f_ypm_getjacobian YPM_GETJACOBIAN +#define f_zpm_getjacobian ZPM_GETJACOBIAN +#define f_shellcordpar SHELLCORDPAR +#endif +#ifdef fortran3 +#define f_get_initial_nbhs_sh get_initial_nbhs_sh_ +#define f_xp_getxyz xp_getxyz_ +#define f_xm_getxyz xm_getxyz_ +#define f_yp_getxyz yp_getxyz_ +#define f_ym_getxyz ym_getxyz_ +#define f_zp_getxyz zp_getxyz_ +#define f_zm_getxyz zm_getxyz_ +#define f_xpm_getjacobian xpm_getjacobian_ +#define f_ypm_getjacobian ypm_getjacobian_ +#define f_zpm_getjacobian zpm_getjacobian_ +#define f_shellcordpar shellcordpar_ +#endif + +extern "C" +{ + void f_get_initial_nbhs_sh(int *, double *, double *, double *, + double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, + double *, double *, double *, + double *, double *, double *, double *, int &); +} + +extern "C" +{ + void f_xp_getxyz(int *, double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_xm_getxyz(int *, double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_yp_getxyz(int *, double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_ym_getxyz(int *, double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_zp_getxyz(int *, double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_zm_getxyz(int *, double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_xpm_getjacobian(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_ypm_getjacobian(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} +extern "C" +{ + void f_zpm_getjacobian(int *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *, + double *, double *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_shellcordpar(double &, double &, double &, double &); +} + +#endif /* SHELLFUNCTIONS_H */ diff --git a/AMSS_NCKU_source/zbesh.for b/AMSS_NCKU_source/Special_Function/zbesh.for similarity index 97% rename from AMSS_NCKU_source/zbesh.for rename to AMSS_NCKU_source/Special_Function/zbesh.for index 0f30a2d..37e515f 100644 --- a/AMSS_NCKU_source/zbesh.for +++ b/AMSS_NCKU_source/Special_Function/zbesh.for @@ -1,8217 +1,8217 @@ - SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESH -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, -C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX -C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 -C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX -C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. -C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS -C -C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1. -C -C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND -C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE -C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). -C -C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), -C -PT.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C CY(J)=H(M,FNU+J-1,Z), J=1,...,N -C = 2 RETURNS -C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) -C J=1,...,N , I**2=-1 -C M - KIND OF HANKEL FUNCTION, M=1 OR 2 -C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 -C -C OUTPUT CYR,CYI ARE DOUBLE PRECISION -C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS -C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE -C CY(J)=H(M,FNU+J-1,Z) OR -C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N -C DEPENDING ON KODE, I**2=-1. -C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, -C NZ= 0 , NORMAL RETURN -C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE -C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) -C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR -C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY -C HALF PLANES, NZ STATES ONLY THE NUMBER -C OF UNDERFLOWS. -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO -C LARGE OR CABS(Z) TOO SMALL OR BOTH -C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE -C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT -C REDUCTION PRODUCE LESS THAN HALF OF MACHINE -C ACCURACY -C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- -C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- -C CANCE BY ARGUMENT REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C THE COMPUTATION IS CARRIED OUT BY THE RELATION -C -C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) -C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 -C -C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE -C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED -C TO THE LEFT HALF PLANE BY THE RELATION -C -C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) -C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 -C -C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. -C -C EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z -C PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL -C GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING -C BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE -C WHOLE Z PLANE FOR Z TO INFINITY. -C -C FOR NEGATIVE ORDERS,THE FORMULAE -C -C H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) -C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) -C I**2=-1 -C -C CAN BE USED. -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS -C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. -C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN -C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG -C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS -C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS -C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE -C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS -C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 -C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION -C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION -C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN -C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT -C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS -C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. -C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH -C***END PROLOGUE ZBESH -C -C COMPLEX CY,Z,ZN,ZT,CSGN - EXTERNAL ZABS - DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, - * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, - * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, - * CSGNR, CSGNI - INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, - * MM, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CYR(N), CYI(N) -C - DATA HPI /1.57079632679489662D0/ -C -C***FIRST EXECUTABLE STATEMENT ZBESH - IERR = 0 - NZ=0 - IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 - IF (FNU.LT.0.0D0) IERR=1 - IF (M.LT.1 .OR. M.GT.2) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - NN = N -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU -C----------------------------------------------------------------------- - TOL = DMAX1(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*DBLE(FLOAT(K1)) - DIG = DMIN1(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + DMAX1(-AA,-41.45D0) - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) - RL = 1.2D0*DIG + 3.0D0 - FN = FNU + DBLE(FLOAT(NN-1)) - MM = 3 - M - M - FMM = DBLE(FLOAT(MM)) - ZNR = FMM*ZI - ZNI = -FMM*ZR -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - AA = 0.5D0/TOL - BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 - AA = DMIN1(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = DSQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE -C----------------------------------------------------------------------- - UFL = D1MACH(1)*1.0D+3 - IF (AZ.LT.UFL) GO TO 230 - IF (FNU.GT.FNUL) GO TO 90 - IF (FN.LE.1.0D0) GO TO 70 - IF (FN.GT.2.0D0) GO TO 60 - IF (AZ.GT.TOL) GO TO 70 - ARG = 0.5D0*AZ - ALN = -FN*DLOG(ARG) - IF (ALN.GT.ELIM) GO TO 230 - GO TO 70 - 60 CONTINUE - CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, - * ALIM) - IF (NUF.LT.0) GO TO 230 - NZ = NZ + NUF - NN = NN - NUF -C----------------------------------------------------------------------- -C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK -C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I -C----------------------------------------------------------------------- - IF (NN.EQ.0) GO TO 140 - 70 CONTINUE - IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND. - * M.EQ.2)) GO TO 80 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. -C YN.GE.0. .OR. M=1) -C----------------------------------------------------------------------- - CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) - GO TO 110 -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C----------------------------------------------------------------------- - 80 CONTINUE - MR = -MM - CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, - * TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 240 - NZ=NW - GO TO 110 - 90 CONTINUE -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - MR = 0 - IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR. - * M.NE.2)) GO TO 100 - MR = -MM - IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100 - ZNR = -ZNR - ZNI = -ZNI - 100 CONTINUE - CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 240 - NZ = NZ + NW - 110 CONTINUE -C----------------------------------------------------------------------- -C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) -C -C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 -C----------------------------------------------------------------------- - SGN = DSIGN(HPI,-FMM) -C----------------------------------------------------------------------- -C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(SNGL(FNU)) - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN - RHPI = 1.0D0/SGN -C ZNI = RHPI*DCOS(ARG) -C ZNR = -RHPI*DSIN(ARG) - CSGNI = RHPI*DCOS(ARG) - CSGNR = -RHPI*DSIN(ARG) - IF (MOD(INUH,2).EQ.0) GO TO 120 -C ZNR = -ZNR -C ZNI = -ZNI - CSGNR = -CSGNR - CSGNI = -CSGNI - 120 CONTINUE - ZTI = -FMM - RTOL = 1.0D0/TOL - ASCLE = UFL*RTOL - DO 130 I=1,NN -C STR = CYR(I)*ZNR - CYI(I)*ZNI -C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR -C CYR(I) = STR -C STR = -ZNI*ZTI -C ZNI = ZNR*ZTI -C ZNR = STR - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 135 CONTINUE - STR = AA*CSGNR - BB*CSGNI - STI = AA*CSGNI + BB*CSGNR - CYR(I) = STR*ATOL - CYI(I) = STI*ATOL - STR = -CSGNI*ZTI - CSGNI = CSGNR*ZTI - CSGNR = STR - 130 CONTINUE - RETURN - 140 CONTINUE - IF (ZNR.LT.0.0D0) GO TO 230 - RETURN - 230 CONTINUE - NZ=0 - IERR=2 - RETURN - 240 CONTINUE - IF(NW.EQ.(-1)) GO TO 230 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END - SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESI -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION OF THE FIRST KIND -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX -C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE -C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE -C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED -C FUNCTIONS -C -C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=REAL(Z) -C -C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND -C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION -C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS -C (REF. 1). -C -C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C CY(J)=I(FNU+J-1,Z), J=1,...,N -C = 2 RETURNS -C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N -C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 -C -C OUTPUT CYR,CYI ARE DOUBLE PRECISION -C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS -C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE -C CY(J)=I(FNU+J-1,Z) OR -C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)) J=1,...,N -C DEPENDING ON KODE, X=REAL(Z) -C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, -C NZ= 0 , NORMAL RETURN -C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO -C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) -C J = N-NZ+1,...,N -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO -C LARGE ON KODE=1 -C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE -C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT -C REDUCTION PRODUCE LESS THAN HALF OF MACHINE -C ACCURACY -C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- -C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- -C CANCE BY ARGUMENT REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR -C SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z), -C THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A -C NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE -C UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z) -C FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE -C SEQUENCES OR REDUCE ORDERS WHEN NECESSARY. -C -C THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND -C CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA -C -C I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z) REAL(Z).GT.0.0 -C M = +I OR -I, I**2=-1 -C -C FOR NEGATIVE ORDERS,THE FORMULA -C -C I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z) -C -C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE -C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE -C INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE -C NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, -C K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF -C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY -C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN -C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, -C LARGE MEANS FNU.GT.CABS(Z). -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS -C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. -C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN -C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG -C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS -C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS -C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE -C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS -C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 -C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION -C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION -C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN -C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT -C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS -C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. -C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZBINU,ZABS,I1MACH,D1MACH -C***END PROLOGUE ZBESI -C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN - EXTERNAL ZABS - DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, - * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, - * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI - INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH - DIMENSION CYR(N), CYI(N) - DATA PI /3.14159265358979324D0/ - DATA CONER, CONEI /1.0D0,0.0D0/ -C -C***FIRST EXECUTABLE STATEMENT ZBESI - IERR = 0 - NZ=0 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - TOL = DMAX1(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*DBLE(FLOAT(K1)) - DIG = DMIN1(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + DMAX1(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) -C----------------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - FN = FNU+DBLE(FLOAT(N-1)) - AA = 0.5D0/TOL - BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 - AA = DMIN1(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = DSQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 - ZNR = ZR - ZNI = ZI - CSGNR = CONER - CSGNI = CONEI - IF (ZR.GE.0.0D0) GO TO 40 - ZNR = -ZR - ZNI = -ZI -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(SNGL(FNU)) - ARG = (FNU-DBLE(FLOAT(INU)))*PI - IF (ZI.LT.0.0D0) ARG = -ARG - CSGNR = DCOS(ARG) - CSGNI = DSIN(ARG) - IF (MOD(INU,2).EQ.0) GO TO 40 - CSGNR = -CSGNR - CSGNI = -CSGNI - 40 CONTINUE - CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NZ.LT.0) GO TO 120 - IF (ZR.GE.0.0D0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE -C----------------------------------------------------------------------- - NN = N - NZ - IF (NN.EQ.0) RETURN - RTOL = 1.0D0/TOL - ASCLE = D1MACH(1)*RTOL*1.0D+3 - DO 50 I=1,NN -C STR = CYR(I)*CSGNR - CYI(I)*CSGNI -C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR -C CYR(I) = STR - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 55 CONTINUE - STR = AA*CSGNR - BB*CSGNI - STI = AA*CSGNI + BB*CSGNR - CYR(I) = STR*ATOL - CYI(I) = STI*ATOL - CSGNR = -CSGNR - CSGNI = -CSGNI - 50 CONTINUE - RETURN - 120 CONTINUE - IF(NZ.EQ.(-2)) GO TO 130 - NZ = 0 - IERR=2 - RETURN - 130 CONTINUE - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END - SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESJ -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, -C BESSEL FUNCTION OF FIRST KIND -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C ON KODE=1, ZBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX -C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE -C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE -C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESJ RETURNS THE SCALED -C FUNCTIONS -C -C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) -C -C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND -C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION -C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS -C (REF. 1). -C -C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C CY(I)=J(FNU+I-1,Z), I=1,...,N -C = 2 RETURNS -C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N -C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 -C -C OUTPUT CYR,CYI ARE DOUBLE PRECISION -C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS -C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE -C CY(I)=J(FNU+I-1,Z) OR -C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N -C DEPENDING ON KODE, Y=AIMAG(Z). -C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, -C NZ= 0 , NORMAL RETURN -C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE -C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), -C I = N-NZ+1,...,N -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z) -C TOO LARGE ON KODE=1 -C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE -C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT -C REDUCTION PRODUCE LESS THAN HALF OF MACHINE -C ACCURACY -C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- -C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- -C CANCE BY ARGUMENT REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C THE COMPUTATION IS CARRIED OUT BY THE FORMULA -C -C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0 -C -C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0 -C -C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION. -C -C FOR NEGATIVE ORDERS,THE FORMULA -C -C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU) -C -C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE -C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE -C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A -C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, -C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF -C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY -C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN -C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, -C LARGE MEANS FNU.GT.CABS(Z). -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS -C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. -C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN -C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG -C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS -C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS -C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE -C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS -C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 -C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION -C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION -C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN -C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT -C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS -C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. -C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZBINU,ZABS,I1MACH,D1MACH -C***END PROLOGUE ZBESJ -C -C COMPLEX CI,CSGN,CY,Z,ZN - EXTERNAL ZABS - DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, - * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, - * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI - INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH - DIMENSION CYR(N), CYI(N) - DATA HPI /1.57079632679489662D0/ -C -C***FIRST EXECUTABLE STATEMENT ZBESJ - IERR = 0 - NZ=0 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - TOL = DMAX1(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*DBLE(FLOAT(K1)) - DIG = DMIN1(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + DMAX1(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) -C----------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - FN = FNU+DBLE(FLOAT(N-1)) - AA = 0.5D0/TOL - BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 - AA = DMIN1(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = DSQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - CII = 1.0D0 - INU = INT(SNGL(FNU)) - INUH = INU/2 - IR = INU - 2*INUH - ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI - CSGNR = DCOS(ARG) - CSGNI = DSIN(ARG) - IF (MOD(INUH,2).EQ.0) GO TO 40 - CSGNR = -CSGNR - CSGNI = -CSGNI - 40 CONTINUE -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE -C----------------------------------------------------------------------- - ZNR = ZI - ZNI = -ZR - IF (ZI.GE.0.0D0) GO TO 50 - ZNR = -ZNR - ZNI = -ZNI - CSGNI = -CSGNI - CII = -CII - 50 CONTINUE - CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NZ.LT.0) GO TO 130 - NL = N - NZ - IF (NL.EQ.0) RETURN - RTOL = 1.0D0/TOL - ASCLE = D1MACH(1)*RTOL*1.0D+3 - DO 60 I=1,NL -C STR = CYR(I)*CSGNR - CYI(I)*CSGNI -C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR -C CYR(I) = STR - AA = CYR(I) - BB = CYI(I) - ATOL = 1.0D0 - IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 - AA = AA*RTOL - BB = BB*RTOL - ATOL = TOL - 55 CONTINUE - STR = AA*CSGNR - BB*CSGNI - STI = AA*CSGNI + BB*CSGNR - CYR(I) = STR*ATOL - CYI(I) = STI*ATOL - STR = -CSGNI*CII - CSGNI = CSGNR*CII - CSGNR = STR - 60 CONTINUE - RETURN - 130 CONTINUE - IF(NZ.EQ.(-2)) GO TO 140 - NZ = 0 - IERR = 2 - RETURN - 140 CONTINUE - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END - SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) -C***BEGIN PROLOGUE ZBESK -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, -C MODIFIED BESSEL FUNCTION OF THE SECOND KIND, -C BESSEL FUNCTION OF THE THIRD KIND -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C -C ON KODE=1, ZBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX -C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE -C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0) -C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESK -C RETURNS THE SCALED K FUNCTIONS, -C -C CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N, -C -C WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND -C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND -C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL -C FUNCTIONS (REF. 1). -C -C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), -C -PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0 -C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C CY(I)=K(FNU+I-1,Z), I=1,...,N -C = 2 RETURNS -C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N -C -C OUTPUT CYR,CYI ARE DOUBLE PRECISION -C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS -C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE -C CY(I)=K(FNU+I-1,Z), I=1,...,N OR -C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N -C DEPENDING ON KODE -C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW. -C NZ= 0 , NORMAL RETURN -C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE -C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), -C I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0 -C NZ STATES ONLY THE NUMBER OF UNDERFLOWS -C IN THE SEQUENCE. -C -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS -C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH -C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE -C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT -C REDUCTION PRODUCE LESS THAN HALF OF MACHINE -C ACCURACY -C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- -C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- -C CANCE BY ARGUMENT REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS -C DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD -C RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT -C HALF PLANE BY THE RELATION -C -C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) -C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 -C -C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. -C -C FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED -C BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS. -C -C FOR NEGATIVE ORDERS, THE FORMULA -C -C K(-FNU,Z) = K(FNU,Z) -C -C CAN BE USED. -C -C ZBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS -C AVAILABLE. -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS -C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. -C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN -C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG -C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS -C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS -C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE -C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS -C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 -C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION -C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION -C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN -C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT -C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS -C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. -C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983. -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH -C***END PROLOGUE ZBESK -C -C COMPLEX CY,Z - EXTERNAL ZABS - DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, - * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB - INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH - DIMENSION CYR(N), CYI(N) -C***FIRST EXECUTABLE STATEMENT ZBESK - IERR = 0 - NZ=0 - IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - NN = N -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU -C----------------------------------------------------------------------- - TOL = DMAX1(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*DBLE(FLOAT(K1)) - DIG = DMIN1(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + DMAX1(-AA,-41.45D0) - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) - RL = 1.2D0*DIG + 3.0D0 -C----------------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AZ = ZABS(ZR,ZI) - FN = FNU + DBLE(FLOAT(NN-1)) - AA = 0.5D0/TOL - BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 - AA = DMIN1(AA,BB) - IF (AZ.GT.AA) GO TO 260 - IF (FN.GT.AA) GO TO 260 - AA = DSQRT(AA) - IF (AZ.GT.AA) IERR=3 - IF (FN.GT.AA) IERR=3 -C----------------------------------------------------------------------- -C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE -C----------------------------------------------------------------------- -C UFL = DEXP(-ELIM) - UFL = D1MACH(1)*1.0D+3 - IF (AZ.LT.UFL) GO TO 180 - IF (FNU.GT.FNUL) GO TO 80 - IF (FN.LE.1.0D0) GO TO 60 - IF (FN.GT.2.0D0) GO TO 50 - IF (AZ.GT.TOL) GO TO 60 - ARG = 0.5D0*AZ - ALN = -FN*DLOG(ARG) - IF (ALN.GT.ELIM) GO TO 180 - GO TO 60 - 50 CONTINUE - CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, - * ALIM) - IF (NUF.LT.0) GO TO 180 - NZ = NZ + NUF - NN = NN - NUF -C----------------------------------------------------------------------- -C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK -C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I -C----------------------------------------------------------------------- - IF (NN.EQ.0) GO TO 100 - 60 CONTINUE - IF (ZR.LT.0.0D0) GO TO 70 -C----------------------------------------------------------------------- -C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. -C----------------------------------------------------------------------- - CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ=NW - RETURN -C----------------------------------------------------------------------- -C LEFT HALF PLANE COMPUTATION -C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. -C----------------------------------------------------------------------- - 70 CONTINUE - IF (NZ.NE.0) GO TO 180 - MR = 1 - IF (ZI.LT.0.0D0) MR = -1 - CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, - * TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 200 - NZ=NW - RETURN -C----------------------------------------------------------------------- -C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL -C----------------------------------------------------------------------- - 80 CONTINUE - MR = 0 - IF (ZR.GE.0.0D0) GO TO 90 - MR = 1 - IF (ZI.LT.0.0D0) MR = -1 - 90 CONTINUE - CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 200 - NZ = NZ + NW - RETURN - 100 CONTINUE - IF (ZR.LT.0.0D0) GO TO 180 - RETURN - 180 CONTINUE - NZ = 0 - IERR=2 - RETURN - 200 CONTINUE - IF(NW.EQ.(-1)) GO TO 180 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - NZ=0 - IERR=4 - RETURN - END - SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, - * CWRKI, IERR) -C***BEGIN PROLOGUE ZBESY -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, -C BESSEL FUNCTION OF SECOND KIND -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C -C ON KODE=1, ZBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX -C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE -C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE -C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESY RETURNS THE SCALED -C FUNCTIONS -C -C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) -C -C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND -C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION -C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS -C (REF. 1). -C -C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), -C -PI.LT.ARG(Z).LE.PI -C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C CY(I)=Y(FNU+I-1,Z), I=1,...,N -C = 2 RETURNS -C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N -C WHERE Y=AIMAG(Z) -C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 -C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT -C CWRKI AT LEAST N -C -C OUTPUT CYR,CYI ARE DOUBLE PRECISION -C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS -C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE -C CY(I)=Y(FNU+I-1,Z) OR -C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N -C DEPENDING ON KODE. -C NZ - NZ=0 , A NORMAL RETURN -C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO -C UNDERFLOW (GENERALLY ON KODE=2) -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS -C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH -C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE -C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT -C REDUCTION PRODUCE LESS THAN HALF OF MACHINE -C ACCURACY -C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- -C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- -C CANCE BY ARGUMENT REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C THE COMPUTATION IS CARRIED OUT IN TERMS OF THE I(FNU,Z) AND -C K(FNU,Z) BESSEL FUNCTIONS IN THE RIGHT HALF PLANE BY -C -C Y(FNU,Z) = I*CC*I(FNU,ARG) - (2/PI)*CONJG(CC)*K(FNU,ARG) -C -C Y(FNU,Z) = CONJG(Y(FNU,CONJG(Z))) -C -C FOR AIMAG(Z).GE.0 AND AIMAG(Z).LT.0 RESPECTIVELY, WHERE -C CC=EXP(I*PI*FNU/2), ARG=Z*EXP(-I*PI/2) AND I**2=-1. -C -C FOR NEGATIVE ORDERS,THE FORMULA -C -C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU) -C -C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD -C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE -C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)* -C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS -C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A -C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM -C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, -C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF -C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z). -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS -C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. -C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN -C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG -C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS -C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS -C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE -C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS -C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 -C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION -C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION -C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN -C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT -C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS -C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. -C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZBESI,ZBESK,I1MACH,D1MACH -C***END PROLOGUE ZBESY -C -C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV - DOUBLE PRECISION ARG, ASCLE, CIPI, CIPR, CSGNI, CSGNR, CSPNI, - * CSPNR, CWRKI, CWRKR, CYI, CYR, D1M5, D1MACH, ELIM, EXI, EXR, EY, - * FNU, FFNU, HPI, RHPI, STR, STI, TAY, TOL, ATOL, RTOL, ZI, ZR, - * ZNI, ZNR, ZUI, ZUR, ZVI, ZVR, ZZI, ZZR - INTEGER I, IERR, IFNU, I4, K, KODE, K1, K2, N, NZ, NZ1, NZ2, - * I1MACH - DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N), CIPR(4), CIPI(4) - DATA CIPR(1),CIPR(2),CIPR(3),CIPR(4)/1.0D0, 0.0D0, -1.0D0, 0.0D0/ - DATA CIPI(1),CIPI(2),CIPI(3),CIPI(4)/0.0D0, 1.0D0, 0.0D0, -1.0D0/ - DATA HPI / 1.57079632679489662D0 / -C***FIRST EXECUTABLE STATEMENT ZBESY - IERR = 0 - NZ=0 - IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 - IF (FNU.LT.0.0D0) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (N.LT.1) IERR=1 - IF (IERR.NE.0) RETURN - ZZR = ZR - ZZI = ZI - IF (ZI.LT.0.0D0) ZZI = -ZZI - ZNR = ZZI - ZNI = -ZZR - CALL ZBESI(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ1, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 90 - CALL ZBESK(ZNR, ZNI, FNU, KODE, N, CWRKR, CWRKI, NZ2, IERR) - IF (IERR.NE.0.AND.IERR.NE.3) GO TO 90 - NZ = MIN(NZ1,NZ2) - IFNU = INT(SNGL(FNU)) - FFNU = FNU - DBLE(FLOAT(IFNU)) - ARG = HPI*FFNU - CSGNR = COS(ARG) - CSGNI = SIN(ARG) - I4 = MOD(IFNU,4) + 1 - STR = CSGNR*CIPR(I4) - CSGNI*CIPI(I4) - CSGNI = CSGNR*CIPI(I4) + CSGNI*CIPR(I4) - CSGNR = STR - RHPI = 1.0D0/HPI - CSPNR = CSGNR*RHPI - CSPNI = -CSGNI*RHPI - STR = -CSGNI - CSGNI = CSGNR - CSGNR = STR - IF (KODE.EQ.2) GO TO 60 - DO 50 I=1,N -C CY(I) = CSGN*CY(I)-CSPN*CWRK(I) - STR = CSGNR*CYR(I) - CSGNI*CYI(I) - STR = STR - (CSPNR*CWRKR(I) - CSPNI*CWRKI(I)) - STI = CSGNR*CYI(I) + CSGNI*CYR(I) - STI = STI - (CSPNR*CWRKI(I) + CSPNI*CWRKR(I)) - CYR(I) = STR - CYI(I) = STI - STR = - CSGNI - CSGNI = CSGNR - CSGNR = STR - STR = CSPNI - CSPNI = -CSPNR - CSPNR = STR - 50 CONTINUE - IF (ZI.LT.0.0D0) THEN - DO 55 I=1,N - CYI(I) = -CYI(I) - 55 CONTINUE - ENDIF - RETURN - 60 CONTINUE - EXR = COS(ZR) - EXI = SIN(ZR) - TOL = MAX(D1MACH(4),1.0D-18) - K1 = I1MACH(15) - K2 = I1MACH(16) - K = MIN(IABS(K1),IABS(K2)) - D1M5 = D1MACH(5) -C----------------------------------------------------------------------- -C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT -C----------------------------------------------------------------------- - ELIM = 2.303D0*(DBLE(FLOAT(K))*D1M5-3.0D0) - EY = 0.0D0 - TAY = ABS(ZI+ZI) - IF (TAY.LT.ELIM) EY = EXP(-TAY) - STR = (EXR*CSPNR - EXI*CSPNI)*EY - CSPNI = (EXR*CSPNI + EXI*CSPNR)*EY - CSPNR = STR - NZ = 0 - RTOL = 1.0D0/TOL - ASCLE = D1MACH(1)*RTOL*1.0D+3 - DO 80 I=1,N -C---------------------------------------------------------------------- -C CY(I) = CSGN*CY(I)-CSPN*CWRK(I): PRODUCTS ARE COMPUTED IN -C SCALED MODE IF CY(I) OR CWRK(I) ARE CLOSE TO UNDERFLOW TO -C PREVENT UNDERFLOW IN AN INTERMEDIATE COMPUTATION. -C---------------------------------------------------------------------- - ZVR = CWRKR(I) - ZVI = CWRKI(I) - ATOL=1.0D0 - IF (MAX(ABS(ZVR),ABS(ZVI)).GT.ASCLE) GO TO 75 - ZVR = ZVR*RTOL - ZVI = ZVI*RTOL - ATOL = TOL - 75 CONTINUE - STR = (ZVR*CSPNR - ZVI*CSPNI)*ATOL - ZVI = (ZVR*CSPNI + ZVI*CSPNR)*ATOL - ZVR = STR - ZUR = CYR(I) - ZUI = CYI(I) - ATOL=1.0D0 - IF (MAX(ABS(ZUR),ABS(ZUI)).GT.ASCLE) GO TO 85 - ZUR = ZUR*RTOL - ZUI = ZUI*RTOL - ATOL = TOL - 85 CONTINUE - STR = (ZUR*CSGNR - ZUI*CSGNI)*ATOL - ZUI = (ZUR*CSGNI + ZUI*CSGNR)*ATOL - ZUR = STR - CYR(I) = ZUR - ZVR - CYI(I) = ZUI - ZVI - IF (ZI.LT.0.0D0) CYI(I) = -CYI(I) - IF (CYR(I).EQ.0.0D0 .AND. CYI(I).EQ.0.0D0 .AND. EY.EQ.0.0D0) - & NZ = NZ + 1 - STR = -CSGNI - CSGNI = CSGNR - CSGNR = STR - STR = CSPNI - CSPNI = -CSPNR - CSPNR = STR - 80 CONTINUE - RETURN - 90 CONTINUE - NZ = 0 - RETURN - END - SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) -C***BEGIN PROLOGUE ZAIRY -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR -C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON -C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)* -C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN -C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN -C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z). -C -C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN -C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED -C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS. -C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF -C MATHEMATICAL FUNCTIONS (REF. 1). -C -C INPUT ZR,ZI ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI) -C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C AI=AI(Z) ON ID=0 OR -C AI=DAI(Z)/DZ ON ID=1 -C = 2 RETURNS -C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR -C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE -C ZTA=(2/3)*Z*CSQRT(Z) -C -C OUTPUT AIR,AII ARE DOUBLE PRECISION -C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND -C KODE -C NZ - UNDERFLOW INDICATOR -C NZ= 0 , NORMAL RETURN -C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN -C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1 -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) -C TOO LARGE ON KODE=1 -C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED -C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION -C PRODUCE LESS THAN HALF OF MACHINE ACCURACY -C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION -C COMPLETE LOSS OF ACCURACY BY ARGUMENT -C REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL -C FUNCTIONS BY -C -C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) -C C=1.0/(PI*SQRT(3.0)) -C ZTA=(2/3)*Z**(3/2) -C -C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES -C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF -C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), -C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR -C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN -C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT -C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE -C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA -C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, -C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE -C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE -C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- -C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- -C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN -C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN -C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, -C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE -C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER -C MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZACAI,ZBKNU,ZEXP,ZSQRT,ZABS,I1MACH,D1MACH -C***END PROLOGUE ZAIRY -C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 - EXTERNAL ZABS - DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, - * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, - * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, - * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, - * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB - INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH - DIMENSION CYR(1), CYI(1) - DATA TTH, C1, C2, COEF /6.66666666666666667D-01, - * 3.55028053887817240D-01,2.58819403792806799D-01, - * 1.83776298473930683D-01/ - DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ -C***FIRST EXECUTABLE STATEMENT ZAIRY - IERR = 0 - NZ=0 - IF (ID.LT.0 .OR. ID.GT.1) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (IERR.NE.0) RETURN - AZ = ZABS(ZR,ZI) - TOL = DMAX1(D1MACH(4),1.0D-18) - FID = DBLE(FLOAT(ID)) - IF (AZ.GT.1.0D0) GO TO 70 -C----------------------------------------------------------------------- -C POWER SERIES FOR CABS(Z).LE.1. -C----------------------------------------------------------------------- - S1R = CONER - S1I = CONEI - S2R = CONER - S2I = CONEI - IF (AZ.LT.TOL) GO TO 170 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1R = CONER - TRM1I = CONEI - TRM2R = CONER - TRM2I = CONEI - ATRM = 1.0D0 - STR = ZR*ZR - ZI*ZI - STI = ZR*ZI + ZI*ZR - Z3R = STR*ZR - STI*ZI - Z3I = STR*ZI + STI*ZR - AZ3 = AZ*AA - AK = 2.0D0 + FID - BK = 3.0D0 - FID - FID - CK = 4.0D0 - FID - DK = 3.0D0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = DMIN1(D1,D2) - AK = 24.0D0 + 9.0D0*FID - BK = 30.0D0 - 9.0D0*FID - DO 30 K=1,25 - STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 - TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 - TRM1R = STR - S1R = S1R + TRM1R - S1I = S1I + TRM1I - STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 - TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 - TRM2R = STR - S2R = S2R + TRM2R - S2I = S2I + TRM2I - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = DMIN1(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0D0 - BK = BK + 18.0D0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) - AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - CALL ZEXP(ZTAR, ZTAI, STR, STI) - PTR = AIR*STR - AII*STI - AII = AIR*STI + AII*STR - AIR = PTR - RETURN - 50 CONTINUE - AIR = -S2R*C2 - AII = -S2I*C2 - IF (AZ.LE.TOL) GO TO 60 - STR = ZR*S1R - ZI*S1I - STI = ZR*S1I + ZI*S1R - CC = C1/(1.0D0+FID) - AIR = AIR + CC*(STR*ZR-STI*ZI) - AII = AII + CC*(STR*ZI+STI*ZR) - 60 CONTINUE - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - CALL ZEXP(ZTAR, ZTAI, STR, STI) - PTR = STR*AIR - STI*AII - AII = STR*AII + STI*AIR - AIR = PTR - RETURN -C----------------------------------------------------------------------- -C CASE FOR CABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 70 CONTINUE - FNU = (1.0D0+FID)/3.0D0 -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C----------------------------------------------------------------------- - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*DBLE(FLOAT(K1)) - DIG = DMIN1(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + DMAX1(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - ALAZ = DLOG(AZ) -C-------------------------------------------------------------------------- -C TEST FOR PROPER RANGE -C----------------------------------------------------------------------- - AA=0.5D0/TOL - BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 - AA=DMIN1(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 260 - AA=DSQRT(AA) - IF (AZ.GT.AA) IERR=3 - CALL ZSQRT(ZR, ZI, CSQR, CSQI) - ZTAR = TTH*(ZR*CSQR-ZI*CSQI) - ZTAI = TTH*(ZR*CSQI+ZI*CSQR) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - IFLAG = 0 - SFAC = 1.0D0 - AK = ZTAI - IF (ZR.GE.0.0D0) GO TO 80 - BK = ZTAR - CK = -DABS(BK) - ZTAR = CK - ZTAI = AK - 80 CONTINUE - IF (ZI.NE.0.0D0) GO TO 90 - IF (ZR.GT.0.0D0) GO TO 90 - ZTAR = 0.0D0 - ZTAI = AK - 90 CONTINUE - AA = ZTAR - IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 - IF (KODE.EQ.2) GO TO 100 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.GT.(-ALIM)) GO TO 100 - AA = -AA + 0.25D0*ALAZ - IFLAG = 1 - SFAC = TOL - IF (AA.GT.ELIM) GO TO 270 - 100 CONTINUE -C----------------------------------------------------------------------- -C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 -C----------------------------------------------------------------------- - MR = 1 - IF (ZI.LT.0.0D0) MR = -1 - CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, - * ELIM, ALIM) - IF (NN.LT.0) GO TO 280 - NZ = NZ + NN - GO TO 130 - 110 CONTINUE - IF (KODE.EQ.2) GO TO 120 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (AA.LT.ALIM) GO TO 120 - AA = -AA - 0.25D0*ALAZ - IFLAG = 2 - SFAC = 1.0D0/TOL - IF (AA.LT.(-ELIM)) GO TO 210 - 120 CONTINUE - CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, - * ALIM) - 130 CONTINUE - S1R = CYR(1)*COEF - S1I = CYI(1)*COEF - IF (IFLAG.NE.0) GO TO 150 - IF (ID.EQ.1) GO TO 140 - AIR = CSQR*S1R - CSQI*S1I - AII = CSQR*S1I + CSQI*S1R - RETURN - 140 CONTINUE - AIR = -(ZR*S1R-ZI*S1I) - AII = -(ZR*S1I+ZI*S1R) - RETURN - 150 CONTINUE - S1R = S1R*SFAC - S1I = S1I*SFAC - IF (ID.EQ.1) GO TO 160 - STR = S1R*CSQR - S1I*CSQI - S1I = S1R*CSQI + S1I*CSQR - S1R = STR - AIR = S1R/SFAC - AII = S1I/SFAC - RETURN - 160 CONTINUE - STR = -(S1R*ZR-S1I*ZI) - S1I = -(S1R*ZI+S1I*ZR) - S1R = STR - AIR = S1R/SFAC - AII = S1I/SFAC - RETURN - 170 CONTINUE - AA = 1.0D+3*D1MACH(1) - S1R = ZEROR - S1I = ZEROI - IF (ID.EQ.1) GO TO 190 - IF (AZ.LE.AA) GO TO 180 - S1R = C2*ZR - S1I = C2*ZI - 180 CONTINUE - AIR = C1 - S1R - AII = -S1I - RETURN - 190 CONTINUE - AIR = -C2 - AII = 0.0D0 - AA = DSQRT(AA) - IF (AZ.LE.AA) GO TO 200 - S1R = 0.5D0*(ZR*ZR-ZI*ZI) - S1I = ZR*ZI - 200 CONTINUE - AIR = AIR + C1*S1R - AII = AII + C1*S1I - RETURN - 210 CONTINUE - NZ = 1 - AIR = ZEROR - AII = ZEROI - RETURN - 270 CONTINUE - NZ = 0 - IERR=2 - RETURN - 280 CONTINUE - IF(NN.EQ.(-1)) GO TO 270 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - IERR=4 - NZ=0 - RETURN - END - SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR) -C***BEGIN PROLOGUE ZBIRY -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 890801, 930101 (YYMMDD) -C***CATEGORY NO. B5K -C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z -C***DESCRIPTION -C -C ***A DOUBLE PRECISION ROUTINE*** -C ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR -C ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON -C KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)* -C DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN -C BOTH THE LEFT AND RIGHT HALF PLANES WHERE -C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA). -C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF -C MATHEMATICAL FUNCTIONS (REF. 1). -C -C INPUT ZR,ZI ARE DOUBLE PRECISION -C ZR,ZI - Z=CMPLX(ZR,ZI) -C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 -C KODE - A PARAMETER TO INDICATE THE SCALING OPTION -C KODE= 1 RETURNS -C BI=BI(Z) ON ID=0 OR -C BI=DBI(Z)/DZ ON ID=1 -C = 2 RETURNS -C BI=CEXP(-AXZTA)*BI(Z) ON ID=0 OR -C BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE -C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) -C AND AXZTA=ABS(XZTA) -C -C OUTPUT BIR,BII ARE DOUBLE PRECISION -C BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND -C KODE -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED -C IERR=1, INPUT ERROR - NO COMPUTATION -C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) -C TOO LARGE ON KODE=1 -C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED -C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION -C PRODUCE LESS THAN HALF OF MACHINE ACCURACY -C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION -C COMPLETE LOSS OF ACCURACY BY ARGUMENT -C REDUCTION -C IERR=5, ERROR - NO COMPUTATION, -C ALGORITHM TERMINATION CONDITION NOT MET -C -C***LONG DESCRIPTION -C -C BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL -C FUNCTIONS BY -C -C BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) ) -C DBI(Z)=C * Z * ( I(-2/3,ZTA) + I(2/3,ZTA) ) -C C=1.0/SQRT(3.0) -C ZTA=(2/3)*Z**(3/2) -C -C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. -C -C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- -C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES -C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF -C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), -C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR -C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS -C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. -C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN -C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT -C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE -C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA -C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, -C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE -C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE -C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- -C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- -C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN -C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN -C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, -C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE -C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER -C MACHINES. -C -C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX -C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT -C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- -C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE -C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), -C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF -C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY -C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN -C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY -C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER -C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, -C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS -C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER -C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY -C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER -C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE -C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, -C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, -C OR -PI/2+P. -C -C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ -C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF -C COMMERCE, 1955. -C -C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 -C -C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- -C 1018, MAY, 1985 -C -C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX -C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM -C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, -C PP 265-273. -C -C***ROUTINES CALLED ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH -C***END PROLOGUE ZBIRY -C COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 - EXTERNAL ZABS - DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR, - * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, - * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, - * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, - * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS - INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH - DIMENSION CYR(2), CYI(2) - DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01, - * 6.14926627446000736D-01,4.48288357353826359D-01, - * 5.77350269189625765D-01,3.14159265358979324D+00/ - DATA CONER, CONEI /1.0D0,0.0D0/ -C***FIRST EXECUTABLE STATEMENT ZBIRY - IERR = 0 - NZ=0 - IF (ID.LT.0 .OR. ID.GT.1) IERR=1 - IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 - IF (IERR.NE.0) RETURN - AZ = ZABS(ZR,ZI) - TOL = DMAX1(D1MACH(4),1.0D-18) - FID = DBLE(FLOAT(ID)) - IF (AZ.GT.1.0E0) GO TO 70 -C----------------------------------------------------------------------- -C POWER SERIES FOR CABS(Z).LE.1. -C----------------------------------------------------------------------- - S1R = CONER - S1I = CONEI - S2R = CONER - S2I = CONEI - IF (AZ.LT.TOL) GO TO 130 - AA = AZ*AZ - IF (AA.LT.TOL/AZ) GO TO 40 - TRM1R = CONER - TRM1I = CONEI - TRM2R = CONER - TRM2I = CONEI - ATRM = 1.0D0 - STR = ZR*ZR - ZI*ZI - STI = ZR*ZI + ZI*ZR - Z3R = STR*ZR - STI*ZI - Z3I = STR*ZI + STI*ZR - AZ3 = AZ*AA - AK = 2.0D0 + FID - BK = 3.0D0 - FID - FID - CK = 4.0D0 - FID - DK = 3.0D0 + FID + FID - D1 = AK*DK - D2 = BK*CK - AD = DMIN1(D1,D2) - AK = 24.0D0 + 9.0D0*FID - BK = 30.0D0 - 9.0D0*FID - DO 30 K=1,25 - STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 - TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 - TRM1R = STR - S1R = S1R + TRM1R - S1I = S1I + TRM1I - STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 - TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 - TRM2R = STR - S2R = S2R + TRM2R - S2I = S2I + TRM2I - ATRM = ATRM*AZ3/AD - D1 = D1 + AK - D2 = D2 + BK - AD = DMIN1(D1,D2) - IF (ATRM.LT.TOL*AD) GO TO 40 - AK = AK + 18.0D0 - BK = BK + 18.0D0 - 30 CONTINUE - 40 CONTINUE - IF (ID.EQ.1) GO TO 50 - BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I) - BII = C1*S1I + C2*(ZR*S2I+ZI*S2R) - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - AA = ZTAR - AA = -DABS(AA) - EAA = DEXP(AA) - BIR = BIR*EAA - BII = BII*EAA - RETURN - 50 CONTINUE - BIR = S2R*C2 - BII = S2I*C2 - IF (AZ.LE.TOL) GO TO 60 - CC = C1/(1.0D0+FID) - STR = S1R*ZR - S1I*ZI - STI = S1R*ZI + S1I*ZR - BIR = BIR + CC*(STR*ZR-STI*ZI) - BII = BII + CC*(STR*ZI+STI*ZR) - 60 CONTINUE - IF (KODE.EQ.1) RETURN - CALL ZSQRT(ZR, ZI, STR, STI) - ZTAR = TTH*(ZR*STR-ZI*STI) - ZTAI = TTH*(ZR*STI+ZI*STR) - AA = ZTAR - AA = -DABS(AA) - EAA = DEXP(AA) - BIR = BIR*EAA - BII = BII*EAA - RETURN -C----------------------------------------------------------------------- -C CASE FOR CABS(Z).GT.1.0 -C----------------------------------------------------------------------- - 70 CONTINUE - FNU = (1.0D0+FID)/3.0D0 -C----------------------------------------------------------------------- -C SET PARAMETERS RELATED TO MACHINE CONSTANTS. -C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. -C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. -C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND -C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR -C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. -C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. -C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). -C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. -C----------------------------------------------------------------------- - K1 = I1MACH(15) - K2 = I1MACH(16) - R1M5 = D1MACH(5) - K = MIN0(IABS(K1),IABS(K2)) - ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) - K1 = I1MACH(14) - 1 - AA = R1M5*DBLE(FLOAT(K1)) - DIG = DMIN1(AA,18.0D0) - AA = AA*2.303D0 - ALIM = ELIM + DMAX1(-AA,-41.45D0) - RL = 1.2D0*DIG + 3.0D0 - FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) -C----------------------------------------------------------------------- -C TEST FOR RANGE -C----------------------------------------------------------------------- - AA=0.5D0/TOL - BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 - AA=DMIN1(AA,BB) - AA=AA**TTH - IF (AZ.GT.AA) GO TO 260 - AA=DSQRT(AA) - IF (AZ.GT.AA) IERR=3 - CALL ZSQRT(ZR, ZI, CSQR, CSQI) - ZTAR = TTH*(ZR*CSQR-ZI*CSQI) - ZTAI = TTH*(ZR*CSQI+ZI*CSQR) -C----------------------------------------------------------------------- -C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL -C----------------------------------------------------------------------- - SFAC = 1.0D0 - AK = ZTAI - IF (ZR.GE.0.0D0) GO TO 80 - BK = ZTAR - CK = -DABS(BK) - ZTAR = CK - ZTAI = AK - 80 CONTINUE - IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90 - ZTAR = 0.0D0 - ZTAI = AK - 90 CONTINUE - AA = ZTAR - IF (KODE.EQ.2) GO TO 100 -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - BB = DABS(AA) - IF (BB.LT.ALIM) GO TO 100 - BB = BB + 0.25D0*DLOG(AZ) - SFAC = TOL - IF (BB.GT.ELIM) GO TO 190 - 100 CONTINUE - FMR = 0.0D0 - IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 - FMR = PI - IF (ZI.LT.0.0D0) FMR = -PI - ZTAR = -ZTAR - ZTAI = -ZTAI - 110 CONTINUE -C----------------------------------------------------------------------- -C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) -C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM ZBESI -C----------------------------------------------------------------------- - CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NZ.LT.0) GO TO 200 - AA = FMR*FNU - Z3R = SFAC - STR = DCOS(AA) - STI = DSIN(AA) - S1R = (STR*CYR(1)-STI*CYI(1))*Z3R - S1I = (STR*CYI(1)+STI*CYR(1))*Z3R - FNU = (2.0D0-FID)/3.0D0 - CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL, - * ELIM, ALIM) - CYR(1) = CYR(1)*Z3R - CYI(1) = CYI(1)*Z3R - CYR(2) = CYR(2)*Z3R - CYI(2) = CYI(2)*Z3R -C----------------------------------------------------------------------- -C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 -C----------------------------------------------------------------------- - CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI) - S2R = (FNU+FNU)*STR + CYR(2) - S2I = (FNU+FNU)*STI + CYI(2) - AA = FMR*(FNU-1.0D0) - STR = DCOS(AA) - STI = DSIN(AA) - S1R = COEF*(S1R+S2R*STR-S2I*STI) - S1I = COEF*(S1I+S2R*STI+S2I*STR) - IF (ID.EQ.1) GO TO 120 - STR = CSQR*S1R - CSQI*S1I - S1I = CSQR*S1I + CSQI*S1R - S1R = STR - BIR = S1R/SFAC - BII = S1I/SFAC - RETURN - 120 CONTINUE - STR = ZR*S1R - ZI*S1I - S1I = ZR*S1I + ZI*S1R - S1R = STR - BIR = S1R/SFAC - BII = S1I/SFAC - RETURN - 130 CONTINUE - AA = C1*(1.0D0-FID) + FID*C2 - BIR = AA - BII = 0.0D0 - RETURN - 190 CONTINUE - IERR=2 - NZ=0 - RETURN - 200 CONTINUE - IF(NZ.EQ.(-1)) GO TO 190 - NZ=0 - IERR=5 - RETURN - 260 CONTINUE - IERR=4 - NZ=0 - RETURN - END - SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI) -C***BEGIN PROLOGUE ZMLT -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. -C -C***ROUTINES CALLED (NONE) -C***END PROLOGUE ZMLT - DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB - CA = AR*BR - AI*BI - CB = AR*BI + AI*BR - CR = CA - CI = CB - RETURN - END - SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI) -C***BEGIN PROLOGUE ZDIV -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. -C -C***ROUTINES CALLED ZABS -C***END PROLOGUE ZDIV - EXTERNAL ZABS - DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD - DOUBLE PRECISION ZABS - BM = 1.0D0/ZABS(BR,BI) - CC = BR*BM - CD = BI*BM - CA = (AR*CC+AI*CD)*BM - CB = (AI*CC-AR*CD)*BM - CR = CA - CI = CB - RETURN - END - SUBROUTINE ZSQRT(AR, AI, BR, BI) -C***BEGIN PROLOGUE ZSQRT -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) -C -C***ROUTINES CALLED ZABS -C***END PROLOGUE ZSQRT - EXTERNAL ZABS - DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT - DOUBLE PRECISION ZABS - DATA DRT , DPI / 7.071067811865475244008443621D-1, - 1 3.141592653589793238462643383D+0/ - ZM = ZABS(AR,AI) - ZM = DSQRT(ZM) - IF (AR.EQ.0.0D+0) GO TO 10 - IF (AI.EQ.0.0D+0) GO TO 20 - DTHETA = DATAN(AI/AR) - IF (DTHETA.LE.0.0D+0) GO TO 40 - IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI - GO TO 50 - 10 IF (AI.GT.0.0D+0) GO TO 60 - IF (AI.LT.0.0D+0) GO TO 70 - BR = 0.0D+0 - BI = 0.0D+0 - RETURN - 20 IF (AR.GT.0.0D+0) GO TO 30 - BR = 0.0D+0 - BI = DSQRT(DABS(AR)) - RETURN - 30 BR = DSQRT(AR) - BI = 0.0D+0 - RETURN - 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI - 50 DTHETA = DTHETA*0.5D+0 - BR = ZM*DCOS(DTHETA) - BI = ZM*DSIN(DTHETA) - RETURN - 60 BR = ZM*DRT - BI = ZM*DRT - RETURN - 70 BR = ZM*DRT - BI = -ZM*DRT - RETURN - END - SUBROUTINE ZEXP(AR, AI, BR, BI) -C***BEGIN PROLOGUE ZEXP -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) -C -C***ROUTINES CALLED (NONE) -C***END PROLOGUE ZEXP - DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB - ZM = DEXP(AR) - CA = ZM*DCOS(AI) - CB = ZM*DSIN(AI) - BR = CA - BI = CB - RETURN - END - SUBROUTINE ZLOG(AR, AI, BR, BI, IERR) -C***BEGIN PROLOGUE ZLOG -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) -C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) -C***ROUTINES CALLED ZABS -C***END PROLOGUE ZLOG - EXTERNAL ZABS - DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI - DOUBLE PRECISION ZABS - INTEGER IERR - DATA DPI , DHPI / 3.141592653589793238462643383D+0, - 1 1.570796326794896619231321696D+0/ -C - IERR=0 - IF (AR.EQ.0.0D+0) GO TO 10 - IF (AI.EQ.0.0D+0) GO TO 20 - DTHETA = DATAN(AI/AR) - IF (DTHETA.LE.0.0D+0) GO TO 40 - IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI - GO TO 50 - 10 IF (AI.EQ.0.0D+0) GO TO 60 - BI = DHPI - BR = DLOG(DABS(AI)) - IF (AI.LT.0.0D+0) BI = -BI - RETURN - 20 IF (AR.GT.0.0D+0) GO TO 30 - BR = DLOG(DABS(AR)) - BI = DPI - RETURN - 30 BR = DLOG(AR) - BI = 0.0D+0 - RETURN - 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI - 50 ZM = ZABS(AR,AI) - BR = DLOG(ZM) - BI = DTHETA - RETURN - 60 CONTINUE - IERR=1 - RETURN - END - DOUBLE PRECISION FUNCTION ZABS(ZR, ZI) -C***BEGIN PROLOGUE ZABS -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY -C -C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE -C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) -C -C***ROUTINES CALLED (NONE) -C***END PROLOGUE ZABS - DOUBLE PRECISION ZR, ZI, U, V, Q, S - U = DABS(ZR) - V = DABS(ZI) - S = U + V -C----------------------------------------------------------------------- -C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A -C TRUE FLOATING ZERO -C----------------------------------------------------------------------- - S = S*1.0D+0 - IF (S.EQ.0.0D+0) GO TO 20 - IF (U.GT.V) GO TO 10 - Q = U/V - ZABS = V*DSQRT(1.D+0+Q*Q) - RETURN - 10 Q = V/U - ZABS = U*DSQRT(1.D+0+Q*Q) - RETURN - 20 ZABS = 0.0D+0 - RETURN - END - SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE ZBKNU -C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH -C -C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. -C -C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV, -C ZEXP,ZLOG,ZMLT,ZSQRT -C***END PROLOGUE ZBKNU -C - EXTERNAL ZABS - DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, - * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, - * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, - * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, - * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, - * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, - * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, - * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, - * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI - INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, - * IDUM, I1MACH, J, IC, INUB, NW - DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), - * CYI(2) -C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH -C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK -C - DATA KMAX / 30 / - DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ - 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / - DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / - 1 3.14159265358979324D0, 1.25331413731550025D0, - 2 1.90985931710274403D0, 1.57079632679489662D0, - 3 1.89769999331517738D0, 6.66666666666666666D-01/ - DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ - 1 5.77215664901532861D-01, -4.20026350340952355D-02, - 2 -4.21977345555443367D-02, 7.21894324666309954D-03, - 3 -2.15241674114950973D-04, -2.01348547807882387D-05, - 4 1.13302723198169588D-06, 6.11609510448141582D-09/ -C - CAZ = ZABS(ZR,ZI) - CSCLR = 1.0D0/TOL - CRSCR = TOL - CSSR(1) = CSCLR - CSSR(2) = 1.0D0 - CSSR(3) = CRSCR - CSRR(1) = CRSCR - CSRR(2) = 1.0D0 - CSRR(3) = CSCLR - BRY(1) = 1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - NZ = 0 - IFLAG = 0 - KODED = KODE - RCAZ = 1.0D0/CAZ - STR = ZR*RCAZ - STI = -ZI*RCAZ - RZR = (STR+STR)*RCAZ - RZI = (STI+STI)*RCAZ - INU = INT(FNU+0.5D0) - DNU = FNU - DBLE(FLOAT(INU)) - IF (DABS(DNU).EQ.0.5D0) GO TO 110 - DNU2 = 0.0D0 - IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU - IF (CAZ.GT.R1) GO TO 110 -C----------------------------------------------------------------------- -C SERIES FOR CABS(Z).LE.R1 -C----------------------------------------------------------------------- - FC = 1.0D0 - CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM) - FMUR = SMUR*DNU - FMUI = SMUI*DNU - CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) - IF (DNU.EQ.0.0D0) GO TO 10 - FC = DNU*DPI - FC = FC/DSIN(FC) - SMUR = CSHR/DNU - SMUI = CSHI/DNU - 10 CONTINUE - A2 = 1.0D0 + DNU -C----------------------------------------------------------------------- -C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) -C----------------------------------------------------------------------- - T2 = DEXP(-DGAMLN(A2,IDUM)) - T1 = 1.0D0/(T2*FC) - IF (DABS(DNU).GT.0.1D0) GO TO 40 -C----------------------------------------------------------------------- -C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) -C----------------------------------------------------------------------- - AK = 1.0D0 - S = CC(1) - DO 20 K=2,8 - AK = AK*DNU2 - TM = CC(K)*AK - S = S + TM - IF (DABS(TM).LT.TOL) GO TO 30 - 20 CONTINUE - 30 G1 = -S - GO TO 50 - 40 CONTINUE - G1 = (T1-T2)/(DNU+DNU) - 50 CONTINUE - G2 = (T1+T2)*0.5D0 - FR = FC*(CCHR*G1+SMUR*G2) - FI = FC*(CCHI*G1+SMUI*G2) - CALL ZEXP(FMUR, FMUI, STR, STI) - PR = 0.5D0*STR/T2 - PI = 0.5D0*STI/T2 - CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) - QR = PTR/T1 - QI = PTI/T1 - S1R = FR - S1I = FI - S2R = PR - S2I = PI - AK = 1.0D0 - A1 = 1.0D0 - CKR = CONER - CKI = CONEI - BK = 1.0D0 - DNU2 - IF (INU.GT.0 .OR. N.GT.1) GO TO 80 -C----------------------------------------------------------------------- -C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 -C----------------------------------------------------------------------- - IF (CAZ.LT.TOL) GO TO 70 - CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) - CZR = 0.25D0*CZR - CZI = 0.25D0*CZI - T1 = 0.25D0*CAZ*CAZ - 60 CONTINUE - FR = (FR*AK+PR+QR)/BK - FI = (FI*AK+PI+QI)/BK - STR = 1.0D0/(AK-DNU) - PR = PR*STR - PI = PI*STR - STR = 1.0D0/(AK+DNU) - QR = QR*STR - QI = QI*STR - STR = CKR*CZR - CKI*CZI - RAK = 1.0D0/AK - CKI = (CKR*CZI+CKI*CZR)*RAK - CKR = STR*RAK - S1R = CKR*FR - CKI*FI + S1R - S1I = CKR*FI + CKI*FR + S1I - A1 = A1*T1*RAK - BK = BK + AK + AK + 1.0D0 - AK = AK + 1.0D0 - IF (A1.GT.TOL) GO TO 60 - 70 CONTINUE - YR(1) = S1R - YI(1) = S1I - IF (KODED.EQ.1) RETURN - CALL ZEXP(ZR, ZI, STR, STI) - CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) - RETURN -C----------------------------------------------------------------------- -C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE -C----------------------------------------------------------------------- - 80 CONTINUE - IF (CAZ.LT.TOL) GO TO 100 - CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) - CZR = 0.25D0*CZR - CZI = 0.25D0*CZI - T1 = 0.25D0*CAZ*CAZ - 90 CONTINUE - FR = (FR*AK+PR+QR)/BK - FI = (FI*AK+PI+QI)/BK - STR = 1.0D0/(AK-DNU) - PR = PR*STR - PI = PI*STR - STR = 1.0D0/(AK+DNU) - QR = QR*STR - QI = QI*STR - STR = CKR*CZR - CKI*CZI - RAK = 1.0D0/AK - CKI = (CKR*CZI+CKI*CZR)*RAK - CKR = STR*RAK - S1R = CKR*FR - CKI*FI + S1R - S1I = CKR*FI + CKI*FR + S1I - STR = PR - FR*AK - STI = PI - FI*AK - S2R = CKR*STR - CKI*STI + S2R - S2I = CKR*STI + CKI*STR + S2I - A1 = A1*T1*RAK - BK = BK + AK + AK + 1.0D0 - AK = AK + 1.0D0 - IF (A1.GT.TOL) GO TO 90 - 100 CONTINUE - KFLAG = 2 - A1 = FNU + 1.0D0 - AK = A1*DABS(SMUR) - IF (AK.GT.ALIM) KFLAG = 3 - STR = CSSR(KFLAG) - P2R = S2R*STR - P2I = S2I*STR - CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) - S1R = S1R*STR - S1I = S1I*STR - IF (KODED.EQ.1) GO TO 210 - CALL ZEXP(ZR, ZI, FR, FI) - CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I) - CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I) - GO TO 210 -C----------------------------------------------------------------------- -C IFLAG=0 MEANS NO UNDERFLOW OCCURRED -C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH -C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD -C RECURSION -C----------------------------------------------------------------------- - 110 CONTINUE - CALL ZSQRT(ZR, ZI, STR, STI) - CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) - KFLAG = 2 - IF (KODED.EQ.2) GO TO 120 - IF (ZR.GT.ALIM) GO TO 290 -C BLANK LINE - STR = DEXP(-ZR)*CSSR(KFLAG) - STI = -STR*DSIN(ZI) - STR = STR*DCOS(ZI) - CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) - 120 CONTINUE - IF (DABS(DNU).EQ.0.5D0) GO TO 300 -C----------------------------------------------------------------------- -C MILLER ALGORITHM FOR CABS(Z).GT.R1 -C----------------------------------------------------------------------- - AK = DCOS(DPI*DNU) - AK = DABS(AK) - IF (AK.EQ.CZEROR) GO TO 300 - FHS = DABS(0.25D0-DNU2) - IF (FHS.EQ.CZEROR) GO TO 300 -C----------------------------------------------------------------------- -C COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO -C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON -C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= -C TOL WHERE B IS THE BASE OF THE ARITHMETIC. -C----------------------------------------------------------------------- - T1 = DBLE(FLOAT(I1MACH(14)-1)) - T1 = T1*D1MACH(5)*3.321928094D0 - T1 = DMAX1(T1,12.0D0) - T1 = DMIN1(T1,60.0D0) - T2 = TTH*T1 - 6.0D0 - IF (ZR.NE.0.0D0) GO TO 130 - T1 = HPI - GO TO 140 - 130 CONTINUE - T1 = DATAN(ZI/ZR) - T1 = DABS(T1) - 140 CONTINUE - IF (T2.GT.CAZ) GO TO 170 -C----------------------------------------------------------------------- -C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 -C----------------------------------------------------------------------- - ETEST = AK/(DPI*CAZ*TOL) - FK = CONER - IF (ETEST.LT.CONER) GO TO 180 - FKS = CTWOR - CKR = CAZ + CAZ + CTWOR - P1R = CZEROR - P2R = CONER - DO 150 I=1,KMAX - AK = FHS/FKS - CBR = CKR/(FK+CONER) - PTR = P2R - P2R = CBR*P2R - P1R*AK - P1R = PTR - CKR = CKR + CTWOR - FKS = FKS + FK + FK + CTWOR - FHS = FHS + FK + FK - FK = FK + CONER - STR = DABS(P2R)*FK - IF (ETEST.LT.STR) GO TO 160 - 150 CONTINUE - GO TO 310 - 160 CONTINUE - FK = FK + SPI*T1*DSQRT(T2/CAZ) - FHS = DABS(0.25D0-DNU2) - GO TO 180 - 170 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 -C----------------------------------------------------------------------- - A2 = DSQRT(CAZ) - AK = FPI*AK/(TOL*DSQRT(A2)) - AA = 3.0D0*T1/(1.0D0+CAZ) - BB = 14.7D0*T1/(28.0D0+CAZ) - AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB) - FK = 0.12125D0*AK*AK/CAZ + 1.5D0 - 180 CONTINUE -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - K = INT(SNGL(FK)) - FK = DBLE(FLOAT(K)) - FKS = FK*FK - P1R = CZEROR - P1I = CZEROI - P2R = TOL - P2I = CZEROI - CSR = P2R - CSI = P2I - DO 190 I=1,K - A1 = FKS - FK - AK = (FKS+FK)/(A1+FHS) - RAK = 2.0D0/(FK+CONER) - CBR = (FK+ZR)*RAK - CBI = ZI*RAK - PTR = P2R - PTI = P2I - P2R = (PTR*CBR-PTI*CBI-P1R)*AK - P2I = (PTI*CBR+PTR*CBI-P1I)*AK - P1R = PTR - P1I = PTI - CSR = CSR + P2R - CSI = CSI + P2I - FKS = A1 - FK + CONER - FK = FK - CONER - 190 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER -C SCALING -C----------------------------------------------------------------------- - TM = ZABS(CSR,CSI) - PTR = 1.0D0/TM - S1R = P2R*PTR - S1I = P2I*PTR - CSR = CSR*PTR - CSI = -CSI*PTR - CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) - CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I) - IF (INU.GT.0 .OR. N.GT.1) GO TO 200 - ZDR = ZR - ZDI = ZI - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 200 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING -C----------------------------------------------------------------------- - TM = ZABS(P2R,P2I) - PTR = 1.0D0/TM - P1R = P1R*PTR - P1I = P1I*PTR - P2R = P2R*PTR - P2I = -P2I*PTR - CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) - STR = DNU + 0.5D0 - PTR - STI = -PTI - CALL ZDIV(STR, STI, ZR, ZI, STR, STI) - STR = STR + 1.0D0 - CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I) -C----------------------------------------------------------------------- -C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH -C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 -C----------------------------------------------------------------------- - 210 CONTINUE - STR = DNU + 1.0D0 - CKR = STR*RZR - CKI = STR*RZI - IF (N.EQ.1) INU = INU - 1 - IF (INU.GT.0) GO TO 220 - IF (N.GT.1) GO TO 215 - S1R = S2R - S1I = S2I - 215 CONTINUE - ZDR = ZR - ZDI = ZI - IF(IFLAG.EQ.1) GO TO 270 - GO TO 240 - 220 CONTINUE - INUB = 1 - IF(IFLAG.EQ.1) GO TO 261 - 225 CONTINUE - P1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 230 I=INUB,INU - STR = S2R - STI = S2I - S2R = CKR*STR - CKI*STI + S1R - S2I = CKR*STI + CKI*STR + S1I - S1R = STR - S1I = STI - CKR = CKR + RZR - CKI = CKI + RZI - IF (KFLAG.GE.3) GO TO 230 - P2R = S2R*P1R - P2I = S2I*P1R - STR = DABS(P2R) - STI = DABS(P2I) - P2M = DMAX1(STR,STI) - IF (P2M.LE.ASCLE) GO TO 230 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*P1R - S1I = S1I*P1R - S2R = P2R - S2I = P2I - STR = CSSR(KFLAG) - S1R = S1R*STR - S1I = S1I*STR - S2R = S2R*STR - S2I = S2I*STR - P1R = CSRR(KFLAG) - 230 CONTINUE - IF (N.NE.1) GO TO 240 - S1R = S2R - S1I = S2I - 240 CONTINUE - STR = CSRR(KFLAG) - YR(1) = S1R*STR - YI(1) = S1I*STR - IF (N.EQ.1) RETURN - YR(2) = S2R*STR - YI(2) = S2I*STR - IF (N.EQ.2) RETURN - KK = 2 - 250 CONTINUE - KK = KK + 1 - IF (KK.GT.N) RETURN - P1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 260 I=KK,N - P2R = S2R - P2I = S2I - S2R = CKR*P2R - CKI*P2I + S1R - S2I = CKI*P2R + CKR*P2I + S1I - S1R = P2R - S1I = P2I - CKR = CKR + RZR - CKI = CKI + RZI - P2R = S2R*P1R - P2I = S2I*P1R - YR(I) = P2R - YI(I) = P2I - IF (KFLAG.GE.3) GO TO 260 - STR = DABS(P2R) - STI = DABS(P2I) - P2M = DMAX1(STR,STI) - IF (P2M.LE.ASCLE) GO TO 260 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*P1R - S1I = S1I*P1R - S2R = P2R - S2I = P2I - STR = CSSR(KFLAG) - S1R = S1R*STR - S1I = S1I*STR - S2R = S2R*STR - S2I = S2I*STR - P1R = CSRR(KFLAG) - 260 CONTINUE - RETURN -C----------------------------------------------------------------------- -C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW -C----------------------------------------------------------------------- - 261 CONTINUE - HELIM = 0.5D0*ELIM - ELM = DEXP(-ELIM) - CELMR = ELM - ASCLE = BRY(1) - ZDR = ZR - ZDI = ZI - IC = -1 - J = 2 - DO 262 I=1,INU - STR = S2R - STI = S2I - S2R = STR*CKR-STI*CKI+S1R - S2I = STI*CKR+STR*CKI+S1I - S1R = STR - S1I = STI - CKR = CKR+RZR - CKI = CKI+RZI - AS = ZABS(S2R,S2I) - ALAS = DLOG(AS) - P2R = -ZDR+ALAS - IF(P2R.LT.(-ELIM)) GO TO 263 - CALL ZLOG(S2R,S2I,STR,STI,IDUM) - P2R = -ZDR+STR - P2I = -ZDI+STI - P2M = DEXP(P2R)/TOL - P1R = P2M*DCOS(P2I) - P1I = P2M*DSIN(P2I) - CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL) - IF(NW.NE.0) GO TO 263 - J = 3 - J - CYR(J) = P1R - CYI(J) = P1I - IF(IC.EQ.(I-1)) GO TO 264 - IC = I - GO TO 262 - 263 CONTINUE - IF(ALAS.LT.HELIM) GO TO 262 - ZDR = ZDR-ELIM - S1R = S1R*CELMR - S1I = S1I*CELMR - S2R = S2R*CELMR - S2I = S2I*CELMR - 262 CONTINUE - IF(N.NE.1) GO TO 270 - S1R = S2R - S1I = S2I - GO TO 270 - 264 CONTINUE - KFLAG = 1 - INUB = I+1 - S2R = CYR(J) - S2I = CYI(J) - J = 3 - J - S1R = CYR(J) - S1I = CYI(J) - IF(INUB.LE.INU) GO TO 225 - IF(N.NE.1) GO TO 240 - S1R = S2R - S1I = S2I - GO TO 240 - 270 CONTINUE - YR(1) = S1R - YI(1) = S1I - IF(N.EQ.1) GO TO 280 - YR(2) = S2R - YI(2) = S2I - 280 CONTINUE - ASCLE = BRY(1) - CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) - INU = N - NZ - IF (INU.LE.0) RETURN - KK = NZ + 1 - S1R = YR(KK) - S1I = YI(KK) - YR(KK) = S1R*CSRR(1) - YI(KK) = S1I*CSRR(1) - IF (INU.EQ.1) RETURN - KK = NZ + 2 - S2R = YR(KK) - S2I = YI(KK) - YR(KK) = S2R*CSRR(1) - YI(KK) = S2I*CSRR(1) - IF (INU.EQ.2) RETURN - T2 = FNU + DBLE(FLOAT(KK-1)) - CKR = T2*RZR - CKI = T2*RZI - KFLAG = 1 - GO TO 250 - 290 CONTINUE -C----------------------------------------------------------------------- -C SCALE BY DEXP(Z), IFLAG = 1 CASES -C----------------------------------------------------------------------- - KODED = 2 - IFLAG = 1 - KFLAG = 2 - GO TO 120 -C----------------------------------------------------------------------- -C FNU=HALF ODD INTEGER CASE, DNU=-0.5 -C----------------------------------------------------------------------- - 300 CONTINUE - S1R = COEFR - S1I = COEFI - S2R = COEFR - S2I = COEFI - GO TO 210 -C -C - 310 CONTINUE - NZ=-2 - RETURN - END - SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) -C***BEGIN PROLOGUE ZKSCL -C***REFER TO ZBESK -C -C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE -C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN -C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. -C -C***ROUTINES CALLED ZUCHK,ZABS,ZLOG -C***END PROLOGUE ZKSCL -C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM - EXTERNAL ZABS - DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, - * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, - * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, - * ZDR, ZDI, CELMR, ELM, HELIM, ALAS - INTEGER I, IC, IDUM, KK, N, NN, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2) - DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / -C - NZ = 0 - IC = 0 - NN = MIN0(2,N) - DO 10 I=1,NN - S1R = YR(I) - S1I = YI(I) - CYR(I) = S1R - CYI(I) = S1I - AS = ZABS(S1R,S1I) - ACS = -ZRR + DLOG(AS) - NZ = NZ + 1 - YR(I) = ZEROR - YI(I) = ZEROI - IF (ACS.LT.(-ELIM)) GO TO 10 - CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) - CSR = CSR - ZRR - CSI = CSI - ZRI - STR = DEXP(CSR)/TOL - CSR = STR*DCOS(CSI) - CSI = STR*DSIN(CSI) - CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 10 - YR(I) = CSR - YI(I) = CSI - IC = I - NZ = NZ - 1 - 10 CONTINUE - IF (N.EQ.1) RETURN - IF (IC.GT.1) GO TO 20 - YR(1) = ZEROR - YI(1) = ZEROI - NZ = 2 - 20 CONTINUE - IF (N.EQ.2) RETURN - IF (NZ.EQ.0) RETURN - FN = FNU + 1.0D0 - CKR = FN*RZR - CKI = FN*RZI - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - HELIM = 0.5D0*ELIM - ELM = DEXP(-ELIM) - CELMR = ELM - ZDR = ZRR - ZDI = ZRI -C -C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF -C S2 GETS LARGER THAN EXP(ELIM/2) -C - DO 30 I=3,N - KK = I - CSR = S2R - CSI = S2I - S2R = CKR*CSR - CKI*CSI + S1R - S2I = CKI*CSR + CKR*CSI + S1I - S1R = CSR - S1I = CSI - CKR = CKR + RZR - CKI = CKI + RZI - AS = ZABS(S2R,S2I) - ALAS = DLOG(AS) - ACS = -ZDR + ALAS - NZ = NZ + 1 - YR(I) = ZEROR - YI(I) = ZEROI - IF (ACS.LT.(-ELIM)) GO TO 25 - CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) - CSR = CSR - ZDR - CSI = CSI - ZDI - STR = DEXP(CSR)/TOL - CSR = STR*DCOS(CSI) - CSI = STR*DSIN(CSI) - CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 25 - YR(I) = CSR - YI(I) = CSI - NZ = NZ - 1 - IF (IC.EQ.KK-1) GO TO 40 - IC = KK - GO TO 30 - 25 CONTINUE - IF(ALAS.LT.HELIM) GO TO 30 - ZDR = ZDR - ELIM - S1R = S1R*CELMR - S1I = S1I*CELMR - S2R = S2R*CELMR - S2I = S2I*CELMR - 30 CONTINUE - NZ = N - IF(IC.EQ.N) NZ=N-1 - GO TO 45 - 40 CONTINUE - NZ = KK - 2 - 45 CONTINUE - DO 50 I=1,NZ - YR(I) = ZEROR - YI(I) = ZEROI - 50 CONTINUE - RETURN - END - SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI) -C***BEGIN PROLOGUE ZSHCH -C***REFER TO ZBESK,ZBESH -C -C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) -C AND CCH=COSH(X+I*Y), WHERE I**2=-1. -C -C***ROUTINES CALLED (NONE) -C***END PROLOGUE ZSHCH -C - DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, - * DCOSH, DSINH - SH = DSINH(ZR) - CH = DCOSH(ZR) - SN = DSIN(ZI) - CN = DCOS(ZI) - CSHR = SH*CN - CSHI = CH*SN - CCHR = CH*CN - CCHI = SH*SN - RETURN - END - SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL) -C***BEGIN PROLOGUE ZRATI -C***REFER TO ZBESI,ZBESK,ZBESH -C -C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD -C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD -C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, -C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, -C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, -C BY D. J. SOOKNE. -C -C***ROUTINES CALLED ZABS,ZDIV -C***END PROLOGUE ZRATI -C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU - EXTERNAL ZABS - DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, - * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, - * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, - * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS - INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N - DIMENSION CYR(N), CYI(N) - DATA CZEROR,CZEROI,CONER,CONEI,RT2/ - 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / - AZ = ZABS(ZR,ZI) - INU = INT(SNGL(FNU)) - IDNU = INU + N - 1 - MAGZ = INT(SNGL(AZ)) - AMAGZ = DBLE(FLOAT(MAGZ+1)) - FDNU = DBLE(FLOAT(IDNU)) - FNUP = DMAX1(AMAGZ,FDNU) - ID = IDNU - MAGZ - 1 - ITIME = 1 - K = 1 - PTR = 1.0D0/AZ - RZR = PTR*(ZR+ZR)*PTR - RZI = -PTR*(ZI+ZI)*PTR - T1R = RZR*FNUP - T1I = RZI*FNUP - P2R = -T1R - P2I = -T1I - P1R = CONER - P1I = CONEI - T1R = T1R + RZR - T1I = T1I + RZI - IF (ID.GT.0) ID = 0 - AP2 = ZABS(P2R,P2I) - AP1 = ZABS(P1R,P1I) -C----------------------------------------------------------------------- -C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU -C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT -C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR -C PREMATURELY. -C----------------------------------------------------------------------- - ARG = (AP2+AP2)/(AP1*TOL) - TEST1 = DSQRT(ARG) - TEST = TEST1 - RAP1 = 1.0D0/AP1 - P1R = P1R*RAP1 - P1I = P1I*RAP1 - P2R = P2R*RAP1 - P2I = P2I*RAP1 - AP2 = AP2*RAP1 - 10 CONTINUE - K = K + 1 - AP1 = AP2 - PTR = P2R - PTI = P2I - P2R = P1R - (T1R*PTR-T1I*PTI) - P2I = P1I - (T1R*PTI+T1I*PTR) - P1R = PTR - P1I = PTI - T1R = T1R + RZR - T1I = T1I + RZI - AP2 = ZABS(P2R,P2I) - IF (AP1.LE.TEST) GO TO 10 - IF (ITIME.EQ.2) GO TO 20 - AK = ZABS(T1R,T1I)*0.5D0 - FLAM = AK + DSQRT(AK*AK-1.0D0) - RHO = DMIN1(AP2/AP1,FLAM) - TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0)) - ITIME = 2 - GO TO 10 - 20 CONTINUE - KK = K + 1 - ID - AK = DBLE(FLOAT(KK)) - T1R = AK - T1I = CZEROI - DFNU = FNU + DBLE(FLOAT(N-1)) - P1R = 1.0D0/AP2 - P1I = CZEROI - P2R = CZEROR - P2I = CZEROI - DO 30 I=1,KK - PTR = P1R - PTI = P1I - RAP1 = DFNU + T1R - TTR = RZR*RAP1 - TTI = RZI*RAP1 - P1R = (PTR*TTR-PTI*TTI) + P2R - P1I = (PTR*TTI+PTI*TTR) + P2I - P2R = PTR - P2I = PTI - T1R = T1R - CONER - 30 CONTINUE - IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 - P1R = TOL - P1I = TOL - 40 CONTINUE - CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) - IF (N.EQ.1) RETURN - K = N - 1 - AK = DBLE(FLOAT(K)) - T1R = AK - T1I = CZEROI - CDFNUR = FNU*RZR - CDFNUI = FNU*RZI - DO 60 I=2,N - PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) - PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) - AK = ZABS(PTR,PTI) - IF (AK.NE.CZEROR) GO TO 50 - PTR = TOL - PTI = TOL - AK = TOL*RT2 - 50 CONTINUE - RAK = CONER/AK - CYR(K) = RAK*PTR*RAK - CYI(K) = -RAK*PTI*RAK - T1R = T1R - CONER - K = K - 1 - 60 CONTINUE - RETURN - END - SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, - * IUF) -C***BEGIN PROLOGUE ZS1S2 -C***REFER TO ZBESK,ZAIRY -C -C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE -C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- -C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. -C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF -C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER -C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE -C PRECISION ABOVE THE UNDERFLOW LIMIT. -C -C***ROUTINES CALLED ZABS,ZEXP,ZLOG -C***END PROLOGUE ZS1S2 -C COMPLEX CZERO,C1,S1,S1D,S2,ZR - EXTERNAL ZABS - DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, - * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS - INTEGER IUF, IDUM, NZ - DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / - NZ = 0 - AS1 = ZABS(S1R,S1I) - AS2 = ZABS(S2R,S2I) - IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 - IF (AS1.EQ.0.0D0) GO TO 10 - ALN = -ZRR - ZRR + DLOG(AS1) - S1DR = S1R - S1DI = S1I - S1R = ZEROR - S1I = ZEROI - AS1 = ZEROR - IF (ALN.LT.(-ALIM)) GO TO 10 - CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) - C1R = C1R - ZRR - ZRR - C1I = C1I - ZRI - ZRI - CALL ZEXP(C1R, C1I, S1R, S1I) - AS1 = ZABS(S1R,S1I) - IUF = IUF + 1 - 10 CONTINUE - AA = DMAX1(AS1,AS2) - IF (AA.GT.ASCLE) RETURN - S1R = ZEROR - S1I = ZEROI - S2R = ZEROR - S2I = ZEROI - NZ = 1 - IUF = 0 - RETURN - END - SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE ZBUNK -C***REFER TO ZBESK,ZBESH -C -C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) -C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 -C -C***ROUTINES CALLED ZUNK1,ZUNK2 -C***END PROLOGUE ZBUNK -C COMPLEX Y,Z - DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR - INTEGER KODE, MR, N, NZ - DIMENSION YR(N), YI(N) - NZ = 0 - AX = DABS(ZR)*1.7321D0 - AY = DABS(ZI) - IF (AY.GT.AX) GO TO 10 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) - GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) - 20 CONTINUE - RETURN - END - SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) -C***BEGIN PROLOGUE ZMLRI -C***REFER TO ZBESI,ZBESK -C -C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE -C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. -C -C***ROUTINES CALLED DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT -C***END PROLOGUE ZMLRI -C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z - EXTERNAL ZABS - DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, - * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, - * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, - * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, - * D1MACH, ZABS - INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ - DIMENSION YR(N), YI(N) - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / - SCLE = D1MACH(1)/TOL - NZ=0 - AZ = ZABS(ZR,ZI) - IAZ = INT(SNGL(AZ)) - IFNU = INT(SNGL(FNU)) - INU = IFNU + N - 1 - AT = DBLE(FLOAT(IAZ)) + 1.0D0 - RAZ = 1.0D0/AZ - STR = ZR*RAZ - STI = -ZI*RAZ - CKR = STR*AT*RAZ - CKI = STI*AT*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - P1R = ZEROR - P1I = ZEROI - P2R = CONER - P2I = CONEI - ACK = (AT+1.0D0)*RAZ - RHO = ACK + DSQRT(ACK*ACK-1.0D0) - RHO2 = RHO*RHO - TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) - TST = TST/TOL -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES -C----------------------------------------------------------------------- - AK = AT - DO 10 I=1,80 - PTR = P2R - PTI = P2I - P2R = P1R - (CKR*PTR-CKI*PTI) - P2I = P1I - (CKI*PTR+CKR*PTI) - P1R = PTR - P1I = PTI - CKR = CKR + RZR - CKI = CKI + RZI - AP = ZABS(P2R,P2I) - IF (AP.GT.TST*AK*AK) GO TO 20 - AK = AK + 1.0D0 - 10 CONTINUE - GO TO 110 - 20 CONTINUE - I = I + 1 - K = 0 - IF (INU.LT.IAZ) GO TO 40 -C----------------------------------------------------------------------- -C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS -C----------------------------------------------------------------------- - P1R = ZEROR - P1I = ZEROI - P2R = CONER - P2I = CONEI - AT = DBLE(FLOAT(INU)) + 1.0D0 - STR = ZR*RAZ - STI = -ZI*RAZ - CKR = STR*AT*RAZ - CKI = STI*AT*RAZ - ACK = AT*RAZ - TST = DSQRT(ACK/TOL) - ITIME = 1 - DO 30 K=1,80 - PTR = P2R - PTI = P2I - P2R = P1R - (CKR*PTR-CKI*PTI) - P2I = P1I - (CKR*PTI+CKI*PTR) - P1R = PTR - P1I = PTI - CKR = CKR + RZR - CKI = CKI + RZI - AP = ZABS(P2R,P2I) - IF (AP.LT.TST) GO TO 30 - IF (ITIME.EQ.2) GO TO 40 - ACK = ZABS(CKR,CKI) - FLAM = ACK + DSQRT(ACK*ACK-1.0D0) - FKAP = AP/ZABS(P1R,P1I) - RHO = DMIN1(FLAM,FKAP) - TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0)) - ITIME = 2 - 30 CONTINUE - GO TO 110 - 40 CONTINUE -C----------------------------------------------------------------------- -C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION -C----------------------------------------------------------------------- - K = K + 1 - KK = MAX0(I+IAZ,K+INU) - FKK = DBLE(FLOAT(KK)) - P1R = ZEROR - P1I = ZEROI -C----------------------------------------------------------------------- -C SCALE P2 AND SUM BY SCLE -C----------------------------------------------------------------------- - P2R = SCLE - P2I = ZEROI - FNF = FNU - DBLE(FLOAT(IFNU)) - TFNF = FNF + FNF - BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - - * DGAMLN(TFNF+1.0D0,IDUM) - BK = DEXP(BK) - SUMR = ZEROR - SUMI = ZEROI - KM = KK - INU - DO 50 I=1,KM - PTR = P2R - PTI = P2I - P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) - P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) - P1R = PTR - P1I = PTI - AK = 1.0D0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUMR = SUMR + (ACK+BK)*P1R - SUMI = SUMI + (ACK+BK)*P1I - BK = ACK - FKK = FKK - 1.0D0 - 50 CONTINUE - YR(N) = P2R - YI(N) = P2I - IF (N.EQ.1) GO TO 70 - DO 60 I=2,N - PTR = P2R - PTI = P2I - P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) - P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) - P1R = PTR - P1I = PTI - AK = 1.0D0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUMR = SUMR + (ACK+BK)*P1R - SUMI = SUMI + (ACK+BK)*P1I - BK = ACK - FKK = FKK - 1.0D0 - M = N - I + 1 - YR(M) = P2R - YI(M) = P2I - 60 CONTINUE - 70 CONTINUE - IF (IFNU.LE.0) GO TO 90 - DO 80 I=1,IFNU - PTR = P2R - PTI = P2I - P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) - P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) - P1R = PTR - P1I = PTI - AK = 1.0D0 - TFNF/(FKK+TFNF) - ACK = BK*AK - SUMR = SUMR + (ACK+BK)*P1R - SUMI = SUMI + (ACK+BK)*P1I - BK = ACK - FKK = FKK - 1.0D0 - 80 CONTINUE - 90 CONTINUE - PTR = ZR - PTI = ZI - IF (KODE.EQ.2) PTR = ZEROR - CALL ZLOG(RZR, RZI, STR, STI, IDUM) - P1R = -FNF*STR + PTR - P1I = -FNF*STI + PTI - AP = DGAMLN(1.0D0+FNF,IDUM) - PTR = P1R - AP - PTI = P1I -C----------------------------------------------------------------------- -C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW -C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES -C----------------------------------------------------------------------- - P2R = P2R + SUMR - P2I = P2I + SUMI - AP = ZABS(P2R,P2I) - P1R = 1.0D0/AP - CALL ZEXP(PTR, PTI, STR, STI) - CKR = STR*P1R - CKI = STI*P1R - PTR = P2R*P1R - PTI = -P2I*P1R - CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) - DO 100 I=1,N - STR = YR(I)*CNORMR - YI(I)*CNORMI - YI(I) = YR(I)*CNORMI + YI(I)*CNORMR - YR(I) = STR - 100 CONTINUE - RETURN - 110 CONTINUE - NZ=-2 - RETURN - END - SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, - * TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZWRSK -C***REFER TO ZBESI,ZBESK -C -C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY -C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN -C -C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS -C***END PROLOGUE ZWRSK -C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR - EXTERNAL ZABS - DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, - * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, - * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH - INTEGER I, KODE, N, NW, NZ - DIMENSION YR(N), YI(N), CWR(2), CWI(2) -C----------------------------------------------------------------------- -C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS -C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE -C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. -C----------------------------------------------------------------------- - NZ = 0 - CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 50 - CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) -C----------------------------------------------------------------------- -C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), -C R(FNU+J-1,Z)=Y(J), J=1,...,N -C----------------------------------------------------------------------- - CINUR = 1.0D0 - CINUI = 0.0D0 - IF (KODE.EQ.1) GO TO 10 - CINUR = DCOS(ZRI) - CINUI = DSIN(ZRI) - 10 CONTINUE -C----------------------------------------------------------------------- -C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH -C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE -C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT -C THE RESULT IS ON SCALE. -C----------------------------------------------------------------------- - ACW = ZABS(CWR(2),CWI(2)) - ASCLE = 1.0D+3*D1MACH(1)/TOL - CSCLR = 1.0D0 - IF (ACW.GT.ASCLE) GO TO 20 - CSCLR = 1.0D0/TOL - GO TO 30 - 20 CONTINUE - ASCLE = 1.0D0/ASCLE - IF (ACW.LT.ASCLE) GO TO 30 - CSCLR = TOL - 30 CONTINUE - C1R = CWR(1)*CSCLR - C1I = CWI(1)*CSCLR - C2R = CWR(2)*CSCLR - C2I = CWI(2)*CSCLR - STR = YR(1) - STI = YI(1) -C----------------------------------------------------------------------- -C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS -C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) -C----------------------------------------------------------------------- - PTR = STR*C1R - STI*C1I - PTI = STR*C1I + STI*C1R - PTR = PTR + C2R - PTI = PTI + C2I - CTR = ZRR*PTR - ZRI*PTI - CTI = ZRR*PTI + ZRI*PTR - ACT = ZABS(CTR,CTI) - RACT = 1.0D0/ACT - CTR = CTR*RACT - CTI = -CTI*RACT - PTR = CINUR*RACT - PTI = CINUI*RACT - CINUR = PTR*CTR - PTI*CTI - CINUI = PTR*CTI + PTI*CTR - YR(1) = CINUR*CSCLR - YI(1) = CINUI*CSCLR - IF (N.EQ.1) RETURN - DO 40 I=2,N - PTR = STR*CINUR - STI*CINUI - CINUI = STR*CINUI + STI*CINUR - CINUR = PTR - STR = YR(I) - STI = YI(I) - YR(I) = CINUR*CSCLR - YI(I) = CINUI*CSCLR - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END - SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE ZSERI -C***REFER TO ZBESI,ZBESK -C -C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY -C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE -C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. -C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO -C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE -C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE -C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). -C -C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT -C***END PROLOGUE ZSERI -C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z - EXTERNAL ZABS - DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, - * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, - * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, - * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, - * ZR, DGAMLN, D1MACH, ZABS - INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW - DIMENSION YR(N), YI(N), WR(2), WI(2) - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C - NZ = 0 - AZ = ZABS(ZR,ZI) - IF (AZ.EQ.0.0D0) GO TO 160 - ARM = 1.0D+3*D1MACH(1) - RTR1 = DSQRT(ARM) - CRSCR = 1.0D0 - IFLAG = 0 - IF (AZ.LT.ARM) GO TO 150 - HZR = 0.5D0*ZR - HZI = 0.5D0*ZI - CZR = ZEROR - CZI = ZEROI - IF (AZ.LE.RTR1) GO TO 10 - CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) - 10 CONTINUE - ACZ = ZABS(CZR,CZI) - NN = N - CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) - 20 CONTINUE - DFNU = FNU + DBLE(FLOAT(NN-1)) - FNUP = DFNU + 1.0D0 -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - AK1R = CKR*DFNU - AK1I = CKI*DFNU - AK = DGAMLN(FNUP,IDUM) - AK1R = AK1R - AK - IF (KODE.EQ.2) AK1R = AK1R - ZR - IF (AK1R.GT.(-ELIM)) GO TO 40 - 30 CONTINUE - NZ = NZ + 1 - YR(NN) = ZEROR - YI(NN) = ZEROI - IF (ACZ.GT.DFNU) GO TO 190 - NN = NN - 1 - IF (NN.EQ.0) RETURN - GO TO 20 - 40 CONTINUE - IF (AK1R.GT.(-ALIM)) GO TO 50 - IFLAG = 1 - SS = 1.0D0/TOL - CRSCR = TOL - ASCLE = ARM*SS - 50 CONTINUE - AA = DEXP(AK1R) - IF (IFLAG.EQ.1) AA = AA*SS - COEFR = AA*DCOS(AK1I) - COEFI = AA*DSIN(AK1I) - ATOL = TOL*ACZ/FNUP - IL = MIN0(2,NN) - DO 90 I=1,IL - DFNU = FNU + DBLE(FLOAT(NN-I)) - FNUP = DFNU + 1.0D0 - S1R = CONER - S1I = CONEI - IF (ACZ.LT.TOL*FNUP) GO TO 70 - AK1R = CONER - AK1I = CONEI - AK = FNUP + 2.0D0 - S = FNUP - AA = 2.0D0 - 60 CONTINUE - RS = 1.0D0/S - STR = AK1R*CZR - AK1I*CZI - STI = AK1R*CZI + AK1I*CZR - AK1R = STR*RS - AK1I = STI*RS - S1R = S1R + AK1R - S1I = S1I + AK1I - S = S + AK - AK = AK + 2.0D0 - AA = AA*ACZ*RS - IF (AA.GT.ATOL) GO TO 60 - 70 CONTINUE - S2R = S1R*COEFR - S1I*COEFI - S2I = S1R*COEFI + S1I*COEFR - WR(I) = S2R - WI(I) = S2I - IF (IFLAG.EQ.0) GO TO 80 - CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 30 - 80 CONTINUE - M = NN - I + 1 - YR(M) = S2R*CRSCR - YI(M) = S2I*CRSCR - IF (I.EQ.IL) GO TO 90 - CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) - COEFR = STR*DFNU - COEFI = STI*DFNU - 90 CONTINUE - IF (NN.LE.2) RETURN - K = NN - 2 - AK = DBLE(FLOAT(K)) - RAZ = 1.0D0/AZ - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - IF (IFLAG.EQ.1) GO TO 120 - IB = 3 - 100 CONTINUE - DO 110 I=IB,NN - YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) - YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) - AK = AK - 1.0D0 - K = K - 1 - 110 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD WITH SCALED VALUES -C----------------------------------------------------------------------- - 120 CONTINUE -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE -C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 -C----------------------------------------------------------------------- - S1R = WR(1) - S1I = WI(1) - S2R = WR(2) - S2I = WI(2) - DO 130 L=3,NN - CKR = S2R - CKI = S2I - S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) - S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) - S1R = CKR - S1I = CKI - CKR = S2R*CRSCR - CKI = S2I*CRSCR - YR(K) = CKR - YI(K) = CKI - AK = AK - 1.0D0 - K = K - 1 - IF (ZABS(CKR,CKI).GT.ASCLE) GO TO 140 - 130 CONTINUE - RETURN - 140 CONTINUE - IB = L + 1 - IF (IB.GT.NN) RETURN - GO TO 100 - 150 CONTINUE - NZ = N - IF (FNU.EQ.0.0D0) NZ = NZ - 1 - 160 CONTINUE - YR(1) = ZEROR - YI(1) = ZEROI - IF (FNU.NE.0.0D0) GO TO 170 - YR(1) = CONER - YI(1) = CONEI - 170 CONTINUE - IF (N.EQ.1) RETURN - DO 180 I=2,N - YR(I) = ZEROR - YI(I) = ZEROI - 180 CONTINUE - RETURN -C----------------------------------------------------------------------- -C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE -C THE CALCULATION IN CBINU WITH N=N-IABS(NZ) -C----------------------------------------------------------------------- - 190 CONTINUE - NZ = -NZ - RETURN - END - SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE ZASYI -C***REFER TO ZBESI,ZBESK -C -C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY -C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE -C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. -C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. -C -C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT -C***END PROLOGUE ZASYI -C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z - EXTERNAL ZABS - DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, - * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, - * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, - * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, - * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS - INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ - DIMENSION YR(N), YI(N) - DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C - NZ = 0 - AZ = ZABS(ZR,ZI) - ARM = 1.0D+3*D1MACH(1) - RTR1 = DSQRT(ARM) - IL = MIN0(2,N) - DFNU = FNU + DBLE(FLOAT(N-IL)) -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - RAZ = 1.0D0/AZ - STR = ZR*RAZ - STI = -ZI*RAZ - AK1R = RTPI*STR*RAZ - AK1I = RTPI*STI*RAZ - CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) - CZR = ZR - CZI = ZI - IF (KODE.NE.2) GO TO 10 - CZR = ZEROR - CZI = ZI - 10 CONTINUE - IF (DABS(CZR).GT.ELIM) GO TO 100 - DNU2 = DFNU + DFNU - KODED = 1 - IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 - KODED = 0 - CALL ZEXP(CZR, CZI, STR, STI) - CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) - 20 CONTINUE - FDN = 0.0D0 - IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 - EZR = ZR*8.0D0 - EZI = ZI*8.0D0 -C----------------------------------------------------------------------- -C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE -C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE -C EXPANSION FOR THE IMAGINARY PART. -C----------------------------------------------------------------------- - AEZ = 8.0D0*AZ - S = TOL/AEZ - JL = INT(SNGL(RL+RL)) + 2 - P1R = ZEROR - P1I = ZEROI - IF (ZI.EQ.0.0D0) GO TO 30 -C----------------------------------------------------------------------- -C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF -C SIGNIFICANCE WHEN FNU OR N IS LARGE -C----------------------------------------------------------------------- - INU = INT(SNGL(FNU)) - ARG = (FNU-DBLE(FLOAT(INU)))*PI - INU = INU + N - IL - AK = -DSIN(ARG) - BK = DCOS(ARG) - IF (ZI.LT.0.0D0) BK = -BK - P1R = AK - P1I = BK - IF (MOD(INU,2).EQ.0) GO TO 30 - P1R = -P1R - P1I = -P1I - 30 CONTINUE - DO 70 K=1,IL - SQK = FDN - 1.0D0 - ATOL = S*DABS(SQK) - SGN = 1.0D0 - CS1R = CONER - CS1I = CONEI - CS2R = CONER - CS2I = CONEI - CKR = CONER - CKI = CONEI - AK = 0.0D0 - AA = 1.0D0 - BB = AEZ - DKR = EZR - DKI = EZI - DO 40 J=1,JL - CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) - CKR = STR*SQK - CKI = STI*SQK - CS2R = CS2R + CKR - CS2I = CS2I + CKI - SGN = -SGN - CS1R = CS1R + CKR*SGN - CS1I = CS1I + CKI*SGN - DKR = DKR + EZR - DKI = DKI + EZI - AA = AA*DABS(SQK)/BB - BB = BB + AEZ - AK = AK + 8.0D0 - SQK = SQK - AK - IF (AA.LE.ATOL) GO TO 50 - 40 CONTINUE - GO TO 110 - 50 CONTINUE - S2R = CS1R - S2I = CS1I - IF (ZR+ZR.GE.ELIM) GO TO 60 - TZR = ZR + ZR - TZI = ZI + ZI - CALL ZEXP(-TZR, -TZI, STR, STI) - CALL ZMLT(STR, STI, P1R, P1I, STR, STI) - CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) - S2R = S2R + STR - S2I = S2I + STI - 60 CONTINUE - FDN = FDN + 8.0D0*DFNU + 4.0D0 - P1R = -P1R - P1I = -P1I - M = N - IL + K - YR(M) = S2R*AK1R - S2I*AK1I - YI(M) = S2R*AK1I + S2I*AK1R - 70 CONTINUE - IF (N.LE.2) RETURN - NN = N - K = NN - 2 - AK = DBLE(FLOAT(K)) - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - IB = 3 - DO 80 I=IB,NN - YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) - YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) - AK = AK - 1.0D0 - K = K - 1 - 80 CONTINUE - IF (KODED.EQ.0) RETURN - CALL ZEXP(CZR, CZI, CKR, CKI) - DO 90 I=1,NN - STR = YR(I)*CKR - YI(I)*CKI - YI(I) = YR(I)*CKI + YI(I)*CKR - YR(I) = STR - 90 CONTINUE - RETURN - 100 CONTINUE - NZ = -1 - RETURN - 110 CONTINUE - NZ=-2 - RETURN - END - SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, - * ELIM, ALIM) -C***BEGIN PROLOGUE ZUOIK -C***REFER TO ZBESI,ZBESK,ZBESH -C -C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC -C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM -C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW -C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING -C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN -C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER -C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE -C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= -C EXP(-ELIM)/TOL -C -C IKFLG=1 MEANS THE I SEQUENCE IS TESTED -C =2 MEANS THE K SEQUENCE IS TESTED -C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE -C =-1 MEANS AN OVERFLOW WOULD OCCUR -C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO -C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE -C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO -C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY -C ANOTHER ROUTINE -C -C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG -C***END PROLOGUE ZUOIK -C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, -C *ZR - EXTERNAL ZABS - DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, - * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, - * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, - * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, - * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS - INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW - DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) - DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / - DATA AIC / 1.265512123484645396D+00 / - NUF = 0 - NN = N - ZRR = ZR - ZRI = ZI - IF (ZR.GE.0.0D0) GO TO 10 - ZRR = -ZR - ZRI = -ZI - 10 CONTINUE - ZBR = ZRR - ZBI = ZRI - AX = DABS(ZR)*1.7321D0 - AY = DABS(ZI) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - GNU = DMAX1(FNU,1.0D0) - IF (IKFLG.EQ.1) GO TO 20 - FNN = DBLE(FLOAT(NN)) - GNN = FNU + FNN - 1.0D0 - GNU = DMAX1(GNN,FNN) - 20 CONTINUE -C----------------------------------------------------------------------- -C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE -C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET -C THE SIGN OF THE IMAGINARY PART CORRECT. -C----------------------------------------------------------------------- - IF (IFORM.EQ.2) GO TO 30 - INIT = 0 - CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - GO TO 50 - 30 CONTINUE - ZNR = ZRI - ZNI = -ZRR - IF (ZI.GT.0.0D0) GO TO 40 - ZNR = -ZNR - 40 CONTINUE - CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - AARG = ZABS(ARGR,ARGI) - 50 CONTINUE - IF (KODE.EQ.1) GO TO 60 - CZR = CZR - ZBR - CZI = CZI - ZBI - 60 CONTINUE - IF (IKFLG.EQ.1) GO TO 70 - CZR = -CZR - CZI = -CZI - 70 CONTINUE - APHI = ZABS(PHIR,PHII) - RCZ = CZR -C----------------------------------------------------------------------- -C OVERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.GT.ELIM) GO TO 210 - IF (RCZ.LT.ALIM) GO TO 80 - RCZ = RCZ + DLOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC - IF (RCZ.GT.ELIM) GO TO 210 - GO TO 130 - 80 CONTINUE -C----------------------------------------------------------------------- -C UNDERFLOW TEST -C----------------------------------------------------------------------- - IF (RCZ.LT.(-ELIM)) GO TO 90 - IF (RCZ.GT.(-ALIM)) GO TO 130 - RCZ = RCZ + DLOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 110 - 90 CONTINUE - DO 100 I=1,NN - YR(I) = ZEROR - YI(I) = ZEROI - 100 CONTINUE - NUF = NN - RETURN - 110 CONTINUE - ASCLE = 1.0D+3*D1MACH(1)/TOL - CALL ZLOG(PHIR, PHII, STR, STI, IDUM) - CZR = CZR + STR - CZI = CZI + STI - IF (IFORM.EQ.1) GO TO 120 - CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) - CZR = CZR - 0.25D0*STR - AIC - CZI = CZI - 0.25D0*STI - 120 CONTINUE - AX = DEXP(RCZ)/TOL - AY = CZI - CZR = AX*DCOS(AY) - CZI = AX*DSIN(AY) - CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 90 - 130 CONTINUE - IF (IKFLG.EQ.2) RETURN - IF (N.EQ.1) RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOWS ON I SEQUENCE -C----------------------------------------------------------------------- - 140 CONTINUE - GNU = FNU + DBLE(FLOAT(NN-1)) - IF (IFORM.EQ.2) GO TO 150 - INIT = 0 - CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - GO TO 160 - 150 CONTINUE - CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - CZR = -ZETA1R + ZETA2R - CZI = -ZETA1I + ZETA2I - AARG = ZABS(ARGR,ARGI) - 160 CONTINUE - IF (KODE.EQ.1) GO TO 170 - CZR = CZR - ZBR - CZI = CZI - ZBI - 170 CONTINUE - APHI = ZABS(PHIR,PHII) - RCZ = CZR - IF (RCZ.LT.(-ELIM)) GO TO 180 - IF (RCZ.GT.(-ALIM)) RETURN - RCZ = RCZ + DLOG(APHI) - IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC - IF (RCZ.GT.(-ELIM)) GO TO 190 - 180 CONTINUE - YR(NN) = ZEROR - YI(NN) = ZEROI - NN = NN - 1 - NUF = NUF + 1 - IF (NN.EQ.0) RETURN - GO TO 140 - 190 CONTINUE - ASCLE = 1.0D+3*D1MACH(1)/TOL - CALL ZLOG(PHIR, PHII, STR, STI, IDUM) - CZR = CZR + STR - CZI = CZI + STI - IF (IFORM.EQ.1) GO TO 200 - CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) - CZR = CZR - 0.25D0*STR - AIC - CZI = CZI - 0.25D0*STI - 200 CONTINUE - AX = DEXP(RCZ)/TOL - AY = CZI - CZR = AX*DCOS(AY) - CZI = AX*DSIN(AY) - CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) - IF (NW.NE.0) GO TO 180 - RETURN - 210 CONTINUE - NUF = -1 - RETURN - END - SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, - * TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZACON -C***REFER TO ZBESK,ZBESH -C -C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA -C -C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) -C MP=PI*MR*CMPLX(0.0,1.0) -C -C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT -C HALF Z PLANE -C -C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT -C***END PROLOGUE ZACON -C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, -C *S1,S2,Y,Z,ZN - EXTERNAL ZABS - DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, - * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, - * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, - * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, - * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, - * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS - INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) - DATA PI / 3.14159265358979324D0 / - DATA ZEROR,CONER / 0.0D0,1.0D0 / - NZ = 0 - ZNR = -ZR - ZNI = -ZI - NN = N - CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, - * ELIM, ALIM) - IF (NW.LT.0) GO TO 90 -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - NN = MIN0(2,N) - CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 90 - S1R = CYR(1) - S1I = CYI(1) - FMR = DBLE(FLOAT(MR)) - SGN = -DSIGN(PI,FMR) - CSGNR = ZEROR - CSGNI = SGN - IF (KODE.EQ.1) GO TO 10 - YY = -ZNI - CPN = DCOS(YY) - SPN = DSIN(YY) - CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) - 10 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(SNGL(FNU)) - ARG = (FNU-DBLE(FLOAT(INU)))*SGN - CPN = DCOS(ARG) - SPN = DSIN(ARG) - CSPNR = CPN - CSPNI = SPN - IF (MOD(INU,2).EQ.0) GO TO 20 - CSPNR = -CSPNR - CSPNI = -CSPNI - 20 CONTINUE - IUF = 0 - C1R = S1R - C1I = S1I - C2R = YR(1) - C2I = YI(1) - ASCLE = 1.0D+3*D1MACH(1)/TOL - IF (KODE.EQ.1) GO TO 30 - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1R = C1R - SC1I = C1I - 30 CONTINUE - CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) - CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) - YR(1) = STR + PTR - YI(1) = STI + PTI - IF (N.EQ.1) RETURN - CSPNR = -CSPNR - CSPNI = -CSPNI - S2R = CYR(2) - S2I = CYI(2) - C1R = S2R - C1I = S2I - C2R = YR(2) - C2I = YI(2) - IF (KODE.EQ.1) GO TO 40 - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC2R = C1R - SC2I = C1I - 40 CONTINUE - CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) - CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) - YR(2) = STR + PTR - YI(2) = STI + PTI - IF (N.EQ.2) RETURN - CSPNR = -CSPNR - CSPNI = -CSPNI - AZN = ZABS(ZNR,ZNI) - RAZN = 1.0D0/AZN - STR = ZNR*RAZN - STI = -ZNI*RAZN - RZR = (STR+STR)*RAZN - RZI = (STI+STI)*RAZN - FN = FNU + 1.0D0 - CKR = FN*RZR - CKI = FN*RZI -C----------------------------------------------------------------------- -C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CSCR = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CSCR - CSRR(1) = CSCR - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = ASCLE - BRY(2) = 1.0D0/ASCLE - BRY(3) = D1MACH(2) - AS2 = ZABS(S2R,S2I) - KFLAG = 2 - IF (AS2.GT.BRY(1)) GO TO 50 - KFLAG = 1 - GO TO 60 - 50 CONTINUE - IF (AS2.LT.BRY(2)) GO TO 60 - KFLAG = 3 - 60 CONTINUE - BSCLE = BRY(KFLAG) - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - CSR = CSRR(KFLAG) - DO 80 I=3,N - STR = S2R - STI = S2I - S2R = CKR*STR - CKI*STI + S1R - S2I = CKR*STI + CKI*STR + S1I - S1R = STR - S1I = STI - C1R = S2R*CSR - C1I = S2I*CSR - STR = C1R - STI = C1I - C2R = YR(I) - C2I = YI(I) - IF (KODE.EQ.1) GO TO 70 - IF (IUF.LT.0) GO TO 70 - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - SC1R = SC2R - SC1I = SC2I - SC2R = C1R - SC2I = C1I - IF (IUF.NE.3) GO TO 70 - IUF = -4 - S1R = SC1R*CSSR(KFLAG) - S1I = SC1I*CSSR(KFLAG) - S2R = SC2R*CSSR(KFLAG) - S2I = SC2I*CSSR(KFLAG) - STR = SC2R - STI = SC2I - 70 CONTINUE - PTR = CSPNR*C1R - CSPNI*C1I - PTI = CSPNR*C1I + CSPNI*C1R - YR(I) = PTR + CSGNR*C2R - CSGNI*C2I - YI(I) = PTI + CSGNR*C2I + CSGNI*C2R - CKR = CKR + RZR - CKI = CKI + RZI - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (KFLAG.GE.3) GO TO 80 - PTR = DABS(C1R) - PTI = DABS(C1I) - C1M = DMAX1(PTR,PTI) - IF (C1M.LE.BSCLE) GO TO 80 - KFLAG = KFLAG + 1 - BSCLE = BRY(KFLAG) - S1R = S1R*CSR - S1I = S1I*CSR - S2R = STR - S2I = STI - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - CSR = CSRR(KFLAG) - 80 CONTINUE - RETURN - 90 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END - SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, - * TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZBINU -C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY -C -C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE -C -C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK -C***END PROLOGUE ZBINU - EXTERNAL ZABS - DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, - * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS - INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ - DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) - DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / -C - NZ = 0 - AZ = ZABS(ZR,ZI) - NN = N - DFNU = FNU + DBLE(FLOAT(N-1)) - IF (AZ.LE.2.0D0) GO TO 10 - IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES -C----------------------------------------------------------------------- - CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) - INW = IABS(NW) - NZ = NZ + INW - NN = NN - INW - IF (NN.EQ.0) RETURN - IF (NW.GE.0) GO TO 120 - DFNU = FNU + DBLE(FLOAT(NN-1)) - 20 CONTINUE - IF (AZ.LT.RL) GO TO 40 - IF (DFNU.LE.1.0D0) GO TO 30 - IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z -C----------------------------------------------------------------------- - 30 CONTINUE - CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 40 CONTINUE - IF (DFNU.LE.1.0D0) GO TO 70 - 50 CONTINUE -C----------------------------------------------------------------------- -C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM -C----------------------------------------------------------------------- - CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - NN = NN - NW - IF (NN.EQ.0) RETURN - DFNU = FNU+DBLE(FLOAT(NN-1)) - IF (DFNU.GT.FNUL) GO TO 110 - IF (AZ.GT.FNUL) GO TO 110 - 60 CONTINUE - IF (AZ.GT.RL) GO TO 80 - 70 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES -C----------------------------------------------------------------------- - CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) - IF(NW.LT.0) GO TO 130 - GO TO 120 - 80 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- -C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN -C----------------------------------------------------------------------- - CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, - * ALIM) - IF (NW.GE.0) GO TO 100 - NZ = NN - DO 90 I=1,NN - CYR(I) = ZEROR - CYI(I) = ZEROI - 90 CONTINUE - RETURN - 100 CONTINUE - IF (NW.GT.0) GO TO 130 - CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, - * ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - GO TO 120 - 110 CONTINUE -C----------------------------------------------------------------------- -C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD -C----------------------------------------------------------------------- - NUI = INT(SNGL(FNUL-DFNU)) + 1 - NUI = MAX0(NUI,0) - CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, - * TOL, ELIM, ALIM) - IF (NW.LT.0) GO TO 130 - NZ = NZ + NW - IF (NLAST.EQ.0) GO TO 120 - NN = NLAST - GO TO 60 - 120 CONTINUE - RETURN - 130 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END - DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR) -C***BEGIN PROLOGUE DGAMLN -C***DATE WRITTEN 830501 (YYMMDD) -C***REVISION DATE 830501 (YYMMDD) -C***CATEGORY NO. B5F -C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION -C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES -C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION -C***DESCRIPTION -C -C **** A DOUBLE PRECISION ROUTINE **** -C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR -C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES -C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION -C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS -C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE -C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) -C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. -C -C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 -C VALUES IS USED FOR SPEED OF EXECUTION. -C -C DESCRIPTION OF ARGUMENTS -C -C INPUT Z IS D0UBLE PRECISION -C Z - ARGUMENT, Z.GT.0.0D0 -C -C OUTPUT DGAMLN IS DOUBLE PRECISION -C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 -C IERR - ERROR FLAG -C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED -C IERR=1, Z.LE.0.0D0, NO COMPUTATION -C -C -C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT -C BY D. E. AMOS, SAND83-0083, MAY, 1983. -C***ROUTINES CALLED I1MACH,D1MACH -C***END PROLOGUE DGAMLN - DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, - * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH - INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH - DIMENSION CF(22), GLN(100) -C LNGAMMA(N), N=1,100 - DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), - 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), - 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), - 3 GLN(21), GLN(22)/ - 4 0.00000000000000000D+00, 0.00000000000000000D+00, - 5 6.93147180559945309D-01, 1.79175946922805500D+00, - 6 3.17805383034794562D+00, 4.78749174278204599D+00, - 7 6.57925121201010100D+00, 8.52516136106541430D+00, - 8 1.06046029027452502D+01, 1.28018274800814696D+01, - 9 1.51044125730755153D+01, 1.75023078458738858D+01, - A 1.99872144956618861D+01, 2.25521638531234229D+01, - B 2.51912211827386815D+01, 2.78992713838408916D+01, - C 3.06718601060806728D+01, 3.35050734501368889D+01, - D 3.63954452080330536D+01, 3.93398841871994940D+01, - E 4.23356164607534850D+01, 4.53801388984769080D+01/ - DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), - 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), - 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), - 3 GLN(41), GLN(42), GLN(43), GLN(44)/ - 4 4.84711813518352239D+01, 5.16066755677643736D+01, - 5 5.47847293981123192D+01, 5.80036052229805199D+01, - 6 6.12617017610020020D+01, 6.45575386270063311D+01, - 7 6.78897431371815350D+01, 7.12570389671680090D+01, - 8 7.46582363488301644D+01, 7.80922235533153106D+01, - 9 8.15579594561150372D+01, 8.50544670175815174D+01, - A 8.85808275421976788D+01, 9.21361756036870925D+01, - B 9.57196945421432025D+01, 9.93306124547874269D+01, - C 1.02968198614513813D+02, 1.06631760260643459D+02, - D 1.10320639714757395D+02, 1.14034211781461703D+02, - E 1.17771881399745072D+02, 1.21533081515438634D+02/ - DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), - 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), - 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), - 3 GLN(63), GLN(64), GLN(65), GLN(66)/ - 4 1.25317271149356895D+02, 1.29123933639127215D+02, - 5 1.32952575035616310D+02, 1.36802722637326368D+02, - 6 1.40673923648234259D+02, 1.44565743946344886D+02, - 7 1.48477766951773032D+02, 1.52409592584497358D+02, - 8 1.56360836303078785D+02, 1.60331128216630907D+02, - 9 1.64320112263195181D+02, 1.68327445448427652D+02, - A 1.72352797139162802D+02, 1.76395848406997352D+02, - B 1.80456291417543771D+02, 1.84533828861449491D+02, - C 1.88628173423671591D+02, 1.92739047287844902D+02, - D 1.96866181672889994D+02, 2.01009316399281527D+02, - E 2.05168199482641199D+02, 2.09342586752536836D+02/ - DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), - 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), - 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), - 3 GLN(85), GLN(86), GLN(87), GLN(88)/ - 4 2.13532241494563261D+02, 2.17736934113954227D+02, - 5 2.21956441819130334D+02, 2.26190548323727593D+02, - 6 2.30439043565776952D+02, 2.34701723442818268D+02, - 7 2.38978389561834323D+02, 2.43268849002982714D+02, - 8 2.47572914096186884D+02, 2.51890402209723194D+02, - 9 2.56221135550009525D+02, 2.60564940971863209D+02, - A 2.64921649798552801D+02, 2.69291097651019823D+02, - B 2.73673124285693704D+02, 2.78067573440366143D+02, - C 2.82474292687630396D+02, 2.86893133295426994D+02, - D 2.91323950094270308D+02, 2.95766601350760624D+02, - E 3.00220948647014132D+02, 3.04686856765668715D+02/ - DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), - 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ - 2 3.09164193580146922D+02, 3.13652829949879062D+02, - 3 3.18152639620209327D+02, 3.22663499126726177D+02, - 4 3.27185287703775217D+02, 3.31717887196928473D+02, - 5 3.36261181979198477D+02, 3.40815058870799018D+02, - 6 3.45379407062266854D+02, 3.49954118040770237D+02, - 7 3.54539085519440809D+02, 3.59134205369575399D+02/ -C COEFFICIENTS OF ASYMPTOTIC EXPANSION - DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), - 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), - 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ - 3 8.33333333333333333D-02, -2.77777777777777778D-03, - 4 7.93650793650793651D-04, -5.95238095238095238D-04, - 5 8.41750841750841751D-04, -1.91752691752691753D-03, - 6 6.41025641025641026D-03, -2.95506535947712418D-02, - 7 1.79644372368830573D-01, -1.39243221690590112D+00, - 8 1.34028640441683920D+01, -1.56848284626002017D+02, - 9 2.19310333333333333D+03, -3.61087712537249894D+04, - A 6.91472268851313067D+05, -1.52382215394074162D+07, - B 3.82900751391414141D+08, -1.08822660357843911D+10, - C 3.47320283765002252D+11, -1.23696021422692745D+13, - D 4.88788064793079335D+14, -2.13203339609193739D+16/ -C -C LN(2*PI) - DATA CON / 1.83787706640934548D+00/ -C -C***FIRST EXECUTABLE STATEMENT DGAMLN - IERR=0 - IF (Z.LE.0.0D0) GO TO 70 - IF (Z.GT.101.0D0) GO TO 10 - NZ = INT(Z) - FZ = Z - FLOAT(NZ) - IF (FZ.GT.0.0D0) GO TO 10 - IF (NZ.GT.100) GO TO 10 - DGAMLN = GLN(NZ) - RETURN - 10 CONTINUE - WDTOL = D1MACH(4) - WDTOL = DMAX1(WDTOL,0.5D-18) - I1M = I1MACH(14) - RLN = D1MACH(5)*FLOAT(I1M) - FLN = DMIN1(RLN,20.0D0) - FLN = DMAX1(FLN,3.0D0) - FLN = FLN - 3.0D0 - ZM = 1.8000D0 + 0.3875D0*FLN - MZ = INT(SNGL(ZM)) + 1 - ZMIN = FLOAT(MZ) - ZDMY = Z - ZINC = 0.0D0 - IF (Z.GE.ZMIN) GO TO 20 - ZINC = ZMIN - FLOAT(NZ) - ZDMY = Z + ZINC - 20 CONTINUE - ZP = 1.0D0/ZDMY - T1 = CF(1)*ZP - S = T1 - IF (ZP.LT.WDTOL) GO TO 40 - ZSQ = ZP*ZP - TST = T1*WDTOL - DO 30 K=2,22 - ZP = ZP*ZSQ - TRM = CF(K)*ZP - IF (DABS(TRM).LT.TST) GO TO 40 - S = S + TRM - 30 CONTINUE - 40 CONTINUE - IF (ZINC.NE.0.0D0) GO TO 50 - TLG = DLOG(Z) - DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S - RETURN - 50 CONTINUE - ZP = 1.0D0 - NZ = INT(SNGL(ZINC)) - DO 60 I=1,NZ - ZP = ZP*(Z+FLOAT(I-1)) - 60 CONTINUE - TLG = DLOG(ZDMY) - DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S - RETURN -C -C - 70 CONTINUE - IERR=1 - RETURN - END - SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, - * ELIM, ALIM) -C***BEGIN PROLOGUE ZACAI -C***REFER TO ZAIRY -C -C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA -C -C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) -C MP=PI*MR*CMPLX(0.0,1.0) -C -C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT -C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. -C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND -C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON -C IS CALLED FROM ZAIRY. -C -C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS -C***END PROLOGUE ZACAI -C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY - EXTERNAL ZABS - DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, - * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, - * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS - INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2) - DATA PI / 3.14159265358979324D0 / - NZ = 0 - ZNR = -ZR - ZNI = -ZI - AZ = ZABS(ZR,ZI) - NN = N - DFNU = FNU + DBLE(FLOAT(N-1)) - IF (AZ.LE.2.0D0) GO TO 10 - IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C POWER SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) - GO TO 40 - 20 CONTINUE - IF (AZ.LT.RL) GO TO 30 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, - * ALIM) - IF (NW.LT.0) GO TO 80 - GO TO 40 - 30 CONTINUE -C----------------------------------------------------------------------- -C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION -C----------------------------------------------------------------------- - CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) - IF(NW.LT.0) GO TO 80 - 40 CONTINUE -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION -C----------------------------------------------------------------------- - CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) - IF (NW.NE.0) GO TO 80 - FMR = DBLE(FLOAT(MR)) - SGN = -DSIGN(PI,FMR) - CSGNR = 0.0D0 - CSGNI = SGN - IF (KODE.EQ.1) GO TO 50 - YY = -ZNI - CSGNR = -CSGNI*DSIN(YY) - CSGNI = CSGNI*DCOS(YY) - 50 CONTINUE -C----------------------------------------------------------------------- -C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE -C WHEN FNU IS LARGE -C----------------------------------------------------------------------- - INU = INT(SNGL(FNU)) - ARG = (FNU-DBLE(FLOAT(INU)))*SGN - CSPNR = DCOS(ARG) - CSPNI = DSIN(ARG) - IF (MOD(INU,2).EQ.0) GO TO 60 - CSPNR = -CSPNR - CSPNI = -CSPNI - 60 CONTINUE - C1R = CYR(1) - C1I = CYI(1) - C2R = YR(1) - C2I = YI(1) - IF (KODE.EQ.1) GO TO 70 - IUF = 0 - ASCLE = 1.0D+3*D1MACH(1)/TOL - CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) - NZ = NZ + NW - 70 CONTINUE - YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I - YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R - RETURN - 80 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - END - SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL) -C***BEGIN PROLOGUE ZUCHK -C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL -C -C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN -C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE -C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW -C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED -C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE -C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE -C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. -C -C***ROUTINES CALLED (NONE) -C***END PROLOGUE ZUCHK -C -C COMPLEX Y - DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI - INTEGER NZ - NZ = 0 - WR = DABS(YR) - WI = DABS(YI) - ST = DMIN1(WR,WI) - IF (ST.GT.ASCLE) RETURN - SS = DMAX1(WR,WI) - ST = ST/TOL - IF (SS.LT.ST) NZ = 1 - RETURN - END - SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, - * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) -C***BEGIN PROLOGUE ZUNIK -C***REFER TO ZBESI,ZBESK -C -C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC -C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 -C RESPECTIVELY BY -C -C W(FNU,ZR) = PHI*EXP(ZETA)*SUM -C -C WHERE ZETA=-ZETA1 + ZETA2 OR -C ZETA1 - ZETA2 -C -C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE -C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= -C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK -C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, -C ZETA1,ZETA2. -C -C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH -C***END PROLOGUE ZUNIK -C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, -C *ZETA2,ZN,ZR - DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, - * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, - * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, - * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH - INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L - DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / - DATA CON(1), CON(2) / - 1 3.98942280401432678D-01, 1.25331413731550025D+00 / - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 1.00000000000000000D+00, -2.08333333333333333D-01, - 4 1.25000000000000000D-01, 3.34201388888888889D-01, - 5 -4.01041666666666667D-01, 7.03125000000000000D-02, - 6 -1.02581259645061728D+00, 1.84646267361111111D+00, - 7 -8.91210937500000000D-01, 7.32421875000000000D-02, - 8 4.66958442342624743D+00, -1.12070026162229938D+01, - 9 8.78912353515625000D+00, -2.36408691406250000D+00, - A 1.12152099609375000D-01, -2.82120725582002449D+01, - B 8.46362176746007346D+01, -9.18182415432400174D+01, - C 4.25349987453884549D+01, -7.36879435947963170D+00, - D 2.27108001708984375D-01, 2.12570130039217123D+02, - E -7.65252468141181642D+02, 1.05999045252799988D+03/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 -6.99579627376132541D+02, 2.18190511744211590D+02, - 4 -2.64914304869515555D+01, 5.72501420974731445D-01, - 5 -1.91945766231840700D+03, 8.06172218173730938D+03, - 6 -1.35865500064341374D+04, 1.16553933368645332D+04, - 7 -5.30564697861340311D+03, 1.20090291321635246D+03, - 8 -1.08090919788394656D+02, 1.72772750258445740D+00, - 9 2.02042913309661486D+04, -9.69805983886375135D+04, - A 1.92547001232531532D+05, -2.03400177280415534D+05, - B 1.22200464983017460D+05, -4.11926549688975513D+04, - C 7.10951430248936372D+03, -4.93915304773088012D+02, - D 6.07404200127348304D+00, -2.42919187900551333D+05, - E 1.31176361466297720D+06, -2.99801591853810675D+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.76327129765640400D+06, -2.81356322658653411D+06, - 4 1.26836527332162478D+06, -3.31645172484563578D+05, - 5 4.52187689813627263D+04, -2.49983048181120962D+03, - 6 2.43805296995560639D+01, 3.28446985307203782D+06, - 7 -1.97068191184322269D+07, 5.09526024926646422D+07, - 8 -7.41051482115326577D+07, 6.63445122747290267D+07, - 9 -3.75671766607633513D+07, 1.32887671664218183D+07, - A -2.78561812808645469D+06, 3.08186404612662398D+05, - B -1.38860897537170405D+04, 1.10017140269246738D+02, - C -4.93292536645099620D+07, 3.25573074185765749D+08, - D -9.39462359681578403D+08, 1.55359689957058006D+09, - E -1.62108055210833708D+09, 1.10684281682301447D+09/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 -4.95889784275030309D+08, 1.42062907797533095D+08, - 4 -2.44740627257387285D+07, 2.24376817792244943D+06, - 5 -8.40054336030240853D+04, 5.51335896122020586D+02, - 6 8.14789096118312115D+08, -5.86648149205184723D+09, - 7 1.86882075092958249D+10, -3.46320433881587779D+10, - 8 4.12801855797539740D+10, -3.30265997498007231D+10, - 9 1.79542137311556001D+10, -6.56329379261928433D+09, - A 1.55927986487925751D+09, -2.25105661889415278D+08, - B 1.73951075539781645D+07, -5.49842327572288687D+05, - C 3.03809051092238427D+03, -1.46792612476956167D+10, - D 1.14498237732025810D+11, -3.99096175224466498D+11, - E 8.19218669548577329D+11, -1.09837515608122331D+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), - 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ - 3 1.00815810686538209D+12, -6.45364869245376503D+11, - 4 2.87900649906150589D+11, -8.78670721780232657D+10, - 5 1.76347306068349694D+10, -2.16716498322379509D+09, - 6 1.43157876718888981D+08, -3.87183344257261262D+06, - 7 1.82577554742931747D+04, 2.86464035717679043D+11, - 8 -2.40629790002850396D+12, 9.10934118523989896D+12, - 9 -2.05168994109344374D+13, 3.05651255199353206D+13, - A -3.16670885847851584D+13, 2.33483640445818409D+13, - B -1.23204913055982872D+13, 4.61272578084913197D+12, - C -1.19655288019618160D+12, 2.05914503232410016D+11, - D -2.18229277575292237D+10, 1.24700929351271032D+09/ - DATA C(119), C(120)/ - 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ -C - IF (INIT.NE.0) GO TO 40 -C----------------------------------------------------------------------- -C INITIALIZE ALL VARIABLES -C----------------------------------------------------------------------- - RFN = 1.0D0/FNU -C----------------------------------------------------------------------- -C OVERFLOW TEST (ZR/FNU TOO SMALL) -C----------------------------------------------------------------------- - TEST = D1MACH(1)*1.0D+3 - AC = FNU*TEST - IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15 - ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU - ZETA1I = 0.0D0 - ZETA2R = FNU - ZETA2I = 0.0D0 - PHIR = 1.0D0 - PHII = 0.0D0 - RETURN - 15 CONTINUE - TR = ZRR*RFN - TI = ZRI*RFN - SR = CONER + (TR*TR-TI*TI) - SI = CONEI + (TR*TI+TI*TR) - CALL ZSQRT(SR, SI, SRR, SRI) - STR = CONER + SRR - STI = CONEI + SRI - CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) - CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) - ZETA1R = FNU*STR - ZETA1I = FNU*STI - ZETA2R = FNU*SRR - ZETA2I = FNU*SRI - CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) - SRR = TR*RFN - SRI = TI*RFN - CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) - PHIR = CWRKR(16)*CON(IKFLG) - PHII = CWRKI(16)*CON(IKFLG) - IF (IPMTR.NE.0) RETURN - CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) - CWRKR(1) = CONER - CWRKI(1) = CONEI - CRFNR = CONER - CRFNI = CONEI - AC = 1.0D0 - L = 1 - DO 20 K=2,15 - SR = ZEROR - SI = ZEROI - DO 10 J=1,K - L = L + 1 - STR = SR*T2R - SI*T2I + C(L) - SI = SR*T2I + SI*T2R - SR = STR - 10 CONTINUE - STR = CRFNR*SRR - CRFNI*SRI - CRFNI = CRFNR*SRI + CRFNI*SRR - CRFNR = STR - CWRKR(K) = CRFNR*SR - CRFNI*SI - CWRKI(K) = CRFNR*SI + CRFNI*SR - AC = AC*RFN - TEST = DABS(CWRKR(K)) + DABS(CWRKI(K)) - IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 - 20 CONTINUE - K = 15 - 30 CONTINUE - INIT = K - 40 CONTINUE - IF (IKFLG.EQ.2) GO TO 60 -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE I FUNCTION -C----------------------------------------------------------------------- - SR = ZEROR - SI = ZEROI - DO 50 I=1,INIT - SR = SR + CWRKR(I) - SI = SI + CWRKI(I) - 50 CONTINUE - SUMR = SR - SUMI = SI - PHIR = CWRKR(16)*CON(1) - PHII = CWRKI(16)*CON(1) - RETURN - 60 CONTINUE -C----------------------------------------------------------------------- -C COMPUTE SUM FOR THE K FUNCTION -C----------------------------------------------------------------------- - SR = ZEROR - SI = ZEROI - TR = CONER - DO 70 I=1,INIT - SR = SR + TR*CWRKR(I) - SI = SI + TR*CWRKI(I) - TR = -TR - 70 CONTINUE - SUMR = SR - SUMI = SI - PHIR = CWRKR(16)*CON(2) - PHII = CWRKI(16)*CON(2) - RETURN - END - SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) -C***BEGIN PROLOGUE ZUNHJ -C***REFER TO ZBESI,ZBESK -C -C REFERENCES -C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. -C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. -C -C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC -C PRESS, N.Y., 1974, PAGE 420 -C -C ABSTRACT -C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = -C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU -C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION -C -C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) -C -C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS -C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. -C -C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, -C -C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING -C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. -C -C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND -C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= -C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. -C -C***ROUTINES CALLED ZABS,ZDIV,ZLOG,ZSQRT,D1MACH -C***END PROLOGUE ZUNHJ -C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, -C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, -C *ZETA2,ZTH - EXTERNAL ZABS - DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, - * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, - * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, - * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, - * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, - * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, - * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, - * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, - * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH - INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, - * LRP1, L1, L2, M, IDUM - DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), - * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), - * DRR(14), DRI(14) - DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), - 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ - 2 1.00000000000000000D+00, 1.04166666666666667D-01, - 3 8.35503472222222222D-02, 1.28226574556327160D-01, - 4 2.91849026464140464D-01, 8.81627267443757652D-01, - 5 3.32140828186276754D+00, 1.49957629868625547D+01, - 6 7.89230130115865181D+01, 4.74451538868264323D+02, - 7 3.20749009089066193D+03, 2.40865496408740049D+04, - 8 1.98923119169509794D+05, 1.79190200777534383D+06/ - DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), - 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ - 2 1.00000000000000000D+00, -1.45833333333333333D-01, - 3 -9.87413194444444444D-02, -1.43312053915895062D-01, - 4 -3.17227202678413548D-01, -9.42429147957120249D-01, - 5 -3.51120304082635426D+00, -1.57272636203680451D+01, - 6 -8.22814390971859444D+01, -4.92355370523670524D+02, - 7 -3.31621856854797251D+03, -2.48276742452085896D+04, - 8 -2.04526587315129788D+05, -1.83844491706820990D+06/ - DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), - 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), - 2 C(19), C(20), C(21), C(22), C(23), C(24)/ - 3 1.00000000000000000D+00, -2.08333333333333333D-01, - 4 1.25000000000000000D-01, 3.34201388888888889D-01, - 5 -4.01041666666666667D-01, 7.03125000000000000D-02, - 6 -1.02581259645061728D+00, 1.84646267361111111D+00, - 7 -8.91210937500000000D-01, 7.32421875000000000D-02, - 8 4.66958442342624743D+00, -1.12070026162229938D+01, - 9 8.78912353515625000D+00, -2.36408691406250000D+00, - A 1.12152099609375000D-01, -2.82120725582002449D+01, - B 8.46362176746007346D+01, -9.18182415432400174D+01, - C 4.25349987453884549D+01, -7.36879435947963170D+00, - D 2.27108001708984375D-01, 2.12570130039217123D+02, - E -7.65252468141181642D+02, 1.05999045252799988D+03/ - DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), - 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), - 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ - 3 -6.99579627376132541D+02, 2.18190511744211590D+02, - 4 -2.64914304869515555D+01, 5.72501420974731445D-01, - 5 -1.91945766231840700D+03, 8.06172218173730938D+03, - 6 -1.35865500064341374D+04, 1.16553933368645332D+04, - 7 -5.30564697861340311D+03, 1.20090291321635246D+03, - 8 -1.08090919788394656D+02, 1.72772750258445740D+00, - 9 2.02042913309661486D+04, -9.69805983886375135D+04, - A 1.92547001232531532D+05, -2.03400177280415534D+05, - B 1.22200464983017460D+05, -4.11926549688975513D+04, - C 7.10951430248936372D+03, -4.93915304773088012D+02, - D 6.07404200127348304D+00, -2.42919187900551333D+05, - E 1.31176361466297720D+06, -2.99801591853810675D+06/ - DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), - 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), - 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ - 3 3.76327129765640400D+06, -2.81356322658653411D+06, - 4 1.26836527332162478D+06, -3.31645172484563578D+05, - 5 4.52187689813627263D+04, -2.49983048181120962D+03, - 6 2.43805296995560639D+01, 3.28446985307203782D+06, - 7 -1.97068191184322269D+07, 5.09526024926646422D+07, - 8 -7.41051482115326577D+07, 6.63445122747290267D+07, - 9 -3.75671766607633513D+07, 1.32887671664218183D+07, - A -2.78561812808645469D+06, 3.08186404612662398D+05, - B -1.38860897537170405D+04, 1.10017140269246738D+02, - C -4.93292536645099620D+07, 3.25573074185765749D+08, - D -9.39462359681578403D+08, 1.55359689957058006D+09, - E -1.62108055210833708D+09, 1.10684281682301447D+09/ - DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), - 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), - 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ - 3 -4.95889784275030309D+08, 1.42062907797533095D+08, - 4 -2.44740627257387285D+07, 2.24376817792244943D+06, - 5 -8.40054336030240853D+04, 5.51335896122020586D+02, - 6 8.14789096118312115D+08, -5.86648149205184723D+09, - 7 1.86882075092958249D+10, -3.46320433881587779D+10, - 8 4.12801855797539740D+10, -3.30265997498007231D+10, - 9 1.79542137311556001D+10, -6.56329379261928433D+09, - A 1.55927986487925751D+09, -2.25105661889415278D+08, - B 1.73951075539781645D+07, -5.49842327572288687D+05, - C 3.03809051092238427D+03, -1.46792612476956167D+10, - D 1.14498237732025810D+11, -3.99096175224466498D+11, - E 8.19218669548577329D+11, -1.09837515608122331D+12/ - DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), - 1 C(105)/ - 2 1.00815810686538209D+12, -6.45364869245376503D+11, - 3 2.87900649906150589D+11, -8.78670721780232657D+10, - 4 1.76347306068349694D+10, -2.16716498322379509D+09, - 5 1.43157876718888981D+08, -3.87183344257261262D+06, - 6 1.82577554742931747D+04/ - DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), - 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), - 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), - 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ - 4 -4.44444444444444444D-03, -9.22077922077922078D-04, - 5 -8.84892884892884893D-05, 1.65927687832449737D-04, - 6 2.46691372741792910D-04, 2.65995589346254780D-04, - 7 2.61824297061500945D-04, 2.48730437344655609D-04, - 8 2.32721040083232098D-04, 2.16362485712365082D-04, - 9 2.00738858762752355D-04, 1.86267636637545172D-04, - A 1.73060775917876493D-04, 1.61091705929015752D-04, - B 1.50274774160908134D-04, 1.40503497391269794D-04, - C 1.31668816545922806D-04, 1.23667445598253261D-04, - D 1.16405271474737902D-04, 1.09798298372713369D-04, - E 1.03772410422992823D-04, 9.82626078369363448D-05/ - DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), - 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), - 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), - 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ - 4 9.32120517249503256D-05, 8.85710852478711718D-05, - 5 8.42963105715700223D-05, 8.03497548407791151D-05, - 6 7.66981345359207388D-05, 7.33122157481777809D-05, - 7 7.01662625163141333D-05, 6.72375633790160292D-05, - 8 6.93735541354588974D-04, 2.32241745182921654D-04, - 9 -1.41986273556691197D-05, -1.16444931672048640D-04, - A -1.50803558053048762D-04, -1.55121924918096223D-04, - B -1.46809756646465549D-04, -1.33815503867491367D-04, - C -1.19744975684254051D-04, -1.06184319207974020D-04, - D -9.37699549891194492D-05, -8.26923045588193274D-05, - E -7.29374348155221211D-05, -6.44042357721016283D-05/ - DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), - 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), - 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), - 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ - 4 -5.69611566009369048D-05, -5.04731044303561628D-05, - 5 -4.48134868008882786D-05, -3.98688727717598864D-05, - 6 -3.55400532972042498D-05, -3.17414256609022480D-05, - 7 -2.83996793904174811D-05, -2.54522720634870566D-05, - 8 -2.28459297164724555D-05, -2.05352753106480604D-05, - 9 -1.84816217627666085D-05, -1.66519330021393806D-05, - A -1.50179412980119482D-05, -1.35554031379040526D-05, - B -1.22434746473858131D-05, -1.10641884811308169D-05, - C -3.54211971457743841D-04, -1.56161263945159416D-04, - D 3.04465503594936410D-05, 1.30198655773242693D-04, - E 1.67471106699712269D-04, 1.70222587683592569D-04/ - DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), - 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), - 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), - 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ - 4 1.56501427608594704D-04, 1.36339170977445120D-04, - 5 1.14886692029825128D-04, 9.45869093034688111D-05, - 6 7.64498419250898258D-05, 6.07570334965197354D-05, - 7 4.74394299290508799D-05, 3.62757512005344297D-05, - 8 2.69939714979224901D-05, 1.93210938247939253D-05, - 9 1.30056674793963203D-05, 7.82620866744496661D-06, - A 3.59257485819351583D-06, 1.44040049814251817D-07, - B -2.65396769697939116D-06, -4.91346867098485910D-06, - C -6.72739296091248287D-06, -8.17269379678657923D-06, - D -9.31304715093561232D-06, -1.02011418798016441D-05, - E -1.08805962510592880D-05, -1.13875481509603555D-05/ - DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), - 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), - 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), - 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ - 4 -1.17519675674556414D-05, -1.19987364870944141D-05, - 5 3.78194199201772914D-04, 2.02471952761816167D-04, - 6 -6.37938506318862408D-05, -2.38598230603005903D-04, - 7 -3.10916256027361568D-04, -3.13680115247576316D-04, - 8 -2.78950273791323387D-04, -2.28564082619141374D-04, - 9 -1.75245280340846749D-04, -1.25544063060690348D-04, - A -8.22982872820208365D-05, -4.62860730588116458D-05, - B -1.72334302366962267D-05, 5.60690482304602267D-06, - C 2.31395443148286800D-05, 3.62642745856793957D-05, - D 4.58006124490188752D-05, 5.24595294959114050D-05, - E 5.68396208545815266D-05, 5.94349820393104052D-05/ - DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), - 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), - 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), - 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ - 4 6.06478527578421742D-05, 6.08023907788436497D-05, - 5 6.01577894539460388D-05, 5.89199657344698500D-05, - 6 5.72515823777593053D-05, 5.52804375585852577D-05, - 7 5.31063773802880170D-05, 5.08069302012325706D-05, - 8 4.84418647620094842D-05, 4.60568581607475370D-05, - 9 -6.91141397288294174D-04, -4.29976633058871912D-04, - A 1.83067735980039018D-04, 6.60088147542014144D-04, - B 8.75964969951185931D-04, 8.77335235958235514D-04, - C 7.49369585378990637D-04, 5.63832329756980918D-04, - D 3.68059319971443156D-04, 1.88464535514455599D-04/ - DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), - 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), - 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), - 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ - 4 3.70663057664904149D-05, -8.28520220232137023D-05, - 5 -1.72751952869172998D-04, -2.36314873605872983D-04, - 6 -2.77966150694906658D-04, -3.02079514155456919D-04, - 7 -3.12594712643820127D-04, -3.12872558758067163D-04, - 8 -3.05678038466324377D-04, -2.93226470614557331D-04, - 9 -2.77255655582934777D-04, -2.59103928467031709D-04, - A -2.39784014396480342D-04, -2.20048260045422848D-04, - B -2.00443911094971498D-04, -1.81358692210970687D-04, - C -1.63057674478657464D-04, -1.45712672175205844D-04, - D -1.29425421983924587D-04, -1.14245691942445952D-04/ - DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), - 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), - 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), - 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ - 4 1.92821964248775885D-03, 1.35592576302022234D-03, - 5 -7.17858090421302995D-04, -2.58084802575270346D-03, - 6 -3.49271130826168475D-03, -3.46986299340960628D-03, - 7 -2.82285233351310182D-03, -1.88103076404891354D-03, - 8 -8.89531718383947600D-04, 3.87912102631035228D-06, - 9 7.28688540119691412D-04, 1.26566373053457758D-03, - A 1.62518158372674427D-03, 1.83203153216373172D-03, - B 1.91588388990527909D-03, 1.90588846755546138D-03, - C 1.82798982421825727D-03, 1.70389506421121530D-03, - D 1.55097127171097686D-03, 1.38261421852276159D-03/ - DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), - 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ - 2 1.20881424230064774D-03, 1.03676532638344962D-03, - 3 8.71437918068619115D-04, 7.16080155297701002D-04, - 4 5.72637002558129372D-04, 4.42089819465802277D-04, - 5 3.24724948503090564D-04, 2.20342042730246599D-04, - 6 1.28412898401353882D-04, 4.82005924552095464D-05/ - DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), - 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), - 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), - 3 BETA(19), BETA(20), BETA(21), BETA(22)/ - 4 1.79988721413553309D-02, 5.59964911064388073D-03, - 5 2.88501402231132779D-03, 1.80096606761053941D-03, - 6 1.24753110589199202D-03, 9.22878876572938311D-04, - 7 7.14430421727287357D-04, 5.71787281789704872D-04, - 8 4.69431007606481533D-04, 3.93232835462916638D-04, - 9 3.34818889318297664D-04, 2.88952148495751517D-04, - A 2.52211615549573284D-04, 2.22280580798883327D-04, - B 1.97541838033062524D-04, 1.76836855019718004D-04, - C 1.59316899661821081D-04, 1.44347930197333986D-04, - D 1.31448068119965379D-04, 1.20245444949302884D-04, - E 1.10449144504599392D-04, 1.01828770740567258D-04/ - DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), - 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), - 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), - 3 BETA(41), BETA(42), BETA(43), BETA(44)/ - 4 9.41998224204237509D-05, 8.74130545753834437D-05, - 5 8.13466262162801467D-05, 7.59002269646219339D-05, - 6 7.09906300634153481D-05, 6.65482874842468183D-05, - 7 6.25146958969275078D-05, 5.88403394426251749D-05, - 8 -1.49282953213429172D-03, -8.78204709546389328D-04, - 9 -5.02916549572034614D-04, -2.94822138512746025D-04, - A -1.75463996970782828D-04, -1.04008550460816434D-04, - B -5.96141953046457895D-05, -3.12038929076098340D-05, - C -1.26089735980230047D-05, -2.42892608575730389D-07, - D 8.05996165414273571D-06, 1.36507009262147391D-05, - E 1.73964125472926261D-05, 1.98672978842133780D-05/ - DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), - 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), - 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), - 3 BETA(63), BETA(64), BETA(65), BETA(66)/ - 4 2.14463263790822639D-05, 2.23954659232456514D-05, - 5 2.28967783814712629D-05, 2.30785389811177817D-05, - 6 2.30321976080909144D-05, 2.28236073720348722D-05, - 7 2.25005881105292418D-05, 2.20981015361991429D-05, - 8 2.16418427448103905D-05, 2.11507649256220843D-05, - 9 2.06388749782170737D-05, 2.01165241997081666D-05, - A 1.95913450141179244D-05, 1.90689367910436740D-05, - B 1.85533719641636667D-05, 1.80475722259674218D-05, - C 5.52213076721292790D-04, 4.47932581552384646D-04, - D 2.79520653992020589D-04, 1.52468156198446602D-04, - E 6.93271105657043598D-05, 1.76258683069991397D-05/ - DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), - 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), - 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), - 3 BETA(85), BETA(86), BETA(87), BETA(88)/ - 4 -1.35744996343269136D-05, -3.17972413350427135D-05, - 5 -4.18861861696693365D-05, -4.69004889379141029D-05, - 6 -4.87665447413787352D-05, -4.87010031186735069D-05, - 7 -4.74755620890086638D-05, -4.55813058138628452D-05, - 8 -4.33309644511266036D-05, -4.09230193157750364D-05, - 9 -3.84822638603221274D-05, -3.60857167535410501D-05, - A -3.37793306123367417D-05, -3.15888560772109621D-05, - B -2.95269561750807315D-05, -2.75978914828335759D-05, - C -2.58006174666883713D-05, -2.41308356761280200D-05, - D -2.25823509518346033D-05, -2.11479656768912971D-05, - E -1.98200638885294927D-05, -1.85909870801065077D-05/ - DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), - 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), - 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), - 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ - 4 -1.74532699844210224D-05, -1.63997823854497997D-05, - 5 -4.74617796559959808D-04, -4.77864567147321487D-04, - 6 -3.20390228067037603D-04, -1.61105016119962282D-04, - 7 -4.25778101285435204D-05, 3.44571294294967503D-05, - 8 7.97092684075674924D-05, 1.03138236708272200D-04, - 9 1.12466775262204158D-04, 1.13103642108481389D-04, - A 1.08651634848774268D-04, 1.01437951597661973D-04, - B 9.29298396593363896D-05, 8.40293133016089978D-05, - C 7.52727991349134062D-05, 6.69632521975730872D-05, - D 5.92564547323194704D-05, 5.22169308826975567D-05, - E 4.58539485165360646D-05, 4.01445513891486808D-05/ - DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), - 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), - 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), - 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ - 4 3.50481730031328081D-05, 3.05157995034346659D-05, - 5 2.64956119950516039D-05, 2.29363633690998152D-05, - 6 1.97893056664021636D-05, 1.70091984636412623D-05, - 7 1.45547428261524004D-05, 1.23886640995878413D-05, - 8 1.04775876076583236D-05, 8.79179954978479373D-06, - 9 7.36465810572578444D-04, 8.72790805146193976D-04, - A 6.22614862573135066D-04, 2.85998154194304147D-04, - B 3.84737672879366102D-06, -1.87906003636971558D-04, - C -2.97603646594554535D-04, -3.45998126832656348D-04, - D -3.53382470916037712D-04, -3.35715635775048757D-04/ - DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), - 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), - 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), - 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ - 4 -3.04321124789039809D-04, -2.66722723047612821D-04, - 5 -2.27654214122819527D-04, -1.89922611854562356D-04, - 6 -1.55058918599093870D-04, -1.23778240761873630D-04, - 7 -9.62926147717644187D-05, -7.25178327714425337D-05, - 8 -5.22070028895633801D-05, -3.50347750511900522D-05, - 9 -2.06489761035551757D-05, -8.70106096849767054D-06, - A 1.13698686675100290D-06, 9.16426474122778849D-06, - B 1.56477785428872620D-05, 2.08223629482466847D-05, - C 2.48923381004595156D-05, 2.80340509574146325D-05, - D 3.03987774629861915D-05, 3.21156731406700616D-05/ - DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), - 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), - 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), - 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ - 4 -1.80182191963885708D-03, -2.43402962938042533D-03, - 5 -1.83422663549856802D-03, -7.62204596354009765D-04, - 6 2.39079475256927218D-04, 9.49266117176881141D-04, - 7 1.34467449701540359D-03, 1.48457495259449178D-03, - 8 1.44732339830617591D-03, 1.30268261285657186D-03, - 9 1.10351597375642682D-03, 8.86047440419791759D-04, - A 6.73073208165665473D-04, 4.77603872856582378D-04, - B 3.05991926358789362D-04, 1.60315694594721630D-04, - C 4.00749555270613286D-05, -5.66607461635251611D-05, - D -1.32506186772982638D-04, -1.90296187989614057D-04/ - DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), - 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), - 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), - 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ - 4 -2.32811450376937408D-04, -2.62628811464668841D-04, - 5 -2.82050469867598672D-04, -2.93081563192861167D-04, - 6 -2.97435962176316616D-04, -2.96557334239348078D-04, - 7 -2.91647363312090861D-04, -2.83696203837734166D-04, - 8 -2.73512317095673346D-04, -2.61750155806768580D-04, - 9 6.38585891212050914D-03, 9.62374215806377941D-03, - A 7.61878061207001043D-03, 2.83219055545628054D-03, - B -2.09841352012720090D-03, -5.73826764216626498D-03, - C -7.70804244495414620D-03, -8.21011692264844401D-03, - D -7.65824520346905413D-03, -6.47209729391045177D-03/ - DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), - 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), - 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), - 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ - 4 -4.99132412004966473D-03, -3.45612289713133280D-03, - 5 -2.01785580014170775D-03, -7.59430686781961401D-04, - 6 2.84173631523859138D-04, 1.10891667586337403D-03, - 7 1.72901493872728771D-03, 2.16812590802684701D-03, - 8 2.45357710494539735D-03, 2.61281821058334862D-03, - 9 2.67141039656276912D-03, 2.65203073395980430D-03, - A 2.57411652877287315D-03, 2.45389126236094427D-03, - B 2.30460058071795494D-03, 2.13684837686712662D-03, - C 1.95896528478870911D-03, 1.77737008679454412D-03, - D 1.59690280765839059D-03, 1.42111975664438546D-03/ - DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), - 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), - 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), - 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ - 4 6.29960524947436582D-01, 2.51984209978974633D-01, - 5 1.54790300415655846D-01, 1.10713062416159013D-01, - 6 8.57309395527394825D-02, 6.97161316958684292D-02, - 7 5.86085671893713576D-02, 5.04698873536310685D-02, - 8 4.42600580689154809D-02, 3.93720661543509966D-02, - 9 3.54283195924455368D-02, 3.21818857502098231D-02, - A 2.94646240791157679D-02, 2.71581677112934479D-02, - B 2.51768272973861779D-02, 2.34570755306078891D-02, - C 2.19508390134907203D-02, 2.06210828235646240D-02, - D 1.94388240897880846D-02, 1.83810633800683158D-02, - E 1.74293213231963172D-02, 1.65685837786612353D-02/ - DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), - 1 GAMA(29), GAMA(30)/ - 2 1.57865285987918445D-02, 1.50729501494095594D-02, - 3 1.44193250839954639D-02, 1.38184805735341786D-02, - 4 1.32643378994276568D-02, 1.27517121970498651D-02, - 5 1.22761545318762767D-02, 1.18338262398482403D-02/ - DATA EX1, EX2, HPI, GPI, THPI / - 1 3.33333333333333333D-01, 6.66666666666666667D-01, - 2 1.57079632679489662D+00, 3.14159265358979324D+00, - 3 4.71238898038468986D+00/ - DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / -C - RFNU = 1.0D0/FNU -C----------------------------------------------------------------------- -C OVERFLOW TEST (Z/FNU TOO SMALL) -C----------------------------------------------------------------------- - TEST = D1MACH(1)*1.0D+3 - AC = FNU*TEST - IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15 - ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU - ZETA1I = 0.0D0 - ZETA2R = FNU - ZETA2I = 0.0D0 - PHIR = 1.0D0 - PHII = 0.0D0 - ARGR = 1.0D0 - ARGI = 0.0D0 - RETURN - 15 CONTINUE - ZBR = ZR*RFNU - ZBI = ZI*RFNU - RFNU2 = RFNU*RFNU -C----------------------------------------------------------------------- -C COMPUTE IN THE FOURTH QUADRANT -C----------------------------------------------------------------------- - FN13 = FNU**EX1 - FN23 = FN13*FN13 - RFN13 = 1.0D0/FN13 - W2R = CONER - ZBR*ZBR + ZBI*ZBI - W2I = CONEI - ZBR*ZBI - ZBR*ZBI - AW2 = ZABS(W2R,W2I) - IF (AW2.GT.0.25D0) GO TO 130 -C----------------------------------------------------------------------- -C POWER SERIES FOR CABS(W2).LE.0.25D0 -C----------------------------------------------------------------------- - K = 1 - PR(1) = CONER - PI(1) = CONEI - SUMAR = GAMA(1) - SUMAI = ZEROI - AP(1) = 1.0D0 - IF (AW2.LT.TOL) GO TO 20 - DO 10 K=2,30 - PR(K) = PR(K-1)*W2R - PI(K-1)*W2I - PI(K) = PR(K-1)*W2I + PI(K-1)*W2R - SUMAR = SUMAR + PR(K)*GAMA(K) - SUMAI = SUMAI + PI(K)*GAMA(K) - AP(K) = AP(K-1)*AW2 - IF (AP(K).LT.TOL) GO TO 20 - 10 CONTINUE - K = 30 - 20 CONTINUE - KMAX = K - ZETAR = W2R*SUMAR - W2I*SUMAI - ZETAI = W2R*SUMAI + W2I*SUMAR - ARGR = ZETAR*FN23 - ARGI = ZETAI*FN23 - CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI) - CALL ZSQRT(W2R, W2I, STR, STI) - ZETA2R = STR*FNU - ZETA2I = STI*FNU - STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) - STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) - ZETA1R = STR*ZETA2R - STI*ZETA2I - ZETA1I = STR*ZETA2I + STI*ZETA2R - ZAR = ZAR + ZAR - ZAI = ZAI + ZAI - CALL ZSQRT(ZAR, ZAI, STR, STI) - PHIR = STR*RFN13 - PHII = STI*RFN13 - IF (IPMTR.EQ.1) GO TO 120 -C----------------------------------------------------------------------- -C SUM SERIES FOR ASUM AND BSUM -C----------------------------------------------------------------------- - SUMBR = ZEROR - SUMBI = ZEROI - DO 30 K=1,KMAX - SUMBR = SUMBR + PR(K)*BETA(K) - SUMBI = SUMBI + PI(K)*BETA(K) - 30 CONTINUE - ASUMR = ZEROR - ASUMI = ZEROI - BSUMR = SUMBR - BSUMI = SUMBI - L1 = 0 - L2 = 30 - BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) - ATOL = TOL - PP = 1.0D0 - IAS = 0 - IBS = 0 - IF (RFNU2.LT.TOL) GO TO 110 - DO 100 IS=2,7 - ATOL = ATOL/RFNU2 - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 60 - SUMAR = ZEROR - SUMAI = ZEROI - DO 40 K=1,KMAX - M = L1 + K - SUMAR = SUMAR + PR(K)*ALFA(M) - SUMAI = SUMAI + PI(K)*ALFA(M) - IF (AP(K).LT.ATOL) GO TO 50 - 40 CONTINUE - 50 CONTINUE - ASUMR = ASUMR + SUMAR*PP - ASUMI = ASUMI + SUMAI*PP - IF (PP.LT.TOL) IAS = 1 - 60 CONTINUE - IF (IBS.EQ.1) GO TO 90 - SUMBR = ZEROR - SUMBI = ZEROI - DO 70 K=1,KMAX - M = L2 + K - SUMBR = SUMBR + PR(K)*BETA(M) - SUMBI = SUMBI + PI(K)*BETA(M) - IF (AP(K).LT.ATOL) GO TO 80 - 70 CONTINUE - 80 CONTINUE - BSUMR = BSUMR + SUMBR*PP - BSUMI = BSUMI + SUMBI*PP - IF (PP.LT.BTOL) IBS = 1 - 90 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110 - L1 = L1 + 30 - L2 = L2 + 30 - 100 CONTINUE - 110 CONTINUE - ASUMR = ASUMR + CONER - PP = RFNU*RFN13 - BSUMR = BSUMR*PP - BSUMI = BSUMI*PP - 120 CONTINUE - RETURN -C----------------------------------------------------------------------- -C CABS(W2).GT.0.25D0 -C----------------------------------------------------------------------- - 130 CONTINUE - CALL ZSQRT(W2R, W2I, WR, WI) - IF (WR.LT.0.0D0) WR = 0.0D0 - IF (WI.LT.0.0D0) WI = 0.0D0 - STR = CONER + WR - STI = WI - CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) - CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) - IF (ZCI.LT.0.0D0) ZCI = 0.0D0 - IF (ZCI.GT.HPI) ZCI = HPI - IF (ZCR.LT.0.0D0) ZCR = 0.0D0 - ZTHR = (ZCR-WR)*1.5D0 - ZTHI = (ZCI-WI)*1.5D0 - ZETA1R = ZCR*FNU - ZETA1I = ZCI*FNU - ZETA2R = WR*FNU - ZETA2I = WI*FNU - AZTH = ZABS(ZTHR,ZTHI) - ANG = THPI - IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140 - ANG = HPI - IF (ZTHR.EQ.0.0D0) GO TO 140 - ANG = DATAN(ZTHI/ZTHR) - IF (ZTHR.LT.0.0D0) ANG = ANG + GPI - 140 CONTINUE - PP = AZTH**EX2 - ANG = ANG*EX2 - ZETAR = PP*DCOS(ANG) - ZETAI = PP*DSIN(ANG) - IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0 - ARGR = ZETAR*FN23 - ARGI = ZETAI*FN23 - CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) - CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) - TZAR = ZAR + ZAR - TZAI = ZAI + ZAI - CALL ZSQRT(TZAR, TZAI, STR, STI) - PHIR = STR*RFN13 - PHII = STI*RFN13 - IF (IPMTR.EQ.1) GO TO 120 - RAW = 1.0D0/DSQRT(AW2) - STR = WR*RAW - STI = -WI*RAW - TFNR = STR*RFNU*RAW - TFNI = STI*RFNU*RAW - RAZTH = 1.0D0/AZTH - STR = ZTHR*RAZTH - STI = -ZTHI*RAZTH - RZTHR = STR*RAZTH*RFNU - RZTHI = STI*RAZTH*RFNU - ZCR = RZTHR*AR(2) - ZCI = RZTHI*AR(2) - RAW2 = 1.0D0/AW2 - STR = W2R*RAW2 - STI = -W2I*RAW2 - T2R = STR*RAW2 - T2I = STI*RAW2 - STR = T2R*C(2) + C(3) - STI = T2I*C(2) - UPR(2) = STR*TFNR - STI*TFNI - UPI(2) = STR*TFNI + STI*TFNR - BSUMR = UPR(2) + ZCR - BSUMI = UPI(2) + ZCI - ASUMR = ZEROR - ASUMI = ZEROI - IF (RFNU.LT.TOL) GO TO 220 - PRZTHR = RZTHR - PRZTHI = RZTHI - PTFNR = TFNR - PTFNI = TFNI - UPR(1) = CONER - UPI(1) = CONEI - PP = 1.0D0 - BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) - KS = 0 - KP1 = 2 - L = 3 - IAS = 0 - IBS = 0 - DO 210 LR=2,12,2 - LRP1 = LR + 1 -C----------------------------------------------------------------------- -C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN -C NEXT SUMA AND SUMB -C----------------------------------------------------------------------- - DO 160 K=LR,LRP1 - KS = KS + 1 - KP1 = KP1 + 1 - L = L + 1 - ZAR = C(L) - ZAI = ZEROI - DO 150 J=2,KP1 - L = L + 1 - STR = ZAR*T2R - T2I*ZAI + C(L) - ZAI = ZAR*T2I + ZAI*T2R - ZAR = STR - 150 CONTINUE - STR = PTFNR*TFNR - PTFNI*TFNI - PTFNI = PTFNR*TFNI + PTFNI*TFNR - PTFNR = STR - UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI - UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI - CRR(KS) = PRZTHR*BR(KS+1) - CRI(KS) = PRZTHI*BR(KS+1) - STR = PRZTHR*RZTHR - PRZTHI*RZTHI - PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR - PRZTHR = STR - DRR(KS) = PRZTHR*AR(KS+2) - DRI(KS) = PRZTHI*AR(KS+2) - 160 CONTINUE - PP = PP*RFNU2 - IF (IAS.EQ.1) GO TO 180 - SUMAR = UPR(LRP1) - SUMAI = UPI(LRP1) - JU = LRP1 - DO 170 JR=1,LR - JU = JU - 1 - SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) - SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) - 170 CONTINUE - ASUMR = ASUMR + SUMAR - ASUMI = ASUMI + SUMAI - TEST = DABS(SUMAR) + DABS(SUMAI) - IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 - 180 CONTINUE - IF (IBS.EQ.1) GO TO 200 - SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI - SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR - JU = LRP1 - DO 190 JR=1,LR - JU = JU - 1 - SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) - SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) - 190 CONTINUE - BSUMR = BSUMR + SUMBR - BSUMI = BSUMI + SUMBI - TEST = DABS(SUMBR) + DABS(SUMBI) - IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1 - 200 CONTINUE - IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 - 210 CONTINUE - 220 CONTINUE - ASUMR = ASUMR + CONER - STR = -BSUMR*RFN13 - STI = -BSUMI*RFN13 - CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) - GO TO 120 - END - SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE ZUNK1 -C***REFER TO ZBESK -C -C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE -C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE -C UNIFORM ASYMPTOTIC EXPANSION. -C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. -C NZ=-1 MEANS AN OVERFLOW WILL OCCUR -C -C***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS -C***END PROLOGUE ZUNK1 -C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, -C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR - EXTERNAL ZABS - DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, - * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, - * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, - * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, - * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, - * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, - * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS - INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, - * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M - DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), - * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), - * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) - DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / - DATA PI / 3.14159265358979324D0 / -C - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - ZRR = ZR - ZRI = ZI - IF (ZR.GE.0.0D0) GO TO 10 - ZRR = -ZR - ZRI = -ZI - 10 CONTINUE - J = 2 - DO 70 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + DBLE(FLOAT(I-1)) - INIT(J) = 0 - CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), - * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), - * CWRKR(1,J), CWRKI(1,J)) - IF (KODE.EQ.1) GO TO 20 - STR = ZRR + ZETA2R(J) - STI = ZRI + ZETA2I(J) - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZETA1R(J) - STR - S1I = ZETA1I(J) - STI - GO TO 30 - 20 CONTINUE - S1R = ZETA1R(J) - ZETA2R(J) - S1I = ZETA1I(J) - ZETA2I(J) - 30 CONTINUE - RS1 = S1R -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - IF (DABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (DABS(RS1).LT.ALIM) GO TO 40 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIR(J),PHII(J)) - RS1 = RS1 + DLOG(APHI) - IF (DABS(RS1).GT.ELIM) GO TO 60 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 40 - IF (KDFLG.EQ.1) KFLAG = 3 - 40 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) - S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) - STR = DEXP(S1R)*CSSR(KFLAG) - S1R = STR*DCOS(S1I) - S1I = STR*DSIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S1R*S2I + S2R*S1I - S2R = STR - IF (KFLAG.NE.1) GO TO 50 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 60 - 50 CONTINUE - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - YR(I) = S2R*CSRR(KFLAG) - YI(I) = S2I*CSRR(KFLAG) - IF (KDFLG.EQ.2) GO TO 75 - KDFLG = 2 - GO TO 70 - 60 CONTINUE - IF (RS1.GT.0.0D0) GO TO 300 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 300 - KDFLG = 1 - YR(I)=ZEROR - YI(I)=ZEROI - NZ=NZ+1 - IF (I.EQ.1) GO TO 70 - IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70 - YR(I-1)=ZEROR - YI(I-1)=ZEROI - NZ=NZ+1 - 70 CONTINUE - I = N - 75 CONTINUE - RAZR = 1.0D0/ZABS(ZRR,ZRI) - STR = ZRR*RAZR - STI = -ZRI*RAZR - RZR = (STR+STR)*RAZR - RZI = (STI+STI)*RAZR - CKR = FN*RZR - CKI = FN*RZI - IB = I + 1 - IF (N.LT.IB) GO TO 160 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO -C ON UNDERFLOW. -C----------------------------------------------------------------------- - FN = FNU + DBLE(FLOAT(N-1)) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - INITD = 0 - CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, - * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), - * CWRKI(1,3)) - IF (KODE.EQ.1) GO TO 80 - STR = ZRR + ZET2DR - STI = ZRI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZET1DR - STR - S1I = ZET1DI - STI - GO TO 90 - 80 CONTINUE - S1R = ZET1DR - ZET2DR - S1I = ZET1DI - ZET2DI - 90 CONTINUE - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 95 - IF (DABS(RS1).LT.ALIM) GO TO 100 -C---------------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C------------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - RS1 = RS1+DLOG(APHI) - IF (DABS(RS1).LT.ELIM) GO TO 100 - 95 CONTINUE - IF (DABS(RS1).GT.0.0D0) GO TO 300 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 300 - NZ = N - DO 96 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 96 CONTINUE - RETURN -C--------------------------------------------------------------------------- -C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE -C---------------------------------------------------------------------------- - 100 CONTINUE - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 120 I=IB,N - C2R = S2R - C2I = S2I - S2R = CKR*C2R - CKI*C2I + S1R - S2I = CKR*C2I + CKI*C2R + S1I - S1R = C2R - S1I = C2I - CKR = CKR + RZR - CKI = CKI + RZI - C2R = S2R*C1R - C2I = S2I*C1R - YR(I) = C2R - YI(I) = C2I - IF (KFLAG.GE.3) GO TO 120 - STR = DABS(C2R) - STI = DABS(C2I) - C2M = DMAX1(STR,STI) - IF (C2M.LE.ASCLE) GO TO 120 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - C1R = CSRR(KFLAG) - 120 CONTINUE - 160 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = DBLE(FLOAT(MR)) - SGN = -DSIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. -C----------------------------------------------------------------------- - CSGNI = SGN - INU = INT(SNGL(FNU)) - FNF = FNU - DBLE(FLOAT(INU)) - IFN = INU + N - 1 - ANG = FNF*SGN - CSPNR = DCOS(ANG) - CSPNI = DSIN(ANG) - IF (MOD(IFN,2).EQ.0) GO TO 170 - CSPNR = -CSPNR - CSPNI = -CSPNI - 170 CONTINUE - ASC = BRY(1) - IUF = 0 - KK = N - KDFLG = 1 - IB = IB - 1 - IC = IB - 1 - DO 270 K=1,N - FN = FNU + DBLE(FLOAT(KK-1)) -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - M=3 - IF (N.GT.2) GO TO 175 - 172 CONTINUE - INITD = INIT(J) - PHIDR = PHIR(J) - PHIDI = PHII(J) - ZET1DR = ZETA1R(J) - ZET1DI = ZETA1I(J) - ZET2DR = ZETA2R(J) - ZET2DI = ZETA2I(J) - SUMDR = SUMR(J) - SUMDI = SUMI(J) - M = J - J = 3 - J - GO TO 180 - 175 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 - INITD = 0 - 180 CONTINUE - CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, - * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, - * CWRKR(1,M), CWRKI(1,M)) - IF (KODE.EQ.1) GO TO 200 - STR = ZRR + ZET2DR - STI = ZRI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZET1DR + STR - S1I = -ZET1DI + STI - GO TO 210 - 200 CONTINUE - S1R = -ZET1DR + ZET2DR - S1I = -ZET1DI + ZET2DI - 210 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (DABS(RS1).LT.ALIM) GO TO 220 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - RS1 = RS1 + DLOG(APHI) - IF (DABS(RS1).GT.ELIM) GO TO 260 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 220 - IF (KDFLG.EQ.1) IFLAG = 3 - 220 CONTINUE - STR = PHIDR*SUMDR - PHIDI*SUMDI - STI = PHIDR*SUMDI + PHIDI*SUMDR - S2R = -CSGNI*STI - S2I = CSGNI*STR - STR = DEXP(S1R)*CSSR(IFLAG) - S1R = STR*DCOS(S1I) - S1I = STR*DSIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 230 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.EQ.0) GO TO 230 - S2R = ZEROR - S2I = ZEROI - 230 CONTINUE - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - C2R = S2R - C2I = S2I - S2R = S2R*CSRR(IFLAG) - S2I = S2I*CSRR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1R = YR(KK) - S1I = YI(KK) - IF (KODE.EQ.1) GO TO 250 - CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 250 CONTINUE - YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R - YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 - KDFLG = 1 - GO TO 270 - 255 CONTINUE - IF (KDFLG.EQ.2) GO TO 275 - KDFLG = 2 - GO TO 270 - 260 CONTINUE - IF (RS1.GT.0.0D0) GO TO 300 - S2R = ZEROR - S2I = ZEROI - GO TO 230 - 270 CONTINUE - K = N - 275 CONTINUE - IL = N - K - IF (IL.EQ.0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE -C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP -C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. -C----------------------------------------------------------------------- - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - CSR = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - FN = DBLE(FLOAT(INU+IL)) - DO 290 I=1,IL - C2R = S2R - C2I = S2I - S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - FN = FN - 1.0D0 - C2R = S2R*CSR - C2I = S2I*CSR - CKR = C2R - CKI = C2I - C1R = YR(KK) - C1I = YI(KK) - IF (KODE.EQ.1) GO TO 280 - CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 280 CONTINUE - YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R - YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (IFLAG.GE.3) GO TO 290 - C2R = DABS(CKR) - C2I = DABS(CKI) - C2M = DMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 290 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSR - S1I = S1I*CSR - S2R = CKR - S2I = CKI - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - CSR = CSRR(IFLAG) - 290 CONTINUE - RETURN - 300 CONTINUE - NZ = -1 - RETURN - END - SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, - * ALIM) -C***BEGIN PROLOGUE ZUNK2 -C***REFER TO ZBESK -C -C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE -C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE -C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) -C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR -C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT -C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- -C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. -C NZ=-1 MEANS AN OVERFLOW WILL OCCUR -C -C***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS -C***END PROLOGUE ZUNK2 -C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, -C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, -C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR - EXTERNAL ZABS - DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, - * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, - * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, - * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, - * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, - * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, - * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, - * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, - * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, - * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS - INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, - * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC - DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), - * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), - * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), - * CIPI(4), CSSR(3), CSRR(3) - DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / - 1 0.0D0, 0.0D0, 1.0D0, - 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / - DATA HPI, PI, AIC / - 1 1.57079632679489662D+00, 3.14159265358979324D+00, - 1 1.26551212348464539D+00/ - DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), - * CIPI(4) / - 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / -C - KDFLG = 1 - NZ = 0 -C----------------------------------------------------------------------- -C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN -C THE UNDERFLOW LIMIT -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - ZRR = ZR - ZRI = ZI - IF (ZR.GE.0.0D0) GO TO 10 - ZRR = -ZR - ZRI = -ZI - 10 CONTINUE - YY = ZRI - ZNR = ZRI - ZNI = -ZRR - ZBR = ZRR - ZBI = ZRI - INU = INT(SNGL(FNU)) - FNF = FNU - DBLE(FLOAT(INU)) - ANG = -HPI*FNF - CAR = DCOS(ANG) - SAR = DSIN(ANG) - C2R = HPI*SAR - C2I = -HPI*CAR - KK = MOD(INU,4) + 1 - STR = C2R*CIPR(KK) - C2I*CIPI(KK) - STI = C2R*CIPI(KK) + C2I*CIPR(KK) - CSR = CR1R*STR - CR1I*STI - CSI = CR1R*STI + CR1I*STR - IF (YY.GT.0.0D0) GO TO 20 - ZNR = -ZNR - ZBI = -ZBI - 20 CONTINUE -C----------------------------------------------------------------------- -C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST -C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY -C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS -C----------------------------------------------------------------------- - J = 2 - DO 80 I=1,N -C----------------------------------------------------------------------- -C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J -C----------------------------------------------------------------------- - J = 3 - J - FN = FNU + DBLE(FLOAT(I-1)) - CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), - * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), - * ASUMI(J), BSUMR(J), BSUMI(J)) - IF (KODE.EQ.1) GO TO 30 - STR = ZBR + ZETA2R(J) - STI = ZBI + ZETA2I(J) - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZETA1R(J) - STR - S1I = ZETA1I(J) - STI - GO TO 40 - 30 CONTINUE - S1R = ZETA1R(J) - ZETA2R(J) - S1I = ZETA1I(J) - ZETA2I(J) - 40 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 70 - IF (KDFLG.EQ.1) KFLAG = 2 - IF (DABS(RS1).LT.ALIM) GO TO 50 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIR(J),PHII(J)) - AARG = ZABS(ARGR(J),ARGI(J)) - RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC - IF (DABS(RS1).GT.ELIM) GO TO 70 - IF (KDFLG.EQ.1) KFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 50 - IF (KDFLG.EQ.1) KFLAG = 3 - 50 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - C2R = ARGR(J)*CR2R - ARGI(J)*CR2I - C2I = ARGR(J)*CR2I + ARGI(J)*CR2R - CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) - CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) - STR = DAIR*BSUMR(J) - DAII*BSUMI(J) - STI = DAIR*BSUMI(J) + DAII*BSUMR(J) - PTR = STR*CR2R - STI*CR2I - PTI = STR*CR2I + STI*CR2R - STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) - STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) - PTR = STR*PHIR(J) - STI*PHII(J) - PTI = STR*PHII(J) + STI*PHIR(J) - S2R = PTR*CSR - PTI*CSI - S2I = PTR*CSI + PTI*CSR - STR = DEXP(S1R)*CSSR(KFLAG) - S1R = STR*DCOS(S1I) - S1I = STR*DSIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S1R*S2I + S2R*S1I - S2R = STR - IF (KFLAG.NE.1) GO TO 60 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 70 - 60 CONTINUE - IF (YY.LE.0.0D0) S2I = -S2I - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - YR(I) = S2R*CSRR(KFLAG) - YI(I) = S2I*CSRR(KFLAG) - STR = CSI - CSI = -CSR - CSR = STR - IF (KDFLG.EQ.2) GO TO 85 - KDFLG = 2 - GO TO 80 - 70 CONTINUE - IF (RS1.GT.0.0D0) GO TO 320 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 320 - KDFLG = 1 - YR(I)=ZEROR - YI(I)=ZEROI - NZ=NZ+1 - STR = CSI - CSI =-CSR - CSR = STR - IF (I.EQ.1) GO TO 80 - IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80 - YR(I-1)=ZEROR - YI(I-1)=ZEROI - NZ=NZ+1 - 80 CONTINUE - I = N - 85 CONTINUE - RAZR = 1.0D0/ZABS(ZRR,ZRI) - STR = ZRR*RAZR - STI = -ZRI*RAZR - RZR = (STR+STR)*RAZR - RZI = (STI+STI)*RAZR - CKR = FN*RZR - CKI = FN*RZI - IB = I + 1 - IF (N.LT.IB) GO TO 180 -C----------------------------------------------------------------------- -C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO -C ON UNDERFLOW. -C----------------------------------------------------------------------- - FN = FNU + DBLE(FLOAT(N-1)) - IPARD = 1 - IF (MR.NE.0) IPARD = 0 - CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, - * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) - IF (KODE.EQ.1) GO TO 90 - STR = ZBR + ZET2DR - STI = ZBI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = ZET1DR - STR - S1I = ZET1DI - STI - GO TO 100 - 90 CONTINUE - S1R = ZET1DR - ZET2DR - S1I = ZET1DI - ZET2DI - 100 CONTINUE - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 105 - IF (DABS(RS1).LT.ALIM) GO TO 120 -C---------------------------------------------------------------------------- -C REFINE ESTIMATE AND TEST -C------------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - RS1 = RS1+DLOG(APHI) - IF (DABS(RS1).LT.ELIM) GO TO 120 - 105 CONTINUE - IF (RS1.GT.0.0D0) GO TO 320 -C----------------------------------------------------------------------- -C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW -C----------------------------------------------------------------------- - IF (ZR.LT.0.0D0) GO TO 320 - NZ = N - DO 106 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 106 CONTINUE - RETURN - 120 CONTINUE - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(KFLAG) - ASCLE = BRY(KFLAG) - DO 130 I=IB,N - C2R = S2R - C2I = S2I - S2R = CKR*C2R - CKI*C2I + S1R - S2I = CKR*C2I + CKI*C2R + S1I - S1R = C2R - S1I = C2I - CKR = CKR + RZR - CKI = CKI + RZI - C2R = S2R*C1R - C2I = S2I*C1R - YR(I) = C2R - YI(I) = C2I - IF (KFLAG.GE.3) GO TO 130 - STR = DABS(C2R) - STI = DABS(C2I) - C2M = DMAX1(STR,STI) - IF (C2M.LE.ASCLE) GO TO 130 - KFLAG = KFLAG + 1 - ASCLE = BRY(KFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(KFLAG) - S1I = S1I*CSSR(KFLAG) - S2R = S2R*CSSR(KFLAG) - S2I = S2I*CSSR(KFLAG) - C1R = CSRR(KFLAG) - 130 CONTINUE - 180 CONTINUE - IF (MR.EQ.0) RETURN -C----------------------------------------------------------------------- -C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 -C----------------------------------------------------------------------- - NZ = 0 - FMR = DBLE(FLOAT(MR)) - SGN = -DSIGN(PI,FMR) -C----------------------------------------------------------------------- -C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. -C----------------------------------------------------------------------- - CSGNI = SGN - IF (YY.LE.0.0D0) CSGNI = -CSGNI - IFN = INU + N - 1 - ANG = FNF*SGN - CSPNR = DCOS(ANG) - CSPNI = DSIN(ANG) - IF (MOD(IFN,2).EQ.0) GO TO 190 - CSPNR = -CSPNR - CSPNI = -CSPNI - 190 CONTINUE -C----------------------------------------------------------------------- -C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS -C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST -C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY -C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS -C----------------------------------------------------------------------- - CSR = SAR*CSGNI - CSI = CAR*CSGNI - IN = MOD(IFN,4) + 1 - C2R = CIPR(IN) - C2I = CIPI(IN) - STR = CSR*C2R + CSI*C2I - CSI = -CSR*C2I + CSI*C2R - CSR = STR - ASC = BRY(1) - IUF = 0 - KK = N - KDFLG = 1 - IB = IB - 1 - IC = IB - 1 - DO 290 K=1,N - FN = FNU + DBLE(FLOAT(KK-1)) -C----------------------------------------------------------------------- -C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K -C FUNCTION ABOVE -C----------------------------------------------------------------------- - IF (N.GT.2) GO TO 175 - 172 CONTINUE - PHIDR = PHIR(J) - PHIDI = PHII(J) - ARGDR = ARGR(J) - ARGDI = ARGI(J) - ZET1DR = ZETA1R(J) - ZET1DI = ZETA1I(J) - ZET2DR = ZETA2R(J) - ZET2DI = ZETA2I(J) - ASUMDR = ASUMR(J) - ASUMDI = ASUMI(J) - BSUMDR = BSUMR(J) - BSUMDI = BSUMI(J) - J = 3 - J - GO TO 210 - 175 CONTINUE - IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210 - IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 - CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, - * ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, - * ASUMDI, BSUMDR, BSUMDI) - 210 CONTINUE - IF (KODE.EQ.1) GO TO 220 - STR = ZBR + ZET2DR - STI = ZBI + ZET2DI - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZET1DR + STR - S1I = -ZET1DI + STI - GO TO 230 - 220 CONTINUE - S1R = -ZET1DR + ZET2DR - S1I = -ZET1DI + ZET2DI - 230 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 280 - IF (KDFLG.EQ.1) IFLAG = 2 - IF (DABS(RS1).LT.ALIM) GO TO 240 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIDR,PHIDI) - AARG = ZABS(ARGDR,ARGDI) - RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC - IF (DABS(RS1).GT.ELIM) GO TO 280 - IF (KDFLG.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 240 - IF (KDFLG.EQ.1) IFLAG = 3 - 240 CONTINUE - CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) - CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) - STR = DAIR*BSUMDR - DAII*BSUMDI - STI = DAIR*BSUMDI + DAII*BSUMDR - STR = STR + (AIR*ASUMDR-AII*ASUMDI) - STI = STI + (AIR*ASUMDI+AII*ASUMDR) - PTR = STR*PHIDR - STI*PHIDI - PTI = STR*PHIDI + STI*PHIDR - S2R = PTR*CSR - PTI*CSI - S2I = PTR*CSI + PTI*CSR - STR = DEXP(S1R)*CSSR(IFLAG) - S1R = STR*DCOS(S1I) - S1I = STR*DSIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 250 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.EQ.0) GO TO 250 - S2R = ZEROR - S2I = ZEROI - 250 CONTINUE - IF (YY.LE.0.0D0) S2I = -S2I - CYR(KDFLG) = S2R - CYI(KDFLG) = S2I - C2R = S2R - C2I = S2I - S2R = S2R*CSRR(IFLAG) - S2I = S2I*CSRR(IFLAG) -C----------------------------------------------------------------------- -C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N -C----------------------------------------------------------------------- - S1R = YR(KK) - S1I = YI(KK) - IF (KODE.EQ.1) GO TO 270 - CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 270 CONTINUE - YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R - YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - STR = CSI - CSI = -CSR - CSR = STR - IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 - KDFLG = 1 - GO TO 290 - 255 CONTINUE - IF (KDFLG.EQ.2) GO TO 295 - KDFLG = 2 - GO TO 290 - 280 CONTINUE - IF (RS1.GT.0.0D0) GO TO 320 - S2R = ZEROR - S2I = ZEROI - GO TO 250 - 290 CONTINUE - K = N - 295 CONTINUE - IL = N - K - IF (IL.EQ.0) RETURN -C----------------------------------------------------------------------- -C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE -C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP -C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. -C----------------------------------------------------------------------- - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - CSR = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - FN = DBLE(FLOAT(INU+IL)) - DO 310 I=1,IL - C2R = S2R - C2I = S2I - S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - FN = FN - 1.0D0 - C2R = S2R*CSR - C2I = S2I*CSR - CKR = C2R - CKI = C2I - C1R = YR(KK) - C1I = YI(KK) - IF (KODE.EQ.1) GO TO 300 - CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) - NZ = NZ + NW - 300 CONTINUE - YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R - YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I - KK = KK - 1 - CSPNR = -CSPNR - CSPNI = -CSPNI - IF (IFLAG.GE.3) GO TO 310 - C2R = DABS(CKR) - C2I = DABS(CKI) - C2M = DMAX1(C2R,C2I) - IF (C2M.LE.ASCLE) GO TO 310 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSR - S1I = S1I*CSR - S2R = CKR - S2I = CKI - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - CSR = CSRR(IFLAG) - 310 CONTINUE - RETURN - 320 CONTINUE - NZ = -1 - RETURN - END - SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, - * FNUL, TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZBUNI -C***REFER TO ZBESI,ZBESK -C -C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. -C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM -C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING -C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) -C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 -C -C***ROUTINES CALLED ZUNI1,ZUNI2,ZABS,D1MACH -C***END PROLOGUE ZBUNI -C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z - EXTERNAL ZABS - DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, - * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, - * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, - * D1MACH - INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ - DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) - NZ = 0 - AX = DABS(ZR)*1.7321D0 - AY = DABS(ZI) - IFORM = 1 - IF (AY.GT.AX) IFORM = 2 - IF (NUI.EQ.0) GO TO 60 - FNUI = DBLE(FLOAT(NUI)) - DFNU = FNU + DBLE(FLOAT(N-1)) - GNU = DFNU + FNUI - IF (IFORM.EQ.2) GO TO 10 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - GO TO 20 - 10 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - 20 CONTINUE - IF (NW.LT.0) GO TO 50 - IF (NW.NE.0) GO TO 90 - STR = ZABS(CYR(1),CYI(1)) -C---------------------------------------------------------------------- -C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED -C---------------------------------------------------------------------- - BRY(1)=1.0D+3*D1MACH(1)/TOL - BRY(2) = 1.0D0/BRY(1) - BRY(3) = BRY(2) - IFLAG = 2 - ASCLE = BRY(2) - CSCLR = 1.0D0 - IF (STR.GT.BRY(1)) GO TO 21 - IFLAG = 1 - ASCLE = BRY(1) - CSCLR = 1.0D0/TOL - GO TO 25 - 21 CONTINUE - IF (STR.LT.BRY(2)) GO TO 25 - IFLAG = 3 - ASCLE=BRY(3) - CSCLR = TOL - 25 CONTINUE - CSCRR = 1.0D0/CSCLR - S1R = CYR(2)*CSCLR - S1I = CYI(2)*CSCLR - S2R = CYR(1)*CSCLR - S2I = CYI(1)*CSCLR - RAZ = 1.0D0/ZABS(ZR,ZI) - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - DO 30 I=1,NUI - STR = S2R - STI = S2I - S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R - S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I - S1R = STR - S1I = STI - FNUI = FNUI - 1.0D0 - IF (IFLAG.GE.3) GO TO 30 - STR = S2R*CSCRR - STI = S2I*CSCRR - C1R = DABS(STR) - C1I = DABS(STI) - C1M = DMAX1(C1R,C1I) - IF (C1M.LE.ASCLE) GO TO 30 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSCRR - S1I = S1I*CSCRR - S2R = STR - S2I = STI - CSCLR = CSCLR*TOL - CSCRR = 1.0D0/CSCLR - S1R = S1R*CSCLR - S1I = S1I*CSCLR - S2R = S2R*CSCLR - S2I = S2I*CSCLR - 30 CONTINUE - YR(N) = S2R*CSCRR - YI(N) = S2I*CSCRR - IF (N.EQ.1) RETURN - NL = N - 1 - FNUI = DBLE(FLOAT(NL)) - K = NL - DO 40 I=1,NL - STR = S2R - STI = S2I - S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R - S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I - S1R = STR - S1I = STI - STR = S2R*CSCRR - STI = S2I*CSCRR - YR(K) = STR - YI(K) = STI - FNUI = FNUI - 1.0D0 - K = K - 1 - IF (IFLAG.GE.3) GO TO 40 - C1R = DABS(STR) - C1I = DABS(STI) - C1M = DMAX1(C1R,C1I) - IF (C1M.LE.ASCLE) GO TO 40 - IFLAG = IFLAG+1 - ASCLE = BRY(IFLAG) - S1R = S1R*CSCRR - S1I = S1I*CSCRR - S2R = STR - S2I = STI - CSCLR = CSCLR*TOL - CSCRR = 1.0D0/CSCLR - S1R = S1R*CSCLR - S1I = S1I*CSCLR - S2R = S2R*CSCLR - S2I = S2I*CSCLR - 40 CONTINUE - RETURN - 50 CONTINUE - NZ = -1 - IF(NW.EQ.(-2)) NZ=-2 - RETURN - 60 CONTINUE - IF (IFORM.EQ.2) GO TO 70 -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN -C -PI/3.LE.ARG(Z).LE.PI/3 -C----------------------------------------------------------------------- - CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - GO TO 80 - 70 CONTINUE -C----------------------------------------------------------------------- -C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU -C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I -C AND HPI=PI/2 -C----------------------------------------------------------------------- - CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, - * ELIM, ALIM) - 80 CONTINUE - IF (NW.LT.0) GO TO 50 - NZ = NW - RETURN - 90 CONTINUE - NLAST = N - RETURN - END - SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, - * TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZUNI1 -C***REFER TO ZBESI,ZBESK -C -C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC -C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. -C -C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC -C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. -C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER -C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. -C Y(I)=CZERO FOR I=NLAST+1,N -C -C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS -C***END PROLOGUE ZUNI1 -C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, -C *S2,Y,Z,ZETA1,ZETA2 - EXTERNAL ZABS - DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, - * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, - * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, - * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, - * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS - INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ - DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), - * CSRR(3), CYR(2), CYI(2) - DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / -C - NZ = 0 - ND = N - NLAST = 0 -C----------------------------------------------------------------------- -C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- -C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, -C EXP(ALIM)=EXP(ELIM)*TOL -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = DMAX1(FNU,1.0D0) - INIT = 0 - CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - IF (KODE.EQ.1) GO TO 10 - STR = ZR + ZETA2R - STI = ZI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI - GO TO 20 - 10 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 20 CONTINUE - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 130 - 30 CONTINUE - NN = MIN0(2,ND) - DO 80 I=1,NN - FN = FNU + DBLE(FLOAT(ND-I)) - INIT = 0 - CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) - IF (KODE.EQ.1) GO TO 40 - STR = ZR + ZETA2R - STI = ZI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI + ZI - GO TO 50 - 40 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 50 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 2 - IF (DABS(RS1).LT.ALIM) GO TO 60 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- - APHI = ZABS(PHIR,PHII) - RS1 = RS1 + DLOG(APHI) - IF (DABS(RS1).GT.ELIM) GO TO 110 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 60 - IF (I.EQ.1) IFLAG = 3 - 60 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 IF CABS(S1).LT.ASCLE -C----------------------------------------------------------------------- - S2R = PHIR*SUMR - PHII*SUMI - S2I = PHIR*SUMI + PHII*SUMR - STR = DEXP(S1R)*CSSR(IFLAG) - S1R = STR*DCOS(S1I) - S1I = STR*DSIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 70 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 110 - 70 CONTINUE - CYR(I) = S2R - CYI(I) = S2I - M = ND - I + 1 - YR(M) = S2R*CSRR(IFLAG) - YI(M) = S2I*CSRR(IFLAG) - 80 CONTINUE - IF (ND.LE.2) GO TO 100 - RAST = 1.0D0/ZABS(ZR,ZI) - STR = ZR*RAST - STI = -ZI*RAST - RZR = (STR+STR)*RAST - RZI = (STI+STI)*RAST - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = DBLE(FLOAT(K)) - DO 90 I=3,ND - C2R = S2R - C2I = S2I - S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - C2R = S2R*C1R - C2I = S2I*C1R - YR(K) = C2R - YI(K) = C2I - K = K - 1 - FN = FN - 1.0D0 - IF (IFLAG.GE.3) GO TO 90 - STR = DABS(C2R) - STI = DABS(C2I) - C2M = DMAX1(STR,STI) - IF (C2M.LE.ASCLE) GO TO 90 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - C1R = CSRR(IFLAG) - 90 CONTINUE - 100 CONTINUE - RETURN -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - 110 CONTINUE - IF (RS1.GT.0.0D0) GO TO 120 - YR(ND) = ZEROR - YI(ND) = ZEROI - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 100 - CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 120 - ND = ND - NUF - NZ = NZ + NUF - IF (ND.EQ.0) GO TO 100 - FN = FNU + DBLE(FLOAT(ND-1)) - IF (FN.GE.FNUL) GO TO 30 - NLAST = ND - RETURN - 120 CONTINUE - NZ = -1 - RETURN - 130 CONTINUE - IF (RS1.GT.0.0D0) GO TO 120 - NZ = N - DO 140 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 140 CONTINUE - RETURN - END - SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, - * TOL, ELIM, ALIM) -C***BEGIN PROLOGUE ZUNI2 -C***REFER TO ZBESI,ZBESK -C -C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF -C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I -C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. -C -C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC -C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. -C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER -C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. -C Y(I)=CZERO FOR I=NLAST+1,N -C -C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS -C***END PROLOGUE ZUNI2 -C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, -C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN - EXTERNAL ZABS - DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, - * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, - * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, - * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, - * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, - * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, - * CYI, D1MACH, ZABS, CAR, SAR - INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, - * NN, NUF, NW, NZ, IDUM - DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), - * CSRR(3), CYR(2), CYI(2) - DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / - DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), - * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ - DATA HPI, AIC / - 1 1.57079632679489662D+00, 1.265512123484645396D+00/ -C - NZ = 0 - ND = N - NLAST = 0 -C----------------------------------------------------------------------- -C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- -C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, -C EXP(ALIM)=EXP(ELIM)*TOL -C----------------------------------------------------------------------- - CSCL = 1.0D0/TOL - CRSC = TOL - CSSR(1) = CSCL - CSSR(2) = CONER - CSSR(3) = CRSC - CSRR(1) = CRSC - CSRR(2) = CONER - CSRR(3) = CSCL - BRY(1) = 1.0D+3*D1MACH(1)/TOL -C----------------------------------------------------------------------- -C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI -C----------------------------------------------------------------------- - ZNR = ZI - ZNI = -ZR - ZBR = ZR - ZBI = ZI - CIDI = -CONER - INU = INT(SNGL(FNU)) - ANG = HPI*(FNU-DBLE(FLOAT(INU))) - C2R = DCOS(ANG) - C2I = DSIN(ANG) - CAR = C2R - SAR = C2I - IN = INU + N - 1 - IN = MOD(IN,4) + 1 - STR = C2R*CIPR(IN) - C2I*CIPI(IN) - C2I = C2R*CIPI(IN) + C2I*CIPR(IN) - C2R = STR - IF (ZI.GT.0.0D0) GO TO 10 - ZNR = -ZNR - ZBI = -ZBI - CIDI = -CIDI - C2I = -C2I - 10 CONTINUE -C----------------------------------------------------------------------- -C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER -C----------------------------------------------------------------------- - FN = DMAX1(FNU,1.0D0) - CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, - * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - IF (KODE.EQ.1) GO TO 20 - STR = ZBR + ZETA2R - STI = ZBI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI - GO TO 30 - 20 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 30 CONTINUE - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 150 - 40 CONTINUE - NN = MIN0(2,ND) - DO 90 I=1,NN - FN = FNU + DBLE(FLOAT(ND-I)) - CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, - * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) - IF (KODE.EQ.1) GO TO 50 - STR = ZBR + ZETA2R - STI = ZBI + ZETA2I - RAST = FN/ZABS(STR,STI) - STR = STR*RAST*RAST - STI = -STI*RAST*RAST - S1R = -ZETA1R + STR - S1I = -ZETA1I + STI + DABS(ZI) - GO TO 60 - 50 CONTINUE - S1R = -ZETA1R + ZETA2R - S1I = -ZETA1I + ZETA2I - 60 CONTINUE -C----------------------------------------------------------------------- -C TEST FOR UNDERFLOW AND OVERFLOW -C----------------------------------------------------------------------- - RS1 = S1R - IF (DABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 2 - IF (DABS(RS1).LT.ALIM) GO TO 70 -C----------------------------------------------------------------------- -C REFINE TEST AND SCALE -C----------------------------------------------------------------------- -C----------------------------------------------------------------------- - APHI = ZABS(PHIR,PHII) - AARG = ZABS(ARGR,ARGI) - RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC - IF (DABS(RS1).GT.ELIM) GO TO 120 - IF (I.EQ.1) IFLAG = 1 - IF (RS1.LT.0.0D0) GO TO 70 - IF (I.EQ.1) IFLAG = 3 - 70 CONTINUE -C----------------------------------------------------------------------- -C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR -C EXPONENT EXTREMES -C----------------------------------------------------------------------- - CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) - CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) - STR = DAIR*BSUMR - DAII*BSUMI - STI = DAIR*BSUMI + DAII*BSUMR - STR = STR + (AIR*ASUMR-AII*ASUMI) - STI = STI + (AIR*ASUMI+AII*ASUMR) - S2R = PHIR*STR - PHII*STI - S2I = PHIR*STI + PHII*STR - STR = DEXP(S1R)*CSSR(IFLAG) - S1R = STR*DCOS(S1I) - S1I = STR*DSIN(S1I) - STR = S2R*S1R - S2I*S1I - S2I = S2R*S1I + S2I*S1R - S2R = STR - IF (IFLAG.NE.1) GO TO 80 - CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) - IF (NW.NE.0) GO TO 120 - 80 CONTINUE - IF (ZI.LE.0.0D0) S2I = -S2I - STR = S2R*C2R - S2I*C2I - S2I = S2R*C2I + S2I*C2R - S2R = STR - CYR(I) = S2R - CYI(I) = S2I - J = ND - I + 1 - YR(J) = S2R*CSRR(IFLAG) - YI(J) = S2I*CSRR(IFLAG) - STR = -C2I*CIDI - C2I = C2R*CIDI - C2R = STR - 90 CONTINUE - IF (ND.LE.2) GO TO 110 - RAZ = 1.0D0/ZABS(ZR,ZI) - STR = ZR*RAZ - STI = -ZI*RAZ - RZR = (STR+STR)*RAZ - RZI = (STI+STI)*RAZ - BRY(2) = 1.0D0/BRY(1) - BRY(3) = D1MACH(2) - S1R = CYR(1) - S1I = CYI(1) - S2R = CYR(2) - S2I = CYI(2) - C1R = CSRR(IFLAG) - ASCLE = BRY(IFLAG) - K = ND - 2 - FN = DBLE(FLOAT(K)) - DO 100 I=3,ND - C2R = S2R - C2I = S2I - S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) - S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) - S1R = C2R - S1I = C2I - C2R = S2R*C1R - C2I = S2I*C1R - YR(K) = C2R - YI(K) = C2I - K = K - 1 - FN = FN - 1.0D0 - IF (IFLAG.GE.3) GO TO 100 - STR = DABS(C2R) - STI = DABS(C2I) - C2M = DMAX1(STR,STI) - IF (C2M.LE.ASCLE) GO TO 100 - IFLAG = IFLAG + 1 - ASCLE = BRY(IFLAG) - S1R = S1R*C1R - S1I = S1I*C1R - S2R = C2R - S2I = C2I - S1R = S1R*CSSR(IFLAG) - S1I = S1I*CSSR(IFLAG) - S2R = S2R*CSSR(IFLAG) - S2I = S2I*CSSR(IFLAG) - C1R = CSRR(IFLAG) - 100 CONTINUE - 110 CONTINUE - RETURN - 120 CONTINUE - IF (RS1.GT.0.0D0) GO TO 140 -C----------------------------------------------------------------------- -C SET UNDERFLOW AND UPDATE PARAMETERS -C----------------------------------------------------------------------- - YR(ND) = ZEROR - YI(ND) = ZEROI - NZ = NZ + 1 - ND = ND - 1 - IF (ND.EQ.0) GO TO 110 - CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) - IF (NUF.LT.0) GO TO 140 - ND = ND - NUF - NZ = NZ + NUF - IF (ND.EQ.0) GO TO 110 - FN = FNU + DBLE(FLOAT(ND-1)) - IF (FN.LT.FNUL) GO TO 130 -C FN = CIDI -C J = NUF + 1 -C K = MOD(J,4) + 1 -C S1R = CIPR(K) -C S1I = CIPI(K) -C IF (FN.LT.0.0D0) S1I = -S1I -C STR = C2R*S1R - C2I*S1I -C C2I = C2R*S1I + C2I*S1R -C C2R = STR - IN = INU + ND - 1 - IN = MOD(IN,4) + 1 - C2R = CAR*CIPR(IN) - SAR*CIPI(IN) - C2I = CAR*CIPI(IN) + SAR*CIPR(IN) - IF (ZI.LE.0.0D0) C2I = -C2I - GO TO 40 - 130 CONTINUE - NLAST = ND - RETURN - 140 CONTINUE - NZ = -1 - RETURN - 150 CONTINUE - IF (RS1.GT.0.0D0) GO TO 140 - NZ = N - DO 160 I=1,N - YR(I) = ZEROR - YI(I) = ZEROI - 160 CONTINUE - RETURN - END - SUBROUTINE XERROR(MESS,NMESS,L1,L2) -C -C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS -C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL -C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 -C ROUTINE. -C - INTEGER NMESS, L1, L2, NN, NR, K, I, KMIN - CHARACTER*(*) MESS - NN=NMESS/70 - NR=NMESS-70*NN - IF(NR.NE.0) NN=NN+1 - K=1 - PRINT 900 - 900 FORMAT(/) - DO 10 I=1,NN - KMIN=MIN0(K+69,NMESS) - PRINT *, MESS(K:KMIN) - K=K+70 - 10 CONTINUE - PRINT 900 - RETURN - END - DOUBLE PRECISION FUNCTION D1MACH(I) -C -C DOUBLE-PRECISION MACHINE CONSTANTS -C -C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. -C -C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. -C -C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. -C -C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. -C -C D1MACH( 5) = LOG10(B) -C -C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, -C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY -C REMOVING THE C FROM COLUMN 1. -C -C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), ONE OF THE FIRST -C TWO SETS OF CONSTANTS BELOW SHOULD BE APPROPRIATE. -C -C WHERE POSSIBLE, DECIMAL, OCTAL OR HEXADECIMAL CONSTANTS ARE USED -C TO SPECIFY THE CONSTANTS EXACTLY. SOMETIMES THIS REQUIRES USING -C EQUIVALENT INTEGER ARRAYS. IF YOUR COMPILER USES HALF-WORD -C INTEGERS BY DEFAULT (SOMETIMES CALLED INTEGER*2), YOU MAY NEED TO -C CHANGE INTEGER TO INTEGER*4 OR OTHERWISE INSTRUCT YOUR COMPILER -C TO USE FULL-WORD INTEGERS IN THE NEXT 5 DECLARATIONS. -C - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) - INTEGER SC -C - DOUBLE PRECISION DMACH(5) -C - EQUIVALENCE (DMACH(1),SMALL(1)) - EQUIVALENCE (DMACH(2),LARGE(1)) - EQUIVALENCE (DMACH(3),RIGHT(1)) - EQUIVALENCE (DMACH(4),DIVER(1)) - EQUIVALENCE (DMACH(5),LOG10(1)) -C -C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T -C 3B SERIES AND MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T -C PC 7300), IN WHICH THE MOST SIGNIFICANT BYTE IS STORED FIRST. -C - DATA SMALL(1),SMALL(2) / 1048576, 0 / - DATA LARGE(1),LARGE(2) / 2146435071, -1 / - DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / - DATA DIVER(1),DIVER(2) / 1018167296, 0 / - DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 /, SC/987/ -C -C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES AND 8087-BASED -C MICROS, SUCH AS THE IBM PC AND AT&T 6300, IN WHICH THE LEAST -C SIGNIFICANT BYTE IS STORED FIRST. -C -C DATA SMALL(1),SMALL(2) / 0, 1048576 / -C DATA LARGE(1),LARGE(2) / -1, 2146435071 / -C DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / -C DATA DIVER(1),DIVER(2) / 0, 1018167296 / -C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /, SC/987/ -C -C MACHINE CONSTANTS FOR AMDAHL MACHINES. -C -C DATA SMALL(1),SMALL(2) / 1048576, 0 / -C DATA LARGE(1),LARGE(2) / 2147483647, -1 / -C DATA RIGHT(1),RIGHT(2) / 856686592, 0 / -C DATA DIVER(1),DIVER(2) / 873463808, 0 / -C DATA LOG10(1),LOG10(2) / 1091781651, 1352628735 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 /, SC/987/ -C -C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777774B / -C -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B /, SC/987/ -C -C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. -C -C DATA SMALL(1) / O"00564000000000000000" / -C DATA SMALL(2) / O"00000000000000000000" / -C -C DATA LARGE(1) / O"37757777777777777777" / -C DATA LARGE(2) / O"37157777777777777774" / -C -C DATA RIGHT(1) / O"15624000000000000000" / -C DATA RIGHT(2) / O"00000000000000000000" / -C -C DATA DIVER(1) / O"15634000000000000000" / -C DATA DIVER(2) / O"00000000000000000000" / -C -C DATA LOG10(1) / O"17164642023241175717" / -C DATA LOG10(2) / O"16367571421742254654" /, SC/987/ -C -C MACHINE CONSTANTS FOR CONVEX C-1 -C -C DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X / -C DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X / -C DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X / -C DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X / -C DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X /, SC/987/ -C -C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777776B / -C -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B /, SC/987/ -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - -C STATIC DMACH(5) -C -C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ -C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ -C DATA LOG10/40423K,42023K,50237K,74776K/, SC/987/ -C -C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 -C -C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1),LOG10(2) / '23210115, '10237777 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. -C -C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / -C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / -C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / -C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / -C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. -C -C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /, SC/987/ -C -C MACHINE CONSTANTS FOR THE INTERDATA 8/32 -C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. -C -C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE -C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. -C -C DATA SMALL(1),SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1),LARGE(2) / Z'7EFFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1),RIGHT(2) / Z'33100000', Z'00000000' / -C DATA DIVER(1),DIVER(2) / Z'34100000', Z'00000000' / -C DATA LOG10(1),LOG10(2) / Z'41134413', Z'509F79FF' /, SC/987/ -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). -C -C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). -C -C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1),LOG10(2) / "177464202324, "047674776746 /, SC/987/ -C -C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1),SMALL(2) / 8388608, 0 / -C DATA LARGE(1),LARGE(2) / 2147483647, -1 / -C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / -C DATA DIVER(1),DIVER(2) / 620756992, 0 / -C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ -C -C DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /, SC/987/ -C -C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1),SMALL(2) / 128, 0 / -C DATA SMALL(3),SMALL(4) / 0, 0 / -C -C DATA LARGE(1),LARGE(2) / 32767, -1 / -C DATA LARGE(3),LARGE(4) / -1, -1 / -C -C DATA RIGHT(1),RIGHT(2) / 9344, 0 / -C DATA RIGHT(3),RIGHT(4) / 0, 0 / -C -C DATA DIVER(1),DIVER(2) / 9472, 0 / -C DATA DIVER(3),DIVER(4) / 0, 0 / -C -C DATA LOG10(1),LOG10(2) / 16282, 8346 / -C DATA LOG10(3),LOG10(4) / -31493, -12296 /, SC/987/ -C -C DATA SMALL(1),SMALL(2) / O000200, O000000 / -C DATA SMALL(3),SMALL(4) / O000000, O000000 / -C -C DATA LARGE(1),LARGE(2) / O077777, O177777 / -C DATA LARGE(3),LARGE(4) / O177777, O177777 / -C -C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / -C -C DATA DIVER(1),DIVER(2) / O022400, O000000 / -C DATA DIVER(3),DIVER(4) / O000000, O000000 / -C -C DATA LOG10(1),LOG10(2) / O037632, O020232 / -C DATA LOG10(3),LOG10(4) / O102373, O147770 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS -C WITH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, -C SUPPLIED BY IGOR BRAY. -C -C DATA SMALL(1),SMALL(2) / :10000000000, :00000100001 / -C DATA LARGE(1),LARGE(2) / :17777777777, :37777677775 / -C DATA RIGHT(1),RIGHT(2) / :10000000000, :00000000122 / -C DATA DIVER(1),DIVER(2) / :10000000000, :00000000123 / -C DATA LOG10(1),LOG10(2) / :11504046501, :07674600177 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 -C -C DATA SMALL(1),SMALL(2) / $00000000, $00100000 / -C DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / -C DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / -C DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / -C DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. -C -C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / -C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / -C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / -C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / -C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE VAX UNIX F77 COMPILER -C -C DATA SMALL(1),SMALL(2) / 128, 0 / -C DATA LARGE(1),LARGE(2) / -32769, -1 / -C DATA RIGHT(1),RIGHT(2) / 9344, 0 / -C DATA DIVER(1),DIVER(2) / 9472, 0 / -C DATA LOG10(1),LOG10(2) / 546979738, -805796613 /, SC/987/ -C -C MACHINE CONSTANTS FOR THE VAX-11 WITH -C FORTRAN IV-PLUS COMPILER -C -C DATA SMALL(1),SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1),LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1),RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1),DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1),LOG10(2) / Z209A3F9A, ZCFF884FB /, SC/987/ -C -C MACHINE CONSTANTS FOR VAX/VMS VERSION 2.2 -C -C DATA SMALL(1),SMALL(2) / '80'X, '0'X / -C DATA LARGE(1),LARGE(2) / 'FFFF7FFF'X, 'FFFFFFFF'X / -C DATA RIGHT(1),RIGHT(2) / '2480'X, '0'X / -C DATA DIVER(1),DIVER(2) / '2500'X, '0'X / -C DATA LOG10(1),LOG10(2) / '209A3F9A'X, 'CFF884FB'X /, SC/987/ -C -C *** ISSUE STOP 779 IF ALL DATA STATEMENTS ARE COMMENTED... - IF (SC .NE. 987) STOP 779 -C/6S -C IF (I .LT. 1 .OR. I .GT. 5) -C 1 CALL SETERR(24HD1MACH - I OUT OF BOUNDS,24,1,2) -C/7S -C IF (I .LT. 1 .OR. I .GT. 5) -C 1 CALL SETERR('D1MACH - I OUT OF BOUNDS',24,1,2) -C/ -C - D1MACH = DMACH(I) - RETURN -C - END - INTEGER FUNCTION I1MACH(I) -C -C I/O UNIT NUMBERS. -C -C I1MACH( 1) = THE STANDARD INPUT UNIT. -C -C I1MACH( 2) = THE STANDARD OUTPUT UNIT. -C -C I1MACH( 3) = THE STANDARD PUNCH UNIT. -C -C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. -C -C WORDS. -C -C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. -C -C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. -C FOR FORTRAN 77, THIS IS ALWAYS 1. FOR FORTRAN 66, -C CHARACTER STORAGE UNIT = INTEGER STORAGE UNIT. -C -C INTEGERS. -C -C ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM -C -C SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. -C -C I1MACH( 7) = A, THE BASE. -C -C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. -C -C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. -C -C FLOATING-POINT NUMBERS. -C -C ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, -C BASE-B FORM -C -C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, -C 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. -C -C I1MACH(10) = B, THE BASE. -C -C SINGLE-PRECISION -C -C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. -C -C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. -C -C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. -C -C DOUBLE-PRECISION -C -C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. -C -C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. -C -C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. -C -C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, -C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY -C REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF -C I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY -C WITH THE LOCAL OPERATING SYSTEM. FOR FORTRAN 77, YOU MAY WISH -C TO ADJUST THE DATA STATEMENT SO IMACH(6) IS SET TO 1, AND -C THEN TO COMMENT OUT THE EXECUTABLE TEST ON I .EQ. 6 BELOW. -C -C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), THE FIRST -C SET OF CONSTANTS BELOW SHOULD BE APPROPRIATE, EXCEPT PERHAPS -C FOR IMACH(1) - IMACH(4). -C - INTEGER IMACH(16),OUTPUT,SANITY -C - EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T -C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T -C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). -C - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 7 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -125 / - DATA IMACH(13) / 128 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1021 / - DATA IMACH(16) / 1024 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR AMDAHL MACHINES. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / O"00007777777777777777" / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR CONVEX C-1. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) /-1024 / -C DATA IMACH(16) / 1023 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) /32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 43 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE INTERDATA 8/32 -C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. -C -C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE -C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 62 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 62 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS -C WTIH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, -C SUPPLIED BY IGOR BRAY. -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / :17777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / +127 / -C DATA IMACH(14) / 47 / -C DATA IMACH(15) / -32895 / -C DATA IMACH(16) / +32637 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. -C -C DATA IMACH( 1) / 0 / -C DATA IMACH( 2) / 0 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 1 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. -C -C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 -C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. -C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) /-1024 / -C DATA IMACH(16) / 1023 /, SANITY/987/ -C -C MACHINE CONSTANTS FOR VAX. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 /, SANITY/987/ -C -C *** ISSUE STOP 777 IF ALL DATA STATEMENTS ARE COMMENTED... - IF (SANITY .NE. 987) STOP 777 - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) -C/6S -C/7S - IF (I .EQ. 6) I1MACH = 1 -C/ - RETURN -C - 10 WRITE(OUTPUT,9000) - 9000 FORMAT(39H1ERROR 1 IN I1MACH - I OUT OF BOUNDS) -C -C CALL FDUMP -C - STOP -C - END + SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESH +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, +C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 +C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX +C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. +C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS +C +C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1. +C +C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND +C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE +C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), +C -PT.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(J)=H(M,FNU+J-1,Z), J=1,...,N +C = 2 RETURNS +C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) +C J=1,...,N , I**2=-1 +C M - KIND OF HANKEL FUNCTION, M=1 OR 2 +C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(J)=H(M,FNU+J-1,Z) OR +C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N +C DEPENDING ON KODE, I**2=-1. +C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, +C NZ= 0 , NORMAL RETURN +C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE +C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) +C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR +C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY +C HALF PLANES, NZ STATES ONLY THE NUMBER +C OF UNDERFLOWS. +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO +C LARGE OR CABS(Z) TOO SMALL OR BOTH +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT BY THE RELATION +C +C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) +C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 +C +C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE +C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED +C TO THE LEFT HALF PLANE BY THE RELATION +C +C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) +C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 +C +C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. +C +C EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z +C PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL +C GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING +C BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE +C WHOLE Z PLANE FOR Z TO INFINITY. +C +C FOR NEGATIVE ORDERS,THE FORMULAE +C +C H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) +C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) +C I**2=-1 +C +C CAN BE USED. +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH +C***END PROLOGUE ZBESH +C +C COMPLEX CY,Z,ZN,ZT,CSGN + EXTERNAL ZABS + DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, + * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, + * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, + * CSGNR, CSGNI + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, + * MM, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CYR(N), CYI(N) +C + DATA HPI /1.57079632679489662D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESH + IERR = 0 + NZ=0 + IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (M.LT.1 .OR. M.GT.2) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + NN = N +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU +C----------------------------------------------------------------------- + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) + RL = 1.2D0*DIG + 3.0D0 + FN = FNU + DBLE(FLOAT(NN-1)) + MM = 3 - M - M + FMM = DBLE(FLOAT(MM)) + ZNR = FMM*ZI + ZNI = -FMM*ZR +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + AA = 0.5D0/TOL + BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 + AA = DMIN1(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = DSQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 +C----------------------------------------------------------------------- +C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE +C----------------------------------------------------------------------- + UFL = D1MACH(1)*1.0D+3 + IF (AZ.LT.UFL) GO TO 230 + IF (FNU.GT.FNUL) GO TO 90 + IF (FN.LE.1.0D0) GO TO 70 + IF (FN.GT.2.0D0) GO TO 60 + IF (AZ.GT.TOL) GO TO 70 + ARG = 0.5D0*AZ + ALN = -FN*DLOG(ARG) + IF (ALN.GT.ELIM) GO TO 230 + GO TO 70 + 60 CONTINUE + CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, + * ALIM) + IF (NUF.LT.0) GO TO 230 + NZ = NZ + NUF + NN = NN - NUF +C----------------------------------------------------------------------- +C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK +C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I +C----------------------------------------------------------------------- + IF (NN.EQ.0) GO TO 140 + 70 CONTINUE + IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND. + * M.EQ.2)) GO TO 80 +C----------------------------------------------------------------------- +C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. +C YN.GE.0. .OR. M=1) +C----------------------------------------------------------------------- + CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM) + GO TO 110 +C----------------------------------------------------------------------- +C LEFT HALF PLANE COMPUTATION +C----------------------------------------------------------------------- + 80 CONTINUE + MR = -MM + CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, + * TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 240 + NZ=NW + GO TO 110 + 90 CONTINUE +C----------------------------------------------------------------------- +C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL +C----------------------------------------------------------------------- + MR = 0 + IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR. + * M.NE.2)) GO TO 100 + MR = -MM + IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100 + ZNR = -ZNR + ZNI = -ZNI + 100 CONTINUE + CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 240 + NZ = NZ + NW + 110 CONTINUE +C----------------------------------------------------------------------- +C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) +C +C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 +C----------------------------------------------------------------------- + SGN = DSIGN(HPI,-FMM) +C----------------------------------------------------------------------- +C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(SNGL(FNU)) + INUH = INU/2 + IR = INU - 2*INUH + ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN + RHPI = 1.0D0/SGN +C ZNI = RHPI*DCOS(ARG) +C ZNR = -RHPI*DSIN(ARG) + CSGNI = RHPI*DCOS(ARG) + CSGNR = -RHPI*DSIN(ARG) + IF (MOD(INUH,2).EQ.0) GO TO 120 +C ZNR = -ZNR +C ZNI = -ZNI + CSGNR = -CSGNR + CSGNI = -CSGNI + 120 CONTINUE + ZTI = -FMM + RTOL = 1.0D0/TOL + ASCLE = UFL*RTOL + DO 130 I=1,NN +C STR = CYR(I)*ZNR - CYI(I)*ZNI +C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR +C CYR(I) = STR +C STR = -ZNI*ZTI +C ZNI = ZNR*ZTI +C ZNR = STR + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 135 CONTINUE + STR = AA*CSGNR - BB*CSGNI + STI = AA*CSGNI + BB*CSGNR + CYR(I) = STR*ATOL + CYI(I) = STI*ATOL + STR = -CSGNI*ZTI + CSGNI = CSGNR*ZTI + CSGNR = STR + 130 CONTINUE + RETURN + 140 CONTINUE + IF (ZNR.LT.0.0D0) GO TO 230 + RETURN + 230 CONTINUE + NZ=0 + IERR=2 + RETURN + 240 CONTINUE + IF(NW.EQ.(-1)) GO TO 230 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END + SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESI +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION OF THE FIRST KIND +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE +C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE +C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED +C FUNCTIONS +C +C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=REAL(Z) +C +C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND +C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION +C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS +C (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(J)=I(FNU+J-1,Z), J=1,...,N +C = 2 RETURNS +C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(J)=I(FNU+J-1,Z) OR +C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)) J=1,...,N +C DEPENDING ON KODE, X=REAL(Z) +C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, +C NZ= 0 , NORMAL RETURN +C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO +C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) +C J = N-NZ+1,...,N +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO +C LARGE ON KODE=1 +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR +C SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z), +C THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A +C NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE +C UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z) +C FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE +C SEQUENCES OR REDUCE ORDERS WHEN NECESSARY. +C +C THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND +C CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA +C +C I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z) REAL(Z).GT.0.0 +C M = +I OR -I, I**2=-1 +C +C FOR NEGATIVE ORDERS,THE FORMULA +C +C I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z) +C +C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE +C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE +C INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE +C NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, +C K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF +C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY +C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN +C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, +C LARGE MEANS FNU.GT.CABS(Z). +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZBINU,ZABS,I1MACH,D1MACH +C***END PROLOGUE ZBESI +C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN + EXTERNAL ZABS + DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, + * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, + * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI + INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH + DIMENSION CYR(N), CYI(N) + DATA PI /3.14159265358979324D0/ + DATA CONER, CONEI /1.0D0,0.0D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESI + IERR = 0 + NZ=0 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. +C----------------------------------------------------------------------- + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) +C----------------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + FN = FNU+DBLE(FLOAT(N-1)) + AA = 0.5D0/TOL + BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 + AA = DMIN1(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = DSQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 + ZNR = ZR + ZNI = ZI + CSGNR = CONER + CSGNI = CONEI + IF (ZR.GE.0.0D0) GO TO 40 + ZNR = -ZR + ZNI = -ZI +C----------------------------------------------------------------------- +C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(SNGL(FNU)) + ARG = (FNU-DBLE(FLOAT(INU)))*PI + IF (ZI.LT.0.0D0) ARG = -ARG + CSGNR = DCOS(ARG) + CSGNI = DSIN(ARG) + IF (MOD(INU,2).EQ.0) GO TO 40 + CSGNR = -CSGNR + CSGNI = -CSGNI + 40 CONTINUE + CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NZ.LT.0) GO TO 120 + IF (ZR.GE.0.0D0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE +C----------------------------------------------------------------------- + NN = N - NZ + IF (NN.EQ.0) RETURN + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 50 I=1,NN +C STR = CYR(I)*CSGNR - CYI(I)*CSGNI +C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR +C CYR(I) = STR + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 55 CONTINUE + STR = AA*CSGNR - BB*CSGNI + STI = AA*CSGNI + BB*CSGNR + CYR(I) = STR*ATOL + CYI(I) = STI*ATOL + CSGNR = -CSGNR + CSGNI = -CSGNI + 50 CONTINUE + RETURN + 120 CONTINUE + IF(NZ.EQ.(-2)) GO TO 130 + NZ = 0 + IERR=2 + RETURN + 130 CONTINUE + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END + SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESJ +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, +C BESSEL FUNCTION OF FIRST KIND +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, ZBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE +C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE +C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESJ RETURNS THE SCALED +C FUNCTIONS +C +C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) +C +C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND +C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION +C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS +C (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(I)=J(FNU+I-1,Z), I=1,...,N +C = 2 RETURNS +C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(I)=J(FNU+I-1,Z) OR +C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N +C DEPENDING ON KODE, Y=AIMAG(Z). +C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, +C NZ= 0 , NORMAL RETURN +C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE +C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), +C I = N-NZ+1,...,N +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z) +C TOO LARGE ON KODE=1 +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT BY THE FORMULA +C +C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0 +C +C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0 +C +C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION. +C +C FOR NEGATIVE ORDERS,THE FORMULA +C +C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU) +C +C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE +C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE +C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A +C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, +C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF +C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY +C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN +C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, +C LARGE MEANS FNU.GT.CABS(Z). +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZBINU,ZABS,I1MACH,D1MACH +C***END PROLOGUE ZBESJ +C +C COMPLEX CI,CSGN,CY,Z,ZN + EXTERNAL ZABS + DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, + * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, + * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH + DIMENSION CYR(N), CYI(N) + DATA HPI /1.57079632679489662D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESJ + IERR = 0 + NZ=0 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. +C----------------------------------------------------------------------- + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + FN = FNU+DBLE(FLOAT(N-1)) + AA = 0.5D0/TOL + BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 + AA = DMIN1(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = DSQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 +C----------------------------------------------------------------------- +C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + CII = 1.0D0 + INU = INT(SNGL(FNU)) + INUH = INU/2 + IR = INU - 2*INUH + ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI + CSGNR = DCOS(ARG) + CSGNI = DSIN(ARG) + IF (MOD(INUH,2).EQ.0) GO TO 40 + CSGNR = -CSGNR + CSGNI = -CSGNI + 40 CONTINUE +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE +C----------------------------------------------------------------------- + ZNR = ZI + ZNI = -ZR + IF (ZI.GE.0.0D0) GO TO 50 + ZNR = -ZNR + ZNI = -ZNI + CSGNI = -CSGNI + CII = -CII + 50 CONTINUE + CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NZ.LT.0) GO TO 130 + NL = N - NZ + IF (NL.EQ.0) RETURN + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 60 I=1,NL +C STR = CYR(I)*CSGNR - CYI(I)*CSGNI +C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR +C CYR(I) = STR + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 55 CONTINUE + STR = AA*CSGNR - BB*CSGNI + STI = AA*CSGNI + BB*CSGNR + CYR(I) = STR*ATOL + CYI(I) = STI*ATOL + STR = -CSGNI*CII + CSGNI = CSGNR*CII + CSGNR = STR + 60 CONTINUE + RETURN + 130 CONTINUE + IF(NZ.EQ.(-2)) GO TO 140 + NZ = 0 + IERR = 2 + RETURN + 140 CONTINUE + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END + SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESK +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, +C MODIFIED BESSEL FUNCTION OF THE SECOND KIND, +C BESSEL FUNCTION OF THE THIRD KIND +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C +C ON KODE=1, ZBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE +C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0) +C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESK +C RETURNS THE SCALED K FUNCTIONS, +C +C CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N, +C +C WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND +C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND +C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL +C FUNCTIONS (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), +C -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0 +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(I)=K(FNU+I-1,Z), I=1,...,N +C = 2 RETURNS +C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(I)=K(FNU+I-1,Z), I=1,...,N OR +C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N +C DEPENDING ON KODE +C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW. +C NZ= 0 , NORMAL RETURN +C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE +C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), +C I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0 +C NZ STATES ONLY THE NUMBER OF UNDERFLOWS +C IN THE SEQUENCE. +C +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS +C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS +C DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD +C RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT +C HALF PLANE BY THE RELATION +C +C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) +C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 +C +C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. +C +C FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED +C BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS. +C +C FOR NEGATIVE ORDERS, THE FORMULA +C +C K(-FNU,Z) = K(FNU,Z) +C +C CAN BE USED. +C +C ZBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS +C AVAILABLE. +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983. +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH +C***END PROLOGUE ZBESK +C +C COMPLEX CY,Z + EXTERNAL ZABS + DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, + * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB + INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CYR(N), CYI(N) +C***FIRST EXECUTABLE STATEMENT ZBESK + IERR = 0 + NZ=0 + IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + NN = N +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU +C----------------------------------------------------------------------- + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) + RL = 1.2D0*DIG + 3.0D0 +C----------------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(ZR,ZI) + FN = FNU + DBLE(FLOAT(NN-1)) + AA = 0.5D0/TOL + BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 + AA = DMIN1(AA,BB) + IF (AZ.GT.AA) GO TO 260 + IF (FN.GT.AA) GO TO 260 + AA = DSQRT(AA) + IF (AZ.GT.AA) IERR=3 + IF (FN.GT.AA) IERR=3 +C----------------------------------------------------------------------- +C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE +C----------------------------------------------------------------------- +C UFL = DEXP(-ELIM) + UFL = D1MACH(1)*1.0D+3 + IF (AZ.LT.UFL) GO TO 180 + IF (FNU.GT.FNUL) GO TO 80 + IF (FN.LE.1.0D0) GO TO 60 + IF (FN.GT.2.0D0) GO TO 50 + IF (AZ.GT.TOL) GO TO 60 + ARG = 0.5D0*AZ + ALN = -FN*DLOG(ARG) + IF (ALN.GT.ELIM) GO TO 180 + GO TO 60 + 50 CONTINUE + CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, + * ALIM) + IF (NUF.LT.0) GO TO 180 + NZ = NZ + NUF + NN = NN - NUF +C----------------------------------------------------------------------- +C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK +C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I +C----------------------------------------------------------------------- + IF (NN.EQ.0) GO TO 100 + 60 CONTINUE + IF (ZR.LT.0.0D0) GO TO 70 +C----------------------------------------------------------------------- +C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. +C----------------------------------------------------------------------- + CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 200 + NZ=NW + RETURN +C----------------------------------------------------------------------- +C LEFT HALF PLANE COMPUTATION +C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. +C----------------------------------------------------------------------- + 70 CONTINUE + IF (NZ.NE.0) GO TO 180 + MR = 1 + IF (ZI.LT.0.0D0) MR = -1 + CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, + * TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 200 + NZ=NW + RETURN +C----------------------------------------------------------------------- +C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL +C----------------------------------------------------------------------- + 80 CONTINUE + MR = 0 + IF (ZR.GE.0.0D0) GO TO 90 + MR = 1 + IF (ZI.LT.0.0D0) MR = -1 + 90 CONTINUE + CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 200 + NZ = NZ + NW + RETURN + 100 CONTINUE + IF (ZR.LT.0.0D0) GO TO 180 + RETURN + 180 CONTINUE + NZ = 0 + IERR=2 + RETURN + 200 CONTINUE + IF(NW.EQ.(-1)) GO TO 180 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + NZ=0 + IERR=4 + RETURN + END + SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, + * CWRKI, IERR) +C***BEGIN PROLOGUE ZBESY +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, +C BESSEL FUNCTION OF SECOND KIND +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C +C ON KODE=1, ZBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE +C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE +C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESY RETURNS THE SCALED +C FUNCTIONS +C +C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) +C +C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND +C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION +C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS +C (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), +C -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(I)=Y(FNU+I-1,Z), I=1,...,N +C = 2 RETURNS +C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N +C WHERE Y=AIMAG(Z) +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT +C CWRKI AT LEAST N +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(I)=Y(FNU+I-1,Z) OR +C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N +C DEPENDING ON KODE. +C NZ - NZ=0 , A NORMAL RETURN +C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO +C UNDERFLOW (GENERALLY ON KODE=2) +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS +C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT IN TERMS OF THE I(FNU,Z) AND +C K(FNU,Z) BESSEL FUNCTIONS IN THE RIGHT HALF PLANE BY +C +C Y(FNU,Z) = I*CC*I(FNU,ARG) - (2/PI)*CONJG(CC)*K(FNU,ARG) +C +C Y(FNU,Z) = CONJG(Y(FNU,CONJG(Z))) +C +C FOR AIMAG(Z).GE.0 AND AIMAG(Z).LT.0 RESPECTIVELY, WHERE +C CC=EXP(I*PI*FNU/2), ARG=Z*EXP(-I*PI/2) AND I**2=-1. +C +C FOR NEGATIVE ORDERS,THE FORMULA +C +C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU) +C +C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD +C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE +C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)* +C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS +C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A +C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM +C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, +C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF +C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z). +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZBESI,ZBESK,I1MACH,D1MACH +C***END PROLOGUE ZBESY +C +C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV + DOUBLE PRECISION ARG, ASCLE, CIPI, CIPR, CSGNI, CSGNR, CSPNI, + * CSPNR, CWRKI, CWRKR, CYI, CYR, D1M5, D1MACH, ELIM, EXI, EXR, EY, + * FNU, FFNU, HPI, RHPI, STR, STI, TAY, TOL, ATOL, RTOL, ZI, ZR, + * ZNI, ZNR, ZUI, ZUR, ZVI, ZVR, ZZI, ZZR + INTEGER I, IERR, IFNU, I4, K, KODE, K1, K2, N, NZ, NZ1, NZ2, + * I1MACH + DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N), CIPR(4), CIPI(4) + DATA CIPR(1),CIPR(2),CIPR(3),CIPR(4)/1.0D0, 0.0D0, -1.0D0, 0.0D0/ + DATA CIPI(1),CIPI(2),CIPI(3),CIPI(4)/0.0D0, 1.0D0, 0.0D0, -1.0D0/ + DATA HPI / 1.57079632679489662D0 / +C***FIRST EXECUTABLE STATEMENT ZBESY + IERR = 0 + NZ=0 + IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + ZZR = ZR + ZZI = ZI + IF (ZI.LT.0.0D0) ZZI = -ZZI + ZNR = ZZI + ZNI = -ZZR + CALL ZBESI(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ1, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 90 + CALL ZBESK(ZNR, ZNI, FNU, KODE, N, CWRKR, CWRKI, NZ2, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 90 + NZ = MIN(NZ1,NZ2) + IFNU = INT(SNGL(FNU)) + FFNU = FNU - DBLE(FLOAT(IFNU)) + ARG = HPI*FFNU + CSGNR = COS(ARG) + CSGNI = SIN(ARG) + I4 = MOD(IFNU,4) + 1 + STR = CSGNR*CIPR(I4) - CSGNI*CIPI(I4) + CSGNI = CSGNR*CIPI(I4) + CSGNI*CIPR(I4) + CSGNR = STR + RHPI = 1.0D0/HPI + CSPNR = CSGNR*RHPI + CSPNI = -CSGNI*RHPI + STR = -CSGNI + CSGNI = CSGNR + CSGNR = STR + IF (KODE.EQ.2) GO TO 60 + DO 50 I=1,N +C CY(I) = CSGN*CY(I)-CSPN*CWRK(I) + STR = CSGNR*CYR(I) - CSGNI*CYI(I) + STR = STR - (CSPNR*CWRKR(I) - CSPNI*CWRKI(I)) + STI = CSGNR*CYI(I) + CSGNI*CYR(I) + STI = STI - (CSPNR*CWRKI(I) + CSPNI*CWRKR(I)) + CYR(I) = STR + CYI(I) = STI + STR = - CSGNI + CSGNI = CSGNR + CSGNR = STR + STR = CSPNI + CSPNI = -CSPNR + CSPNR = STR + 50 CONTINUE + IF (ZI.LT.0.0D0) THEN + DO 55 I=1,N + CYI(I) = -CYI(I) + 55 CONTINUE + ENDIF + RETURN + 60 CONTINUE + EXR = COS(ZR) + EXI = SIN(ZR) + TOL = MAX(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + K = MIN(IABS(K1),IABS(K2)) + D1M5 = D1MACH(5) +C----------------------------------------------------------------------- +C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT +C----------------------------------------------------------------------- + ELIM = 2.303D0*(DBLE(FLOAT(K))*D1M5-3.0D0) + EY = 0.0D0 + TAY = ABS(ZI+ZI) + IF (TAY.LT.ELIM) EY = EXP(-TAY) + STR = (EXR*CSPNR - EXI*CSPNI)*EY + CSPNI = (EXR*CSPNI + EXI*CSPNR)*EY + CSPNR = STR + NZ = 0 + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 80 I=1,N +C---------------------------------------------------------------------- +C CY(I) = CSGN*CY(I)-CSPN*CWRK(I): PRODUCTS ARE COMPUTED IN +C SCALED MODE IF CY(I) OR CWRK(I) ARE CLOSE TO UNDERFLOW TO +C PREVENT UNDERFLOW IN AN INTERMEDIATE COMPUTATION. +C---------------------------------------------------------------------- + ZVR = CWRKR(I) + ZVI = CWRKI(I) + ATOL=1.0D0 + IF (MAX(ABS(ZVR),ABS(ZVI)).GT.ASCLE) GO TO 75 + ZVR = ZVR*RTOL + ZVI = ZVI*RTOL + ATOL = TOL + 75 CONTINUE + STR = (ZVR*CSPNR - ZVI*CSPNI)*ATOL + ZVI = (ZVR*CSPNI + ZVI*CSPNR)*ATOL + ZVR = STR + ZUR = CYR(I) + ZUI = CYI(I) + ATOL=1.0D0 + IF (MAX(ABS(ZUR),ABS(ZUI)).GT.ASCLE) GO TO 85 + ZUR = ZUR*RTOL + ZUI = ZUI*RTOL + ATOL = TOL + 85 CONTINUE + STR = (ZUR*CSGNR - ZUI*CSGNI)*ATOL + ZUI = (ZUR*CSGNI + ZUI*CSGNR)*ATOL + ZUR = STR + CYR(I) = ZUR - ZVR + CYI(I) = ZUI - ZVI + IF (ZI.LT.0.0D0) CYI(I) = -CYI(I) + IF (CYR(I).EQ.0.0D0 .AND. CYI(I).EQ.0.0D0 .AND. EY.EQ.0.0D0) + & NZ = NZ + 1 + STR = -CSGNI + CSGNI = CSGNR + CSGNR = STR + STR = CSPNI + CSPNI = -CSPNR + CSPNR = STR + 80 CONTINUE + RETURN + 90 CONTINUE + NZ = 0 + RETURN + END + SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) +C***BEGIN PROLOGUE ZAIRY +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR +C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON +C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)* +C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN +C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN +C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z). +C +C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN +C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED +C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS. +C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF +C MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT ZR,ZI ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI) +C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C AI=AI(Z) ON ID=0 OR +C AI=DAI(Z)/DZ ON ID=1 +C = 2 RETURNS +C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR +C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE +C ZTA=(2/3)*Z*CSQRT(Z) +C +C OUTPUT AIR,AII ARE DOUBLE PRECISION +C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND +C KODE +C NZ - UNDERFLOW INDICATOR +C NZ= 0 , NORMAL RETURN +C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN +C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1 +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) +C TOO LARGE ON KODE=1 +C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED +C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION +C PRODUCE LESS THAN HALF OF MACHINE ACCURACY +C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION +C COMPLETE LOSS OF ACCURACY BY ARGUMENT +C REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL +C FUNCTIONS BY +C +C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) +C C=1.0/(PI*SQRT(3.0)) +C ZTA=(2/3)*Z**(3/2) +C +C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES +C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF +C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), +C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR +C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN +C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT +C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE +C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA +C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, +C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE +C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE +C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- +C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- +C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN +C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN +C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, +C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE +C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER +C MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZACAI,ZBKNU,ZEXP,ZSQRT,ZABS,I1MACH,D1MACH +C***END PROLOGUE ZAIRY +C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 + EXTERNAL ZABS + DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, + * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, + * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, + * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, + * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB + INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH + DIMENSION CYR(1), CYI(1) + DATA TTH, C1, C2, COEF /6.66666666666666667D-01, + * 3.55028053887817240D-01,2.58819403792806799D-01, + * 1.83776298473930683D-01/ + DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ +C***FIRST EXECUTABLE STATEMENT ZAIRY + IERR = 0 + NZ=0 + IF (ID.LT.0 .OR. ID.GT.1) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (IERR.NE.0) RETURN + AZ = ZABS(ZR,ZI) + TOL = DMAX1(D1MACH(4),1.0D-18) + FID = DBLE(FLOAT(ID)) + IF (AZ.GT.1.0D0) GO TO 70 +C----------------------------------------------------------------------- +C POWER SERIES FOR CABS(Z).LE.1. +C----------------------------------------------------------------------- + S1R = CONER + S1I = CONEI + S2R = CONER + S2I = CONEI + IF (AZ.LT.TOL) GO TO 170 + AA = AZ*AZ + IF (AA.LT.TOL/AZ) GO TO 40 + TRM1R = CONER + TRM1I = CONEI + TRM2R = CONER + TRM2I = CONEI + ATRM = 1.0D0 + STR = ZR*ZR - ZI*ZI + STI = ZR*ZI + ZI*ZR + Z3R = STR*ZR - STI*ZI + Z3I = STR*ZI + STI*ZR + AZ3 = AZ*AA + AK = 2.0D0 + FID + BK = 3.0D0 - FID - FID + CK = 4.0D0 - FID + DK = 3.0D0 + FID + FID + D1 = AK*DK + D2 = BK*CK + AD = DMIN1(D1,D2) + AK = 24.0D0 + 9.0D0*FID + BK = 30.0D0 - 9.0D0*FID + DO 30 K=1,25 + STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 + TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 + TRM1R = STR + S1R = S1R + TRM1R + S1I = S1I + TRM1I + STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 + TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 + TRM2R = STR + S2R = S2R + TRM2R + S2I = S2I + TRM2I + ATRM = ATRM*AZ3/AD + D1 = D1 + AK + D2 = D2 + BK + AD = DMIN1(D1,D2) + IF (ATRM.LT.TOL*AD) GO TO 40 + AK = AK + 18.0D0 + BK = BK + 18.0D0 + 30 CONTINUE + 40 CONTINUE + IF (ID.EQ.1) GO TO 50 + AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I) + AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R) + IF (KODE.EQ.1) RETURN + CALL ZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + CALL ZEXP(ZTAR, ZTAI, STR, STI) + PTR = AIR*STR - AII*STI + AII = AIR*STI + AII*STR + AIR = PTR + RETURN + 50 CONTINUE + AIR = -S2R*C2 + AII = -S2I*C2 + IF (AZ.LE.TOL) GO TO 60 + STR = ZR*S1R - ZI*S1I + STI = ZR*S1I + ZI*S1R + CC = C1/(1.0D0+FID) + AIR = AIR + CC*(STR*ZR-STI*ZI) + AII = AII + CC*(STR*ZI+STI*ZR) + 60 CONTINUE + IF (KODE.EQ.1) RETURN + CALL ZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + CALL ZEXP(ZTAR, ZTAI, STR, STI) + PTR = STR*AIR - STI*AII + AII = STR*AII + STI*AIR + AIR = PTR + RETURN +C----------------------------------------------------------------------- +C CASE FOR CABS(Z).GT.1.0 +C----------------------------------------------------------------------- + 70 CONTINUE + FNU = (1.0D0+FID)/3.0D0 +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C----------------------------------------------------------------------- + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + ALAZ = DLOG(AZ) +C-------------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AA=0.5D0/TOL + BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 + AA=DMIN1(AA,BB) + AA=AA**TTH + IF (AZ.GT.AA) GO TO 260 + AA=DSQRT(AA) + IF (AZ.GT.AA) IERR=3 + CALL ZSQRT(ZR, ZI, CSQR, CSQI) + ZTAR = TTH*(ZR*CSQR-ZI*CSQI) + ZTAI = TTH*(ZR*CSQI+ZI*CSQR) +C----------------------------------------------------------------------- +C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL +C----------------------------------------------------------------------- + IFLAG = 0 + SFAC = 1.0D0 + AK = ZTAI + IF (ZR.GE.0.0D0) GO TO 80 + BK = ZTAR + CK = -DABS(BK) + ZTAR = CK + ZTAI = AK + 80 CONTINUE + IF (ZI.NE.0.0D0) GO TO 90 + IF (ZR.GT.0.0D0) GO TO 90 + ZTAR = 0.0D0 + ZTAI = AK + 90 CONTINUE + AA = ZTAR + IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 + IF (KODE.EQ.2) GO TO 100 +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + IF (AA.GT.(-ALIM)) GO TO 100 + AA = -AA + 0.25D0*ALAZ + IFLAG = 1 + SFAC = TOL + IF (AA.GT.ELIM) GO TO 270 + 100 CONTINUE +C----------------------------------------------------------------------- +C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 +C----------------------------------------------------------------------- + MR = 1 + IF (ZI.LT.0.0D0) MR = -1 + CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, + * ELIM, ALIM) + IF (NN.LT.0) GO TO 280 + NZ = NZ + NN + GO TO 130 + 110 CONTINUE + IF (KODE.EQ.2) GO TO 120 +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + IF (AA.LT.ALIM) GO TO 120 + AA = -AA - 0.25D0*ALAZ + IFLAG = 2 + SFAC = 1.0D0/TOL + IF (AA.LT.(-ELIM)) GO TO 210 + 120 CONTINUE + CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, + * ALIM) + 130 CONTINUE + S1R = CYR(1)*COEF + S1I = CYI(1)*COEF + IF (IFLAG.NE.0) GO TO 150 + IF (ID.EQ.1) GO TO 140 + AIR = CSQR*S1R - CSQI*S1I + AII = CSQR*S1I + CSQI*S1R + RETURN + 140 CONTINUE + AIR = -(ZR*S1R-ZI*S1I) + AII = -(ZR*S1I+ZI*S1R) + RETURN + 150 CONTINUE + S1R = S1R*SFAC + S1I = S1I*SFAC + IF (ID.EQ.1) GO TO 160 + STR = S1R*CSQR - S1I*CSQI + S1I = S1R*CSQI + S1I*CSQR + S1R = STR + AIR = S1R/SFAC + AII = S1I/SFAC + RETURN + 160 CONTINUE + STR = -(S1R*ZR-S1I*ZI) + S1I = -(S1R*ZI+S1I*ZR) + S1R = STR + AIR = S1R/SFAC + AII = S1I/SFAC + RETURN + 170 CONTINUE + AA = 1.0D+3*D1MACH(1) + S1R = ZEROR + S1I = ZEROI + IF (ID.EQ.1) GO TO 190 + IF (AZ.LE.AA) GO TO 180 + S1R = C2*ZR + S1I = C2*ZI + 180 CONTINUE + AIR = C1 - S1R + AII = -S1I + RETURN + 190 CONTINUE + AIR = -C2 + AII = 0.0D0 + AA = DSQRT(AA) + IF (AZ.LE.AA) GO TO 200 + S1R = 0.5D0*(ZR*ZR-ZI*ZI) + S1I = ZR*ZI + 200 CONTINUE + AIR = AIR + C1*S1R + AII = AII + C1*S1I + RETURN + 210 CONTINUE + NZ = 1 + AIR = ZEROR + AII = ZEROI + RETURN + 270 CONTINUE + NZ = 0 + IERR=2 + RETURN + 280 CONTINUE + IF(NN.EQ.(-1)) GO TO 270 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + IERR=4 + NZ=0 + RETURN + END + SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR) +C***BEGIN PROLOGUE ZBIRY +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801, 930101 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR +C ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON +C KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)* +C DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN +C BOTH THE LEFT AND RIGHT HALF PLANES WHERE +C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA). +C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF +C MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT ZR,ZI ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI) +C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C BI=BI(Z) ON ID=0 OR +C BI=DBI(Z)/DZ ON ID=1 +C = 2 RETURNS +C BI=CEXP(-AXZTA)*BI(Z) ON ID=0 OR +C BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE +C ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) +C AND AXZTA=ABS(XZTA) +C +C OUTPUT BIR,BII ARE DOUBLE PRECISION +C BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND +C KODE +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) +C TOO LARGE ON KODE=1 +C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED +C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION +C PRODUCE LESS THAN HALF OF MACHINE ACCURACY +C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION +C COMPLETE LOSS OF ACCURACY BY ARGUMENT +C REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL +C FUNCTIONS BY +C +C BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) ) +C DBI(Z)=C * Z * ( I(-2/3,ZTA) + I(2/3,ZTA) ) +C C=1.0/SQRT(3.0) +C ZTA=(2/3)*Z**(3/2) +C +C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES +C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF +C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), +C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR +C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN +C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT +C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE +C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA +C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, +C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE +C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE +C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- +C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- +C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN +C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN +C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, +C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE +C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER +C MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM +C TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, +C PP 265-273. +C +C***ROUTINES CALLED ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH +C***END PROLOGUE ZBIRY +C COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 + EXTERNAL ZABS + DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR, + * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, + * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5, + * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, + * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS + INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH + DIMENSION CYR(2), CYI(2) + DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01, + * 6.14926627446000736D-01,4.48288357353826359D-01, + * 5.77350269189625765D-01,3.14159265358979324D+00/ + DATA CONER, CONEI /1.0D0,0.0D0/ +C***FIRST EXECUTABLE STATEMENT ZBIRY + IERR = 0 + NZ=0 + IF (ID.LT.0 .OR. ID.GT.1) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (IERR.NE.0) RETURN + AZ = ZABS(ZR,ZI) + TOL = DMAX1(D1MACH(4),1.0D-18) + FID = DBLE(FLOAT(ID)) + IF (AZ.GT.1.0E0) GO TO 70 +C----------------------------------------------------------------------- +C POWER SERIES FOR CABS(Z).LE.1. +C----------------------------------------------------------------------- + S1R = CONER + S1I = CONEI + S2R = CONER + S2I = CONEI + IF (AZ.LT.TOL) GO TO 130 + AA = AZ*AZ + IF (AA.LT.TOL/AZ) GO TO 40 + TRM1R = CONER + TRM1I = CONEI + TRM2R = CONER + TRM2I = CONEI + ATRM = 1.0D0 + STR = ZR*ZR - ZI*ZI + STI = ZR*ZI + ZI*ZR + Z3R = STR*ZR - STI*ZI + Z3I = STR*ZI + STI*ZR + AZ3 = AZ*AA + AK = 2.0D0 + FID + BK = 3.0D0 - FID - FID + CK = 4.0D0 - FID + DK = 3.0D0 + FID + FID + D1 = AK*DK + D2 = BK*CK + AD = DMIN1(D1,D2) + AK = 24.0D0 + 9.0D0*FID + BK = 30.0D0 - 9.0D0*FID + DO 30 K=1,25 + STR = (TRM1R*Z3R-TRM1I*Z3I)/D1 + TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1 + TRM1R = STR + S1R = S1R + TRM1R + S1I = S1I + TRM1I + STR = (TRM2R*Z3R-TRM2I*Z3I)/D2 + TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2 + TRM2R = STR + S2R = S2R + TRM2R + S2I = S2I + TRM2I + ATRM = ATRM*AZ3/AD + D1 = D1 + AK + D2 = D2 + BK + AD = DMIN1(D1,D2) + IF (ATRM.LT.TOL*AD) GO TO 40 + AK = AK + 18.0D0 + BK = BK + 18.0D0 + 30 CONTINUE + 40 CONTINUE + IF (ID.EQ.1) GO TO 50 + BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I) + BII = C1*S1I + C2*(ZR*S2I+ZI*S2R) + IF (KODE.EQ.1) RETURN + CALL ZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + AA = ZTAR + AA = -DABS(AA) + EAA = DEXP(AA) + BIR = BIR*EAA + BII = BII*EAA + RETURN + 50 CONTINUE + BIR = S2R*C2 + BII = S2I*C2 + IF (AZ.LE.TOL) GO TO 60 + CC = C1/(1.0D0+FID) + STR = S1R*ZR - S1I*ZI + STI = S1R*ZI + S1I*ZR + BIR = BIR + CC*(STR*ZR-STI*ZI) + BII = BII + CC*(STR*ZI+STI*ZR) + 60 CONTINUE + IF (KODE.EQ.1) RETURN + CALL ZSQRT(ZR, ZI, STR, STI) + ZTAR = TTH*(ZR*STR-ZI*STI) + ZTAI = TTH*(ZR*STI+ZI*STR) + AA = ZTAR + AA = -DABS(AA) + EAA = DEXP(AA) + BIR = BIR*EAA + BII = BII*EAA + RETURN +C----------------------------------------------------------------------- +C CASE FOR CABS(Z).GT.1.0 +C----------------------------------------------------------------------- + 70 CONTINUE + FNU = (1.0D0+FID)/3.0D0 +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. +C----------------------------------------------------------------------- + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) +C----------------------------------------------------------------------- +C TEST FOR RANGE +C----------------------------------------------------------------------- + AA=0.5D0/TOL + BB=DBLE(FLOAT(I1MACH(9)))*0.5D0 + AA=DMIN1(AA,BB) + AA=AA**TTH + IF (AZ.GT.AA) GO TO 260 + AA=DSQRT(AA) + IF (AZ.GT.AA) IERR=3 + CALL ZSQRT(ZR, ZI, CSQR, CSQI) + ZTAR = TTH*(ZR*CSQR-ZI*CSQI) + ZTAI = TTH*(ZR*CSQI+ZI*CSQR) +C----------------------------------------------------------------------- +C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL +C----------------------------------------------------------------------- + SFAC = 1.0D0 + AK = ZTAI + IF (ZR.GE.0.0D0) GO TO 80 + BK = ZTAR + CK = -DABS(BK) + ZTAR = CK + ZTAI = AK + 80 CONTINUE + IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90 + ZTAR = 0.0D0 + ZTAI = AK + 90 CONTINUE + AA = ZTAR + IF (KODE.EQ.2) GO TO 100 +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + BB = DABS(AA) + IF (BB.LT.ALIM) GO TO 100 + BB = BB + 0.25D0*DLOG(AZ) + SFAC = TOL + IF (BB.GT.ELIM) GO TO 190 + 100 CONTINUE + FMR = 0.0D0 + IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110 + FMR = PI + IF (ZI.LT.0.0D0) FMR = -PI + ZTAR = -ZTAR + ZTAI = -ZTAI + 110 CONTINUE +C----------------------------------------------------------------------- +C AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) +C KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM ZBESI +C----------------------------------------------------------------------- + CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NZ.LT.0) GO TO 200 + AA = FMR*FNU + Z3R = SFAC + STR = DCOS(AA) + STI = DSIN(AA) + S1R = (STR*CYR(1)-STI*CYI(1))*Z3R + S1I = (STR*CYI(1)+STI*CYR(1))*Z3R + FNU = (2.0D0-FID)/3.0D0 + CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL, + * ELIM, ALIM) + CYR(1) = CYR(1)*Z3R + CYI(1) = CYI(1)*Z3R + CYR(2) = CYR(2)*Z3R + CYI(2) = CYI(2)*Z3R +C----------------------------------------------------------------------- +C BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 +C----------------------------------------------------------------------- + CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI) + S2R = (FNU+FNU)*STR + CYR(2) + S2I = (FNU+FNU)*STI + CYI(2) + AA = FMR*(FNU-1.0D0) + STR = DCOS(AA) + STI = DSIN(AA) + S1R = COEF*(S1R+S2R*STR-S2I*STI) + S1I = COEF*(S1I+S2R*STI+S2I*STR) + IF (ID.EQ.1) GO TO 120 + STR = CSQR*S1R - CSQI*S1I + S1I = CSQR*S1I + CSQI*S1R + S1R = STR + BIR = S1R/SFAC + BII = S1I/SFAC + RETURN + 120 CONTINUE + STR = ZR*S1R - ZI*S1I + S1I = ZR*S1I + ZI*S1R + S1R = STR + BIR = S1R/SFAC + BII = S1I/SFAC + RETURN + 130 CONTINUE + AA = C1*(1.0D0-FID) + FID*C2 + BIR = AA + BII = 0.0D0 + RETURN + 190 CONTINUE + IERR=2 + NZ=0 + RETURN + 200 CONTINUE + IF(NZ.EQ.(-1)) GO TO 190 + NZ=0 + IERR=5 + RETURN + 260 CONTINUE + IERR=4 + NZ=0 + RETURN + END + SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI) +C***BEGIN PROLOGUE ZMLT +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZMLT + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB + CA = AR*BR - AI*BI + CB = AR*BI + AI*BR + CR = CA + CI = CB + RETURN + END + SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI) +C***BEGIN PROLOGUE ZDIV +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. +C +C***ROUTINES CALLED ZABS +C***END PROLOGUE ZDIV + EXTERNAL ZABS + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD + DOUBLE PRECISION ZABS + BM = 1.0D0/ZABS(BR,BI) + CC = BR*BM + CD = BI*BM + CA = (AR*CC+AI*CD)*BM + CB = (AI*CC-AR*CD)*BM + CR = CA + CI = CB + RETURN + END + SUBROUTINE ZSQRT(AR, AI, BR, BI) +C***BEGIN PROLOGUE ZSQRT +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) +C +C***ROUTINES CALLED ZABS +C***END PROLOGUE ZSQRT + EXTERNAL ZABS + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT + DOUBLE PRECISION ZABS + DATA DRT , DPI / 7.071067811865475244008443621D-1, + 1 3.141592653589793238462643383D+0/ + ZM = ZABS(AR,AI) + ZM = DSQRT(ZM) + IF (AR.EQ.0.0D+0) GO TO 10 + IF (AI.EQ.0.0D+0) GO TO 20 + DTHETA = DATAN(AI/AR) + IF (DTHETA.LE.0.0D+0) GO TO 40 + IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI + GO TO 50 + 10 IF (AI.GT.0.0D+0) GO TO 60 + IF (AI.LT.0.0D+0) GO TO 70 + BR = 0.0D+0 + BI = 0.0D+0 + RETURN + 20 IF (AR.GT.0.0D+0) GO TO 30 + BR = 0.0D+0 + BI = DSQRT(DABS(AR)) + RETURN + 30 BR = DSQRT(AR) + BI = 0.0D+0 + RETURN + 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI + 50 DTHETA = DTHETA*0.5D+0 + BR = ZM*DCOS(DTHETA) + BI = ZM*DSIN(DTHETA) + RETURN + 60 BR = ZM*DRT + BI = ZM*DRT + RETURN + 70 BR = ZM*DRT + BI = -ZM*DRT + RETURN + END + SUBROUTINE ZEXP(AR, AI, BR, BI) +C***BEGIN PROLOGUE ZEXP +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZEXP + DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB + ZM = DEXP(AR) + CA = ZM*DCOS(AI) + CB = ZM*DSIN(AI) + BR = CA + BI = CB + RETURN + END + SUBROUTINE ZLOG(AR, AI, BR, BI, IERR) +C***BEGIN PROLOGUE ZLOG +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) +C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) +C***ROUTINES CALLED ZABS +C***END PROLOGUE ZLOG + EXTERNAL ZABS + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI + DOUBLE PRECISION ZABS + INTEGER IERR + DATA DPI , DHPI / 3.141592653589793238462643383D+0, + 1 1.570796326794896619231321696D+0/ +C + IERR=0 + IF (AR.EQ.0.0D+0) GO TO 10 + IF (AI.EQ.0.0D+0) GO TO 20 + DTHETA = DATAN(AI/AR) + IF (DTHETA.LE.0.0D+0) GO TO 40 + IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI + GO TO 50 + 10 IF (AI.EQ.0.0D+0) GO TO 60 + BI = DHPI + BR = DLOG(DABS(AI)) + IF (AI.LT.0.0D+0) BI = -BI + RETURN + 20 IF (AR.GT.0.0D+0) GO TO 30 + BR = DLOG(DABS(AR)) + BI = DPI + RETURN + 30 BR = DLOG(AR) + BI = 0.0D+0 + RETURN + 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI + 50 ZM = ZABS(AR,AI) + BR = DLOG(ZM) + BI = DTHETA + RETURN + 60 CONTINUE + IERR=1 + RETURN + END + DOUBLE PRECISION FUNCTION ZABS(ZR, ZI) +C***BEGIN PROLOGUE ZABS +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE +C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZABS + DOUBLE PRECISION ZR, ZI, U, V, Q, S + U = DABS(ZR) + V = DABS(ZI) + S = U + V +C----------------------------------------------------------------------- +C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A +C TRUE FLOATING ZERO +C----------------------------------------------------------------------- + S = S*1.0D+0 + IF (S.EQ.0.0D+0) GO TO 20 + IF (U.GT.V) GO TO 10 + Q = U/V + ZABS = V*DSQRT(1.D+0+Q*Q) + RETURN + 10 Q = V/U + ZABS = U*DSQRT(1.D+0+Q*Q) + RETURN + 20 ZABS = 0.0D+0 + RETURN + END + SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZBKNU +C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH +C +C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. +C +C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV, +C ZEXP,ZLOG,ZMLT,ZSQRT +C***END PROLOGUE ZBKNU +C + EXTERNAL ZABS + DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, + * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, + * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, + * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, + * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, + * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, + * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, + * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, + * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI + INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, + * IDUM, I1MACH, J, IC, INUB, NW + DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), + * CYI(2) +C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH +C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK +C + DATA KMAX / 30 / + DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ + 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / + DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / + 1 3.14159265358979324D0, 1.25331413731550025D0, + 2 1.90985931710274403D0, 1.57079632679489662D0, + 3 1.89769999331517738D0, 6.66666666666666666D-01/ + DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ + 1 5.77215664901532861D-01, -4.20026350340952355D-02, + 2 -4.21977345555443367D-02, 7.21894324666309954D-03, + 3 -2.15241674114950973D-04, -2.01348547807882387D-05, + 4 1.13302723198169588D-06, 6.11609510448141582D-09/ +C + CAZ = ZABS(ZR,ZI) + CSCLR = 1.0D0/TOL + CRSCR = TOL + CSSR(1) = CSCLR + CSSR(2) = 1.0D0 + CSSR(3) = CRSCR + CSRR(1) = CRSCR + CSRR(2) = 1.0D0 + CSRR(3) = CSCLR + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + NZ = 0 + IFLAG = 0 + KODED = KODE + RCAZ = 1.0D0/CAZ + STR = ZR*RCAZ + STI = -ZI*RCAZ + RZR = (STR+STR)*RCAZ + RZI = (STI+STI)*RCAZ + INU = INT(FNU+0.5D0) + DNU = FNU - DBLE(FLOAT(INU)) + IF (DABS(DNU).EQ.0.5D0) GO TO 110 + DNU2 = 0.0D0 + IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU + IF (CAZ.GT.R1) GO TO 110 +C----------------------------------------------------------------------- +C SERIES FOR CABS(Z).LE.R1 +C----------------------------------------------------------------------- + FC = 1.0D0 + CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM) + FMUR = SMUR*DNU + FMUI = SMUI*DNU + CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI) + IF (DNU.EQ.0.0D0) GO TO 10 + FC = DNU*DPI + FC = FC/DSIN(FC) + SMUR = CSHR/DNU + SMUI = CSHI/DNU + 10 CONTINUE + A2 = 1.0D0 + DNU +C----------------------------------------------------------------------- +C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) +C----------------------------------------------------------------------- + T2 = DEXP(-DGAMLN(A2,IDUM)) + T1 = 1.0D0/(T2*FC) + IF (DABS(DNU).GT.0.1D0) GO TO 40 +C----------------------------------------------------------------------- +C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) +C----------------------------------------------------------------------- + AK = 1.0D0 + S = CC(1) + DO 20 K=2,8 + AK = AK*DNU2 + TM = CC(K)*AK + S = S + TM + IF (DABS(TM).LT.TOL) GO TO 30 + 20 CONTINUE + 30 G1 = -S + GO TO 50 + 40 CONTINUE + G1 = (T1-T2)/(DNU+DNU) + 50 CONTINUE + G2 = (T1+T2)*0.5D0 + FR = FC*(CCHR*G1+SMUR*G2) + FI = FC*(CCHI*G1+SMUI*G2) + CALL ZEXP(FMUR, FMUI, STR, STI) + PR = 0.5D0*STR/T2 + PI = 0.5D0*STI/T2 + CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI) + QR = PTR/T1 + QI = PTI/T1 + S1R = FR + S1I = FI + S2R = PR + S2I = PI + AK = 1.0D0 + A1 = 1.0D0 + CKR = CONER + CKI = CONEI + BK = 1.0D0 - DNU2 + IF (INU.GT.0 .OR. N.GT.1) GO TO 80 +C----------------------------------------------------------------------- +C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 +C----------------------------------------------------------------------- + IF (CAZ.LT.TOL) GO TO 70 + CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) + CZR = 0.25D0*CZR + CZI = 0.25D0*CZI + T1 = 0.25D0*CAZ*CAZ + 60 CONTINUE + FR = (FR*AK+PR+QR)/BK + FI = (FI*AK+PI+QI)/BK + STR = 1.0D0/(AK-DNU) + PR = PR*STR + PI = PI*STR + STR = 1.0D0/(AK+DNU) + QR = QR*STR + QI = QI*STR + STR = CKR*CZR - CKI*CZI + RAK = 1.0D0/AK + CKI = (CKR*CZI+CKI*CZR)*RAK + CKR = STR*RAK + S1R = CKR*FR - CKI*FI + S1R + S1I = CKR*FI + CKI*FR + S1I + A1 = A1*T1*RAK + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + IF (A1.GT.TOL) GO TO 60 + 70 CONTINUE + YR(1) = S1R + YI(1) = S1I + IF (KODED.EQ.1) RETURN + CALL ZEXP(ZR, ZI, STR, STI) + CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1)) + RETURN +C----------------------------------------------------------------------- +C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE +C----------------------------------------------------------------------- + 80 CONTINUE + IF (CAZ.LT.TOL) GO TO 100 + CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI) + CZR = 0.25D0*CZR + CZI = 0.25D0*CZI + T1 = 0.25D0*CAZ*CAZ + 90 CONTINUE + FR = (FR*AK+PR+QR)/BK + FI = (FI*AK+PI+QI)/BK + STR = 1.0D0/(AK-DNU) + PR = PR*STR + PI = PI*STR + STR = 1.0D0/(AK+DNU) + QR = QR*STR + QI = QI*STR + STR = CKR*CZR - CKI*CZI + RAK = 1.0D0/AK + CKI = (CKR*CZI+CKI*CZR)*RAK + CKR = STR*RAK + S1R = CKR*FR - CKI*FI + S1R + S1I = CKR*FI + CKI*FR + S1I + STR = PR - FR*AK + STI = PI - FI*AK + S2R = CKR*STR - CKI*STI + S2R + S2I = CKR*STI + CKI*STR + S2I + A1 = A1*T1*RAK + BK = BK + AK + AK + 1.0D0 + AK = AK + 1.0D0 + IF (A1.GT.TOL) GO TO 90 + 100 CONTINUE + KFLAG = 2 + A1 = FNU + 1.0D0 + AK = A1*DABS(SMUR) + IF (AK.GT.ALIM) KFLAG = 3 + STR = CSSR(KFLAG) + P2R = S2R*STR + P2I = S2I*STR + CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I) + S1R = S1R*STR + S1I = S1I*STR + IF (KODED.EQ.1) GO TO 210 + CALL ZEXP(ZR, ZI, FR, FI) + CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I) + CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I) + GO TO 210 +C----------------------------------------------------------------------- +C IFLAG=0 MEANS NO UNDERFLOW OCCURRED +C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH +C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD +C RECURSION +C----------------------------------------------------------------------- + 110 CONTINUE + CALL ZSQRT(ZR, ZI, STR, STI) + CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI) + KFLAG = 2 + IF (KODED.EQ.2) GO TO 120 + IF (ZR.GT.ALIM) GO TO 290 +C BLANK LINE + STR = DEXP(-ZR)*CSSR(KFLAG) + STI = -STR*DSIN(ZI) + STR = STR*DCOS(ZI) + CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI) + 120 CONTINUE + IF (DABS(DNU).EQ.0.5D0) GO TO 300 +C----------------------------------------------------------------------- +C MILLER ALGORITHM FOR CABS(Z).GT.R1 +C----------------------------------------------------------------------- + AK = DCOS(DPI*DNU) + AK = DABS(AK) + IF (AK.EQ.CZEROR) GO TO 300 + FHS = DABS(0.25D0-DNU2) + IF (FHS.EQ.CZEROR) GO TO 300 +C----------------------------------------------------------------------- +C COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO +C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON +C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= +C TOL WHERE B IS THE BASE OF THE ARITHMETIC. +C----------------------------------------------------------------------- + T1 = DBLE(FLOAT(I1MACH(14)-1)) + T1 = T1*D1MACH(5)*3.321928094D0 + T1 = DMAX1(T1,12.0D0) + T1 = DMIN1(T1,60.0D0) + T2 = TTH*T1 - 6.0D0 + IF (ZR.NE.0.0D0) GO TO 130 + T1 = HPI + GO TO 140 + 130 CONTINUE + T1 = DATAN(ZI/ZR) + T1 = DABS(T1) + 140 CONTINUE + IF (T2.GT.CAZ) GO TO 170 +C----------------------------------------------------------------------- +C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 +C----------------------------------------------------------------------- + ETEST = AK/(DPI*CAZ*TOL) + FK = CONER + IF (ETEST.LT.CONER) GO TO 180 + FKS = CTWOR + CKR = CAZ + CAZ + CTWOR + P1R = CZEROR + P2R = CONER + DO 150 I=1,KMAX + AK = FHS/FKS + CBR = CKR/(FK+CONER) + PTR = P2R + P2R = CBR*P2R - P1R*AK + P1R = PTR + CKR = CKR + CTWOR + FKS = FKS + FK + FK + CTWOR + FHS = FHS + FK + FK + FK = FK + CONER + STR = DABS(P2R)*FK + IF (ETEST.LT.STR) GO TO 160 + 150 CONTINUE + GO TO 310 + 160 CONTINUE + FK = FK + SPI*T1*DSQRT(T2/CAZ) + FHS = DABS(0.25D0-DNU2) + GO TO 180 + 170 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 +C----------------------------------------------------------------------- + A2 = DSQRT(CAZ) + AK = FPI*AK/(TOL*DSQRT(A2)) + AA = 3.0D0*T1/(1.0D0+CAZ) + BB = 14.7D0*T1/(28.0D0+CAZ) + AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB) + FK = 0.12125D0*AK*AK/CAZ + 1.5D0 + 180 CONTINUE +C----------------------------------------------------------------------- +C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM +C----------------------------------------------------------------------- + K = INT(SNGL(FK)) + FK = DBLE(FLOAT(K)) + FKS = FK*FK + P1R = CZEROR + P1I = CZEROI + P2R = TOL + P2I = CZEROI + CSR = P2R + CSI = P2I + DO 190 I=1,K + A1 = FKS - FK + AK = (FKS+FK)/(A1+FHS) + RAK = 2.0D0/(FK+CONER) + CBR = (FK+ZR)*RAK + CBI = ZI*RAK + PTR = P2R + PTI = P2I + P2R = (PTR*CBR-PTI*CBI-P1R)*AK + P2I = (PTI*CBR+PTR*CBI-P1I)*AK + P1R = PTR + P1I = PTI + CSR = CSR + P2R + CSI = CSI + P2I + FKS = A1 - FK + CONER + FK = FK - CONER + 190 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER +C SCALING +C----------------------------------------------------------------------- + TM = ZABS(CSR,CSI) + PTR = 1.0D0/TM + S1R = P2R*PTR + S1I = P2I*PTR + CSR = CSR*PTR + CSI = -CSI*PTR + CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI) + CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I) + IF (INU.GT.0 .OR. N.GT.1) GO TO 200 + ZDR = ZR + ZDI = ZI + IF(IFLAG.EQ.1) GO TO 270 + GO TO 240 + 200 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING +C----------------------------------------------------------------------- + TM = ZABS(P2R,P2I) + PTR = 1.0D0/TM + P1R = P1R*PTR + P1I = P1I*PTR + P2R = P2R*PTR + P2I = -P2I*PTR + CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI) + STR = DNU + 0.5D0 - PTR + STI = -PTI + CALL ZDIV(STR, STI, ZR, ZI, STR, STI) + STR = STR + 1.0D0 + CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I) +C----------------------------------------------------------------------- +C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH +C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 +C----------------------------------------------------------------------- + 210 CONTINUE + STR = DNU + 1.0D0 + CKR = STR*RZR + CKI = STR*RZI + IF (N.EQ.1) INU = INU - 1 + IF (INU.GT.0) GO TO 220 + IF (N.GT.1) GO TO 215 + S1R = S2R + S1I = S2I + 215 CONTINUE + ZDR = ZR + ZDI = ZI + IF(IFLAG.EQ.1) GO TO 270 + GO TO 240 + 220 CONTINUE + INUB = 1 + IF(IFLAG.EQ.1) GO TO 261 + 225 CONTINUE + P1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 230 I=INUB,INU + STR = S2R + STI = S2I + S2R = CKR*STR - CKI*STI + S1R + S2I = CKR*STI + CKI*STR + S1I + S1R = STR + S1I = STI + CKR = CKR + RZR + CKI = CKI + RZI + IF (KFLAG.GE.3) GO TO 230 + P2R = S2R*P1R + P2I = S2I*P1R + STR = DABS(P2R) + STI = DABS(P2I) + P2M = DMAX1(STR,STI) + IF (P2M.LE.ASCLE) GO TO 230 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*P1R + S1I = S1I*P1R + S2R = P2R + S2I = P2I + STR = CSSR(KFLAG) + S1R = S1R*STR + S1I = S1I*STR + S2R = S2R*STR + S2I = S2I*STR + P1R = CSRR(KFLAG) + 230 CONTINUE + IF (N.NE.1) GO TO 240 + S1R = S2R + S1I = S2I + 240 CONTINUE + STR = CSRR(KFLAG) + YR(1) = S1R*STR + YI(1) = S1I*STR + IF (N.EQ.1) RETURN + YR(2) = S2R*STR + YI(2) = S2I*STR + IF (N.EQ.2) RETURN + KK = 2 + 250 CONTINUE + KK = KK + 1 + IF (KK.GT.N) RETURN + P1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 260 I=KK,N + P2R = S2R + P2I = S2I + S2R = CKR*P2R - CKI*P2I + S1R + S2I = CKI*P2R + CKR*P2I + S1I + S1R = P2R + S1I = P2I + CKR = CKR + RZR + CKI = CKI + RZI + P2R = S2R*P1R + P2I = S2I*P1R + YR(I) = P2R + YI(I) = P2I + IF (KFLAG.GE.3) GO TO 260 + STR = DABS(P2R) + STI = DABS(P2I) + P2M = DMAX1(STR,STI) + IF (P2M.LE.ASCLE) GO TO 260 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*P1R + S1I = S1I*P1R + S2R = P2R + S2I = P2I + STR = CSSR(KFLAG) + S1R = S1R*STR + S1I = S1I*STR + S2R = S2R*STR + S2I = S2I*STR + P1R = CSRR(KFLAG) + 260 CONTINUE + RETURN +C----------------------------------------------------------------------- +C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW +C----------------------------------------------------------------------- + 261 CONTINUE + HELIM = 0.5D0*ELIM + ELM = DEXP(-ELIM) + CELMR = ELM + ASCLE = BRY(1) + ZDR = ZR + ZDI = ZI + IC = -1 + J = 2 + DO 262 I=1,INU + STR = S2R + STI = S2I + S2R = STR*CKR-STI*CKI+S1R + S2I = STI*CKR+STR*CKI+S1I + S1R = STR + S1I = STI + CKR = CKR+RZR + CKI = CKI+RZI + AS = ZABS(S2R,S2I) + ALAS = DLOG(AS) + P2R = -ZDR+ALAS + IF(P2R.LT.(-ELIM)) GO TO 263 + CALL ZLOG(S2R,S2I,STR,STI,IDUM) + P2R = -ZDR+STR + P2I = -ZDI+STI + P2M = DEXP(P2R)/TOL + P1R = P2M*DCOS(P2I) + P1I = P2M*DSIN(P2I) + CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL) + IF(NW.NE.0) GO TO 263 + J = 3 - J + CYR(J) = P1R + CYI(J) = P1I + IF(IC.EQ.(I-1)) GO TO 264 + IC = I + GO TO 262 + 263 CONTINUE + IF(ALAS.LT.HELIM) GO TO 262 + ZDR = ZDR-ELIM + S1R = S1R*CELMR + S1I = S1I*CELMR + S2R = S2R*CELMR + S2I = S2I*CELMR + 262 CONTINUE + IF(N.NE.1) GO TO 270 + S1R = S2R + S1I = S2I + GO TO 270 + 264 CONTINUE + KFLAG = 1 + INUB = I+1 + S2R = CYR(J) + S2I = CYI(J) + J = 3 - J + S1R = CYR(J) + S1I = CYI(J) + IF(INUB.LE.INU) GO TO 225 + IF(N.NE.1) GO TO 240 + S1R = S2R + S1I = S2I + GO TO 240 + 270 CONTINUE + YR(1) = S1R + YI(1) = S1I + IF(N.EQ.1) GO TO 280 + YR(2) = S2R + YI(2) = S2I + 280 CONTINUE + ASCLE = BRY(1) + CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) + INU = N - NZ + IF (INU.LE.0) RETURN + KK = NZ + 1 + S1R = YR(KK) + S1I = YI(KK) + YR(KK) = S1R*CSRR(1) + YI(KK) = S1I*CSRR(1) + IF (INU.EQ.1) RETURN + KK = NZ + 2 + S2R = YR(KK) + S2I = YI(KK) + YR(KK) = S2R*CSRR(1) + YI(KK) = S2I*CSRR(1) + IF (INU.EQ.2) RETURN + T2 = FNU + DBLE(FLOAT(KK-1)) + CKR = T2*RZR + CKI = T2*RZI + KFLAG = 1 + GO TO 250 + 290 CONTINUE +C----------------------------------------------------------------------- +C SCALE BY DEXP(Z), IFLAG = 1 CASES +C----------------------------------------------------------------------- + KODED = 2 + IFLAG = 1 + KFLAG = 2 + GO TO 120 +C----------------------------------------------------------------------- +C FNU=HALF ODD INTEGER CASE, DNU=-0.5 +C----------------------------------------------------------------------- + 300 CONTINUE + S1R = COEFR + S1I = COEFI + S2R = COEFR + S2I = COEFI + GO TO 210 +C +C + 310 CONTINUE + NZ=-2 + RETURN + END + SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) +C***BEGIN PROLOGUE ZKSCL +C***REFER TO ZBESK +C +C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE +C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN +C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. +C +C***ROUTINES CALLED ZUCHK,ZABS,ZLOG +C***END PROLOGUE ZKSCL +C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM + EXTERNAL ZABS + DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, + * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, + * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, + * ZDR, ZDI, CELMR, ELM, HELIM, ALAS + INTEGER I, IC, IDUM, KK, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2) + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / +C + NZ = 0 + IC = 0 + NN = MIN0(2,N) + DO 10 I=1,NN + S1R = YR(I) + S1I = YI(I) + CYR(I) = S1R + CYI(I) = S1I + AS = ZABS(S1R,S1I) + ACS = -ZRR + DLOG(AS) + NZ = NZ + 1 + YR(I) = ZEROR + YI(I) = ZEROI + IF (ACS.LT.(-ELIM)) GO TO 10 + CALL ZLOG(S1R, S1I, CSR, CSI, IDUM) + CSR = CSR - ZRR + CSI = CSI - ZRI + STR = DEXP(CSR)/TOL + CSR = STR*DCOS(CSI) + CSI = STR*DSIN(CSI) + CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 10 + YR(I) = CSR + YI(I) = CSI + IC = I + NZ = NZ - 1 + 10 CONTINUE + IF (N.EQ.1) RETURN + IF (IC.GT.1) GO TO 20 + YR(1) = ZEROR + YI(1) = ZEROI + NZ = 2 + 20 CONTINUE + IF (N.EQ.2) RETURN + IF (NZ.EQ.0) RETURN + FN = FNU + 1.0D0 + CKR = FN*RZR + CKI = FN*RZI + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + HELIM = 0.5D0*ELIM + ELM = DEXP(-ELIM) + CELMR = ELM + ZDR = ZRR + ZDI = ZRI +C +C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF +C S2 GETS LARGER THAN EXP(ELIM/2) +C + DO 30 I=3,N + KK = I + CSR = S2R + CSI = S2I + S2R = CKR*CSR - CKI*CSI + S1R + S2I = CKI*CSR + CKR*CSI + S1I + S1R = CSR + S1I = CSI + CKR = CKR + RZR + CKI = CKI + RZI + AS = ZABS(S2R,S2I) + ALAS = DLOG(AS) + ACS = -ZDR + ALAS + NZ = NZ + 1 + YR(I) = ZEROR + YI(I) = ZEROI + IF (ACS.LT.(-ELIM)) GO TO 25 + CALL ZLOG(S2R, S2I, CSR, CSI, IDUM) + CSR = CSR - ZDR + CSI = CSI - ZDI + STR = DEXP(CSR)/TOL + CSR = STR*DCOS(CSI) + CSI = STR*DSIN(CSI) + CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 25 + YR(I) = CSR + YI(I) = CSI + NZ = NZ - 1 + IF (IC.EQ.KK-1) GO TO 40 + IC = KK + GO TO 30 + 25 CONTINUE + IF(ALAS.LT.HELIM) GO TO 30 + ZDR = ZDR - ELIM + S1R = S1R*CELMR + S1I = S1I*CELMR + S2R = S2R*CELMR + S2I = S2I*CELMR + 30 CONTINUE + NZ = N + IF(IC.EQ.N) NZ=N-1 + GO TO 45 + 40 CONTINUE + NZ = KK - 2 + 45 CONTINUE + DO 50 I=1,NZ + YR(I) = ZEROR + YI(I) = ZEROI + 50 CONTINUE + RETURN + END + SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI) +C***BEGIN PROLOGUE ZSHCH +C***REFER TO ZBESK,ZBESH +C +C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) +C AND CCH=COSH(X+I*Y), WHERE I**2=-1. +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZSHCH +C + DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, + * DCOSH, DSINH + SH = DSINH(ZR) + CH = DCOSH(ZR) + SN = DSIN(ZI) + CN = DCOS(ZI) + CSHR = SH*CN + CSHI = CH*SN + CCHR = CH*CN + CCHI = SH*SN + RETURN + END + SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL) +C***BEGIN PROLOGUE ZRATI +C***REFER TO ZBESI,ZBESK,ZBESH +C +C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD +C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD +C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, +C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, +C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, +C BY D. J. SOOKNE. +C +C***ROUTINES CALLED ZABS,ZDIV +C***END PROLOGUE ZRATI +C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU + EXTERNAL ZABS + DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, + * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, + * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, + * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS + INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N + DIMENSION CYR(N), CYI(N) + DATA CZEROR,CZEROI,CONER,CONEI,RT2/ + 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / + AZ = ZABS(ZR,ZI) + INU = INT(SNGL(FNU)) + IDNU = INU + N - 1 + MAGZ = INT(SNGL(AZ)) + AMAGZ = DBLE(FLOAT(MAGZ+1)) + FDNU = DBLE(FLOAT(IDNU)) + FNUP = DMAX1(AMAGZ,FDNU) + ID = IDNU - MAGZ - 1 + ITIME = 1 + K = 1 + PTR = 1.0D0/AZ + RZR = PTR*(ZR+ZR)*PTR + RZI = -PTR*(ZI+ZI)*PTR + T1R = RZR*FNUP + T1I = RZI*FNUP + P2R = -T1R + P2I = -T1I + P1R = CONER + P1I = CONEI + T1R = T1R + RZR + T1I = T1I + RZI + IF (ID.GT.0) ID = 0 + AP2 = ZABS(P2R,P2I) + AP1 = ZABS(P1R,P1I) +C----------------------------------------------------------------------- +C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU +C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT +C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR +C PREMATURELY. +C----------------------------------------------------------------------- + ARG = (AP2+AP2)/(AP1*TOL) + TEST1 = DSQRT(ARG) + TEST = TEST1 + RAP1 = 1.0D0/AP1 + P1R = P1R*RAP1 + P1I = P1I*RAP1 + P2R = P2R*RAP1 + P2I = P2I*RAP1 + AP2 = AP2*RAP1 + 10 CONTINUE + K = K + 1 + AP1 = AP2 + PTR = P2R + PTI = P2I + P2R = P1R - (T1R*PTR-T1I*PTI) + P2I = P1I - (T1R*PTI+T1I*PTR) + P1R = PTR + P1I = PTI + T1R = T1R + RZR + T1I = T1I + RZI + AP2 = ZABS(P2R,P2I) + IF (AP1.LE.TEST) GO TO 10 + IF (ITIME.EQ.2) GO TO 20 + AK = ZABS(T1R,T1I)*0.5D0 + FLAM = AK + DSQRT(AK*AK-1.0D0) + RHO = DMIN1(AP2/AP1,FLAM) + TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0)) + ITIME = 2 + GO TO 10 + 20 CONTINUE + KK = K + 1 - ID + AK = DBLE(FLOAT(KK)) + T1R = AK + T1I = CZEROI + DFNU = FNU + DBLE(FLOAT(N-1)) + P1R = 1.0D0/AP2 + P1I = CZEROI + P2R = CZEROR + P2I = CZEROI + DO 30 I=1,KK + PTR = P1R + PTI = P1I + RAP1 = DFNU + T1R + TTR = RZR*RAP1 + TTI = RZI*RAP1 + P1R = (PTR*TTR-PTI*TTI) + P2R + P1I = (PTR*TTI+PTI*TTR) + P2I + P2R = PTR + P2I = PTI + T1R = T1R - CONER + 30 CONTINUE + IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40 + P1R = TOL + P1I = TOL + 40 CONTINUE + CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N)) + IF (N.EQ.1) RETURN + K = N - 1 + AK = DBLE(FLOAT(K)) + T1R = AK + T1I = CZEROI + CDFNUR = FNU*RZR + CDFNUI = FNU*RZI + DO 60 I=2,N + PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1) + PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1) + AK = ZABS(PTR,PTI) + IF (AK.NE.CZEROR) GO TO 50 + PTR = TOL + PTI = TOL + AK = TOL*RT2 + 50 CONTINUE + RAK = CONER/AK + CYR(K) = RAK*PTR*RAK + CYI(K) = -RAK*PTI*RAK + T1R = T1R - CONER + K = K - 1 + 60 CONTINUE + RETURN + END + SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, + * IUF) +C***BEGIN PROLOGUE ZS1S2 +C***REFER TO ZBESK,ZAIRY +C +C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE +C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- +C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. +C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF +C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER +C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE +C PRECISION ABOVE THE UNDERFLOW LIMIT. +C +C***ROUTINES CALLED ZABS,ZEXP,ZLOG +C***END PROLOGUE ZS1S2 +C COMPLEX CZERO,C1,S1,S1D,S2,ZR + EXTERNAL ZABS + DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, + * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS + INTEGER IUF, IDUM, NZ + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / + NZ = 0 + AS1 = ZABS(S1R,S1I) + AS2 = ZABS(S2R,S2I) + IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10 + IF (AS1.EQ.0.0D0) GO TO 10 + ALN = -ZRR - ZRR + DLOG(AS1) + S1DR = S1R + S1DI = S1I + S1R = ZEROR + S1I = ZEROI + AS1 = ZEROR + IF (ALN.LT.(-ALIM)) GO TO 10 + CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM) + C1R = C1R - ZRR - ZRR + C1I = C1I - ZRI - ZRI + CALL ZEXP(C1R, C1I, S1R, S1I) + AS1 = ZABS(S1R,S1I) + IUF = IUF + 1 + 10 CONTINUE + AA = DMAX1(AS1,AS2) + IF (AA.GT.ASCLE) RETURN + S1R = ZEROR + S1I = ZEROI + S2R = ZEROR + S2I = ZEROI + NZ = 1 + IUF = 0 + RETURN + END + SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZBUNK +C***REFER TO ZBESK,ZBESH +C +C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) +C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 +C +C***ROUTINES CALLED ZUNK1,ZUNK2 +C***END PROLOGUE ZBUNK +C COMPLEX Y,Z + DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR + INTEGER KODE, MR, N, NZ + DIMENSION YR(N), YI(N) + NZ = 0 + AX = DABS(ZR)*1.7321D0 + AY = DABS(ZI) + IF (AY.GT.AX) GO TO 10 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) + GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) + 20 CONTINUE + RETURN + END + SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) +C***BEGIN PROLOGUE ZMLRI +C***REFER TO ZBESI,ZBESK +C +C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE +C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. +C +C***ROUTINES CALLED DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT +C***END PROLOGUE ZMLRI +C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z + EXTERNAL ZABS + DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, + * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, + * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, + * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, + * D1MACH, ZABS + INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ + DIMENSION YR(N), YI(N) + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / + SCLE = D1MACH(1)/TOL + NZ=0 + AZ = ZABS(ZR,ZI) + IAZ = INT(SNGL(AZ)) + IFNU = INT(SNGL(FNU)) + INU = IFNU + N - 1 + AT = DBLE(FLOAT(IAZ)) + 1.0D0 + RAZ = 1.0D0/AZ + STR = ZR*RAZ + STI = -ZI*RAZ + CKR = STR*AT*RAZ + CKI = STI*AT*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + P1R = ZEROR + P1I = ZEROI + P2R = CONER + P2I = CONEI + ACK = (AT+1.0D0)*RAZ + RHO = ACK + DSQRT(ACK*ACK-1.0D0) + RHO2 = RHO*RHO + TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0)) + TST = TST/TOL +C----------------------------------------------------------------------- +C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES +C----------------------------------------------------------------------- + AK = AT + DO 10 I=1,80 + PTR = P2R + PTI = P2I + P2R = P1R - (CKR*PTR-CKI*PTI) + P2I = P1I - (CKI*PTR+CKR*PTI) + P1R = PTR + P1I = PTI + CKR = CKR + RZR + CKI = CKI + RZI + AP = ZABS(P2R,P2I) + IF (AP.GT.TST*AK*AK) GO TO 20 + AK = AK + 1.0D0 + 10 CONTINUE + GO TO 110 + 20 CONTINUE + I = I + 1 + K = 0 + IF (INU.LT.IAZ) GO TO 40 +C----------------------------------------------------------------------- +C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS +C----------------------------------------------------------------------- + P1R = ZEROR + P1I = ZEROI + P2R = CONER + P2I = CONEI + AT = DBLE(FLOAT(INU)) + 1.0D0 + STR = ZR*RAZ + STI = -ZI*RAZ + CKR = STR*AT*RAZ + CKI = STI*AT*RAZ + ACK = AT*RAZ + TST = DSQRT(ACK/TOL) + ITIME = 1 + DO 30 K=1,80 + PTR = P2R + PTI = P2I + P2R = P1R - (CKR*PTR-CKI*PTI) + P2I = P1I - (CKR*PTI+CKI*PTR) + P1R = PTR + P1I = PTI + CKR = CKR + RZR + CKI = CKI + RZI + AP = ZABS(P2R,P2I) + IF (AP.LT.TST) GO TO 30 + IF (ITIME.EQ.2) GO TO 40 + ACK = ZABS(CKR,CKI) + FLAM = ACK + DSQRT(ACK*ACK-1.0D0) + FKAP = AP/ZABS(P1R,P1I) + RHO = DMIN1(FLAM,FKAP) + TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0)) + ITIME = 2 + 30 CONTINUE + GO TO 110 + 40 CONTINUE +C----------------------------------------------------------------------- +C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION +C----------------------------------------------------------------------- + K = K + 1 + KK = MAX0(I+IAZ,K+INU) + FKK = DBLE(FLOAT(KK)) + P1R = ZEROR + P1I = ZEROI +C----------------------------------------------------------------------- +C SCALE P2 AND SUM BY SCLE +C----------------------------------------------------------------------- + P2R = SCLE + P2I = ZEROI + FNF = FNU - DBLE(FLOAT(IFNU)) + TFNF = FNF + FNF + BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - + * DGAMLN(TFNF+1.0D0,IDUM) + BK = DEXP(BK) + SUMR = ZEROR + SUMI = ZEROI + KM = KK - INU + DO 50 I=1,KM + PTR = P2R + PTI = P2I + P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) + P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) + P1R = PTR + P1I = PTI + AK = 1.0D0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUMR = SUMR + (ACK+BK)*P1R + SUMI = SUMI + (ACK+BK)*P1I + BK = ACK + FKK = FKK - 1.0D0 + 50 CONTINUE + YR(N) = P2R + YI(N) = P2I + IF (N.EQ.1) GO TO 70 + DO 60 I=2,N + PTR = P2R + PTI = P2I + P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) + P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI) + P1R = PTR + P1I = PTI + AK = 1.0D0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUMR = SUMR + (ACK+BK)*P1R + SUMI = SUMI + (ACK+BK)*P1I + BK = ACK + FKK = FKK - 1.0D0 + M = N - I + 1 + YR(M) = P2R + YI(M) = P2I + 60 CONTINUE + 70 CONTINUE + IF (IFNU.LE.0) GO TO 90 + DO 80 I=1,IFNU + PTR = P2R + PTI = P2I + P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI) + P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR) + P1R = PTR + P1I = PTI + AK = 1.0D0 - TFNF/(FKK+TFNF) + ACK = BK*AK + SUMR = SUMR + (ACK+BK)*P1R + SUMI = SUMI + (ACK+BK)*P1I + BK = ACK + FKK = FKK - 1.0D0 + 80 CONTINUE + 90 CONTINUE + PTR = ZR + PTI = ZI + IF (KODE.EQ.2) PTR = ZEROR + CALL ZLOG(RZR, RZI, STR, STI, IDUM) + P1R = -FNF*STR + PTR + P1I = -FNF*STI + PTI + AP = DGAMLN(1.0D0+FNF,IDUM) + PTR = P1R - AP + PTI = P1I +C----------------------------------------------------------------------- +C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW +C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES +C----------------------------------------------------------------------- + P2R = P2R + SUMR + P2I = P2I + SUMI + AP = ZABS(P2R,P2I) + P1R = 1.0D0/AP + CALL ZEXP(PTR, PTI, STR, STI) + CKR = STR*P1R + CKI = STI*P1R + PTR = P2R*P1R + PTI = -P2I*P1R + CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI) + DO 100 I=1,N + STR = YR(I)*CNORMR - YI(I)*CNORMI + YI(I) = YR(I)*CNORMI + YI(I)*CNORMR + YR(I) = STR + 100 CONTINUE + RETURN + 110 CONTINUE + NZ=-2 + RETURN + END + SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZWRSK +C***REFER TO ZBESI,ZBESK +C +C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY +C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN +C +C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS +C***END PROLOGUE ZWRSK +C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR + EXTERNAL ZABS + DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, + * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, + * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH + INTEGER I, KODE, N, NW, NZ + DIMENSION YR(N), YI(N), CWR(2), CWI(2) +C----------------------------------------------------------------------- +C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS +C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE +C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. +C----------------------------------------------------------------------- + NZ = 0 + CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 50 + CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) +C----------------------------------------------------------------------- +C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), +C R(FNU+J-1,Z)=Y(J), J=1,...,N +C----------------------------------------------------------------------- + CINUR = 1.0D0 + CINUI = 0.0D0 + IF (KODE.EQ.1) GO TO 10 + CINUR = DCOS(ZRI) + CINUI = DSIN(ZRI) + 10 CONTINUE +C----------------------------------------------------------------------- +C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH +C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE +C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT +C THE RESULT IS ON SCALE. +C----------------------------------------------------------------------- + ACW = ZABS(CWR(2),CWI(2)) + ASCLE = 1.0D+3*D1MACH(1)/TOL + CSCLR = 1.0D0 + IF (ACW.GT.ASCLE) GO TO 20 + CSCLR = 1.0D0/TOL + GO TO 30 + 20 CONTINUE + ASCLE = 1.0D0/ASCLE + IF (ACW.LT.ASCLE) GO TO 30 + CSCLR = TOL + 30 CONTINUE + C1R = CWR(1)*CSCLR + C1I = CWI(1)*CSCLR + C2R = CWR(2)*CSCLR + C2I = CWI(2)*CSCLR + STR = YR(1) + STI = YI(1) +C----------------------------------------------------------------------- +C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS +C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) +C----------------------------------------------------------------------- + PTR = STR*C1R - STI*C1I + PTI = STR*C1I + STI*C1R + PTR = PTR + C2R + PTI = PTI + C2I + CTR = ZRR*PTR - ZRI*PTI + CTI = ZRR*PTI + ZRI*PTR + ACT = ZABS(CTR,CTI) + RACT = 1.0D0/ACT + CTR = CTR*RACT + CTI = -CTI*RACT + PTR = CINUR*RACT + PTI = CINUI*RACT + CINUR = PTR*CTR - PTI*CTI + CINUI = PTR*CTI + PTI*CTR + YR(1) = CINUR*CSCLR + YI(1) = CINUI*CSCLR + IF (N.EQ.1) RETURN + DO 40 I=2,N + PTR = STR*CINUR - STI*CINUI + CINUI = STR*CINUI + STI*CINUR + CINUR = PTR + STR = YR(I) + STI = YI(I) + YR(I) = CINUR*CSCLR + YI(I) = CINUI*CSCLR + 40 CONTINUE + RETURN + 50 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END + SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZSERI +C***REFER TO ZBESI,ZBESK +C +C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY +C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE +C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. +C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO +C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE +C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE +C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). +C +C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT +C***END PROLOGUE ZSERI +C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z + EXTERNAL ZABS + DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, + * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, + * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, + * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, + * ZR, DGAMLN, D1MACH, ZABS + INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW + DIMENSION YR(N), YI(N), WR(2), WI(2) + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C + NZ = 0 + AZ = ZABS(ZR,ZI) + IF (AZ.EQ.0.0D0) GO TO 160 + ARM = 1.0D+3*D1MACH(1) + RTR1 = DSQRT(ARM) + CRSCR = 1.0D0 + IFLAG = 0 + IF (AZ.LT.ARM) GO TO 150 + HZR = 0.5D0*ZR + HZI = 0.5D0*ZI + CZR = ZEROR + CZI = ZEROI + IF (AZ.LE.RTR1) GO TO 10 + CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI) + 10 CONTINUE + ACZ = ZABS(CZR,CZI) + NN = N + CALL ZLOG(HZR, HZI, CKR, CKI, IDUM) + 20 CONTINUE + DFNU = FNU + DBLE(FLOAT(NN-1)) + FNUP = DFNU + 1.0D0 +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + AK1R = CKR*DFNU + AK1I = CKI*DFNU + AK = DGAMLN(FNUP,IDUM) + AK1R = AK1R - AK + IF (KODE.EQ.2) AK1R = AK1R - ZR + IF (AK1R.GT.(-ELIM)) GO TO 40 + 30 CONTINUE + NZ = NZ + 1 + YR(NN) = ZEROR + YI(NN) = ZEROI + IF (ACZ.GT.DFNU) GO TO 190 + NN = NN - 1 + IF (NN.EQ.0) RETURN + GO TO 20 + 40 CONTINUE + IF (AK1R.GT.(-ALIM)) GO TO 50 + IFLAG = 1 + SS = 1.0D0/TOL + CRSCR = TOL + ASCLE = ARM*SS + 50 CONTINUE + AA = DEXP(AK1R) + IF (IFLAG.EQ.1) AA = AA*SS + COEFR = AA*DCOS(AK1I) + COEFI = AA*DSIN(AK1I) + ATOL = TOL*ACZ/FNUP + IL = MIN0(2,NN) + DO 90 I=1,IL + DFNU = FNU + DBLE(FLOAT(NN-I)) + FNUP = DFNU + 1.0D0 + S1R = CONER + S1I = CONEI + IF (ACZ.LT.TOL*FNUP) GO TO 70 + AK1R = CONER + AK1I = CONEI + AK = FNUP + 2.0D0 + S = FNUP + AA = 2.0D0 + 60 CONTINUE + RS = 1.0D0/S + STR = AK1R*CZR - AK1I*CZI + STI = AK1R*CZI + AK1I*CZR + AK1R = STR*RS + AK1I = STI*RS + S1R = S1R + AK1R + S1I = S1I + AK1I + S = S + AK + AK = AK + 2.0D0 + AA = AA*ACZ*RS + IF (AA.GT.ATOL) GO TO 60 + 70 CONTINUE + S2R = S1R*COEFR - S1I*COEFI + S2I = S1R*COEFI + S1I*COEFR + WR(I) = S2R + WI(I) = S2I + IF (IFLAG.EQ.0) GO TO 80 + CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 30 + 80 CONTINUE + M = NN - I + 1 + YR(M) = S2R*CRSCR + YI(M) = S2I*CRSCR + IF (I.EQ.IL) GO TO 90 + CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI) + COEFR = STR*DFNU + COEFI = STI*DFNU + 90 CONTINUE + IF (NN.LE.2) RETURN + K = NN - 2 + AK = DBLE(FLOAT(K)) + RAZ = 1.0D0/AZ + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + IF (IFLAG.EQ.1) GO TO 120 + IB = 3 + 100 CONTINUE + DO 110 I=IB,NN + YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) + YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) + AK = AK - 1.0D0 + K = K - 1 + 110 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD WITH SCALED VALUES +C----------------------------------------------------------------------- + 120 CONTINUE +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE +C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 +C----------------------------------------------------------------------- + S1R = WR(1) + S1I = WI(1) + S2R = WR(2) + S2I = WI(2) + DO 130 L=3,NN + CKR = S2R + CKI = S2I + S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI) + S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR) + S1R = CKR + S1I = CKI + CKR = S2R*CRSCR + CKI = S2I*CRSCR + YR(K) = CKR + YI(K) = CKI + AK = AK - 1.0D0 + K = K - 1 + IF (ZABS(CKR,CKI).GT.ASCLE) GO TO 140 + 130 CONTINUE + RETURN + 140 CONTINUE + IB = L + 1 + IF (IB.GT.NN) RETURN + GO TO 100 + 150 CONTINUE + NZ = N + IF (FNU.EQ.0.0D0) NZ = NZ - 1 + 160 CONTINUE + YR(1) = ZEROR + YI(1) = ZEROI + IF (FNU.NE.0.0D0) GO TO 170 + YR(1) = CONER + YI(1) = CONEI + 170 CONTINUE + IF (N.EQ.1) RETURN + DO 180 I=2,N + YR(I) = ZEROR + YI(I) = ZEROI + 180 CONTINUE + RETURN +C----------------------------------------------------------------------- +C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE +C THE CALCULATION IN CBINU WITH N=N-IABS(NZ) +C----------------------------------------------------------------------- + 190 CONTINUE + NZ = -NZ + RETURN + END + SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZASYI +C***REFER TO ZBESI,ZBESK +C +C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY +C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE +C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. +C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. +C +C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT +C***END PROLOGUE ZASYI +C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z + EXTERNAL ZABS + DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, + * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, + * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, + * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, + * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS + INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ + DIMENSION YR(N), YI(N) + DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C + NZ = 0 + AZ = ZABS(ZR,ZI) + ARM = 1.0D+3*D1MACH(1) + RTR1 = DSQRT(ARM) + IL = MIN0(2,N) + DFNU = FNU + DBLE(FLOAT(N-IL)) +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + RAZ = 1.0D0/AZ + STR = ZR*RAZ + STI = -ZI*RAZ + AK1R = RTPI*STR*RAZ + AK1I = RTPI*STI*RAZ + CALL ZSQRT(AK1R, AK1I, AK1R, AK1I) + CZR = ZR + CZI = ZI + IF (KODE.NE.2) GO TO 10 + CZR = ZEROR + CZI = ZI + 10 CONTINUE + IF (DABS(CZR).GT.ELIM) GO TO 100 + DNU2 = DFNU + DFNU + KODED = 1 + IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20 + KODED = 0 + CALL ZEXP(CZR, CZI, STR, STI) + CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I) + 20 CONTINUE + FDN = 0.0D0 + IF (DNU2.GT.RTR1) FDN = DNU2*DNU2 + EZR = ZR*8.0D0 + EZI = ZI*8.0D0 +C----------------------------------------------------------------------- +C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE +C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE +C EXPANSION FOR THE IMAGINARY PART. +C----------------------------------------------------------------------- + AEZ = 8.0D0*AZ + S = TOL/AEZ + JL = INT(SNGL(RL+RL)) + 2 + P1R = ZEROR + P1I = ZEROI + IF (ZI.EQ.0.0D0) GO TO 30 +C----------------------------------------------------------------------- +C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF +C SIGNIFICANCE WHEN FNU OR N IS LARGE +C----------------------------------------------------------------------- + INU = INT(SNGL(FNU)) + ARG = (FNU-DBLE(FLOAT(INU)))*PI + INU = INU + N - IL + AK = -DSIN(ARG) + BK = DCOS(ARG) + IF (ZI.LT.0.0D0) BK = -BK + P1R = AK + P1I = BK + IF (MOD(INU,2).EQ.0) GO TO 30 + P1R = -P1R + P1I = -P1I + 30 CONTINUE + DO 70 K=1,IL + SQK = FDN - 1.0D0 + ATOL = S*DABS(SQK) + SGN = 1.0D0 + CS1R = CONER + CS1I = CONEI + CS2R = CONER + CS2I = CONEI + CKR = CONER + CKI = CONEI + AK = 0.0D0 + AA = 1.0D0 + BB = AEZ + DKR = EZR + DKI = EZI + DO 40 J=1,JL + CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI) + CKR = STR*SQK + CKI = STI*SQK + CS2R = CS2R + CKR + CS2I = CS2I + CKI + SGN = -SGN + CS1R = CS1R + CKR*SGN + CS1I = CS1I + CKI*SGN + DKR = DKR + EZR + DKI = DKI + EZI + AA = AA*DABS(SQK)/BB + BB = BB + AEZ + AK = AK + 8.0D0 + SQK = SQK - AK + IF (AA.LE.ATOL) GO TO 50 + 40 CONTINUE + GO TO 110 + 50 CONTINUE + S2R = CS1R + S2I = CS1I + IF (ZR+ZR.GE.ELIM) GO TO 60 + TZR = ZR + ZR + TZI = ZI + ZI + CALL ZEXP(-TZR, -TZI, STR, STI) + CALL ZMLT(STR, STI, P1R, P1I, STR, STI) + CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI) + S2R = S2R + STR + S2I = S2I + STI + 60 CONTINUE + FDN = FDN + 8.0D0*DFNU + 4.0D0 + P1R = -P1R + P1I = -P1I + M = N - IL + K + YR(M) = S2R*AK1R - S2I*AK1I + YI(M) = S2R*AK1I + S2I*AK1R + 70 CONTINUE + IF (N.LE.2) RETURN + NN = N + K = NN - 2 + AK = DBLE(FLOAT(K)) + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + IB = 3 + DO 80 I=IB,NN + YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2) + YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2) + AK = AK - 1.0D0 + K = K - 1 + 80 CONTINUE + IF (KODED.EQ.0) RETURN + CALL ZEXP(CZR, CZI, CKR, CKI) + DO 90 I=1,NN + STR = YR(I)*CKR - YI(I)*CKI + YI(I) = YR(I)*CKI + YI(I)*CKR + YR(I) = STR + 90 CONTINUE + RETURN + 100 CONTINUE + NZ = -1 + RETURN + 110 CONTINUE + NZ=-2 + RETURN + END + SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, + * ELIM, ALIM) +C***BEGIN PROLOGUE ZUOIK +C***REFER TO ZBESI,ZBESK,ZBESH +C +C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC +C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM +C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW +C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING +C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN +C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER +C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE +C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= +C EXP(-ELIM)/TOL +C +C IKFLG=1 MEANS THE I SEQUENCE IS TESTED +C =2 MEANS THE K SEQUENCE IS TESTED +C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE +C =-1 MEANS AN OVERFLOW WOULD OCCUR +C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO +C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE +C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO +C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY +C ANOTHER ROUTINE +C +C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG +C***END PROLOGUE ZUOIK +C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, +C *ZR + EXTERNAL ZABS + DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, + * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, + * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, + * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, + * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW + DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) + DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / + DATA AIC / 1.265512123484645396D+00 / + NUF = 0 + NN = N + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + ZBR = ZRR + ZBI = ZRI + AX = DABS(ZR)*1.7321D0 + AY = DABS(ZI) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + GNU = DMAX1(FNU,1.0D0) + IF (IKFLG.EQ.1) GO TO 20 + FNN = DBLE(FLOAT(NN)) + GNN = FNU + FNN - 1.0D0 + GNU = DMAX1(GNN,FNN) + 20 CONTINUE +C----------------------------------------------------------------------- +C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE +C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET +C THE SIGN OF THE IMAGINARY PART CORRECT. +C----------------------------------------------------------------------- + IF (IFORM.EQ.2) GO TO 30 + INIT = 0 + CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + GO TO 50 + 30 CONTINUE + ZNR = ZRI + ZNI = -ZRR + IF (ZI.GT.0.0D0) GO TO 40 + ZNR = -ZNR + 40 CONTINUE + CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + AARG = ZABS(ARGR,ARGI) + 50 CONTINUE + IF (KODE.EQ.1) GO TO 60 + CZR = CZR - ZBR + CZI = CZI - ZBI + 60 CONTINUE + IF (IKFLG.EQ.1) GO TO 70 + CZR = -CZR + CZI = -CZI + 70 CONTINUE + APHI = ZABS(PHIR,PHII) + RCZ = CZR +C----------------------------------------------------------------------- +C OVERFLOW TEST +C----------------------------------------------------------------------- + IF (RCZ.GT.ELIM) GO TO 210 + IF (RCZ.LT.ALIM) GO TO 80 + RCZ = RCZ + DLOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC + IF (RCZ.GT.ELIM) GO TO 210 + GO TO 130 + 80 CONTINUE +C----------------------------------------------------------------------- +C UNDERFLOW TEST +C----------------------------------------------------------------------- + IF (RCZ.LT.(-ELIM)) GO TO 90 + IF (RCZ.GT.(-ALIM)) GO TO 130 + RCZ = RCZ + DLOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC + IF (RCZ.GT.(-ELIM)) GO TO 110 + 90 CONTINUE + DO 100 I=1,NN + YR(I) = ZEROR + YI(I) = ZEROI + 100 CONTINUE + NUF = NN + RETURN + 110 CONTINUE + ASCLE = 1.0D+3*D1MACH(1)/TOL + CALL ZLOG(PHIR, PHII, STR, STI, IDUM) + CZR = CZR + STR + CZI = CZI + STI + IF (IFORM.EQ.1) GO TO 120 + CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) + CZR = CZR - 0.25D0*STR - AIC + CZI = CZI - 0.25D0*STI + 120 CONTINUE + AX = DEXP(RCZ)/TOL + AY = CZI + CZR = AX*DCOS(AY) + CZI = AX*DSIN(AY) + CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 90 + 130 CONTINUE + IF (IKFLG.EQ.2) RETURN + IF (N.EQ.1) RETURN +C----------------------------------------------------------------------- +C SET UNDERFLOWS ON I SEQUENCE +C----------------------------------------------------------------------- + 140 CONTINUE + GNU = FNU + DBLE(FLOAT(NN-1)) + IF (IFORM.EQ.2) GO TO 150 + INIT = 0 + CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + GO TO 160 + 150 CONTINUE + CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + AARG = ZABS(ARGR,ARGI) + 160 CONTINUE + IF (KODE.EQ.1) GO TO 170 + CZR = CZR - ZBR + CZI = CZI - ZBI + 170 CONTINUE + APHI = ZABS(PHIR,PHII) + RCZ = CZR + IF (RCZ.LT.(-ELIM)) GO TO 180 + IF (RCZ.GT.(-ALIM)) RETURN + RCZ = RCZ + DLOG(APHI) + IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC + IF (RCZ.GT.(-ELIM)) GO TO 190 + 180 CONTINUE + YR(NN) = ZEROR + YI(NN) = ZEROI + NN = NN - 1 + NUF = NUF + 1 + IF (NN.EQ.0) RETURN + GO TO 140 + 190 CONTINUE + ASCLE = 1.0D+3*D1MACH(1)/TOL + CALL ZLOG(PHIR, PHII, STR, STI, IDUM) + CZR = CZR + STR + CZI = CZI + STI + IF (IFORM.EQ.1) GO TO 200 + CALL ZLOG(ARGR, ARGI, STR, STI, IDUM) + CZR = CZR - 0.25D0*STR - AIC + CZI = CZI - 0.25D0*STI + 200 CONTINUE + AX = DEXP(RCZ)/TOL + AY = CZI + CZR = AX*DCOS(AY) + CZI = AX*DSIN(AY) + CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL) + IF (NW.NE.0) GO TO 180 + RETURN + 210 CONTINUE + NUF = -1 + RETURN + END + SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZACON +C***REFER TO ZBESK,ZBESH +C +C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA +C +C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) +C MP=PI*MR*CMPLX(0.0,1.0) +C +C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT +C HALF Z PLANE +C +C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT +C***END PROLOGUE ZACON +C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, +C *S1,S2,Y,Z,ZN + EXTERNAL ZABS + DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, + * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, + * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, + * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, + * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, + * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS + INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) + DATA PI / 3.14159265358979324D0 / + DATA ZEROR,CONER / 0.0D0,1.0D0 / + NZ = 0 + ZNR = -ZR + ZNI = -ZI + NN = N + CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NW.LT.0) GO TO 90 +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + NN = MIN0(2,N) + CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 90 + S1R = CYR(1) + S1I = CYI(1) + FMR = DBLE(FLOAT(MR)) + SGN = -DSIGN(PI,FMR) + CSGNR = ZEROR + CSGNI = SGN + IF (KODE.EQ.1) GO TO 10 + YY = -ZNI + CPN = DCOS(YY) + SPN = DSIN(YY) + CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) + 10 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(SNGL(FNU)) + ARG = (FNU-DBLE(FLOAT(INU)))*SGN + CPN = DCOS(ARG) + SPN = DSIN(ARG) + CSPNR = CPN + CSPNI = SPN + IF (MOD(INU,2).EQ.0) GO TO 20 + CSPNR = -CSPNR + CSPNI = -CSPNI + 20 CONTINUE + IUF = 0 + C1R = S1R + C1I = S1I + C2R = YR(1) + C2I = YI(1) + ASCLE = 1.0D+3*D1MACH(1)/TOL + IF (KODE.EQ.1) GO TO 30 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1R = C1R + SC1I = C1I + 30 CONTINUE + CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) + CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) + YR(1) = STR + PTR + YI(1) = STI + PTI + IF (N.EQ.1) RETURN + CSPNR = -CSPNR + CSPNI = -CSPNI + S2R = CYR(2) + S2I = CYI(2) + C1R = S2R + C1I = S2I + C2R = YR(2) + C2I = YI(2) + IF (KODE.EQ.1) GO TO 40 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC2R = C1R + SC2I = C1I + 40 CONTINUE + CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) + CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) + YR(2) = STR + PTR + YI(2) = STI + PTI + IF (N.EQ.2) RETURN + CSPNR = -CSPNR + CSPNI = -CSPNI + AZN = ZABS(ZNR,ZNI) + RAZN = 1.0D0/AZN + STR = ZNR*RAZN + STI = -ZNI*RAZN + RZR = (STR+STR)*RAZN + RZI = (STI+STI)*RAZN + FN = FNU + 1.0D0 + CKR = FN*RZR + CKI = FN*RZI +C----------------------------------------------------------------------- +C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CSCR = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CSCR + CSRR(1) = CSCR + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = ASCLE + BRY(2) = 1.0D0/ASCLE + BRY(3) = D1MACH(2) + AS2 = ZABS(S2R,S2I) + KFLAG = 2 + IF (AS2.GT.BRY(1)) GO TO 50 + KFLAG = 1 + GO TO 60 + 50 CONTINUE + IF (AS2.LT.BRY(2)) GO TO 60 + KFLAG = 3 + 60 CONTINUE + BSCLE = BRY(KFLAG) + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + CSR = CSRR(KFLAG) + DO 80 I=3,N + STR = S2R + STI = S2I + S2R = CKR*STR - CKI*STI + S1R + S2I = CKR*STI + CKI*STR + S1I + S1R = STR + S1I = STI + C1R = S2R*CSR + C1I = S2I*CSR + STR = C1R + STI = C1I + C2R = YR(I) + C2I = YI(I) + IF (KODE.EQ.1) GO TO 70 + IF (IUF.LT.0) GO TO 70 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1R = SC2R + SC1I = SC2I + SC2R = C1R + SC2I = C1I + IF (IUF.NE.3) GO TO 70 + IUF = -4 + S1R = SC1R*CSSR(KFLAG) + S1I = SC1I*CSSR(KFLAG) + S2R = SC2R*CSSR(KFLAG) + S2I = SC2I*CSSR(KFLAG) + STR = SC2R + STI = SC2I + 70 CONTINUE + PTR = CSPNR*C1R - CSPNI*C1I + PTI = CSPNR*C1I + CSPNI*C1R + YR(I) = PTR + CSGNR*C2R - CSGNI*C2I + YI(I) = PTI + CSGNR*C2I + CSGNI*C2R + CKR = CKR + RZR + CKI = CKI + RZI + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (KFLAG.GE.3) GO TO 80 + PTR = DABS(C1R) + PTI = DABS(C1I) + C1M = DMAX1(PTR,PTI) + IF (C1M.LE.BSCLE) GO TO 80 + KFLAG = KFLAG + 1 + BSCLE = BRY(KFLAG) + S1R = S1R*CSR + S1I = S1I*CSR + S2R = STR + S2I = STI + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + CSR = CSRR(KFLAG) + 80 CONTINUE + RETURN + 90 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END + SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZBINU +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY +C +C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE +C +C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK +C***END PROLOGUE ZBINU + EXTERNAL ZABS + DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, + * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS + INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ + DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) + DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / +C + NZ = 0 + AZ = ZABS(ZR,ZI) + NN = N + DFNU = FNU + DBLE(FLOAT(N-1)) + IF (AZ.LE.2.0D0) GO TO 10 + IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C POWER SERIES +C----------------------------------------------------------------------- + CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + INW = IABS(NW) + NZ = NZ + INW + NN = NN - INW + IF (NN.EQ.0) RETURN + IF (NW.GE.0) GO TO 120 + DFNU = FNU + DBLE(FLOAT(NN-1)) + 20 CONTINUE + IF (AZ.LT.RL) GO TO 40 + IF (DFNU.LE.1.0D0) GO TO 30 + IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR LARGE Z +C----------------------------------------------------------------------- + 30 CONTINUE + CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 130 + GO TO 120 + 40 CONTINUE + IF (DFNU.LE.1.0D0) GO TO 70 + 50 CONTINUE +C----------------------------------------------------------------------- +C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM +C----------------------------------------------------------------------- + CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 130 + NZ = NZ + NW + NN = NN - NW + IF (NN.EQ.0) RETURN + DFNU = FNU+DBLE(FLOAT(NN-1)) + IF (DFNU.GT.FNUL) GO TO 110 + IF (AZ.GT.FNUL) GO TO 110 + 60 CONTINUE + IF (AZ.GT.RL) GO TO 80 + 70 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE SERIES +C----------------------------------------------------------------------- + CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL) + IF(NW.LT.0) GO TO 130 + GO TO 120 + 80 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- +C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN +C----------------------------------------------------------------------- + CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, + * ALIM) + IF (NW.GE.0) GO TO 100 + NZ = NN + DO 90 I=1,NN + CYR(I) = ZEROR + CYI(I) = ZEROI + 90 CONTINUE + RETURN + 100 CONTINUE + IF (NW.GT.0) GO TO 130 + CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, + * ELIM, ALIM) + IF (NW.LT.0) GO TO 130 + GO TO 120 + 110 CONTINUE +C----------------------------------------------------------------------- +C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD +C----------------------------------------------------------------------- + NUI = INT(SNGL(FNUL-DFNU)) + 1 + NUI = MAX0(NUI,0) + CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, + * TOL, ELIM, ALIM) + IF (NW.LT.0) GO TO 130 + NZ = NZ + NW + IF (NLAST.EQ.0) GO TO 120 + NN = NLAST + GO TO 60 + 120 CONTINUE + RETURN + 130 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END + DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR) +C***BEGIN PROLOGUE DGAMLN +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 830501 (YYMMDD) +C***CATEGORY NO. B5F +C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION +C***DESCRIPTION +C +C **** A DOUBLE PRECISION ROUTINE **** +C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR +C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES +C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION +C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS +C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE +C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) +C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. +C +C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 +C VALUES IS USED FOR SPEED OF EXECUTION. +C +C DESCRIPTION OF ARGUMENTS +C +C INPUT Z IS D0UBLE PRECISION +C Z - ARGUMENT, Z.GT.0.0D0 +C +C OUTPUT DGAMLN IS DOUBLE PRECISION +C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED +C IERR=1, Z.LE.0.0D0, NO COMPUTATION +C +C +C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C***ROUTINES CALLED I1MACH,D1MACH +C***END PROLOGUE DGAMLN + DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, + * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH + INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH + DIMENSION CF(22), GLN(100) +C LNGAMMA(N), N=1,100 + DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), + 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), + 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), + 3 GLN(21), GLN(22)/ + 4 0.00000000000000000D+00, 0.00000000000000000D+00, + 5 6.93147180559945309D-01, 1.79175946922805500D+00, + 6 3.17805383034794562D+00, 4.78749174278204599D+00, + 7 6.57925121201010100D+00, 8.52516136106541430D+00, + 8 1.06046029027452502D+01, 1.28018274800814696D+01, + 9 1.51044125730755153D+01, 1.75023078458738858D+01, + A 1.99872144956618861D+01, 2.25521638531234229D+01, + B 2.51912211827386815D+01, 2.78992713838408916D+01, + C 3.06718601060806728D+01, 3.35050734501368889D+01, + D 3.63954452080330536D+01, 3.93398841871994940D+01, + E 4.23356164607534850D+01, 4.53801388984769080D+01/ + DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), + 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), + 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), + 3 GLN(41), GLN(42), GLN(43), GLN(44)/ + 4 4.84711813518352239D+01, 5.16066755677643736D+01, + 5 5.47847293981123192D+01, 5.80036052229805199D+01, + 6 6.12617017610020020D+01, 6.45575386270063311D+01, + 7 6.78897431371815350D+01, 7.12570389671680090D+01, + 8 7.46582363488301644D+01, 7.80922235533153106D+01, + 9 8.15579594561150372D+01, 8.50544670175815174D+01, + A 8.85808275421976788D+01, 9.21361756036870925D+01, + B 9.57196945421432025D+01, 9.93306124547874269D+01, + C 1.02968198614513813D+02, 1.06631760260643459D+02, + D 1.10320639714757395D+02, 1.14034211781461703D+02, + E 1.17771881399745072D+02, 1.21533081515438634D+02/ + DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), + 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), + 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), + 3 GLN(63), GLN(64), GLN(65), GLN(66)/ + 4 1.25317271149356895D+02, 1.29123933639127215D+02, + 5 1.32952575035616310D+02, 1.36802722637326368D+02, + 6 1.40673923648234259D+02, 1.44565743946344886D+02, + 7 1.48477766951773032D+02, 1.52409592584497358D+02, + 8 1.56360836303078785D+02, 1.60331128216630907D+02, + 9 1.64320112263195181D+02, 1.68327445448427652D+02, + A 1.72352797139162802D+02, 1.76395848406997352D+02, + B 1.80456291417543771D+02, 1.84533828861449491D+02, + C 1.88628173423671591D+02, 1.92739047287844902D+02, + D 1.96866181672889994D+02, 2.01009316399281527D+02, + E 2.05168199482641199D+02, 2.09342586752536836D+02/ + DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), + 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), + 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), + 3 GLN(85), GLN(86), GLN(87), GLN(88)/ + 4 2.13532241494563261D+02, 2.17736934113954227D+02, + 5 2.21956441819130334D+02, 2.26190548323727593D+02, + 6 2.30439043565776952D+02, 2.34701723442818268D+02, + 7 2.38978389561834323D+02, 2.43268849002982714D+02, + 8 2.47572914096186884D+02, 2.51890402209723194D+02, + 9 2.56221135550009525D+02, 2.60564940971863209D+02, + A 2.64921649798552801D+02, 2.69291097651019823D+02, + B 2.73673124285693704D+02, 2.78067573440366143D+02, + C 2.82474292687630396D+02, 2.86893133295426994D+02, + D 2.91323950094270308D+02, 2.95766601350760624D+02, + E 3.00220948647014132D+02, 3.04686856765668715D+02/ + DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), + 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ + 2 3.09164193580146922D+02, 3.13652829949879062D+02, + 3 3.18152639620209327D+02, 3.22663499126726177D+02, + 4 3.27185287703775217D+02, 3.31717887196928473D+02, + 5 3.36261181979198477D+02, 3.40815058870799018D+02, + 6 3.45379407062266854D+02, 3.49954118040770237D+02, + 7 3.54539085519440809D+02, 3.59134205369575399D+02/ +C COEFFICIENTS OF ASYMPTOTIC EXPANSION + DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), + 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), + 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ + 3 8.33333333333333333D-02, -2.77777777777777778D-03, + 4 7.93650793650793651D-04, -5.95238095238095238D-04, + 5 8.41750841750841751D-04, -1.91752691752691753D-03, + 6 6.41025641025641026D-03, -2.95506535947712418D-02, + 7 1.79644372368830573D-01, -1.39243221690590112D+00, + 8 1.34028640441683920D+01, -1.56848284626002017D+02, + 9 2.19310333333333333D+03, -3.61087712537249894D+04, + A 6.91472268851313067D+05, -1.52382215394074162D+07, + B 3.82900751391414141D+08, -1.08822660357843911D+10, + C 3.47320283765002252D+11, -1.23696021422692745D+13, + D 4.88788064793079335D+14, -2.13203339609193739D+16/ +C +C LN(2*PI) + DATA CON / 1.83787706640934548D+00/ +C +C***FIRST EXECUTABLE STATEMENT DGAMLN + IERR=0 + IF (Z.LE.0.0D0) GO TO 70 + IF (Z.GT.101.0D0) GO TO 10 + NZ = INT(Z) + FZ = Z - FLOAT(NZ) + IF (FZ.GT.0.0D0) GO TO 10 + IF (NZ.GT.100) GO TO 10 + DGAMLN = GLN(NZ) + RETURN + 10 CONTINUE + WDTOL = D1MACH(4) + WDTOL = DMAX1(WDTOL,0.5D-18) + I1M = I1MACH(14) + RLN = D1MACH(5)*FLOAT(I1M) + FLN = DMIN1(RLN,20.0D0) + FLN = DMAX1(FLN,3.0D0) + FLN = FLN - 3.0D0 + ZM = 1.8000D0 + 0.3875D0*FLN + MZ = INT(SNGL(ZM)) + 1 + ZMIN = FLOAT(MZ) + ZDMY = Z + ZINC = 0.0D0 + IF (Z.GE.ZMIN) GO TO 20 + ZINC = ZMIN - FLOAT(NZ) + ZDMY = Z + ZINC + 20 CONTINUE + ZP = 1.0D0/ZDMY + T1 = CF(1)*ZP + S = T1 + IF (ZP.LT.WDTOL) GO TO 40 + ZSQ = ZP*ZP + TST = T1*WDTOL + DO 30 K=2,22 + ZP = ZP*ZSQ + TRM = CF(K)*ZP + IF (DABS(TRM).LT.TST) GO TO 40 + S = S + TRM + 30 CONTINUE + 40 CONTINUE + IF (ZINC.NE.0.0D0) GO TO 50 + TLG = DLOG(Z) + DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S + RETURN + 50 CONTINUE + ZP = 1.0D0 + NZ = INT(SNGL(ZINC)) + DO 60 I=1,NZ + ZP = ZP*(Z+FLOAT(I-1)) + 60 CONTINUE + TLG = DLOG(ZDMY) + DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S + RETURN +C +C + 70 CONTINUE + IERR=1 + RETURN + END + SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, + * ELIM, ALIM) +C***BEGIN PROLOGUE ZACAI +C***REFER TO ZAIRY +C +C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA +C +C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) +C MP=PI*MR*CMPLX(0.0,1.0) +C +C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT +C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. +C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND +C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON +C IS CALLED FROM ZAIRY. +C +C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS +C***END PROLOGUE ZACAI +C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY + EXTERNAL ZABS + DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, + * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, + * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS + INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2) + DATA PI / 3.14159265358979324D0 / + NZ = 0 + ZNR = -ZR + ZNI = -ZI + AZ = ZABS(ZR,ZI) + NN = N + DFNU = FNU + DBLE(FLOAT(N-1)) + IF (AZ.LE.2.0D0) GO TO 10 + IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C POWER SERIES FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM) + GO TO 40 + 20 CONTINUE + IF (AZ.LT.RL) GO TO 30 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, + * ALIM) + IF (NW.LT.0) GO TO 80 + GO TO 40 + 30 CONTINUE +C----------------------------------------------------------------------- +C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION +C----------------------------------------------------------------------- + CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL) + IF(NW.LT.0) GO TO 80 + 40 CONTINUE +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 80 + FMR = DBLE(FLOAT(MR)) + SGN = -DSIGN(PI,FMR) + CSGNR = 0.0D0 + CSGNI = SGN + IF (KODE.EQ.1) GO TO 50 + YY = -ZNI + CSGNR = -CSGNI*DSIN(YY) + CSGNI = CSGNI*DCOS(YY) + 50 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(SNGL(FNU)) + ARG = (FNU-DBLE(FLOAT(INU)))*SGN + CSPNR = DCOS(ARG) + CSPNI = DSIN(ARG) + IF (MOD(INU,2).EQ.0) GO TO 60 + CSPNR = -CSPNR + CSPNI = -CSPNI + 60 CONTINUE + C1R = CYR(1) + C1I = CYI(1) + C2R = YR(1) + C2I = YI(1) + IF (KODE.EQ.1) GO TO 70 + IUF = 0 + ASCLE = 1.0D+3*D1MACH(1)/TOL + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + 70 CONTINUE + YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I + YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R + RETURN + 80 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + END + SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL) +C***BEGIN PROLOGUE ZUCHK +C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL +C +C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN +C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE +C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW +C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED +C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE +C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE +C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZUCHK +C +C COMPLEX Y + DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI + INTEGER NZ + NZ = 0 + WR = DABS(YR) + WI = DABS(YI) + ST = DMIN1(WR,WI) + IF (ST.GT.ASCLE) RETURN + SS = DMAX1(WR,WI) + ST = ST/TOL + IF (SS.LT.ST) NZ = 1 + RETURN + END + SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, + * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) +C***BEGIN PROLOGUE ZUNIK +C***REFER TO ZBESI,ZBESK +C +C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC +C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 +C RESPECTIVELY BY +C +C W(FNU,ZR) = PHI*EXP(ZETA)*SUM +C +C WHERE ZETA=-ZETA1 + ZETA2 OR +C ZETA1 - ZETA2 +C +C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE +C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= +C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK +C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, +C ZETA1,ZETA2. +C +C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH +C***END PROLOGUE ZUNIK +C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, +C *ZETA2,ZN,ZR + DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, + * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, + * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, + * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH + INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L + DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / + DATA CON(1), CON(2) / + 1 3.98942280401432678D-01, 1.25331413731550025D+00 / + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 1.00000000000000000D+00, -2.08333333333333333D-01, + 4 1.25000000000000000D-01, 3.34201388888888889D-01, + 5 -4.01041666666666667D-01, 7.03125000000000000D-02, + 6 -1.02581259645061728D+00, 1.84646267361111111D+00, + 7 -8.91210937500000000D-01, 7.32421875000000000D-02, + 8 4.66958442342624743D+00, -1.12070026162229938D+01, + 9 8.78912353515625000D+00, -2.36408691406250000D+00, + A 1.12152099609375000D-01, -2.82120725582002449D+01, + B 8.46362176746007346D+01, -9.18182415432400174D+01, + C 4.25349987453884549D+01, -7.36879435947963170D+00, + D 2.27108001708984375D-01, 2.12570130039217123D+02, + E -7.65252468141181642D+02, 1.05999045252799988D+03/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 -6.99579627376132541D+02, 2.18190511744211590D+02, + 4 -2.64914304869515555D+01, 5.72501420974731445D-01, + 5 -1.91945766231840700D+03, 8.06172218173730938D+03, + 6 -1.35865500064341374D+04, 1.16553933368645332D+04, + 7 -5.30564697861340311D+03, 1.20090291321635246D+03, + 8 -1.08090919788394656D+02, 1.72772750258445740D+00, + 9 2.02042913309661486D+04, -9.69805983886375135D+04, + A 1.92547001232531532D+05, -2.03400177280415534D+05, + B 1.22200464983017460D+05, -4.11926549688975513D+04, + C 7.10951430248936372D+03, -4.93915304773088012D+02, + D 6.07404200127348304D+00, -2.42919187900551333D+05, + E 1.31176361466297720D+06, -2.99801591853810675D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.76327129765640400D+06, -2.81356322658653411D+06, + 4 1.26836527332162478D+06, -3.31645172484563578D+05, + 5 4.52187689813627263D+04, -2.49983048181120962D+03, + 6 2.43805296995560639D+01, 3.28446985307203782D+06, + 7 -1.97068191184322269D+07, 5.09526024926646422D+07, + 8 -7.41051482115326577D+07, 6.63445122747290267D+07, + 9 -3.75671766607633513D+07, 1.32887671664218183D+07, + A -2.78561812808645469D+06, 3.08186404612662398D+05, + B -1.38860897537170405D+04, 1.10017140269246738D+02, + C -4.93292536645099620D+07, 3.25573074185765749D+08, + D -9.39462359681578403D+08, 1.55359689957058006D+09, + E -1.62108055210833708D+09, 1.10684281682301447D+09/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 -4.95889784275030309D+08, 1.42062907797533095D+08, + 4 -2.44740627257387285D+07, 2.24376817792244943D+06, + 5 -8.40054336030240853D+04, 5.51335896122020586D+02, + 6 8.14789096118312115D+08, -5.86648149205184723D+09, + 7 1.86882075092958249D+10, -3.46320433881587779D+10, + 8 4.12801855797539740D+10, -3.30265997498007231D+10, + 9 1.79542137311556001D+10, -6.56329379261928433D+09, + A 1.55927986487925751D+09, -2.25105661889415278D+08, + B 1.73951075539781645D+07, -5.49842327572288687D+05, + C 3.03809051092238427D+03, -1.46792612476956167D+10, + D 1.14498237732025810D+11, -3.99096175224466498D+11, + E 8.19218669548577329D+11, -1.09837515608122331D+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), + 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ + 3 1.00815810686538209D+12, -6.45364869245376503D+11, + 4 2.87900649906150589D+11, -8.78670721780232657D+10, + 5 1.76347306068349694D+10, -2.16716498322379509D+09, + 6 1.43157876718888981D+08, -3.87183344257261262D+06, + 7 1.82577554742931747D+04, 2.86464035717679043D+11, + 8 -2.40629790002850396D+12, 9.10934118523989896D+12, + 9 -2.05168994109344374D+13, 3.05651255199353206D+13, + A -3.16670885847851584D+13, 2.33483640445818409D+13, + B -1.23204913055982872D+13, 4.61272578084913197D+12, + C -1.19655288019618160D+12, 2.05914503232410016D+11, + D -2.18229277575292237D+10, 1.24700929351271032D+09/ + DATA C(119), C(120)/ + 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ +C + IF (INIT.NE.0) GO TO 40 +C----------------------------------------------------------------------- +C INITIALIZE ALL VARIABLES +C----------------------------------------------------------------------- + RFN = 1.0D0/FNU +C----------------------------------------------------------------------- +C OVERFLOW TEST (ZR/FNU TOO SMALL) +C----------------------------------------------------------------------- + TEST = D1MACH(1)*1.0D+3 + AC = FNU*TEST + IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15 + ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU + ZETA1I = 0.0D0 + ZETA2R = FNU + ZETA2I = 0.0D0 + PHIR = 1.0D0 + PHII = 0.0D0 + RETURN + 15 CONTINUE + TR = ZRR*RFN + TI = ZRI*RFN + SR = CONER + (TR*TR-TI*TI) + SI = CONEI + (TR*TI+TI*TR) + CALL ZSQRT(SR, SI, SRR, SRI) + STR = CONER + SRR + STI = CONEI + SRI + CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) + CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) + ZETA1R = FNU*STR + ZETA1I = FNU*STI + ZETA2R = FNU*SRR + ZETA2I = FNU*SRI + CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) + SRR = TR*RFN + SRI = TI*RFN + CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) + PHIR = CWRKR(16)*CON(IKFLG) + PHII = CWRKI(16)*CON(IKFLG) + IF (IPMTR.NE.0) RETURN + CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) + CWRKR(1) = CONER + CWRKI(1) = CONEI + CRFNR = CONER + CRFNI = CONEI + AC = 1.0D0 + L = 1 + DO 20 K=2,15 + SR = ZEROR + SI = ZEROI + DO 10 J=1,K + L = L + 1 + STR = SR*T2R - SI*T2I + C(L) + SI = SR*T2I + SI*T2R + SR = STR + 10 CONTINUE + STR = CRFNR*SRR - CRFNI*SRI + CRFNI = CRFNR*SRI + CRFNI*SRR + CRFNR = STR + CWRKR(K) = CRFNR*SR - CRFNI*SI + CWRKI(K) = CRFNR*SI + CRFNI*SR + AC = AC*RFN + TEST = DABS(CWRKR(K)) + DABS(CWRKI(K)) + IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 + 20 CONTINUE + K = 15 + 30 CONTINUE + INIT = K + 40 CONTINUE + IF (IKFLG.EQ.2) GO TO 60 +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE I FUNCTION +C----------------------------------------------------------------------- + SR = ZEROR + SI = ZEROI + DO 50 I=1,INIT + SR = SR + CWRKR(I) + SI = SI + CWRKI(I) + 50 CONTINUE + SUMR = SR + SUMI = SI + PHIR = CWRKR(16)*CON(1) + PHII = CWRKI(16)*CON(1) + RETURN + 60 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE K FUNCTION +C----------------------------------------------------------------------- + SR = ZEROR + SI = ZEROI + TR = CONER + DO 70 I=1,INIT + SR = SR + TR*CWRKR(I) + SI = SI + TR*CWRKI(I) + TR = -TR + 70 CONTINUE + SUMR = SR + SUMI = SI + PHIR = CWRKR(16)*CON(2) + PHII = CWRKI(16)*CON(2) + RETURN + END + SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) +C***BEGIN PROLOGUE ZUNHJ +C***REFER TO ZBESI,ZBESK +C +C REFERENCES +C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. +C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. +C +C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC +C PRESS, N.Y., 1974, PAGE 420 +C +C ABSTRACT +C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = +C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU +C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION +C +C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) +C +C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS +C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. +C +C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, +C +C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING +C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. +C +C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND +C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= +C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. +C +C***ROUTINES CALLED ZABS,ZDIV,ZLOG,ZSQRT,D1MACH +C***END PROLOGUE ZUNHJ +C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, +C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, +C *ZETA2,ZTH + EXTERNAL ZABS + DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, + * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, + * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, + * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, + * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, + * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, + * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, + * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, + * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH + INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, + * LRP1, L1, L2, M, IDUM + DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), + * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), + * DRR(14), DRI(14) + DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), + 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ + 2 1.00000000000000000D+00, 1.04166666666666667D-01, + 3 8.35503472222222222D-02, 1.28226574556327160D-01, + 4 2.91849026464140464D-01, 8.81627267443757652D-01, + 5 3.32140828186276754D+00, 1.49957629868625547D+01, + 6 7.89230130115865181D+01, 4.74451538868264323D+02, + 7 3.20749009089066193D+03, 2.40865496408740049D+04, + 8 1.98923119169509794D+05, 1.79190200777534383D+06/ + DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), + 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ + 2 1.00000000000000000D+00, -1.45833333333333333D-01, + 3 -9.87413194444444444D-02, -1.43312053915895062D-01, + 4 -3.17227202678413548D-01, -9.42429147957120249D-01, + 5 -3.51120304082635426D+00, -1.57272636203680451D+01, + 6 -8.22814390971859444D+01, -4.92355370523670524D+02, + 7 -3.31621856854797251D+03, -2.48276742452085896D+04, + 8 -2.04526587315129788D+05, -1.83844491706820990D+06/ + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 1.00000000000000000D+00, -2.08333333333333333D-01, + 4 1.25000000000000000D-01, 3.34201388888888889D-01, + 5 -4.01041666666666667D-01, 7.03125000000000000D-02, + 6 -1.02581259645061728D+00, 1.84646267361111111D+00, + 7 -8.91210937500000000D-01, 7.32421875000000000D-02, + 8 4.66958442342624743D+00, -1.12070026162229938D+01, + 9 8.78912353515625000D+00, -2.36408691406250000D+00, + A 1.12152099609375000D-01, -2.82120725582002449D+01, + B 8.46362176746007346D+01, -9.18182415432400174D+01, + C 4.25349987453884549D+01, -7.36879435947963170D+00, + D 2.27108001708984375D-01, 2.12570130039217123D+02, + E -7.65252468141181642D+02, 1.05999045252799988D+03/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 -6.99579627376132541D+02, 2.18190511744211590D+02, + 4 -2.64914304869515555D+01, 5.72501420974731445D-01, + 5 -1.91945766231840700D+03, 8.06172218173730938D+03, + 6 -1.35865500064341374D+04, 1.16553933368645332D+04, + 7 -5.30564697861340311D+03, 1.20090291321635246D+03, + 8 -1.08090919788394656D+02, 1.72772750258445740D+00, + 9 2.02042913309661486D+04, -9.69805983886375135D+04, + A 1.92547001232531532D+05, -2.03400177280415534D+05, + B 1.22200464983017460D+05, -4.11926549688975513D+04, + C 7.10951430248936372D+03, -4.93915304773088012D+02, + D 6.07404200127348304D+00, -2.42919187900551333D+05, + E 1.31176361466297720D+06, -2.99801591853810675D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.76327129765640400D+06, -2.81356322658653411D+06, + 4 1.26836527332162478D+06, -3.31645172484563578D+05, + 5 4.52187689813627263D+04, -2.49983048181120962D+03, + 6 2.43805296995560639D+01, 3.28446985307203782D+06, + 7 -1.97068191184322269D+07, 5.09526024926646422D+07, + 8 -7.41051482115326577D+07, 6.63445122747290267D+07, + 9 -3.75671766607633513D+07, 1.32887671664218183D+07, + A -2.78561812808645469D+06, 3.08186404612662398D+05, + B -1.38860897537170405D+04, 1.10017140269246738D+02, + C -4.93292536645099620D+07, 3.25573074185765749D+08, + D -9.39462359681578403D+08, 1.55359689957058006D+09, + E -1.62108055210833708D+09, 1.10684281682301447D+09/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 -4.95889784275030309D+08, 1.42062907797533095D+08, + 4 -2.44740627257387285D+07, 2.24376817792244943D+06, + 5 -8.40054336030240853D+04, 5.51335896122020586D+02, + 6 8.14789096118312115D+08, -5.86648149205184723D+09, + 7 1.86882075092958249D+10, -3.46320433881587779D+10, + 8 4.12801855797539740D+10, -3.30265997498007231D+10, + 9 1.79542137311556001D+10, -6.56329379261928433D+09, + A 1.55927986487925751D+09, -2.25105661889415278D+08, + B 1.73951075539781645D+07, -5.49842327572288687D+05, + C 3.03809051092238427D+03, -1.46792612476956167D+10, + D 1.14498237732025810D+11, -3.99096175224466498D+11, + E 8.19218669548577329D+11, -1.09837515608122331D+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105)/ + 2 1.00815810686538209D+12, -6.45364869245376503D+11, + 3 2.87900649906150589D+11, -8.78670721780232657D+10, + 4 1.76347306068349694D+10, -2.16716498322379509D+09, + 5 1.43157876718888981D+08, -3.87183344257261262D+06, + 6 1.82577554742931747D+04/ + DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), + 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), + 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), + 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ + 4 -4.44444444444444444D-03, -9.22077922077922078D-04, + 5 -8.84892884892884893D-05, 1.65927687832449737D-04, + 6 2.46691372741792910D-04, 2.65995589346254780D-04, + 7 2.61824297061500945D-04, 2.48730437344655609D-04, + 8 2.32721040083232098D-04, 2.16362485712365082D-04, + 9 2.00738858762752355D-04, 1.86267636637545172D-04, + A 1.73060775917876493D-04, 1.61091705929015752D-04, + B 1.50274774160908134D-04, 1.40503497391269794D-04, + C 1.31668816545922806D-04, 1.23667445598253261D-04, + D 1.16405271474737902D-04, 1.09798298372713369D-04, + E 1.03772410422992823D-04, 9.82626078369363448D-05/ + DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), + 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), + 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), + 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ + 4 9.32120517249503256D-05, 8.85710852478711718D-05, + 5 8.42963105715700223D-05, 8.03497548407791151D-05, + 6 7.66981345359207388D-05, 7.33122157481777809D-05, + 7 7.01662625163141333D-05, 6.72375633790160292D-05, + 8 6.93735541354588974D-04, 2.32241745182921654D-04, + 9 -1.41986273556691197D-05, -1.16444931672048640D-04, + A -1.50803558053048762D-04, -1.55121924918096223D-04, + B -1.46809756646465549D-04, -1.33815503867491367D-04, + C -1.19744975684254051D-04, -1.06184319207974020D-04, + D -9.37699549891194492D-05, -8.26923045588193274D-05, + E -7.29374348155221211D-05, -6.44042357721016283D-05/ + DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), + 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), + 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), + 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ + 4 -5.69611566009369048D-05, -5.04731044303561628D-05, + 5 -4.48134868008882786D-05, -3.98688727717598864D-05, + 6 -3.55400532972042498D-05, -3.17414256609022480D-05, + 7 -2.83996793904174811D-05, -2.54522720634870566D-05, + 8 -2.28459297164724555D-05, -2.05352753106480604D-05, + 9 -1.84816217627666085D-05, -1.66519330021393806D-05, + A -1.50179412980119482D-05, -1.35554031379040526D-05, + B -1.22434746473858131D-05, -1.10641884811308169D-05, + C -3.54211971457743841D-04, -1.56161263945159416D-04, + D 3.04465503594936410D-05, 1.30198655773242693D-04, + E 1.67471106699712269D-04, 1.70222587683592569D-04/ + DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), + 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), + 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), + 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ + 4 1.56501427608594704D-04, 1.36339170977445120D-04, + 5 1.14886692029825128D-04, 9.45869093034688111D-05, + 6 7.64498419250898258D-05, 6.07570334965197354D-05, + 7 4.74394299290508799D-05, 3.62757512005344297D-05, + 8 2.69939714979224901D-05, 1.93210938247939253D-05, + 9 1.30056674793963203D-05, 7.82620866744496661D-06, + A 3.59257485819351583D-06, 1.44040049814251817D-07, + B -2.65396769697939116D-06, -4.91346867098485910D-06, + C -6.72739296091248287D-06, -8.17269379678657923D-06, + D -9.31304715093561232D-06, -1.02011418798016441D-05, + E -1.08805962510592880D-05, -1.13875481509603555D-05/ + DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), + 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), + 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), + 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ + 4 -1.17519675674556414D-05, -1.19987364870944141D-05, + 5 3.78194199201772914D-04, 2.02471952761816167D-04, + 6 -6.37938506318862408D-05, -2.38598230603005903D-04, + 7 -3.10916256027361568D-04, -3.13680115247576316D-04, + 8 -2.78950273791323387D-04, -2.28564082619141374D-04, + 9 -1.75245280340846749D-04, -1.25544063060690348D-04, + A -8.22982872820208365D-05, -4.62860730588116458D-05, + B -1.72334302366962267D-05, 5.60690482304602267D-06, + C 2.31395443148286800D-05, 3.62642745856793957D-05, + D 4.58006124490188752D-05, 5.24595294959114050D-05, + E 5.68396208545815266D-05, 5.94349820393104052D-05/ + DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), + 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), + 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), + 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ + 4 6.06478527578421742D-05, 6.08023907788436497D-05, + 5 6.01577894539460388D-05, 5.89199657344698500D-05, + 6 5.72515823777593053D-05, 5.52804375585852577D-05, + 7 5.31063773802880170D-05, 5.08069302012325706D-05, + 8 4.84418647620094842D-05, 4.60568581607475370D-05, + 9 -6.91141397288294174D-04, -4.29976633058871912D-04, + A 1.83067735980039018D-04, 6.60088147542014144D-04, + B 8.75964969951185931D-04, 8.77335235958235514D-04, + C 7.49369585378990637D-04, 5.63832329756980918D-04, + D 3.68059319971443156D-04, 1.88464535514455599D-04/ + DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), + 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), + 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), + 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ + 4 3.70663057664904149D-05, -8.28520220232137023D-05, + 5 -1.72751952869172998D-04, -2.36314873605872983D-04, + 6 -2.77966150694906658D-04, -3.02079514155456919D-04, + 7 -3.12594712643820127D-04, -3.12872558758067163D-04, + 8 -3.05678038466324377D-04, -2.93226470614557331D-04, + 9 -2.77255655582934777D-04, -2.59103928467031709D-04, + A -2.39784014396480342D-04, -2.20048260045422848D-04, + B -2.00443911094971498D-04, -1.81358692210970687D-04, + C -1.63057674478657464D-04, -1.45712672175205844D-04, + D -1.29425421983924587D-04, -1.14245691942445952D-04/ + DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), + 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), + 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), + 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ + 4 1.92821964248775885D-03, 1.35592576302022234D-03, + 5 -7.17858090421302995D-04, -2.58084802575270346D-03, + 6 -3.49271130826168475D-03, -3.46986299340960628D-03, + 7 -2.82285233351310182D-03, -1.88103076404891354D-03, + 8 -8.89531718383947600D-04, 3.87912102631035228D-06, + 9 7.28688540119691412D-04, 1.26566373053457758D-03, + A 1.62518158372674427D-03, 1.83203153216373172D-03, + B 1.91588388990527909D-03, 1.90588846755546138D-03, + C 1.82798982421825727D-03, 1.70389506421121530D-03, + D 1.55097127171097686D-03, 1.38261421852276159D-03/ + DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), + 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ + 2 1.20881424230064774D-03, 1.03676532638344962D-03, + 3 8.71437918068619115D-04, 7.16080155297701002D-04, + 4 5.72637002558129372D-04, 4.42089819465802277D-04, + 5 3.24724948503090564D-04, 2.20342042730246599D-04, + 6 1.28412898401353882D-04, 4.82005924552095464D-05/ + DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), + 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), + 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), + 3 BETA(19), BETA(20), BETA(21), BETA(22)/ + 4 1.79988721413553309D-02, 5.59964911064388073D-03, + 5 2.88501402231132779D-03, 1.80096606761053941D-03, + 6 1.24753110589199202D-03, 9.22878876572938311D-04, + 7 7.14430421727287357D-04, 5.71787281789704872D-04, + 8 4.69431007606481533D-04, 3.93232835462916638D-04, + 9 3.34818889318297664D-04, 2.88952148495751517D-04, + A 2.52211615549573284D-04, 2.22280580798883327D-04, + B 1.97541838033062524D-04, 1.76836855019718004D-04, + C 1.59316899661821081D-04, 1.44347930197333986D-04, + D 1.31448068119965379D-04, 1.20245444949302884D-04, + E 1.10449144504599392D-04, 1.01828770740567258D-04/ + DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), + 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), + 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), + 3 BETA(41), BETA(42), BETA(43), BETA(44)/ + 4 9.41998224204237509D-05, 8.74130545753834437D-05, + 5 8.13466262162801467D-05, 7.59002269646219339D-05, + 6 7.09906300634153481D-05, 6.65482874842468183D-05, + 7 6.25146958969275078D-05, 5.88403394426251749D-05, + 8 -1.49282953213429172D-03, -8.78204709546389328D-04, + 9 -5.02916549572034614D-04, -2.94822138512746025D-04, + A -1.75463996970782828D-04, -1.04008550460816434D-04, + B -5.96141953046457895D-05, -3.12038929076098340D-05, + C -1.26089735980230047D-05, -2.42892608575730389D-07, + D 8.05996165414273571D-06, 1.36507009262147391D-05, + E 1.73964125472926261D-05, 1.98672978842133780D-05/ + DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), + 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), + 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), + 3 BETA(63), BETA(64), BETA(65), BETA(66)/ + 4 2.14463263790822639D-05, 2.23954659232456514D-05, + 5 2.28967783814712629D-05, 2.30785389811177817D-05, + 6 2.30321976080909144D-05, 2.28236073720348722D-05, + 7 2.25005881105292418D-05, 2.20981015361991429D-05, + 8 2.16418427448103905D-05, 2.11507649256220843D-05, + 9 2.06388749782170737D-05, 2.01165241997081666D-05, + A 1.95913450141179244D-05, 1.90689367910436740D-05, + B 1.85533719641636667D-05, 1.80475722259674218D-05, + C 5.52213076721292790D-04, 4.47932581552384646D-04, + D 2.79520653992020589D-04, 1.52468156198446602D-04, + E 6.93271105657043598D-05, 1.76258683069991397D-05/ + DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), + 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), + 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), + 3 BETA(85), BETA(86), BETA(87), BETA(88)/ + 4 -1.35744996343269136D-05, -3.17972413350427135D-05, + 5 -4.18861861696693365D-05, -4.69004889379141029D-05, + 6 -4.87665447413787352D-05, -4.87010031186735069D-05, + 7 -4.74755620890086638D-05, -4.55813058138628452D-05, + 8 -4.33309644511266036D-05, -4.09230193157750364D-05, + 9 -3.84822638603221274D-05, -3.60857167535410501D-05, + A -3.37793306123367417D-05, -3.15888560772109621D-05, + B -2.95269561750807315D-05, -2.75978914828335759D-05, + C -2.58006174666883713D-05, -2.41308356761280200D-05, + D -2.25823509518346033D-05, -2.11479656768912971D-05, + E -1.98200638885294927D-05, -1.85909870801065077D-05/ + DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), + 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), + 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), + 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ + 4 -1.74532699844210224D-05, -1.63997823854497997D-05, + 5 -4.74617796559959808D-04, -4.77864567147321487D-04, + 6 -3.20390228067037603D-04, -1.61105016119962282D-04, + 7 -4.25778101285435204D-05, 3.44571294294967503D-05, + 8 7.97092684075674924D-05, 1.03138236708272200D-04, + 9 1.12466775262204158D-04, 1.13103642108481389D-04, + A 1.08651634848774268D-04, 1.01437951597661973D-04, + B 9.29298396593363896D-05, 8.40293133016089978D-05, + C 7.52727991349134062D-05, 6.69632521975730872D-05, + D 5.92564547323194704D-05, 5.22169308826975567D-05, + E 4.58539485165360646D-05, 4.01445513891486808D-05/ + DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), + 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), + 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), + 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ + 4 3.50481730031328081D-05, 3.05157995034346659D-05, + 5 2.64956119950516039D-05, 2.29363633690998152D-05, + 6 1.97893056664021636D-05, 1.70091984636412623D-05, + 7 1.45547428261524004D-05, 1.23886640995878413D-05, + 8 1.04775876076583236D-05, 8.79179954978479373D-06, + 9 7.36465810572578444D-04, 8.72790805146193976D-04, + A 6.22614862573135066D-04, 2.85998154194304147D-04, + B 3.84737672879366102D-06, -1.87906003636971558D-04, + C -2.97603646594554535D-04, -3.45998126832656348D-04, + D -3.53382470916037712D-04, -3.35715635775048757D-04/ + DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), + 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), + 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), + 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ + 4 -3.04321124789039809D-04, -2.66722723047612821D-04, + 5 -2.27654214122819527D-04, -1.89922611854562356D-04, + 6 -1.55058918599093870D-04, -1.23778240761873630D-04, + 7 -9.62926147717644187D-05, -7.25178327714425337D-05, + 8 -5.22070028895633801D-05, -3.50347750511900522D-05, + 9 -2.06489761035551757D-05, -8.70106096849767054D-06, + A 1.13698686675100290D-06, 9.16426474122778849D-06, + B 1.56477785428872620D-05, 2.08223629482466847D-05, + C 2.48923381004595156D-05, 2.80340509574146325D-05, + D 3.03987774629861915D-05, 3.21156731406700616D-05/ + DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), + 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), + 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), + 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ + 4 -1.80182191963885708D-03, -2.43402962938042533D-03, + 5 -1.83422663549856802D-03, -7.62204596354009765D-04, + 6 2.39079475256927218D-04, 9.49266117176881141D-04, + 7 1.34467449701540359D-03, 1.48457495259449178D-03, + 8 1.44732339830617591D-03, 1.30268261285657186D-03, + 9 1.10351597375642682D-03, 8.86047440419791759D-04, + A 6.73073208165665473D-04, 4.77603872856582378D-04, + B 3.05991926358789362D-04, 1.60315694594721630D-04, + C 4.00749555270613286D-05, -5.66607461635251611D-05, + D -1.32506186772982638D-04, -1.90296187989614057D-04/ + DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), + 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), + 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), + 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ + 4 -2.32811450376937408D-04, -2.62628811464668841D-04, + 5 -2.82050469867598672D-04, -2.93081563192861167D-04, + 6 -2.97435962176316616D-04, -2.96557334239348078D-04, + 7 -2.91647363312090861D-04, -2.83696203837734166D-04, + 8 -2.73512317095673346D-04, -2.61750155806768580D-04, + 9 6.38585891212050914D-03, 9.62374215806377941D-03, + A 7.61878061207001043D-03, 2.83219055545628054D-03, + B -2.09841352012720090D-03, -5.73826764216626498D-03, + C -7.70804244495414620D-03, -8.21011692264844401D-03, + D -7.65824520346905413D-03, -6.47209729391045177D-03/ + DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), + 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), + 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), + 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ + 4 -4.99132412004966473D-03, -3.45612289713133280D-03, + 5 -2.01785580014170775D-03, -7.59430686781961401D-04, + 6 2.84173631523859138D-04, 1.10891667586337403D-03, + 7 1.72901493872728771D-03, 2.16812590802684701D-03, + 8 2.45357710494539735D-03, 2.61281821058334862D-03, + 9 2.67141039656276912D-03, 2.65203073395980430D-03, + A 2.57411652877287315D-03, 2.45389126236094427D-03, + B 2.30460058071795494D-03, 2.13684837686712662D-03, + C 1.95896528478870911D-03, 1.77737008679454412D-03, + D 1.59690280765839059D-03, 1.42111975664438546D-03/ + DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), + 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), + 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), + 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ + 4 6.29960524947436582D-01, 2.51984209978974633D-01, + 5 1.54790300415655846D-01, 1.10713062416159013D-01, + 6 8.57309395527394825D-02, 6.97161316958684292D-02, + 7 5.86085671893713576D-02, 5.04698873536310685D-02, + 8 4.42600580689154809D-02, 3.93720661543509966D-02, + 9 3.54283195924455368D-02, 3.21818857502098231D-02, + A 2.94646240791157679D-02, 2.71581677112934479D-02, + B 2.51768272973861779D-02, 2.34570755306078891D-02, + C 2.19508390134907203D-02, 2.06210828235646240D-02, + D 1.94388240897880846D-02, 1.83810633800683158D-02, + E 1.74293213231963172D-02, 1.65685837786612353D-02/ + DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), + 1 GAMA(29), GAMA(30)/ + 2 1.57865285987918445D-02, 1.50729501494095594D-02, + 3 1.44193250839954639D-02, 1.38184805735341786D-02, + 4 1.32643378994276568D-02, 1.27517121970498651D-02, + 5 1.22761545318762767D-02, 1.18338262398482403D-02/ + DATA EX1, EX2, HPI, GPI, THPI / + 1 3.33333333333333333D-01, 6.66666666666666667D-01, + 2 1.57079632679489662D+00, 3.14159265358979324D+00, + 3 4.71238898038468986D+00/ + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C + RFNU = 1.0D0/FNU +C----------------------------------------------------------------------- +C OVERFLOW TEST (Z/FNU TOO SMALL) +C----------------------------------------------------------------------- + TEST = D1MACH(1)*1.0D+3 + AC = FNU*TEST + IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15 + ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU + ZETA1I = 0.0D0 + ZETA2R = FNU + ZETA2I = 0.0D0 + PHIR = 1.0D0 + PHII = 0.0D0 + ARGR = 1.0D0 + ARGI = 0.0D0 + RETURN + 15 CONTINUE + ZBR = ZR*RFNU + ZBI = ZI*RFNU + RFNU2 = RFNU*RFNU +C----------------------------------------------------------------------- +C COMPUTE IN THE FOURTH QUADRANT +C----------------------------------------------------------------------- + FN13 = FNU**EX1 + FN23 = FN13*FN13 + RFN13 = 1.0D0/FN13 + W2R = CONER - ZBR*ZBR + ZBI*ZBI + W2I = CONEI - ZBR*ZBI - ZBR*ZBI + AW2 = ZABS(W2R,W2I) + IF (AW2.GT.0.25D0) GO TO 130 +C----------------------------------------------------------------------- +C POWER SERIES FOR CABS(W2).LE.0.25D0 +C----------------------------------------------------------------------- + K = 1 + PR(1) = CONER + PI(1) = CONEI + SUMAR = GAMA(1) + SUMAI = ZEROI + AP(1) = 1.0D0 + IF (AW2.LT.TOL) GO TO 20 + DO 10 K=2,30 + PR(K) = PR(K-1)*W2R - PI(K-1)*W2I + PI(K) = PR(K-1)*W2I + PI(K-1)*W2R + SUMAR = SUMAR + PR(K)*GAMA(K) + SUMAI = SUMAI + PI(K)*GAMA(K) + AP(K) = AP(K-1)*AW2 + IF (AP(K).LT.TOL) GO TO 20 + 10 CONTINUE + K = 30 + 20 CONTINUE + KMAX = K + ZETAR = W2R*SUMAR - W2I*SUMAI + ZETAI = W2R*SUMAI + W2I*SUMAR + ARGR = ZETAR*FN23 + ARGI = ZETAI*FN23 + CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI) + CALL ZSQRT(W2R, W2I, STR, STI) + ZETA2R = STR*FNU + ZETA2I = STI*FNU + STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI) + STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR) + ZETA1R = STR*ZETA2R - STI*ZETA2I + ZETA1I = STR*ZETA2I + STI*ZETA2R + ZAR = ZAR + ZAR + ZAI = ZAI + ZAI + CALL ZSQRT(ZAR, ZAI, STR, STI) + PHIR = STR*RFN13 + PHII = STI*RFN13 + IF (IPMTR.EQ.1) GO TO 120 +C----------------------------------------------------------------------- +C SUM SERIES FOR ASUM AND BSUM +C----------------------------------------------------------------------- + SUMBR = ZEROR + SUMBI = ZEROI + DO 30 K=1,KMAX + SUMBR = SUMBR + PR(K)*BETA(K) + SUMBI = SUMBI + PI(K)*BETA(K) + 30 CONTINUE + ASUMR = ZEROR + ASUMI = ZEROI + BSUMR = SUMBR + BSUMI = SUMBI + L1 = 0 + L2 = 30 + BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) + ATOL = TOL + PP = 1.0D0 + IAS = 0 + IBS = 0 + IF (RFNU2.LT.TOL) GO TO 110 + DO 100 IS=2,7 + ATOL = ATOL/RFNU2 + PP = PP*RFNU2 + IF (IAS.EQ.1) GO TO 60 + SUMAR = ZEROR + SUMAI = ZEROI + DO 40 K=1,KMAX + M = L1 + K + SUMAR = SUMAR + PR(K)*ALFA(M) + SUMAI = SUMAI + PI(K)*ALFA(M) + IF (AP(K).LT.ATOL) GO TO 50 + 40 CONTINUE + 50 CONTINUE + ASUMR = ASUMR + SUMAR*PP + ASUMI = ASUMI + SUMAI*PP + IF (PP.LT.TOL) IAS = 1 + 60 CONTINUE + IF (IBS.EQ.1) GO TO 90 + SUMBR = ZEROR + SUMBI = ZEROI + DO 70 K=1,KMAX + M = L2 + K + SUMBR = SUMBR + PR(K)*BETA(M) + SUMBI = SUMBI + PI(K)*BETA(M) + IF (AP(K).LT.ATOL) GO TO 80 + 70 CONTINUE + 80 CONTINUE + BSUMR = BSUMR + SUMBR*PP + BSUMI = BSUMI + SUMBI*PP + IF (PP.LT.BTOL) IBS = 1 + 90 CONTINUE + IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110 + L1 = L1 + 30 + L2 = L2 + 30 + 100 CONTINUE + 110 CONTINUE + ASUMR = ASUMR + CONER + PP = RFNU*RFN13 + BSUMR = BSUMR*PP + BSUMI = BSUMI*PP + 120 CONTINUE + RETURN +C----------------------------------------------------------------------- +C CABS(W2).GT.0.25D0 +C----------------------------------------------------------------------- + 130 CONTINUE + CALL ZSQRT(W2R, W2I, WR, WI) + IF (WR.LT.0.0D0) WR = 0.0D0 + IF (WI.LT.0.0D0) WI = 0.0D0 + STR = CONER + WR + STI = WI + CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI) + CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM) + IF (ZCI.LT.0.0D0) ZCI = 0.0D0 + IF (ZCI.GT.HPI) ZCI = HPI + IF (ZCR.LT.0.0D0) ZCR = 0.0D0 + ZTHR = (ZCR-WR)*1.5D0 + ZTHI = (ZCI-WI)*1.5D0 + ZETA1R = ZCR*FNU + ZETA1I = ZCI*FNU + ZETA2R = WR*FNU + ZETA2I = WI*FNU + AZTH = ZABS(ZTHR,ZTHI) + ANG = THPI + IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140 + ANG = HPI + IF (ZTHR.EQ.0.0D0) GO TO 140 + ANG = DATAN(ZTHI/ZTHR) + IF (ZTHR.LT.0.0D0) ANG = ANG + GPI + 140 CONTINUE + PP = AZTH**EX2 + ANG = ANG*EX2 + ZETAR = PP*DCOS(ANG) + ZETAI = PP*DSIN(ANG) + IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0 + ARGR = ZETAR*FN23 + ARGI = ZETAI*FN23 + CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI) + CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI) + TZAR = ZAR + ZAR + TZAI = ZAI + ZAI + CALL ZSQRT(TZAR, TZAI, STR, STI) + PHIR = STR*RFN13 + PHII = STI*RFN13 + IF (IPMTR.EQ.1) GO TO 120 + RAW = 1.0D0/DSQRT(AW2) + STR = WR*RAW + STI = -WI*RAW + TFNR = STR*RFNU*RAW + TFNI = STI*RFNU*RAW + RAZTH = 1.0D0/AZTH + STR = ZTHR*RAZTH + STI = -ZTHI*RAZTH + RZTHR = STR*RAZTH*RFNU + RZTHI = STI*RAZTH*RFNU + ZCR = RZTHR*AR(2) + ZCI = RZTHI*AR(2) + RAW2 = 1.0D0/AW2 + STR = W2R*RAW2 + STI = -W2I*RAW2 + T2R = STR*RAW2 + T2I = STI*RAW2 + STR = T2R*C(2) + C(3) + STI = T2I*C(2) + UPR(2) = STR*TFNR - STI*TFNI + UPI(2) = STR*TFNI + STI*TFNR + BSUMR = UPR(2) + ZCR + BSUMI = UPI(2) + ZCI + ASUMR = ZEROR + ASUMI = ZEROI + IF (RFNU.LT.TOL) GO TO 220 + PRZTHR = RZTHR + PRZTHI = RZTHI + PTFNR = TFNR + PTFNI = TFNI + UPR(1) = CONER + UPI(1) = CONEI + PP = 1.0D0 + BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI)) + KS = 0 + KP1 = 2 + L = 3 + IAS = 0 + IBS = 0 + DO 210 LR=2,12,2 + LRP1 = LR + 1 +C----------------------------------------------------------------------- +C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN +C NEXT SUMA AND SUMB +C----------------------------------------------------------------------- + DO 160 K=LR,LRP1 + KS = KS + 1 + KP1 = KP1 + 1 + L = L + 1 + ZAR = C(L) + ZAI = ZEROI + DO 150 J=2,KP1 + L = L + 1 + STR = ZAR*T2R - T2I*ZAI + C(L) + ZAI = ZAR*T2I + ZAI*T2R + ZAR = STR + 150 CONTINUE + STR = PTFNR*TFNR - PTFNI*TFNI + PTFNI = PTFNR*TFNI + PTFNI*TFNR + PTFNR = STR + UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI + UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI + CRR(KS) = PRZTHR*BR(KS+1) + CRI(KS) = PRZTHI*BR(KS+1) + STR = PRZTHR*RZTHR - PRZTHI*RZTHI + PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR + PRZTHR = STR + DRR(KS) = PRZTHR*AR(KS+2) + DRI(KS) = PRZTHI*AR(KS+2) + 160 CONTINUE + PP = PP*RFNU2 + IF (IAS.EQ.1) GO TO 180 + SUMAR = UPR(LRP1) + SUMAI = UPI(LRP1) + JU = LRP1 + DO 170 JR=1,LR + JU = JU - 1 + SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU) + SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU) + 170 CONTINUE + ASUMR = ASUMR + SUMAR + ASUMI = ASUMI + SUMAI + TEST = DABS(SUMAR) + DABS(SUMAI) + IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1 + 180 CONTINUE + IF (IBS.EQ.1) GO TO 200 + SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI + SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR + JU = LRP1 + DO 190 JR=1,LR + JU = JU - 1 + SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU) + SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU) + 190 CONTINUE + BSUMR = BSUMR + SUMBR + BSUMI = BSUMI + SUMBI + TEST = DABS(SUMBR) + DABS(SUMBI) + IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1 + 200 CONTINUE + IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220 + 210 CONTINUE + 220 CONTINUE + ASUMR = ASUMR + CONER + STR = -BSUMR*RFN13 + STI = -BSUMI*RFN13 + CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI) + GO TO 120 + END + SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZUNK1 +C***REFER TO ZBESK +C +C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE +C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE +C UNIFORM ASYMPTOTIC EXPANSION. +C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. +C NZ=-1 MEANS AN OVERFLOW WILL OCCUR +C +C***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS +C***END PROLOGUE ZUNK1 +C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, +C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR + EXTERNAL ZABS + DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, + * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, + * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, + * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, + * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, + * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, + * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, + * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M + DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), + * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), + * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / + DATA PI / 3.14159265358979324D0 / +C + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + J = 2 + DO 70 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + DBLE(FLOAT(I-1)) + INIT(J) = 0 + CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), + * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), + * CWRKR(1,J), CWRKI(1,J)) + IF (KODE.EQ.1) GO TO 20 + STR = ZRR + ZETA2R(J) + STI = ZRI + ZETA2I(J) + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZETA1R(J) - STR + S1I = ZETA1I(J) - STI + GO TO 30 + 20 CONTINUE + S1R = ZETA1R(J) - ZETA2R(J) + S1I = ZETA1I(J) - ZETA2I(J) + 30 CONTINUE + RS1 = S1R +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + IF (DABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 2 + IF (DABS(RS1).LT.ALIM) GO TO 40 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIR(J),PHII(J)) + RS1 = RS1 + DLOG(APHI) + IF (DABS(RS1).GT.ELIM) GO TO 60 + IF (KDFLG.EQ.1) KFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 40 + IF (KDFLG.EQ.1) KFLAG = 3 + 40 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR +C EXPONENT EXTREMES +C----------------------------------------------------------------------- + S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J) + S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J) + STR = DEXP(S1R)*CSSR(KFLAG) + S1R = STR*DCOS(S1I) + S1I = STR*DSIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S1R*S2I + S2R*S1I + S2R = STR + IF (KFLAG.NE.1) GO TO 50 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 60 + 50 CONTINUE + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + YR(I) = S2R*CSRR(KFLAG) + YI(I) = S2I*CSRR(KFLAG) + IF (KDFLG.EQ.2) GO TO 75 + KDFLG = 2 + GO TO 70 + 60 CONTINUE + IF (RS1.GT.0.0D0) GO TO 300 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 300 + KDFLG = 1 + YR(I)=ZEROR + YI(I)=ZEROI + NZ=NZ+1 + IF (I.EQ.1) GO TO 70 + IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70 + YR(I-1)=ZEROR + YI(I-1)=ZEROI + NZ=NZ+1 + 70 CONTINUE + I = N + 75 CONTINUE + RAZR = 1.0D0/ZABS(ZRR,ZRI) + STR = ZRR*RAZR + STI = -ZRI*RAZR + RZR = (STR+STR)*RAZR + RZI = (STI+STI)*RAZR + CKR = FN*RZR + CKI = FN*RZI + IB = I + 1 + IF (N.LT.IB) GO TO 160 +C----------------------------------------------------------------------- +C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO +C ON UNDERFLOW. +C----------------------------------------------------------------------- + FN = FNU + DBLE(FLOAT(N-1)) + IPARD = 1 + IF (MR.NE.0) IPARD = 0 + INITD = 0 + CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, + * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), + * CWRKI(1,3)) + IF (KODE.EQ.1) GO TO 80 + STR = ZRR + ZET2DR + STI = ZRI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZET1DR - STR + S1I = ZET1DI - STI + GO TO 90 + 80 CONTINUE + S1R = ZET1DR - ZET2DR + S1I = ZET1DI - ZET2DI + 90 CONTINUE + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 95 + IF (DABS(RS1).LT.ALIM) GO TO 100 +C---------------------------------------------------------------------------- +C REFINE ESTIMATE AND TEST +C------------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + RS1 = RS1+DLOG(APHI) + IF (DABS(RS1).LT.ELIM) GO TO 100 + 95 CONTINUE + IF (DABS(RS1).GT.0.0D0) GO TO 300 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 300 + NZ = N + DO 96 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 96 CONTINUE + RETURN +C--------------------------------------------------------------------------- +C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE +C---------------------------------------------------------------------------- + 100 CONTINUE + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 120 I=IB,N + C2R = S2R + C2I = S2I + S2R = CKR*C2R - CKI*C2I + S1R + S2I = CKR*C2I + CKI*C2R + S1I + S1R = C2R + S1I = C2I + CKR = CKR + RZR + CKI = CKI + RZI + C2R = S2R*C1R + C2I = S2I*C1R + YR(I) = C2R + YI(I) = C2I + IF (KFLAG.GE.3) GO TO 120 + STR = DABS(C2R) + STI = DABS(C2I) + C2M = DMAX1(STR,STI) + IF (C2M.LE.ASCLE) GO TO 120 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + C1R = CSRR(KFLAG) + 120 CONTINUE + 160 CONTINUE + IF (MR.EQ.0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 +C----------------------------------------------------------------------- + NZ = 0 + FMR = DBLE(FLOAT(MR)) + SGN = -DSIGN(PI,FMR) +C----------------------------------------------------------------------- +C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. +C----------------------------------------------------------------------- + CSGNI = SGN + INU = INT(SNGL(FNU)) + FNF = FNU - DBLE(FLOAT(INU)) + IFN = INU + N - 1 + ANG = FNF*SGN + CSPNR = DCOS(ANG) + CSPNI = DSIN(ANG) + IF (MOD(IFN,2).EQ.0) GO TO 170 + CSPNR = -CSPNR + CSPNI = -CSPNI + 170 CONTINUE + ASC = BRY(1) + IUF = 0 + KK = N + KDFLG = 1 + IB = IB - 1 + IC = IB - 1 + DO 270 K=1,N + FN = FNU + DBLE(FLOAT(KK-1)) +C----------------------------------------------------------------------- +C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K +C FUNCTION ABOVE +C----------------------------------------------------------------------- + M=3 + IF (N.GT.2) GO TO 175 + 172 CONTINUE + INITD = INIT(J) + PHIDR = PHIR(J) + PHIDI = PHII(J) + ZET1DR = ZETA1R(J) + ZET1DI = ZETA1I(J) + ZET2DR = ZETA2R(J) + ZET2DI = ZETA2I(J) + SUMDR = SUMR(J) + SUMDI = SUMI(J) + M = J + J = 3 - J + GO TO 180 + 175 CONTINUE + IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180 + IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 + INITD = 0 + 180 CONTINUE + CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, + * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, + * CWRKR(1,M), CWRKI(1,M)) + IF (KODE.EQ.1) GO TO 200 + STR = ZRR + ZET2DR + STI = ZRI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZET1DR + STR + S1I = -ZET1DI + STI + GO TO 210 + 200 CONTINUE + S1R = -ZET1DR + ZET2DR + S1I = -ZET1DI + ZET2DI + 210 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 260 + IF (KDFLG.EQ.1) IFLAG = 2 + IF (DABS(RS1).LT.ALIM) GO TO 220 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + RS1 = RS1 + DLOG(APHI) + IF (DABS(RS1).GT.ELIM) GO TO 260 + IF (KDFLG.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 220 + IF (KDFLG.EQ.1) IFLAG = 3 + 220 CONTINUE + STR = PHIDR*SUMDR - PHIDI*SUMDI + STI = PHIDR*SUMDI + PHIDI*SUMDR + S2R = -CSGNI*STI + S2I = CSGNI*STR + STR = DEXP(S1R)*CSSR(IFLAG) + S1R = STR*DCOS(S1I) + S1I = STR*DSIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 230 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.EQ.0) GO TO 230 + S2R = ZEROR + S2I = ZEROI + 230 CONTINUE + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + C2R = S2R + C2I = S2I + S2R = S2R*CSRR(IFLAG) + S2I = S2I*CSRR(IFLAG) +C----------------------------------------------------------------------- +C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N +C----------------------------------------------------------------------- + S1R = YR(KK) + S1I = YI(KK) + IF (KODE.EQ.1) GO TO 250 + CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 250 CONTINUE + YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R + YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 + KDFLG = 1 + GO TO 270 + 255 CONTINUE + IF (KDFLG.EQ.2) GO TO 275 + KDFLG = 2 + GO TO 270 + 260 CONTINUE + IF (RS1.GT.0.0D0) GO TO 300 + S2R = ZEROR + S2I = ZEROI + GO TO 230 + 270 CONTINUE + K = N + 275 CONTINUE + IL = N - K + IF (IL.EQ.0) RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE +C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP +C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. +C----------------------------------------------------------------------- + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + CSR = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + FN = DBLE(FLOAT(INU+IL)) + DO 290 I=1,IL + C2R = S2R + C2I = S2I + S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + FN = FN - 1.0D0 + C2R = S2R*CSR + C2I = S2I*CSR + CKR = C2R + CKI = C2I + C1R = YR(KK) + C1I = YI(KK) + IF (KODE.EQ.1) GO TO 280 + CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 280 CONTINUE + YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R + YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (IFLAG.GE.3) GO TO 290 + C2R = DABS(CKR) + C2I = DABS(CKI) + C2M = DMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 290 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSR + S1I = S1I*CSR + S2R = CKR + S2I = CKI + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + CSR = CSRR(IFLAG) + 290 CONTINUE + RETURN + 300 CONTINUE + NZ = -1 + RETURN + END + SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZUNK2 +C***REFER TO ZBESK +C +C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE +C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE +C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) +C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR +C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT +C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- +C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. +C NZ=-1 MEANS AN OVERFLOW WILL OCCUR +C +C***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS +C***END PROLOGUE ZUNK2 +C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, +C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, +C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR + EXTERNAL ZABS + DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, + * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, + * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, + * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, + * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, + * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, + * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, + * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, + * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, + * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, + * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC + DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), + * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), + * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), + * CIPI(4), CSSR(3), CSRR(3) + DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / + 1 0.0D0, 0.0D0, 1.0D0, + 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / + DATA HPI, PI, AIC / + 1 1.57079632679489662D+00, 3.14159265358979324D+00, + 1 1.26551212348464539D+00/ + DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), + * CIPI(4) / + 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / +C + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + YY = ZRI + ZNR = ZRI + ZNI = -ZRR + ZBR = ZRR + ZBI = ZRI + INU = INT(SNGL(FNU)) + FNF = FNU - DBLE(FLOAT(INU)) + ANG = -HPI*FNF + CAR = DCOS(ANG) + SAR = DSIN(ANG) + C2R = HPI*SAR + C2I = -HPI*CAR + KK = MOD(INU,4) + 1 + STR = C2R*CIPR(KK) - C2I*CIPI(KK) + STI = C2R*CIPI(KK) + C2I*CIPR(KK) + CSR = CR1R*STR - CR1I*STI + CSI = CR1R*STI + CR1I*STR + IF (YY.GT.0.0D0) GO TO 20 + ZNR = -ZNR + ZBI = -ZBI + 20 CONTINUE +C----------------------------------------------------------------------- +C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST +C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY +C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS +C----------------------------------------------------------------------- + J = 2 + DO 80 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + DBLE(FLOAT(I-1)) + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), + * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), + * ASUMI(J), BSUMR(J), BSUMI(J)) + IF (KODE.EQ.1) GO TO 30 + STR = ZBR + ZETA2R(J) + STI = ZBI + ZETA2I(J) + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZETA1R(J) - STR + S1I = ZETA1I(J) - STI + GO TO 40 + 30 CONTINUE + S1R = ZETA1R(J) - ZETA2R(J) + S1I = ZETA1I(J) - ZETA2I(J) + 40 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 70 + IF (KDFLG.EQ.1) KFLAG = 2 + IF (DABS(RS1).LT.ALIM) GO TO 50 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIR(J),PHII(J)) + AARG = ZABS(ARGR(J),ARGI(J)) + RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC + IF (DABS(RS1).GT.ELIM) GO TO 70 + IF (KDFLG.EQ.1) KFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 50 + IF (KDFLG.EQ.1) KFLAG = 3 + 50 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR +C EXPONENT EXTREMES +C----------------------------------------------------------------------- + C2R = ARGR(J)*CR2R - ARGI(J)*CR2I + C2I = ARGR(J)*CR2I + ARGI(J)*CR2R + CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM) + CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM) + STR = DAIR*BSUMR(J) - DAII*BSUMI(J) + STI = DAIR*BSUMI(J) + DAII*BSUMR(J) + PTR = STR*CR2R - STI*CR2I + PTI = STR*CR2I + STI*CR2R + STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J)) + STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J)) + PTR = STR*PHIR(J) - STI*PHII(J) + PTI = STR*PHII(J) + STI*PHIR(J) + S2R = PTR*CSR - PTI*CSI + S2I = PTR*CSI + PTI*CSR + STR = DEXP(S1R)*CSSR(KFLAG) + S1R = STR*DCOS(S1I) + S1I = STR*DSIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S1R*S2I + S2R*S1I + S2R = STR + IF (KFLAG.NE.1) GO TO 60 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 70 + 60 CONTINUE + IF (YY.LE.0.0D0) S2I = -S2I + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + YR(I) = S2R*CSRR(KFLAG) + YI(I) = S2I*CSRR(KFLAG) + STR = CSI + CSI = -CSR + CSR = STR + IF (KDFLG.EQ.2) GO TO 85 + KDFLG = 2 + GO TO 80 + 70 CONTINUE + IF (RS1.GT.0.0D0) GO TO 320 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 320 + KDFLG = 1 + YR(I)=ZEROR + YI(I)=ZEROI + NZ=NZ+1 + STR = CSI + CSI =-CSR + CSR = STR + IF (I.EQ.1) GO TO 80 + IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80 + YR(I-1)=ZEROR + YI(I-1)=ZEROI + NZ=NZ+1 + 80 CONTINUE + I = N + 85 CONTINUE + RAZR = 1.0D0/ZABS(ZRR,ZRI) + STR = ZRR*RAZR + STI = -ZRI*RAZR + RZR = (STR+STR)*RAZR + RZI = (STI+STI)*RAZR + CKR = FN*RZR + CKI = FN*RZI + IB = I + 1 + IF (N.LT.IB) GO TO 180 +C----------------------------------------------------------------------- +C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO +C ON UNDERFLOW. +C----------------------------------------------------------------------- + FN = FNU + DBLE(FLOAT(N-1)) + IPARD = 1 + IF (MR.NE.0) IPARD = 0 + CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, + * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI) + IF (KODE.EQ.1) GO TO 90 + STR = ZBR + ZET2DR + STI = ZBI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = ZET1DR - STR + S1I = ZET1DI - STI + GO TO 100 + 90 CONTINUE + S1R = ZET1DR - ZET2DR + S1I = ZET1DI - ZET2DI + 100 CONTINUE + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 105 + IF (DABS(RS1).LT.ALIM) GO TO 120 +C---------------------------------------------------------------------------- +C REFINE ESTIMATE AND TEST +C------------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + RS1 = RS1+DLOG(APHI) + IF (DABS(RS1).LT.ELIM) GO TO 120 + 105 CONTINUE + IF (RS1.GT.0.0D0) GO TO 320 +C----------------------------------------------------------------------- +C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW +C----------------------------------------------------------------------- + IF (ZR.LT.0.0D0) GO TO 320 + NZ = N + DO 106 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 106 CONTINUE + RETURN + 120 CONTINUE + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(KFLAG) + ASCLE = BRY(KFLAG) + DO 130 I=IB,N + C2R = S2R + C2I = S2I + S2R = CKR*C2R - CKI*C2I + S1R + S2I = CKR*C2I + CKI*C2R + S1I + S1R = C2R + S1I = C2I + CKR = CKR + RZR + CKI = CKI + RZI + C2R = S2R*C1R + C2I = S2I*C1R + YR(I) = C2R + YI(I) = C2I + IF (KFLAG.GE.3) GO TO 130 + STR = DABS(C2R) + STI = DABS(C2I) + C2M = DMAX1(STR,STI) + IF (C2M.LE.ASCLE) GO TO 130 + KFLAG = KFLAG + 1 + ASCLE = BRY(KFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(KFLAG) + S1I = S1I*CSSR(KFLAG) + S2R = S2R*CSSR(KFLAG) + S2I = S2I*CSSR(KFLAG) + C1R = CSRR(KFLAG) + 130 CONTINUE + 180 CONTINUE + IF (MR.EQ.0) RETURN +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 +C----------------------------------------------------------------------- + NZ = 0 + FMR = DBLE(FLOAT(MR)) + SGN = -DSIGN(PI,FMR) +C----------------------------------------------------------------------- +C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. +C----------------------------------------------------------------------- + CSGNI = SGN + IF (YY.LE.0.0D0) CSGNI = -CSGNI + IFN = INU + N - 1 + ANG = FNF*SGN + CSPNR = DCOS(ANG) + CSPNI = DSIN(ANG) + IF (MOD(IFN,2).EQ.0) GO TO 190 + CSPNR = -CSPNR + CSPNI = -CSPNI + 190 CONTINUE +C----------------------------------------------------------------------- +C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS +C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST +C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY +C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS +C----------------------------------------------------------------------- + CSR = SAR*CSGNI + CSI = CAR*CSGNI + IN = MOD(IFN,4) + 1 + C2R = CIPR(IN) + C2I = CIPI(IN) + STR = CSR*C2R + CSI*C2I + CSI = -CSR*C2I + CSI*C2R + CSR = STR + ASC = BRY(1) + IUF = 0 + KK = N + KDFLG = 1 + IB = IB - 1 + IC = IB - 1 + DO 290 K=1,N + FN = FNU + DBLE(FLOAT(KK-1)) +C----------------------------------------------------------------------- +C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K +C FUNCTION ABOVE +C----------------------------------------------------------------------- + IF (N.GT.2) GO TO 175 + 172 CONTINUE + PHIDR = PHIR(J) + PHIDI = PHII(J) + ARGDR = ARGR(J) + ARGDI = ARGI(J) + ZET1DR = ZETA1R(J) + ZET1DI = ZETA1I(J) + ZET2DR = ZETA2R(J) + ZET2DI = ZETA2I(J) + ASUMDR = ASUMR(J) + ASUMDI = ASUMI(J) + BSUMDR = BSUMR(J) + BSUMDI = BSUMI(J) + J = 3 - J + GO TO 210 + 175 CONTINUE + IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210 + IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172 + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, + * ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, + * ASUMDI, BSUMDR, BSUMDI) + 210 CONTINUE + IF (KODE.EQ.1) GO TO 220 + STR = ZBR + ZET2DR + STI = ZBI + ZET2DI + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZET1DR + STR + S1I = -ZET1DI + STI + GO TO 230 + 220 CONTINUE + S1R = -ZET1DR + ZET2DR + S1I = -ZET1DI + ZET2DI + 230 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 280 + IF (KDFLG.EQ.1) IFLAG = 2 + IF (DABS(RS1).LT.ALIM) GO TO 240 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIDR,PHIDI) + AARG = ZABS(ARGDR,ARGDI) + RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC + IF (DABS(RS1).GT.ELIM) GO TO 280 + IF (KDFLG.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 240 + IF (KDFLG.EQ.1) IFLAG = 3 + 240 CONTINUE + CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM) + CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM) + STR = DAIR*BSUMDR - DAII*BSUMDI + STI = DAIR*BSUMDI + DAII*BSUMDR + STR = STR + (AIR*ASUMDR-AII*ASUMDI) + STI = STI + (AIR*ASUMDI+AII*ASUMDR) + PTR = STR*PHIDR - STI*PHIDI + PTI = STR*PHIDI + STI*PHIDR + S2R = PTR*CSR - PTI*CSI + S2I = PTR*CSI + PTI*CSR + STR = DEXP(S1R)*CSSR(IFLAG) + S1R = STR*DCOS(S1I) + S1I = STR*DSIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 250 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.EQ.0) GO TO 250 + S2R = ZEROR + S2I = ZEROI + 250 CONTINUE + IF (YY.LE.0.0D0) S2I = -S2I + CYR(KDFLG) = S2R + CYI(KDFLG) = S2I + C2R = S2R + C2I = S2I + S2R = S2R*CSRR(IFLAG) + S2I = S2I*CSRR(IFLAG) +C----------------------------------------------------------------------- +C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N +C----------------------------------------------------------------------- + S1R = YR(KK) + S1I = YI(KK) + IF (KODE.EQ.1) GO TO 270 + CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 270 CONTINUE + YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R + YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + STR = CSI + CSI = -CSR + CSR = STR + IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255 + KDFLG = 1 + GO TO 290 + 255 CONTINUE + IF (KDFLG.EQ.2) GO TO 295 + KDFLG = 2 + GO TO 290 + 280 CONTINUE + IF (RS1.GT.0.0D0) GO TO 320 + S2R = ZEROR + S2I = ZEROI + GO TO 250 + 290 CONTINUE + K = N + 295 CONTINUE + IL = N - K + IF (IL.EQ.0) RETURN +C----------------------------------------------------------------------- +C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE +C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP +C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. +C----------------------------------------------------------------------- + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + CSR = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + FN = DBLE(FLOAT(INU+IL)) + DO 310 I=1,IL + C2R = S2R + C2I = S2I + S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + FN = FN - 1.0D0 + C2R = S2R*CSR + C2I = S2I*CSR + CKR = C2R + CKI = C2I + C1R = YR(KK) + C1I = YI(KK) + IF (KODE.EQ.1) GO TO 300 + CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF) + NZ = NZ + NW + 300 CONTINUE + YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R + YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I + KK = KK - 1 + CSPNR = -CSPNR + CSPNI = -CSPNI + IF (IFLAG.GE.3) GO TO 310 + C2R = DABS(CKR) + C2I = DABS(CKI) + C2M = DMAX1(C2R,C2I) + IF (C2M.LE.ASCLE) GO TO 310 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSR + S1I = S1I*CSR + S2R = CKR + S2I = CKI + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + CSR = CSRR(IFLAG) + 310 CONTINUE + RETURN + 320 CONTINUE + NZ = -1 + RETURN + END + SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, + * FNUL, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZBUNI +C***REFER TO ZBESI,ZBESK +C +C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. +C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM +C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) +C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 +C +C***ROUTINES CALLED ZUNI1,ZUNI2,ZABS,D1MACH +C***END PROLOGUE ZBUNI +C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z + EXTERNAL ZABS + DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, + * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, + * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, + * D1MACH + INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) + NZ = 0 + AX = DABS(ZR)*1.7321D0 + AY = DABS(ZI) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + IF (NUI.EQ.0) GO TO 60 + FNUI = DBLE(FLOAT(NUI)) + DFNU = FNU + DBLE(FLOAT(N-1)) + GNU = DFNU + FNUI + IF (IFORM.EQ.2) GO TO 10 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + 20 CONTINUE + IF (NW.LT.0) GO TO 50 + IF (NW.NE.0) GO TO 90 + STR = ZABS(CYR(1),CYI(1)) +C---------------------------------------------------------------------- +C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED +C---------------------------------------------------------------------- + BRY(1)=1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = BRY(2) + IFLAG = 2 + ASCLE = BRY(2) + CSCLR = 1.0D0 + IF (STR.GT.BRY(1)) GO TO 21 + IFLAG = 1 + ASCLE = BRY(1) + CSCLR = 1.0D0/TOL + GO TO 25 + 21 CONTINUE + IF (STR.LT.BRY(2)) GO TO 25 + IFLAG = 3 + ASCLE=BRY(3) + CSCLR = TOL + 25 CONTINUE + CSCRR = 1.0D0/CSCLR + S1R = CYR(2)*CSCLR + S1I = CYI(2)*CSCLR + S2R = CYR(1)*CSCLR + S2I = CYI(1)*CSCLR + RAZ = 1.0D0/ZABS(ZR,ZI) + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + DO 30 I=1,NUI + STR = S2R + STI = S2I + S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R + S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I + S1R = STR + S1I = STI + FNUI = FNUI - 1.0D0 + IF (IFLAG.GE.3) GO TO 30 + STR = S2R*CSCRR + STI = S2I*CSCRR + C1R = DABS(STR) + C1I = DABS(STI) + C1M = DMAX1(C1R,C1I) + IF (C1M.LE.ASCLE) GO TO 30 + IFLAG = IFLAG+1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSCRR + S1I = S1I*CSCRR + S2R = STR + S2I = STI + CSCLR = CSCLR*TOL + CSCRR = 1.0D0/CSCLR + S1R = S1R*CSCLR + S1I = S1I*CSCLR + S2R = S2R*CSCLR + S2I = S2I*CSCLR + 30 CONTINUE + YR(N) = S2R*CSCRR + YI(N) = S2I*CSCRR + IF (N.EQ.1) RETURN + NL = N - 1 + FNUI = DBLE(FLOAT(NL)) + K = NL + DO 40 I=1,NL + STR = S2R + STI = S2I + S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R + S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I + S1R = STR + S1I = STI + STR = S2R*CSCRR + STI = S2I*CSCRR + YR(K) = STR + YI(K) = STI + FNUI = FNUI - 1.0D0 + K = K - 1 + IF (IFLAG.GE.3) GO TO 40 + C1R = DABS(STR) + C1I = DABS(STI) + C1M = DMAX1(C1R,C1I) + IF (C1M.LE.ASCLE) GO TO 40 + IFLAG = IFLAG+1 + ASCLE = BRY(IFLAG) + S1R = S1R*CSCRR + S1I = S1I*CSCRR + S2R = STR + S2I = STI + CSCLR = CSCLR*TOL + CSCRR = 1.0D0/CSCLR + S1R = S1R*CSCLR + S1I = S1I*CSCLR + S2R = S2R*CSCLR + S2I = S2I*CSCLR + 40 CONTINUE + RETURN + 50 CONTINUE + NZ = -1 + IF(NW.EQ.(-2)) NZ=-2 + RETURN + 60 CONTINUE + IF (IFORM.EQ.2) GO TO 70 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + GO TO 80 + 70 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + 80 CONTINUE + IF (NW.LT.0) GO TO 50 + NZ = NW + RETURN + 90 CONTINUE + NLAST = N + RETURN + END + SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZUNI1 +C***REFER TO ZBESI,ZBESK +C +C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC +C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. +C +C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC +C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. +C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER +C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. +C Y(I)=CZERO FOR I=NLAST+1,N +C +C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS +C***END PROLOGUE ZUNI1 +C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, +C *S2,Y,Z,ZETA1,ZETA2 + EXTERNAL ZABS + DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, + * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, + * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, + * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, + * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS + INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ + DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), + * CSRR(3), CYR(2), CYI(2) + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / +C + NZ = 0 + ND = N + NLAST = 0 +C----------------------------------------------------------------------- +C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- +C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, +C EXP(ALIM)=EXP(ELIM)*TOL +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = DMAX1(FNU,1.0D0) + INIT = 0 + CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + IF (KODE.EQ.1) GO TO 10 + STR = ZR + ZETA2R + STI = ZI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + GO TO 20 + 10 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 20 CONTINUE + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 130 + 30 CONTINUE + NN = MIN0(2,ND) + DO 80 I=1,NN + FN = FNU + DBLE(FLOAT(ND-I)) + INIT = 0 + CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + IF (KODE.EQ.1) GO TO 40 + STR = ZR + ZETA2R + STI = ZI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + ZI + GO TO 50 + 40 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 50 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 110 + IF (I.EQ.1) IFLAG = 2 + IF (DABS(RS1).LT.ALIM) GO TO 60 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- + APHI = ZABS(PHIR,PHII) + RS1 = RS1 + DLOG(APHI) + IF (DABS(RS1).GT.ELIM) GO TO 110 + IF (I.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 60 + IF (I.EQ.1) IFLAG = 3 + 60 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 IF CABS(S1).LT.ASCLE +C----------------------------------------------------------------------- + S2R = PHIR*SUMR - PHII*SUMI + S2I = PHIR*SUMI + PHII*SUMR + STR = DEXP(S1R)*CSSR(IFLAG) + S1R = STR*DCOS(S1I) + S1I = STR*DSIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 70 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 110 + 70 CONTINUE + CYR(I) = S2R + CYI(I) = S2I + M = ND - I + 1 + YR(M) = S2R*CSRR(IFLAG) + YI(M) = S2I*CSRR(IFLAG) + 80 CONTINUE + IF (ND.LE.2) GO TO 100 + RAST = 1.0D0/ZABS(ZR,ZI) + STR = ZR*RAST + STI = -ZI*RAST + RZR = (STR+STR)*RAST + RZI = (STI+STI)*RAST + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + K = ND - 2 + FN = DBLE(FLOAT(K)) + DO 90 I=3,ND + C2R = S2R + C2I = S2I + S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + C2R = S2R*C1R + C2I = S2I*C1R + YR(K) = C2R + YI(K) = C2I + K = K - 1 + FN = FN - 1.0D0 + IF (IFLAG.GE.3) GO TO 90 + STR = DABS(C2R) + STI = DABS(C2I) + C2M = DMAX1(STR,STI) + IF (C2M.LE.ASCLE) GO TO 90 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + C1R = CSRR(IFLAG) + 90 CONTINUE + 100 CONTINUE + RETURN +C----------------------------------------------------------------------- +C SET UNDERFLOW AND UPDATE PARAMETERS +C----------------------------------------------------------------------- + 110 CONTINUE + IF (RS1.GT.0.0D0) GO TO 120 + YR(ND) = ZEROR + YI(ND) = ZEROI + NZ = NZ + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 100 + CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) + IF (NUF.LT.0) GO TO 120 + ND = ND - NUF + NZ = NZ + NUF + IF (ND.EQ.0) GO TO 100 + FN = FNU + DBLE(FLOAT(ND-1)) + IF (FN.GE.FNUL) GO TO 30 + NLAST = ND + RETURN + 120 CONTINUE + NZ = -1 + RETURN + 130 CONTINUE + IF (RS1.GT.0.0D0) GO TO 120 + NZ = N + DO 140 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 140 CONTINUE + RETURN + END + SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZUNI2 +C***REFER TO ZBESI,ZBESK +C +C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF +C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I +C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. +C +C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC +C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. +C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER +C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. +C Y(I)=CZERO FOR I=NLAST+1,N +C +C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS +C***END PROLOGUE ZUNI2 +C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, +C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN + EXTERNAL ZABS + DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, + * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, + * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, + * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, + * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, + * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, + * CYI, D1MACH, ZABS, CAR, SAR + INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, + * NN, NUF, NW, NZ, IDUM + DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), + * CSRR(3), CYR(2), CYI(2) + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / + DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), + * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ + DATA HPI, AIC / + 1 1.57079632679489662D+00, 1.265512123484645396D+00/ +C + NZ = 0 + ND = N + NLAST = 0 +C----------------------------------------------------------------------- +C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- +C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, +C EXP(ALIM)=EXP(ELIM)*TOL +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI +C----------------------------------------------------------------------- + ZNR = ZI + ZNI = -ZR + ZBR = ZR + ZBI = ZI + CIDI = -CONER + INU = INT(SNGL(FNU)) + ANG = HPI*(FNU-DBLE(FLOAT(INU))) + C2R = DCOS(ANG) + C2I = DSIN(ANG) + CAR = C2R + SAR = C2I + IN = INU + N - 1 + IN = MOD(IN,4) + 1 + STR = C2R*CIPR(IN) - C2I*CIPI(IN) + C2I = C2R*CIPI(IN) + C2I*CIPR(IN) + C2R = STR + IF (ZI.GT.0.0D0) GO TO 10 + ZNR = -ZNR + ZBI = -ZBI + CIDI = -CIDI + C2I = -C2I + 10 CONTINUE +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = DMAX1(FNU,1.0D0) + CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + IF (KODE.EQ.1) GO TO 20 + STR = ZBR + ZETA2R + STI = ZBI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + GO TO 30 + 20 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 30 CONTINUE + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 150 + 40 CONTINUE + NN = MIN0(2,ND) + DO 90 I=1,NN + FN = FNU + DBLE(FLOAT(ND-I)) + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + IF (KODE.EQ.1) GO TO 50 + STR = ZBR + ZETA2R + STI = ZBI + ZETA2I + RAST = FN/ZABS(STR,STI) + STR = STR*RAST*RAST + STI = -STI*RAST*RAST + S1R = -ZETA1R + STR + S1I = -ZETA1I + STI + DABS(ZI) + GO TO 60 + 50 CONTINUE + S1R = -ZETA1R + ZETA2R + S1I = -ZETA1I + ZETA2I + 60 CONTINUE +C----------------------------------------------------------------------- +C TEST FOR UNDERFLOW AND OVERFLOW +C----------------------------------------------------------------------- + RS1 = S1R + IF (DABS(RS1).GT.ELIM) GO TO 120 + IF (I.EQ.1) IFLAG = 2 + IF (DABS(RS1).LT.ALIM) GO TO 70 +C----------------------------------------------------------------------- +C REFINE TEST AND SCALE +C----------------------------------------------------------------------- +C----------------------------------------------------------------------- + APHI = ZABS(PHIR,PHII) + AARG = ZABS(ARGR,ARGI) + RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC + IF (DABS(RS1).GT.ELIM) GO TO 120 + IF (I.EQ.1) IFLAG = 1 + IF (RS1.LT.0.0D0) GO TO 70 + IF (I.EQ.1) IFLAG = 3 + 70 CONTINUE +C----------------------------------------------------------------------- +C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR +C EXPONENT EXTREMES +C----------------------------------------------------------------------- + CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM) + CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM) + STR = DAIR*BSUMR - DAII*BSUMI + STI = DAIR*BSUMI + DAII*BSUMR + STR = STR + (AIR*ASUMR-AII*ASUMI) + STI = STI + (AIR*ASUMI+AII*ASUMR) + S2R = PHIR*STR - PHII*STI + S2I = PHIR*STI + PHII*STR + STR = DEXP(S1R)*CSSR(IFLAG) + S1R = STR*DCOS(S1I) + S1I = STR*DSIN(S1I) + STR = S2R*S1R - S2I*S1I + S2I = S2R*S1I + S2I*S1R + S2R = STR + IF (IFLAG.NE.1) GO TO 80 + CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL) + IF (NW.NE.0) GO TO 120 + 80 CONTINUE + IF (ZI.LE.0.0D0) S2I = -S2I + STR = S2R*C2R - S2I*C2I + S2I = S2R*C2I + S2I*C2R + S2R = STR + CYR(I) = S2R + CYI(I) = S2I + J = ND - I + 1 + YR(J) = S2R*CSRR(IFLAG) + YI(J) = S2I*CSRR(IFLAG) + STR = -C2I*CIDI + C2I = C2R*CIDI + C2R = STR + 90 CONTINUE + IF (ND.LE.2) GO TO 110 + RAZ = 1.0D0/ZABS(ZR,ZI) + STR = ZR*RAZ + STI = -ZI*RAZ + RZR = (STR+STR)*RAZ + RZI = (STI+STI)*RAZ + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + S1R = CYR(1) + S1I = CYI(1) + S2R = CYR(2) + S2I = CYI(2) + C1R = CSRR(IFLAG) + ASCLE = BRY(IFLAG) + K = ND - 2 + FN = DBLE(FLOAT(K)) + DO 100 I=3,ND + C2R = S2R + C2I = S2I + S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I) + S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R) + S1R = C2R + S1I = C2I + C2R = S2R*C1R + C2I = S2I*C1R + YR(K) = C2R + YI(K) = C2I + K = K - 1 + FN = FN - 1.0D0 + IF (IFLAG.GE.3) GO TO 100 + STR = DABS(C2R) + STI = DABS(C2I) + C2M = DMAX1(STR,STI) + IF (C2M.LE.ASCLE) GO TO 100 + IFLAG = IFLAG + 1 + ASCLE = BRY(IFLAG) + S1R = S1R*C1R + S1I = S1I*C1R + S2R = C2R + S2I = C2I + S1R = S1R*CSSR(IFLAG) + S1I = S1I*CSSR(IFLAG) + S2R = S2R*CSSR(IFLAG) + S2I = S2I*CSSR(IFLAG) + C1R = CSRR(IFLAG) + 100 CONTINUE + 110 CONTINUE + RETURN + 120 CONTINUE + IF (RS1.GT.0.0D0) GO TO 140 +C----------------------------------------------------------------------- +C SET UNDERFLOW AND UPDATE PARAMETERS +C----------------------------------------------------------------------- + YR(ND) = ZEROR + YI(ND) = ZEROI + NZ = NZ + 1 + ND = ND - 1 + IF (ND.EQ.0) GO TO 110 + CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM) + IF (NUF.LT.0) GO TO 140 + ND = ND - NUF + NZ = NZ + NUF + IF (ND.EQ.0) GO TO 110 + FN = FNU + DBLE(FLOAT(ND-1)) + IF (FN.LT.FNUL) GO TO 130 +C FN = CIDI +C J = NUF + 1 +C K = MOD(J,4) + 1 +C S1R = CIPR(K) +C S1I = CIPI(K) +C IF (FN.LT.0.0D0) S1I = -S1I +C STR = C2R*S1R - C2I*S1I +C C2I = C2R*S1I + C2I*S1R +C C2R = STR + IN = INU + ND - 1 + IN = MOD(IN,4) + 1 + C2R = CAR*CIPR(IN) - SAR*CIPI(IN) + C2I = CAR*CIPI(IN) + SAR*CIPR(IN) + IF (ZI.LE.0.0D0) C2I = -C2I + GO TO 40 + 130 CONTINUE + NLAST = ND + RETURN + 140 CONTINUE + NZ = -1 + RETURN + 150 CONTINUE + IF (RS1.GT.0.0D0) GO TO 140 + NZ = N + DO 160 I=1,N + YR(I) = ZEROR + YI(I) = ZEROI + 160 CONTINUE + RETURN + END + SUBROUTINE XERROR(MESS,NMESS,L1,L2) +C +C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS +C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL +C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 +C ROUTINE. +C + INTEGER NMESS, L1, L2, NN, NR, K, I, KMIN + CHARACTER*(*) MESS + NN=NMESS/70 + NR=NMESS-70*NN + IF(NR.NE.0) NN=NN+1 + K=1 + PRINT 900 + 900 FORMAT(/) + DO 10 I=1,NN + KMIN=MIN0(K+69,NMESS) + PRINT *, MESS(K:KMIN) + K=K+70 + 10 CONTINUE + PRINT 900 + RETURN + END + DOUBLE PRECISION FUNCTION D1MACH(I) +C +C DOUBLE-PRECISION MACHINE CONSTANTS +C +C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. +C +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. +C +C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. +C +C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. +C +C D1MACH( 5) = LOG10(B) +C +C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, +C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY +C REMOVING THE C FROM COLUMN 1. +C +C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), ONE OF THE FIRST +C TWO SETS OF CONSTANTS BELOW SHOULD BE APPROPRIATE. +C +C WHERE POSSIBLE, DECIMAL, OCTAL OR HEXADECIMAL CONSTANTS ARE USED +C TO SPECIFY THE CONSTANTS EXACTLY. SOMETIMES THIS REQUIRES USING +C EQUIVALENT INTEGER ARRAYS. IF YOUR COMPILER USES HALF-WORD +C INTEGERS BY DEFAULT (SOMETIMES CALLED INTEGER*2), YOU MAY NEED TO +C CHANGE INTEGER TO INTEGER*4 OR OTHERWISE INSTRUCT YOUR COMPILER +C TO USE FULL-WORD INTEGERS IN THE NEXT 5 DECLARATIONS. +C + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) + INTEGER SC +C + DOUBLE PRECISION DMACH(5) +C + EQUIVALENCE (DMACH(1),SMALL(1)) + EQUIVALENCE (DMACH(2),LARGE(1)) + EQUIVALENCE (DMACH(3),RIGHT(1)) + EQUIVALENCE (DMACH(4),DIVER(1)) + EQUIVALENCE (DMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T +C 3B SERIES AND MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T +C PC 7300), IN WHICH THE MOST SIGNIFICANT BYTE IS STORED FIRST. +C + DATA SMALL(1),SMALL(2) / 1048576, 0 / + DATA LARGE(1),LARGE(2) / 2146435071, -1 / + DATA RIGHT(1),RIGHT(2) / 1017118720, 0 / + DATA DIVER(1),DIVER(2) / 1018167296, 0 / + DATA LOG10(1),LOG10(2) / 1070810131, 1352628735 /, SC/987/ +C +C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES AND 8087-BASED +C MICROS, SUCH AS THE IBM PC AND AT&T 6300, IN WHICH THE LEAST +C SIGNIFICANT BYTE IS STORED FIRST. +C +C DATA SMALL(1),SMALL(2) / 0, 1048576 / +C DATA LARGE(1),LARGE(2) / -1, 2146435071 / +C DATA RIGHT(1),RIGHT(2) / 0, 1017118720 / +C DATA DIVER(1),DIVER(2) / 0, 1018167296 / +C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /, SC/987/ +C +C MACHINE CONSTANTS FOR AMDAHL MACHINES. +C +C DATA SMALL(1),SMALL(2) / 1048576, 0 / +C DATA LARGE(1),LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1),RIGHT(2) / 856686592, 0 / +C DATA DIVER(1),DIVER(2) / 873463808, 0 / +C DATA LOG10(1),LOG10(2) / 1091781651, 1352628735 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 /, SC/987/ +C +C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777774B / +C +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B /, SC/987/ +C +C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. +C +C DATA SMALL(1) / O"00564000000000000000" / +C DATA SMALL(2) / O"00000000000000000000" / +C +C DATA LARGE(1) / O"37757777777777777777" / +C DATA LARGE(2) / O"37157777777777777774" / +C +C DATA RIGHT(1) / O"15624000000000000000" / +C DATA RIGHT(2) / O"00000000000000000000" / +C +C DATA DIVER(1) / O"15634000000000000000" / +C DATA DIVER(2) / O"00000000000000000000" / +C +C DATA LOG10(1) / O"17164642023241175717" / +C DATA LOG10(2) / O"16367571421742254654" /, SC/987/ +C +C MACHINE CONSTANTS FOR CONVEX C-1 +C +C DATA SMALL(1),SMALL(2) / '00100000'X, '00000000'X / +C DATA LARGE(1),LARGE(2) / '7FFFFFFF'X, 'FFFFFFFF'X / +C DATA RIGHT(1),RIGHT(2) / '3CC00000'X, '00000000'X / +C DATA DIVER(1),DIVER(2) / '3CD00000'X, '00000000'X / +C DATA LOG10(1),LOG10(2) / '3FF34413'X, '509F79FF'X /, SC/987/ +C +C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777776B / +C +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B /, SC/987/ +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING LINE - +C STATIC DMACH(5) +C +C DATA SMALL/20K,3*0/,LARGE/77777K,3*177777K/ +C DATA RIGHT/31420K,3*0/,DIVER/32020K,3*0/ +C DATA LOG10/40423K,42023K,50237K,74776K/, SC/987/ +C +C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7 +C +C DATA SMALL(1),SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1),LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1),RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1),DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1),LOG10(2) / '23210115, '10237777 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C +C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C +C DATA SMALL(1),SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1),LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1),RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1),DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1),LOG10(2) / Z41134413, Z509F79FF /, SC/987/ +C +C MACHINE CONSTANTS FOR THE INTERDATA 8/32 +C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. +C +C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE +C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. +C +C DATA SMALL(1),SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1),LARGE(2) / Z'7EFFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1),RIGHT(2) / Z'33100000', Z'00000000' / +C DATA DIVER(1),DIVER(2) / Z'34100000', Z'00000000' / +C DATA LOG10(1),LOG10(2) / Z'41134413', Z'509F79FF' /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C +C DATA SMALL(1),SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1),LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1),RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1),DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1),LOG10(2) / "177464202324, "144117571776 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C +C DATA SMALL(1),SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1),LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1),RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1),DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1),LOG10(2) / "177464202324, "047674776746 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1),SMALL(2) / 8388608, 0 / +C DATA LARGE(1),LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / +C DATA DIVER(1),DIVER(2) / 620756992, 0 / +C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ +C +C DATA SMALL(1),SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1),LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1),RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1),DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1),LOG10(2) / O07746420232, O20476747770 /, SC/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1),SMALL(2) / 128, 0 / +C DATA SMALL(3),SMALL(4) / 0, 0 / +C +C DATA LARGE(1),LARGE(2) / 32767, -1 / +C DATA LARGE(3),LARGE(4) / -1, -1 / +C +C DATA RIGHT(1),RIGHT(2) / 9344, 0 / +C DATA RIGHT(3),RIGHT(4) / 0, 0 / +C +C DATA DIVER(1),DIVER(2) / 9472, 0 / +C DATA DIVER(3),DIVER(4) / 0, 0 / +C +C DATA LOG10(1),LOG10(2) / 16282, 8346 / +C DATA LOG10(3),LOG10(4) / -31493, -12296 /, SC/987/ +C +C DATA SMALL(1),SMALL(2) / O000200, O000000 / +C DATA SMALL(3),SMALL(4) / O000000, O000000 / +C +C DATA LARGE(1),LARGE(2) / O077777, O177777 / +C DATA LARGE(3),LARGE(4) / O177777, O177777 / +C +C DATA RIGHT(1),RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3),RIGHT(4) / O000000, O000000 / +C +C DATA DIVER(1),DIVER(2) / O022400, O000000 / +C DATA DIVER(3),DIVER(4) / O000000, O000000 / +C +C DATA LOG10(1),LOG10(2) / O037632, O020232 / +C DATA LOG10(3),LOG10(4) / O102373, O147770 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS +C WITH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, +C SUPPLIED BY IGOR BRAY. +C +C DATA SMALL(1),SMALL(2) / :10000000000, :00000100001 / +C DATA LARGE(1),LARGE(2) / :17777777777, :37777677775 / +C DATA RIGHT(1),RIGHT(2) / :10000000000, :00000000122 / +C DATA DIVER(1),DIVER(2) / :10000000000, :00000000123 / +C DATA LOG10(1),LOG10(2) / :11504046501, :07674600177 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000 +C +C DATA SMALL(1),SMALL(2) / $00000000, $00100000 / +C DATA LARGE(1),LARGE(2) / $FFFFFFFF, $7FEFFFFF / +C DATA RIGHT(1),RIGHT(2) / $00000000, $3CA00000 / +C DATA DIVER(1),DIVER(2) / $00000000, $3CB00000 / +C DATA LOG10(1),LOG10(2) / $509F79FF, $3FD34413 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE VAX UNIX F77 COMPILER +C +C DATA SMALL(1),SMALL(2) / 128, 0 / +C DATA LARGE(1),LARGE(2) / -32769, -1 / +C DATA RIGHT(1),RIGHT(2) / 9344, 0 / +C DATA DIVER(1),DIVER(2) / 9472, 0 / +C DATA LOG10(1),LOG10(2) / 546979738, -805796613 /, SC/987/ +C +C MACHINE CONSTANTS FOR THE VAX-11 WITH +C FORTRAN IV-PLUS COMPILER +C +C DATA SMALL(1),SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1),LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1),RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1),DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1),LOG10(2) / Z209A3F9A, ZCFF884FB /, SC/987/ +C +C MACHINE CONSTANTS FOR VAX/VMS VERSION 2.2 +C +C DATA SMALL(1),SMALL(2) / '80'X, '0'X / +C DATA LARGE(1),LARGE(2) / 'FFFF7FFF'X, 'FFFFFFFF'X / +C DATA RIGHT(1),RIGHT(2) / '2480'X, '0'X / +C DATA DIVER(1),DIVER(2) / '2500'X, '0'X / +C DATA LOG10(1),LOG10(2) / '209A3F9A'X, 'CFF884FB'X /, SC/987/ +C +C *** ISSUE STOP 779 IF ALL DATA STATEMENTS ARE COMMENTED... + IF (SC .NE. 987) STOP 779 +C/6S +C IF (I .LT. 1 .OR. I .GT. 5) +C 1 CALL SETERR(24HD1MACH - I OUT OF BOUNDS,24,1,2) +C/7S +C IF (I .LT. 1 .OR. I .GT. 5) +C 1 CALL SETERR('D1MACH - I OUT OF BOUNDS',24,1,2) +C/ +C + D1MACH = DMACH(I) + RETURN +C + END + INTEGER FUNCTION I1MACH(I) +C +C I/O UNIT NUMBERS. +C +C I1MACH( 1) = THE STANDARD INPUT UNIT. +C +C I1MACH( 2) = THE STANDARD OUTPUT UNIT. +C +C I1MACH( 3) = THE STANDARD PUNCH UNIT. +C +C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT. +C +C WORDS. +C +C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT. +C +C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT. +C FOR FORTRAN 77, THIS IS ALWAYS 1. FOR FORTRAN 66, +C CHARACTER STORAGE UNIT = INTEGER STORAGE UNIT. +C +C INTEGERS. +C +C ASSUME INTEGERS ARE REPRESENTED IN THE S-DIGIT, BASE-A FORM +C +C SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C WHERE 0 .LE. X(I) .LT. A FOR I=0,...,S-1. +C +C I1MACH( 7) = A, THE BASE. +C +C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS. +C +C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE. +C +C FLOATING-POINT NUMBERS. +C +C ASSUME FLOATING-POINT NUMBERS ARE REPRESENTED IN THE T-DIGIT, +C BASE-B FORM +C +C SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, +C 0 .LT. X(1), AND EMIN .LE. E .LE. EMAX. +C +C I1MACH(10) = B, THE BASE. +C +C SINGLE-PRECISION +C +C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS. +C +C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E. +C +C I1MACH(13) = EMAX, THE LARGEST EXPONENT E. +C +C DOUBLE-PRECISION +C +C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS. +C +C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E. +C +C I1MACH(16) = EMAX, THE LARGEST EXPONENT E. +C +C TO ALTER THIS FUNCTION FOR A PARTICULAR ENVIRONMENT, +C THE DESIRED SET OF DATA STATEMENTS SHOULD BE ACTIVATED BY +C REMOVING THE C FROM COLUMN 1. ALSO, THE VALUES OF +C I1MACH(1) - I1MACH(4) SHOULD BE CHECKED FOR CONSISTENCY +C WITH THE LOCAL OPERATING SYSTEM. FOR FORTRAN 77, YOU MAY WISH +C TO ADJUST THE DATA STATEMENT SO IMACH(6) IS SET TO 1, AND +C THEN TO COMMENT OUT THE EXECUTABLE TEST ON I .EQ. 6 BELOW. +C +C FOR IEEE-ARITHMETIC MACHINES (BINARY STANDARD), THE FIRST +C SET OF CONSTANTS BELOW SHOULD BE APPROPRIATE, EXCEPT PERHAPS +C FOR IMACH(1) - IMACH(4). +C + INTEGER IMACH(16),OUTPUT,SANITY +C + EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR IEEE ARITHMETIC MACHINES, SUCH AS THE AT&T +C 3B SERIES, MOTOROLA 68000 BASED MACHINES (E.G. SUN 3 AND AT&T +C PC 7300), AND 8087 BASED MICROS (E.G. IBM PC AND AT&T 6300). +C + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 7 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -125 / + DATA IMACH(13) / 128 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1021 / + DATA IMACH(16) / 1024 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR AMDAHL MACHINES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM. +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR FTN4 ON THE CDC 6000/7000 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR FTN5 ON THE CDC 6000/7000 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / O"00007777777777777777" / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR CONVEX C-1. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) /-1024 / +C DATA IMACH(16) / 1023 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE CRAY 1, XMP, 2, AND 3. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200. +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) /32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE HARRIS SLASH 6 AND SLASH 7. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 43 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9 AND THE SEL SYSTEMS 85/86. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE INTERDATA 8/32 +C WITH THE UNIX SYSTEM FORTRAN 77 COMPILER. +C +C FOR THE INTERDATA FORTRAN VII COMPILER REPLACE +C THE Z'S SPECIFYING HEX CONSTANTS WITH Y'S. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 62 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 62 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR). +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR). +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE PRIME 50 SERIES SYSTEMS +C WTIH 32-BIT INTEGERS AND 64V MODE INSTRUCTIONS, +C SUPPLIED BY IGOR BRAY. +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / :17777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / +127 / +C DATA IMACH(14) / 47 / +C DATA IMACH(15) / -32895 / +C DATA IMACH(16) / +32637 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE SEQUENT BALANCE 8000. +C +C DATA IMACH( 1) / 0 / +C DATA IMACH( 2) / 0 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 1 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. +C +C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7 +C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM. +C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) /-1024 / +C DATA IMACH(16) / 1023 /, SANITY/987/ +C +C MACHINE CONSTANTS FOR VAX. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 /, SANITY/987/ +C +C *** ISSUE STOP 777 IF ALL DATA STATEMENTS ARE COMMENTED... + IF (SANITY .NE. 987) STOP 777 + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) +C/6S +C/7S + IF (I .EQ. 6) I1MACH = 1 +C/ + RETURN +C + 10 WRITE(OUTPUT,9000) + 9000 FORMAT(39H1ERROR 1 IN I1MACH - I OUT OF BOUNDS) +C +C CALL FDUMP +C + STOP +C + END diff --git a/AMSS_NCKU_source/zbesh.h b/AMSS_NCKU_source/Special_Function/zbesh.h similarity index 93% rename from AMSS_NCKU_source/zbesh.h rename to AMSS_NCKU_source/Special_Function/zbesh.h index 997169b..2037bac 100644 --- a/AMSS_NCKU_source/zbesh.h +++ b/AMSS_NCKU_source/Special_Function/zbesh.h @@ -1,20 +1,20 @@ - -#ifndef ZBESH_H -#define ZBESH_H - -#ifdef fortran1 -#define f_zbesj zbesj -#endif -#ifdef fortran2 -#define f_zbesj ZBESJ -#endif -#ifdef fortran3 -#define f_zbesj zbesj_ -#endif - -extern "C" -{ - int f_zbesj(double &, double &, double &, int &, - int &, double &, double &, int &, int &); -} -#endif /* ZBESH_H */ + +#ifndef ZBESH_H +#define ZBESH_H + +#ifdef fortran1 +#define f_zbesj zbesj +#endif +#ifdef fortran2 +#define f_zbesj ZBESJ +#endif +#ifdef fortran3 +#define f_zbesj zbesj_ +#endif + +extern "C" +{ + int f_zbesj(double &, double &, double &, int &, + int &, double &, double &, int &, int &); +} +#endif /* ZBESH_H */ diff --git a/AMSS_NCKU_source/gaussj.C b/AMSS_NCKU_source/Surface_Integral/gaussj.C similarity index 96% rename from AMSS_NCKU_source/gaussj.C rename to AMSS_NCKU_source/Surface_Integral/gaussj.C index 86c7777..3c99841 100644 --- a/AMSS_NCKU_source/gaussj.C +++ b/AMSS_NCKU_source/Surface_Integral/gaussj.C @@ -1,106 +1,106 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -// Intel oneMKL LAPACK interface -#include -/* Linear equation solution using Intel oneMKL LAPACK. -a[0..n-1][0..n-1] is the input matrix. b[0..n-1] is input -containing the right-hand side vectors. On output a is -replaced by its matrix inverse, and b is replaced by the -corresponding set of solution vectors. - -Mathematical equivalence: - Solves: A * x = b => x = A^(-1) * b - Original Gauss-Jordan and LAPACK dgesv/dgetri produce identical results - within numerical precision. */ - -int gaussj(double *a, double *b, int n) -{ - // Allocate pivot array and workspace - lapack_int *ipiv = new lapack_int[n]; - lapack_int info; - - // Make a copy of matrix a for solving (dgesv modifies it to LU form) - double *a_copy = new double[n * n]; - for (int i = 0; i < n * n; i++) { - a_copy[i] = a[i]; - } - - // Step 1: Solve linear system A*x = b using LU decomposition - // LAPACKE_dgesv uses column-major by default, but we use row-major - info = LAPACKE_dgesv(LAPACK_ROW_MAJOR, n, 1, a_copy, n, ipiv, b, 1); - - if (info != 0) { - cout << "gaussj: Singular Matrix (dgesv info=" << info << ")" << endl; - delete[] ipiv; - delete[] a_copy; - return 1; - } - - // Step 2: Compute matrix inverse A^(-1) using LU factorization - // First do LU factorization of original matrix a - info = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, n, n, a, n, ipiv); - - if (info != 0) { - cout << "gaussj: Singular Matrix (dgetrf info=" << info << ")" << endl; - delete[] ipiv; - delete[] a_copy; - return 1; - } - - // Then compute inverse from LU factorization - info = LAPACKE_dgetri(LAPACK_ROW_MAJOR, n, a, n, ipiv); - - if (info != 0) { - cout << "gaussj: Singular Matrix (dgetri info=" << info << ")" << endl; - delete[] ipiv; - delete[] a_copy; - return 1; - } - - delete[] ipiv; - delete[] a_copy; - - return 0; -} -// for check usage -/* -int main() -{ - double *A,*b; - A=new double[9]; - b=new double[3]; - - A[0]=0.5; A[1]=1.0/3; A[2]=1; - A[3]=1; A[4]=5.0/3; A[5]=3; - A[6]=2; A[7]=4.0/3; A[8]=5; - - b[0]=1; b[1]=3; b[2]=2; - - cout<<"initial data:"< +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +// Intel oneMKL LAPACK interface +#include +/* Linear equation solution using Intel oneMKL LAPACK. +a[0..n-1][0..n-1] is the input matrix. b[0..n-1] is input +containing the right-hand side vectors. On output a is +replaced by its matrix inverse, and b is replaced by the +corresponding set of solution vectors. + +Mathematical equivalence: + Solves: A * x = b => x = A^(-1) * b + Original Gauss-Jordan and LAPACK dgesv/dgetri produce identical results + within numerical precision. */ + +int gaussj(double *a, double *b, int n) +{ + // Allocate pivot array and workspace + lapack_int *ipiv = new lapack_int[n]; + lapack_int info; + + // Make a copy of matrix a for solving (dgesv modifies it to LU form) + double *a_copy = new double[n * n]; + for (int i = 0; i < n * n; i++) { + a_copy[i] = a[i]; + } + + // Step 1: Solve linear system A*x = b using LU decomposition + // LAPACKE_dgesv uses column-major by default, but we use row-major + info = LAPACKE_dgesv(LAPACK_ROW_MAJOR, n, 1, a_copy, n, ipiv, b, 1); + + if (info != 0) { + cout << "gaussj: Singular Matrix (dgesv info=" << info << ")" << endl; + delete[] ipiv; + delete[] a_copy; + return 1; + } + + // Step 2: Compute matrix inverse A^(-1) using LU factorization + // First do LU factorization of original matrix a + info = LAPACKE_dgetrf(LAPACK_ROW_MAJOR, n, n, a, n, ipiv); + + if (info != 0) { + cout << "gaussj: Singular Matrix (dgetrf info=" << info << ")" << endl; + delete[] ipiv; + delete[] a_copy; + return 1; + } + + // Then compute inverse from LU factorization + info = LAPACKE_dgetri(LAPACK_ROW_MAJOR, n, a, n, ipiv); + + if (info != 0) { + cout << "gaussj: Singular Matrix (dgetri info=" << info << ")" << endl; + delete[] ipiv; + delete[] a_copy; + return 1; + } + + delete[] ipiv; + delete[] a_copy; + + return 0; +} +// for check usage +/* +int main() +{ + double *A,*b; + A=new double[9]; + b=new double[3]; + + A[0]=0.5; A[1]=1.0/3; A[2]=1; + A[3]=1; A[4]=5.0/3; A[5]=3; + A[6]=2; A[7]=4.0/3; A[8]=5; + + b[0]=1; b[1]=3; b[2]=2; + + cout<<"initial data:"< -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif -#include - -#include "misc.h" -#include "cgh.h" -#include "Parallel.h" -#include "surface_integral.h" -#include "fadmquantites_bssn.h" -#include "getnpem2.h" -#include "getnp4.h" -#include "parameters.h" - -#define PI M_PI -//|============================================================================ -//| Constructor -//|============================================================================ - + +//---------------------------------------------------------------- +// Using Gauss-Legendre quadrature in theta direction +// and trapezoidal rule in phi direction (from Second Euler-Maclaurin summation formula, we can see that +// this method gives expolential convergence for periodic function) +//---------------------------------------------------------------- +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif +#include + +#include "misc.h" +#include "cgh.h" +#include "Parallel.h" +#include "surface_integral.h" +#include "fadmquantites_bssn.h" +#include "getnpem2.h" +#include "getnp4.h" +#include "parameters.h" + +#define PI M_PI +//|============================================================================ +//| Constructor +//|============================================================================ + surface_integral::surface_integral(int iSymmetry) : Symmetry(iSymmetry), wave_cache_spinw(-1), wave_cache_maxl(-1), @@ -47,146 +47,146 @@ surface_integral::surface_integral(int iSymmetry) : Symmetry(iSymmetry), { MPI_Comm_rank(MPI_COMM_WORLD, &myrank); MPI_Comm_size(MPI_COMM_WORLD, &cpusize); - int N = 40; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - ifstream inf(pname, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "Can not open parameter file " << pname << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "SurfaceIntegral") - { - if (skey == "number of points for quarter sphere") - N = atoi(sval.c_str()); - } - } - inf.close(); - } - //|-----number of points for whole [0,pi] x [0,2pi] - N_phi = 4 * N; // for simplicity, we require this number must be 4*N - N_theta = 2 * N; // 2*N - - if (myrank == 0) - { - cout << "-----------------------------------------------------------------------" << endl; -#ifdef GaussInt - cout << " spherical integration for wave form extraction with Gauss method " << endl; -#else - cout << " spherical integration for wave form extraction with mid point method " << endl; -#endif - cout << " N_phi = " << N_phi << endl; - cout << " N_theta = " << N_theta << endl; - cout << "-----------------------------------------------------------------------" << endl; - } - -#ifdef GaussInt - // weight function cover all of [0,pi] - arcostheta = new double[N_theta]; - wtcostheta = new double[N_theta]; - - // note: theta in [0,pi/2], upper half sphere, corresponds to 1 < costheta < 0 - misc::gaulegf(-1.0, 1.0, arcostheta, wtcostheta, N_theta); - // due to symmetry, I need first half array corresponds to upper sphere, note these two arrays must match each other - misc::inversearray(arcostheta, N_theta); - misc::inversearray(wtcostheta, N_theta); -#endif - - if (Symmetry == 2) - { - N_phi = N_phi / 4; - N_theta = N_theta / 2; - dphi = PI / (2.0 * N_phi); - dcostheta = 1.0 / N_theta; - factor = 8; - } - else if (Symmetry == 1) - { - N_theta = N_theta / 2; - dphi = 2.0 * PI / N_phi; - dcostheta = 1.0 / N_theta; - factor = 2; - } - else if (Symmetry == 0) - { - dphi = 2.0 * PI / N_phi; - dcostheta = 2.0 / N_theta; - factor = 1; - } - else if (myrank == 0) - { - cout << "surface_integral::surface_integral: not supported Symmetry setting!" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - -#ifndef GaussInt - // weight function cover all of [0,pi] - arcostheta = new double[N_theta]; -#endif - n_tot = N_theta * N_phi; - nx_g = new double[n_tot]; - ny_g = new double[n_tot]; - nz_g = new double[n_tot]; - - int n = 0; - double costheta, sintheta, ph; - - for (int i = 0; i < N_theta; ++i) - { -#ifndef GaussInt - arcostheta[i] = 1.0 - (i + 0.5) * dcostheta; -#endif - costheta = arcostheta[i]; - sintheta = sqrt(1.0 - costheta * costheta); - - for (int j = 0; j < N_phi; ++j) - { - ph = (j + 0.5) * dphi; - // normal vector respect to the constant R sphere - nx_g[n] = sintheta * cos(ph); - ny_g[n] = sintheta * sin(ph); - nz_g[n] = costheta; - n++; - } - } -} - -//|============================================================================ -//| Destructor -//|============================================================================ + int N = 40; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + ifstream inf(pname, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "Can not open parameter file " << pname << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "SurfaceIntegral") + { + if (skey == "number of points for quarter sphere") + N = atoi(sval.c_str()); + } + } + inf.close(); + } + //|-----number of points for whole [0,pi] x [0,2pi] + N_phi = 4 * N; // for simplicity, we require this number must be 4*N + N_theta = 2 * N; // 2*N + + if (myrank == 0) + { + cout << "-----------------------------------------------------------------------" << endl; +#ifdef GaussInt + cout << " spherical integration for wave form extraction with Gauss method " << endl; +#else + cout << " spherical integration for wave form extraction with mid point method " << endl; +#endif + cout << " N_phi = " << N_phi << endl; + cout << " N_theta = " << N_theta << endl; + cout << "-----------------------------------------------------------------------" << endl; + } + +#ifdef GaussInt + // weight function cover all of [0,pi] + arcostheta = new double[N_theta]; + wtcostheta = new double[N_theta]; + + // note: theta in [0,pi/2], upper half sphere, corresponds to 1 < costheta < 0 + misc::gaulegf(-1.0, 1.0, arcostheta, wtcostheta, N_theta); + // due to symmetry, I need first half array corresponds to upper sphere, note these two arrays must match each other + misc::inversearray(arcostheta, N_theta); + misc::inversearray(wtcostheta, N_theta); +#endif + + if (Symmetry == 2) + { + N_phi = N_phi / 4; + N_theta = N_theta / 2; + dphi = PI / (2.0 * N_phi); + dcostheta = 1.0 / N_theta; + factor = 8; + } + else if (Symmetry == 1) + { + N_theta = N_theta / 2; + dphi = 2.0 * PI / N_phi; + dcostheta = 1.0 / N_theta; + factor = 2; + } + else if (Symmetry == 0) + { + dphi = 2.0 * PI / N_phi; + dcostheta = 2.0 / N_theta; + factor = 1; + } + else if (myrank == 0) + { + cout << "surface_integral::surface_integral: not supported Symmetry setting!" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + +#ifndef GaussInt + // weight function cover all of [0,pi] + arcostheta = new double[N_theta]; +#endif + n_tot = N_theta * N_phi; + nx_g = new double[n_tot]; + ny_g = new double[n_tot]; + nz_g = new double[n_tot]; + + int n = 0; + double costheta, sintheta, ph; + + for (int i = 0; i < N_theta; ++i) + { +#ifndef GaussInt + arcostheta[i] = 1.0 - (i + 0.5) * dcostheta; +#endif + costheta = arcostheta[i]; + sintheta = sqrt(1.0 - costheta * costheta); + + for (int j = 0; j < N_phi; ++j) + { + ph = (j + 0.5) * dphi; + // normal vector respect to the constant R sphere + nx_g[n] = sintheta * cos(ph); + ny_g[n] = sintheta * sin(ph); + nz_g[n] = costheta; + n++; + } + } +} + +//|============================================================================ +//| Destructor +//|============================================================================ surface_integral::~surface_integral() { clear_wave_cache(); @@ -261,16 +261,16 @@ void surface_integral::build_wave_cache(int spinw, int maxl) // spin weighted spinw component of psi4, general routine // l takes from spinw to maxl; m takes from -l to l //|---------------------------------------------------------------- -void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor) // NN is the length of RP and IP -{ - if (myrank == 0 && GH->grids[lev] != 1) - if (Monitor->outfile) - Monitor->outfile << "WARNING: surface integral on multipatches" << endl; - else - cout << "WARNING: surface integral on multipatches" << endl; - +void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor) // NN is the length of RP and IP +{ + if (myrank == 0 && GH->grids[lev] != 1) + if (Monitor->outfile) + Monitor->outfile << "WARNING: surface integral on multipatches" << endl; + else + cout << "WARNING: surface integral on multipatches" << endl; + const int InList = 2; MyList *DG_List = new MyList(Rpsi4); @@ -289,38 +289,38 @@ void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var * int mp, Lp, Nmin, Nmax; mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - + Lp = n_tot - cpusize * mp; + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + double *shellf; shellf = new double[n_tot * InList]; GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry, Nmin, Nmax); - - //|~~~~~> Integrate the dot product of Dphi with the surface normal. - + + //|~~~~~> Integrate the dot product of Dphi with the surface normal. + double *RP_out, *IP_out; RP_out = new double[NN]; IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + int i, j; int lpsy = 0; if (Symmetry == 0) @@ -449,19 +449,19 @@ void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var * } } } - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + { double *RPIP_out = new double[2 * NN]; double *RPIP = new double[2 * NN]; @@ -484,20 +484,20 @@ void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var * delete[] IP_out; DG_List->clearList(); } -void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor, MPI_Comm Comm_here) // NN is the length of RP and IP -{ - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start surface_integral::surf_Wave"); - - int lmyrank; - MPI_Comm_rank(Comm_here, &lmyrank); - if (lmyrank == 0 && GH->grids[lev] != 1) - if (Monitor->outfile) - Monitor->outfile << "WARNING: surface integral on multipatches" << endl; - else - cout << "WARNING: surface integral on multipatches" << endl; - +void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor, MPI_Comm Comm_here) // NN is the length of RP and IP +{ + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"start surface_integral::surf_Wave"); + + int lmyrank; + MPI_Comm_rank(Comm_here, &lmyrank); + if (lmyrank == 0 && GH->grids[lev] != 1) + if (Monitor->outfile) + Monitor->outfile << "WARNING: surface integral on multipatches" << endl; + else + cout << "WARNING: surface integral on multipatches" << endl; + const int InList = 2; MyList *DG_List = new MyList(Rpsi4); @@ -516,47 +516,47 @@ void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var * double *shellf; shellf = new double[n_tot * InList]; - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Interp_Points"); - - GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry, Comm_here); - - // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Interp_Points"); - - int mp, Lp, Nmin, Nmax; - - int cpusize_here; - MPI_Comm_size(Comm_here, &cpusize_here); - - mp = n_tot / cpusize_here; - Lp = n_tot - cpusize_here * mp; - - if (Lp > lmyrank) - { - Nmin = lmyrank * mp + lmyrank; - Nmax = Nmin + mp; - } - else - { - Nmin = lmyrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - //|~~~~~> Integrate the dot product of Dphi with the surface normal. - + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"before Interp_Points"); + + GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry, Comm_here); + + // misc::tillherecheck(GH->Commlev[lev],GH->start_rank[lev],"after Interp_Points"); + + int mp, Lp, Nmin, Nmax; + + int cpusize_here; + MPI_Comm_size(Comm_here, &cpusize_here); + + mp = n_tot / cpusize_here; + Lp = n_tot - cpusize_here * mp; + + if (Lp > lmyrank) + { + Nmin = lmyrank * mp + lmyrank; + Nmax = Nmin + mp; + } + else + { + Nmin = lmyrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + //|~~~~~> Integrate the dot product of Dphi with the surface normal. + double *RP_out, *IP_out; RP_out = new double[NN]; IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + int i, j; int lpsy = 0; if (Symmetry == 0) @@ -685,19 +685,19 @@ void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var * } } } - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + { double *RPIP_out = new double[2 * NN]; double *RPIP = new double[2 * NN]; @@ -720,1735 +720,1735 @@ void surface_integral::surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var * delete[] IP_out; DG_List->clearList(); } -//|---------------------------------------------------------------- -// for shell patch -//|---------------------------------------------------------------- -void surface_integral::surf_Wave(double rex, int lev, ShellPatch *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor) // NN is the length of RP and IP -{ - const int InList = 2; - - MyList *DG_List = new MyList(Rpsi4); - DG_List->insert(Ipsi4); - - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); - - int mp, Lp, Nmin, Nmax; - - mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - //|~~~~~> Integrate the dot product of Dphi with the surface normal. - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - psi4RR = Rpsi4->SoA[2] * shellf[InList * n]; - psi4II = Ipsi4->SoA[2] * shellf[InList * n + 1]; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - psi4RR = Rpsi4->SoA[1] * shellf[InList * n]; - psi4II = Ipsi4->SoA[1] * shellf[InList * n + 1]; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - psi4RR = Rpsi4->SoA[2] * Rpsi4->SoA[1] * shellf[InList * n]; - psi4II = Ipsi4->SoA[2] * Ipsi4->SoA[1] * shellf[InList * n + 1]; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - psi4RR = Rpsi4->SoA[0] * shellf[InList * n]; - psi4II = Ipsi4->SoA[0] * shellf[InList * n + 1]; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - psi4RR = Rpsi4->SoA[2] * Rpsi4->SoA[0] * shellf[InList * n]; - psi4II = Ipsi4->SoA[2] * Ipsi4->SoA[0] * shellf[InList * n + 1]; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - psi4RR = Rpsi4->SoA[1] * Rpsi4->SoA[0] * shellf[InList * n]; - psi4II = Ipsi4->SoA[1] * Ipsi4->SoA[0] * shellf[InList * n + 1]; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - psi4RR = Rpsi4->SoA[2] * Rpsi4->SoA[1] * Rpsi4->SoA[0] * shellf[InList * n]; - psi4II = Ipsi4->SoA[2] * Ipsi4->SoA[1] * Ipsi4->SoA[0] * shellf[InList * n + 1]; - } - - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi); - IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------------------- -// for shell patch -// for EM wave specially symmetric case -//|---------------------------------------------------------------- -void surface_integral::surf_Wave(double rex, int lev, ShellPatch *GH, - var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, - var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor) // NN is the length of RP and IP -{ - const int InList = 13; - - MyList *DG_List = new MyList(Ex); - DG_List->insert(Ey); - DG_List->insert(Ez); - DG_List->insert(Bx); - DG_List->insert(By); - DG_List->insert(Bz); - DG_List->insert(chi); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); - - int mp, Lp, Nmin, Nmax; - - mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - //|~~~~~> Integrate the dot product of Dphi with the surface normal. - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - double px, py, pz; - double pEx, pEy, pEz, pBx, pBy, pBz; - double pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - px = pox[0][n]; - py = pox[1][n]; - pz = pox[2][n]; - pEx = shellf[InList * n]; - pEy = shellf[InList * n + 1]; - pEz = shellf[InList * n + 2]; - pBx = shellf[InList * n + 3]; - pBy = shellf[InList * n + 4]; - pBz = shellf[InList * n + 5]; - pchi = shellf[InList * n + 6]; - pgxx = shellf[InList * n + 7]; - pgxy = shellf[InList * n + 8]; - pgxz = shellf[InList * n + 9]; - pgyy = shellf[InList * n + 10]; - pgyz = shellf[InList * n + 11]; - pgzz = shellf[InList * n + 12]; - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - pz = -pz; - pEz = -pEz; - pBx = -pBx; - pBy = -pBy; - pgxz = -pgxz; - pgyz = -pgyz; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pEy = -pEy; - pBx = -pBx; - pBz = -pBz; - pgxy = -pgxy; - pgyz = -pgyz; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pz = -pz; - pEz = -pEz; - pBz = -pBz; - pgxz = -pgxz; - pEy = -pEy; - pBy = -pBy; - pgxy = -pgxy; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - px = -px; - pEx = -pEx; - pBy = -pBy; - pBz = -pBz; - pgxy = -pgxy; - pgxz = -pgxz; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - pz = -pz; - px = -px; - pEz = -pEz; - pBz = -pBz; - pgyz = -pgyz; - pEx = -pEx; - pBx = -pBx; - pgxy = -pgxy; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pEx = -pEx; - pBx = -pBx; - pgxz = -pgxz; - pEy = -pEy; - pBy = -pBy; - pgyz = -pgyz; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pz = -pz; - pEx = -pEx; - pEy = -pEy; - pEz = -pEz; - } - - f_getnpem2_point(px, py, pz, pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, pEx, pEy, pEz, pBx, pBy, pBz, - psi4RR, psi4II); - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 - - // find back the one - pchi = pchi + 1; -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------------------- -// for shell patch -// for EM wave specially symmetric case -// unify for phi1 and phi2 -//|---------------------------------------------------------------- -void surface_integral::surf_Wave(double rex, int lev, ShellPatch *GH, - var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, - var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor, - void (*funcs)(double &, double &, double &, - double &, double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &)) // NN is the length of RP and IP -{ - const int InList = 13; - - MyList *DG_List = new MyList(Ex); - DG_List->insert(Ey); - DG_List->insert(Ez); - DG_List->insert(Bx); - DG_List->insert(By); - DG_List->insert(Bz); - DG_List->insert(chi); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - -#if 0 -// for debug - if(myrank==0) - { - double costheta, thetap; - double cosmphi,sinmphi; - - int i,j; - int lpsy=0; - if( Symmetry == 0 ) lpsy=1; - else if( Symmetry == 1 ) lpsy=2; - else if( Symmetry == 2 ) lpsy=8; - - double psi4RR,psi4II; - double px,py,pz; - double pEx,pEy,pEz,pBx,pBy,pBz; - double pchi,pgxx,pgxy,pgxz,pgyy,pgyz,pgzz; - for( n = 0; n <= n_tot-1; n++) - { -// need round off always - i = int(n/N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - for(int lp=0;lp myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - double px, py, pz; - double pEx, pEy, pEz, pBx, pBy, pBz; - double pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - px = pox[0][n]; - py = pox[1][n]; - pz = pox[2][n]; - pEx = shellf[InList * n]; - pEy = shellf[InList * n + 1]; - pEz = shellf[InList * n + 2]; - pBx = shellf[InList * n + 3]; - pBy = shellf[InList * n + 4]; - pBz = shellf[InList * n + 5]; - pchi = shellf[InList * n + 6]; - pgxx = shellf[InList * n + 7]; - pgxy = shellf[InList * n + 8]; - pgxz = shellf[InList * n + 9]; - pgyy = shellf[InList * n + 10]; - pgyz = shellf[InList * n + 11]; - pgzz = shellf[InList * n + 12]; - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - pz = -pz; - pEz = -pEz; - pBx = -pBx; - pBy = -pBy; - pgxz = -pgxz; - pgyz = -pgyz; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pEy = -pEy; - pBx = -pBx; - pBz = -pBz; - pgxy = -pgxy; - pgyz = -pgyz; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pz = -pz; - pEz = -pEz; - pBz = -pBz; - pgxz = -pgxz; - pEy = -pEy; - pBy = -pBy; - pgxy = -pgxy; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - px = -px; - pEx = -pEx; - pBy = -pBy; - pBz = -pBz; - pgxy = -pgxy; - pgxz = -pgxz; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - pz = -pz; - px = -px; - pEz = -pEz; - pBz = -pBz; - pgyz = -pgyz; - pEx = -pEx; - pBx = -pBx; - pgxy = -pgxy; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pEx = -pEx; - pBx = -pBx; - pgxz = -pgxz; - pEy = -pEy; - pBy = -pBy; - pgyz = -pgyz; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pz = -pz; - pEx = -pEx; - pEy = -pEy; - pEz = -pEz; - } - - funcs(px, py, pz, pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, pEx, pEy, pEz, pBx, pBy, pBz, - psi4RR, psi4II); - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 - - // find back the one - pchi = pchi + 1; -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } -#endif - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------------------- -// for box -// for EM wave specially symmetric case -// unify for phi1 and phi2 -//|---------------------------------------------------------------- -void surface_integral::surf_Wave(double rex, int lev, cgh *GH, - var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, - var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor, - void (*funcs)(double &, double &, double &, - double &, double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &)) // NN is the length of RP and IP -{ - const int InList = 13; - - MyList *DG_List = new MyList(Ex); - DG_List->insert(Ey); - DG_List->insert(Ez); - DG_List->insert(Bx); - DG_List->insert(By); - DG_List->insert(Bz); - DG_List->insert(chi); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - -#if 0 -// for debug - if(myrank==0) - { - double costheta, thetap; - double cosmphi,sinmphi; - - int i,j; - int lpsy=0; - if( Symmetry == 0 ) lpsy=1; - else if( Symmetry == 1 ) lpsy=2; - else if( Symmetry == 2 ) lpsy=8; - - double psi4RR,psi4II; - double px,py,pz; - double pEx,pEy,pEz,pBx,pBy,pBz; - double pchi,pgxx,pgxy,pgxz,pgyy,pgyz,pgzz; - for( n = 0; n <= n_tot-1; n++) - { -// need round off always - i = int(n/N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - for(int lp=0;lp myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - double px, py, pz; - double pEx, pEy, pEz, pBx, pBy, pBz; - double pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - px = pox[0][n]; - py = pox[1][n]; - pz = pox[2][n]; - pEx = shellf[InList * n]; - pEy = shellf[InList * n + 1]; - pEz = shellf[InList * n + 2]; - pBx = shellf[InList * n + 3]; - pBy = shellf[InList * n + 4]; - pBz = shellf[InList * n + 5]; - pchi = shellf[InList * n + 6]; - pgxx = shellf[InList * n + 7]; - pgxy = shellf[InList * n + 8]; - pgxz = shellf[InList * n + 9]; - pgyy = shellf[InList * n + 10]; - pgyz = shellf[InList * n + 11]; - pgzz = shellf[InList * n + 12]; - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - pz = -pz; - pEz = -pEz; - pBx = -pBx; - pBy = -pBy; - pgxz = -pgxz; - pgyz = -pgyz; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pEy = -pEy; - pBx = -pBx; - pBz = -pBz; - pgxy = -pgxy; - pgyz = -pgyz; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pz = -pz; - pEz = -pEz; - pBz = -pBz; - pgxz = -pgxz; - pEy = -pEy; - pBy = -pBy; - pgxy = -pgxy; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - px = -px; - pEx = -pEx; - pBy = -pBy; - pBz = -pBz; - pgxy = -pgxy; - pgxz = -pgxz; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - pz = -pz; - px = -px; - pEz = -pEz; - pBz = -pBz; - pgyz = -pgyz; - pEx = -pEx; - pBx = -pBx; - pgxy = -pgxy; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pEx = -pEx; - pBx = -pBx; - pgxz = -pgxz; - pEy = -pEy; - pBy = -pBy; - pgyz = -pgyz; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pz = -pz; - pEx = -pEx; - pEy = -pEy; - pEz = -pEz; - } - - funcs(px, py, pz, pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, pEx, pEy, pEz, pBx, pBy, pBz, - psi4RR, psi4II); - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 - - // find back the one - pchi = pchi + 1; -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } -#endif - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------------------- -// for null shell patch2 -//|---------------------------------------------------------------- -// rex is x instead of r -void surface_integral::surf_Wave(double rex, int lev, NullShellPatch2 *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor) // NN is the length of RP and IP -// spinw 0 for scalar; 1 for electricmagnetic wave; 2 for gravitaitonal wave -// we always assume spinw >= 0 -{ - const int InList = 2; - - MyList *DG_List = new MyList(Rpsi4); - DG_List->insert(Ipsi4); - - int n; - // since we used x instead of r, these global coordinates are fake - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - GH->Interp_Points_2D(DG_List, n_tot, pox, shellf, Symmetry); - - int mp, Lp, Nmin, Nmax; - - mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - //|~~~~~> Integrate the dot product of Dphi with the surface normal. - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - } - - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 - // based on Eq.(41) of PRD 77, 024027 (2008) -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi); // + is because \bar of \bar{Y^s_lm} in Eq.(40) - // of PRD 77, 024027 (2008) - IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } - - for (int ii = 0; ii < NN; ii++) - { -// do not need multiply with rex for null shell -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * dphi; - IP_out[ii] = IP_out[ii] * dphi; -#else - RP_out[ii] = RP_out[ii] * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------------------- -// for null shell patch -//|---------------------------------------------------------------- -// rex is x instead of r -void surface_integral::surf_Wave(double rex, int lev, NullShellPatch *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor) // NN is the length of RP and IP -// spinw 0 for scalar; 1 for electricmagnetic wave; 2 for gravitaitonal wave -// we always assume spinw >= 0 -{ - const int InList = 2; - - MyList *DG_List = new MyList(Rpsi4); - DG_List->insert(Ipsi4); - - int n; - // since we used x instead of r, these global coordinates are fake - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - GH->Interp_Points_2D(DG_List, n_tot, pox, shellf, Symmetry); - - int mp, Lp, Nmin, Nmax; - - mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - //|~~~~~> Integrate the dot product of Dphi with the surface normal. - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = shellf[InList * n + 1]; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - psi4RR = shellf[InList * n]; - psi4II = -shellf[InList * n + 1]; - } - - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 - // based on Eq.(41) of PRD 77, 024027 (2008) -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi); // + is because \bar of \bar{Y^s_lm} in Eq.(40) - // of PRD 77, 024027 (2008) - IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } - - for (int ii = 0; ii < NN; ii++) - { -// do not need multiply with rex for null shell -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * dphi; - IP_out[ii] = IP_out[ii] * dphi; -#else - RP_out[ii] = RP_out[ii] * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------- -//| -//| ADM mass, linear momentum and angular momentum -//| -//|---------------------------------------------------- +//|---------------------------------------------------------------- +// for shell patch +//|---------------------------------------------------------------- +void surface_integral::surf_Wave(double rex, int lev, ShellPatch *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor) // NN is the length of RP and IP +{ + const int InList = 2; + + MyList *DG_List = new MyList(Rpsi4); + DG_List->insert(Ipsi4); + + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); + + int mp, Lp, Nmin, Nmax; + + mp = n_tot / cpusize; + Lp = n_tot - cpusize * mp; + + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + //|~~~~~> Integrate the dot product of Dphi with the surface normal. + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + psi4RR = Rpsi4->SoA[2] * shellf[InList * n]; + psi4II = Ipsi4->SoA[2] * shellf[InList * n + 1]; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + psi4RR = Rpsi4->SoA[1] * shellf[InList * n]; + psi4II = Ipsi4->SoA[1] * shellf[InList * n + 1]; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + psi4RR = Rpsi4->SoA[2] * Rpsi4->SoA[1] * shellf[InList * n]; + psi4II = Ipsi4->SoA[2] * Ipsi4->SoA[1] * shellf[InList * n + 1]; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + psi4RR = Rpsi4->SoA[0] * shellf[InList * n]; + psi4II = Ipsi4->SoA[0] * shellf[InList * n + 1]; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + psi4RR = Rpsi4->SoA[2] * Rpsi4->SoA[0] * shellf[InList * n]; + psi4II = Ipsi4->SoA[2] * Ipsi4->SoA[0] * shellf[InList * n + 1]; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + psi4RR = Rpsi4->SoA[1] * Rpsi4->SoA[0] * shellf[InList * n]; + psi4II = Ipsi4->SoA[1] * Ipsi4->SoA[0] * shellf[InList * n + 1]; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + psi4RR = Rpsi4->SoA[2] * Rpsi4->SoA[1] * Rpsi4->SoA[0] * shellf[InList * n]; + psi4II = Ipsi4->SoA[2] * Ipsi4->SoA[1] * Ipsi4->SoA[0] * shellf[InList * n + 1]; + } + + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi); + IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------------------- +// for shell patch +// for EM wave specially symmetric case +//|---------------------------------------------------------------- +void surface_integral::surf_Wave(double rex, int lev, ShellPatch *GH, + var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, + var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor) // NN is the length of RP and IP +{ + const int InList = 13; + + MyList *DG_List = new MyList(Ex); + DG_List->insert(Ey); + DG_List->insert(Ez); + DG_List->insert(Bx); + DG_List->insert(By); + DG_List->insert(Bz); + DG_List->insert(chi); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); + + int mp, Lp, Nmin, Nmax; + + mp = n_tot / cpusize; + Lp = n_tot - cpusize * mp; + + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + //|~~~~~> Integrate the dot product of Dphi with the surface normal. + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + double px, py, pz; + double pEx, pEy, pEz, pBx, pBy, pBz; + double pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + px = pox[0][n]; + py = pox[1][n]; + pz = pox[2][n]; + pEx = shellf[InList * n]; + pEy = shellf[InList * n + 1]; + pEz = shellf[InList * n + 2]; + pBx = shellf[InList * n + 3]; + pBy = shellf[InList * n + 4]; + pBz = shellf[InList * n + 5]; + pchi = shellf[InList * n + 6]; + pgxx = shellf[InList * n + 7]; + pgxy = shellf[InList * n + 8]; + pgxz = shellf[InList * n + 9]; + pgyy = shellf[InList * n + 10]; + pgyz = shellf[InList * n + 11]; + pgzz = shellf[InList * n + 12]; + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + pz = -pz; + pEz = -pEz; + pBx = -pBx; + pBy = -pBy; + pgxz = -pgxz; + pgyz = -pgyz; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pEy = -pEy; + pBx = -pBx; + pBz = -pBz; + pgxy = -pgxy; + pgyz = -pgyz; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pz = -pz; + pEz = -pEz; + pBz = -pBz; + pgxz = -pgxz; + pEy = -pEy; + pBy = -pBy; + pgxy = -pgxy; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + px = -px; + pEx = -pEx; + pBy = -pBy; + pBz = -pBz; + pgxy = -pgxy; + pgxz = -pgxz; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + pz = -pz; + px = -px; + pEz = -pEz; + pBz = -pBz; + pgyz = -pgyz; + pEx = -pEx; + pBx = -pBx; + pgxy = -pgxy; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pEx = -pEx; + pBx = -pBx; + pgxz = -pgxz; + pEy = -pEy; + pBy = -pBy; + pgyz = -pgyz; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pz = -pz; + pEx = -pEx; + pEy = -pEy; + pEz = -pEz; + } + + f_getnpem2_point(px, py, pz, pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, pEx, pEy, pEz, pBx, pBy, pBz, + psi4RR, psi4II); + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 + + // find back the one + pchi = pchi + 1; +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------------------- +// for shell patch +// for EM wave specially symmetric case +// unify for phi1 and phi2 +//|---------------------------------------------------------------- +void surface_integral::surf_Wave(double rex, int lev, ShellPatch *GH, + var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, + var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor, + void (*funcs)(double &, double &, double &, + double &, double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &)) // NN is the length of RP and IP +{ + const int InList = 13; + + MyList *DG_List = new MyList(Ex); + DG_List->insert(Ey); + DG_List->insert(Ez); + DG_List->insert(Bx); + DG_List->insert(By); + DG_List->insert(Bz); + DG_List->insert(chi); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + +#if 0 +// for debug + if(myrank==0) + { + double costheta, thetap; + double cosmphi,sinmphi; + + int i,j; + int lpsy=0; + if( Symmetry == 0 ) lpsy=1; + else if( Symmetry == 1 ) lpsy=2; + else if( Symmetry == 2 ) lpsy=8; + + double psi4RR,psi4II; + double px,py,pz; + double pEx,pEy,pEz,pBx,pBy,pBz; + double pchi,pgxx,pgxy,pgxz,pgyy,pgyz,pgzz; + for( n = 0; n <= n_tot-1; n++) + { +// need round off always + i = int(n/N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + for(int lp=0;lp myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + double px, py, pz; + double pEx, pEy, pEz, pBx, pBy, pBz; + double pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + px = pox[0][n]; + py = pox[1][n]; + pz = pox[2][n]; + pEx = shellf[InList * n]; + pEy = shellf[InList * n + 1]; + pEz = shellf[InList * n + 2]; + pBx = shellf[InList * n + 3]; + pBy = shellf[InList * n + 4]; + pBz = shellf[InList * n + 5]; + pchi = shellf[InList * n + 6]; + pgxx = shellf[InList * n + 7]; + pgxy = shellf[InList * n + 8]; + pgxz = shellf[InList * n + 9]; + pgyy = shellf[InList * n + 10]; + pgyz = shellf[InList * n + 11]; + pgzz = shellf[InList * n + 12]; + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + pz = -pz; + pEz = -pEz; + pBx = -pBx; + pBy = -pBy; + pgxz = -pgxz; + pgyz = -pgyz; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pEy = -pEy; + pBx = -pBx; + pBz = -pBz; + pgxy = -pgxy; + pgyz = -pgyz; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pz = -pz; + pEz = -pEz; + pBz = -pBz; + pgxz = -pgxz; + pEy = -pEy; + pBy = -pBy; + pgxy = -pgxy; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + px = -px; + pEx = -pEx; + pBy = -pBy; + pBz = -pBz; + pgxy = -pgxy; + pgxz = -pgxz; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + pz = -pz; + px = -px; + pEz = -pEz; + pBz = -pBz; + pgyz = -pgyz; + pEx = -pEx; + pBx = -pBx; + pgxy = -pgxy; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pEx = -pEx; + pBx = -pBx; + pgxz = -pgxz; + pEy = -pEy; + pBy = -pBy; + pgyz = -pgyz; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pz = -pz; + pEx = -pEx; + pEy = -pEy; + pEz = -pEz; + } + + funcs(px, py, pz, pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, pEx, pEy, pEz, pBx, pBy, pBz, + psi4RR, psi4II); + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 + + // find back the one + pchi = pchi + 1; +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } +#endif + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------------------- +// for box +// for EM wave specially symmetric case +// unify for phi1 and phi2 +//|---------------------------------------------------------------- +void surface_integral::surf_Wave(double rex, int lev, cgh *GH, + var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, + var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor, + void (*funcs)(double &, double &, double &, + double &, double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &)) // NN is the length of RP and IP +{ + const int InList = 13; + + MyList *DG_List = new MyList(Ex); + DG_List->insert(Ey); + DG_List->insert(Ez); + DG_List->insert(Bx); + DG_List->insert(By); + DG_List->insert(Bz); + DG_List->insert(chi); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + +#if 0 +// for debug + if(myrank==0) + { + double costheta, thetap; + double cosmphi,sinmphi; + + int i,j; + int lpsy=0; + if( Symmetry == 0 ) lpsy=1; + else if( Symmetry == 1 ) lpsy=2; + else if( Symmetry == 2 ) lpsy=8; + + double psi4RR,psi4II; + double px,py,pz; + double pEx,pEy,pEz,pBx,pBy,pBz; + double pchi,pgxx,pgxy,pgxz,pgyy,pgyz,pgzz; + for( n = 0; n <= n_tot-1; n++) + { +// need round off always + i = int(n/N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + for(int lp=0;lp myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + double px, py, pz; + double pEx, pEy, pEz, pBx, pBy, pBz; + double pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + px = pox[0][n]; + py = pox[1][n]; + pz = pox[2][n]; + pEx = shellf[InList * n]; + pEy = shellf[InList * n + 1]; + pEz = shellf[InList * n + 2]; + pBx = shellf[InList * n + 3]; + pBy = shellf[InList * n + 4]; + pBz = shellf[InList * n + 5]; + pchi = shellf[InList * n + 6]; + pgxx = shellf[InList * n + 7]; + pgxy = shellf[InList * n + 8]; + pgxz = shellf[InList * n + 9]; + pgyy = shellf[InList * n + 10]; + pgyz = shellf[InList * n + 11]; + pgzz = shellf[InList * n + 12]; + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + pz = -pz; + pEz = -pEz; + pBx = -pBx; + pBy = -pBy; + pgxz = -pgxz; + pgyz = -pgyz; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pEy = -pEy; + pBx = -pBx; + pBz = -pBz; + pgxy = -pgxy; + pgyz = -pgyz; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pz = -pz; + pEz = -pEz; + pBz = -pBz; + pgxz = -pgxz; + pEy = -pEy; + pBy = -pBy; + pgxy = -pgxy; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + px = -px; + pEx = -pEx; + pBy = -pBy; + pBz = -pBz; + pgxy = -pgxy; + pgxz = -pgxz; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + pz = -pz; + px = -px; + pEz = -pEz; + pBz = -pBz; + pgyz = -pgyz; + pEx = -pEx; + pBx = -pBx; + pgxy = -pgxy; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pEx = -pEx; + pBx = -pBx; + pgxz = -pgxz; + pEy = -pEy; + pBy = -pBy; + pgyz = -pgyz; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pz = -pz; + pEx = -pEx; + pEy = -pEy; + pEz = -pEz; + } + + funcs(px, py, pz, pchi, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, pEx, pEy, pEz, pBx, pBy, pBz, + psi4RR, psi4II); + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 + + // find back the one + pchi = pchi + 1; +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } +#endif + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------------------- +// for null shell patch2 +//|---------------------------------------------------------------- +// rex is x instead of r +void surface_integral::surf_Wave(double rex, int lev, NullShellPatch2 *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor) // NN is the length of RP and IP +// spinw 0 for scalar; 1 for electricmagnetic wave; 2 for gravitaitonal wave +// we always assume spinw >= 0 +{ + const int InList = 2; + + MyList *DG_List = new MyList(Rpsi4); + DG_List->insert(Ipsi4); + + int n; + // since we used x instead of r, these global coordinates are fake + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + GH->Interp_Points_2D(DG_List, n_tot, pox, shellf, Symmetry); + + int mp, Lp, Nmin, Nmax; + + mp = n_tot / cpusize; + Lp = n_tot - cpusize * mp; + + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + //|~~~~~> Integrate the dot product of Dphi with the surface normal. + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + } + + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 + // based on Eq.(41) of PRD 77, 024027 (2008) +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi); // + is because \bar of \bar{Y^s_lm} in Eq.(40) + // of PRD 77, 024027 (2008) + IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } + + for (int ii = 0; ii < NN; ii++) + { +// do not need multiply with rex for null shell +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * dphi; + IP_out[ii] = IP_out[ii] * dphi; +#else + RP_out[ii] = RP_out[ii] * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------------------- +// for null shell patch +//|---------------------------------------------------------------- +// rex is x instead of r +void surface_integral::surf_Wave(double rex, int lev, NullShellPatch *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor) // NN is the length of RP and IP +// spinw 0 for scalar; 1 for electricmagnetic wave; 2 for gravitaitonal wave +// we always assume spinw >= 0 +{ + const int InList = 2; + + MyList *DG_List = new MyList(Rpsi4); + DG_List->insert(Ipsi4); + + int n; + // since we used x instead of r, these global coordinates are fake + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + GH->Interp_Points_2D(DG_List, n_tot, pox, shellf, Symmetry); + + int mp, Lp, Nmin, Nmax; + + mp = n_tot / cpusize; + Lp = n_tot - cpusize * mp; + + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + //|~~~~~> Integrate the dot product of Dphi with the surface normal. + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = shellf[InList * n + 1]; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + psi4RR = shellf[InList * n]; + psi4II = -shellf[InList * n + 1]; + } + + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 + // based on Eq.(41) of PRD 77, 024027 (2008) +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap * (psi4RR * cosmphi + psi4II * sinmphi); // + is because \bar of \bar{Y^s_lm} in Eq.(40) + // of PRD 77, 024027 (2008) + IP_out[countlm] = IP_out[countlm] + thetap * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } + + for (int ii = 0; ii < NN; ii++) + { +// do not need multiply with rex for null shell +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * dphi; + IP_out[ii] = IP_out[ii] * dphi; +#else + RP_out[ii] = RP_out[ii] * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------- +//| +//| ADM mass, linear momentum and angular momentum +//| +//|---------------------------------------------------- void surface_integral::surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var *trK, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, @@ -2490,23 +2490,23 @@ void surface_integral::surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var Pp = Pp->next; } } - - const int InList = 17; - - MyList *DG_List = new MyList(Sfx_rhs); - DG_List->insert(Sfy_rhs); - DG_List->insert(Sfz_rhs); - DG_List->insert(chi); - DG_List->insert(trK); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - DG_List->insert(Axx); - DG_List->insert(Axy); - DG_List->insert(Axz); + + const int InList = 17; + + MyList *DG_List = new MyList(Sfx_rhs); + DG_List->insert(Sfy_rhs); + DG_List->insert(Sfz_rhs); + DG_List->insert(chi); + DG_List->insert(trK); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + DG_List->insert(Axx); + DG_List->insert(Axy); + DG_List->insert(Axz); DG_List->insert(Ayy); DG_List->insert(Ayz); DG_List->insert(Azz); @@ -2524,190 +2524,190 @@ void surface_integral::surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var int mp, Lp, Nmin, Nmax; mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - + Lp = n_tot - cpusize * mp; + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + double *shellf; shellf = new double[n_tot * InList]; // we have assumed there is only one box on this level, // so we do not need loop boxes GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry, Nmin, Nmax); - - double Mass_out = 0; - double ang_outx, ang_outy, ang_outz; - double p_outx, p_outy, p_outz; - ang_outx = ang_outy = ang_outz = 0.0; - p_outx = p_outy = p_outz = 0.0; - const double f1o8 = 0.125; - - double Chi, Psi; - double Gxx, Gxy, Gxz, Gyy, Gyz, Gzz; - double gupxx, gupxy, gupxz, gupyy, gupyz, gupzz; - double TRK, axx, axy, axz, ayy, ayz, azz; - double aupxx, aupxy, aupxz, aupyx, aupyy, aupyz, aupzx, aupzy, aupzz; - int i; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - - Chi = shellf[InList * n + 3]; // chi in fact - TRK = shellf[InList * n + 4]; - Gxx = shellf[InList * n + 5] + 1.0; - Gxy = shellf[InList * n + 6]; - Gxz = shellf[InList * n + 7]; - Gyy = shellf[InList * n + 8] + 1.0; - Gyz = shellf[InList * n + 9]; - Gzz = shellf[InList * n + 10] + 1.0; - axx = shellf[InList * n + 11]; - axy = shellf[InList * n + 12]; - axz = shellf[InList * n + 13]; - ayy = shellf[InList * n + 14]; - ayz = shellf[InList * n + 15]; - azz = shellf[InList * n + 16]; - - Chi = 1.0 / (1.0 + Chi); // exp(4*phi) - Psi = Chi * sqrt(Chi); // Psi^6 - -// Chi^2 corresponds to metric determinant -// but this factor has been considered in f_admmass_bssn -#ifdef GaussInt - // wtcostheta is even function respect costheta - Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]) * wtcostheta[i]; -#else - Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]); -#endif - - gupzz = Gxx * Gyy * Gzz + Gxy * Gyz * Gxz + Gxz * Gxy * Gyz - - Gxz * Gyy * Gxz - Gxy * Gxy * Gzz - Gxx * Gyz * Gyz; - gupxx = (Gyy * Gzz - Gyz * Gyz) / gupzz; - gupxy = -(Gxy * Gzz - Gyz * Gxz) / gupzz; - gupxz = (Gxy * Gyz - Gyy * Gxz) / gupzz; - gupyy = (Gxx * Gzz - Gxz * Gxz) / gupzz; - gupyz = -(Gxx * Gyz - Gxy * Gxz) / gupzz; - gupzz = (Gxx * Gyy - Gxy * Gxy) / gupzz; - - aupxx = gupxx * axx + gupxy * axy + gupxz * axz; - aupxy = gupxx * axy + gupxy * ayy + gupxz * ayz; - aupxz = gupxx * axz + gupxy * ayz + gupxz * azz; - aupyx = gupxy * axx + gupyy * axy + gupyz * axz; - aupyy = gupxy * axy + gupyy * ayy + gupyz * ayz; - aupyz = gupxy * axz + gupyy * ayz + gupyz * azz; - aupzx = gupxz * axx + gupyz * axy + gupzz * axz; - aupzy = gupxz * axy + gupyz * ayy + gupzz * ayz; - aupzz = gupxz * axz + gupyz * ayz + gupzz * azz; - if (Symmetry == 0) - { -#ifdef GaussInt - // wtcostheta is even function respect costheta - // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m + + double Mass_out = 0; + double ang_outx, ang_outy, ang_outz; + double p_outx, p_outy, p_outz; + ang_outx = ang_outy = ang_outz = 0.0; + p_outx = p_outy = p_outz = 0.0; + const double f1o8 = 0.125; + + double Chi, Psi; + double Gxx, Gxy, Gxz, Gyy, Gyz, Gzz; + double gupxx, gupxy, gupxz, gupyy, gupyz, gupzz; + double TRK, axx, axy, axz, ayy, ayz, azz; + double aupxx, aupxy, aupxz, aupyx, aupyy, aupyz, aupzx, aupzy, aupzz; + int i; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + + Chi = shellf[InList * n + 3]; // chi in fact + TRK = shellf[InList * n + 4]; + Gxx = shellf[InList * n + 5] + 1.0; + Gxy = shellf[InList * n + 6]; + Gxz = shellf[InList * n + 7]; + Gyy = shellf[InList * n + 8] + 1.0; + Gyz = shellf[InList * n + 9]; + Gzz = shellf[InList * n + 10] + 1.0; + axx = shellf[InList * n + 11]; + axy = shellf[InList * n + 12]; + axz = shellf[InList * n + 13]; + ayy = shellf[InList * n + 14]; + ayz = shellf[InList * n + 15]; + azz = shellf[InList * n + 16]; + + Chi = 1.0 / (1.0 + Chi); // exp(4*phi) + Psi = Chi * sqrt(Chi); // Psi^6 + +// Chi^2 corresponds to metric determinant +// but this factor has been considered in f_admmass_bssn +#ifdef GaussInt + // wtcostheta is even function respect costheta + Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]) * wtcostheta[i]; +#else + Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]); +#endif + + gupzz = Gxx * Gyy * Gzz + Gxy * Gyz * Gxz + Gxz * Gxy * Gyz - + Gxz * Gyy * Gxz - Gxy * Gxy * Gzz - Gxx * Gyz * Gyz; + gupxx = (Gyy * Gzz - Gyz * Gyz) / gupzz; + gupxy = -(Gxy * Gzz - Gyz * Gxz) / gupzz; + gupxz = (Gxy * Gyz - Gyy * Gxz) / gupzz; + gupyy = (Gxx * Gzz - Gxz * Gxz) / gupzz; + gupyz = -(Gxx * Gyz - Gxy * Gxz) / gupzz; + gupzz = (Gxx * Gyy - Gxy * Gxy) / gupzz; + + aupxx = gupxx * axx + gupxy * axy + gupxz * axz; + aupxy = gupxx * axy + gupxy * ayy + gupxz * ayz; + aupxz = gupxx * axz + gupxy * ayz + gupxz * azz; + aupyx = gupxy * axx + gupyy * axy + gupyz * axz; + aupyy = gupxy * axy + gupyy * ayy + gupyz * ayz; + aupyz = gupxy * axz + gupyy * ayz + gupyz * azz; + aupzx = gupxz * axx + gupyz * axy + gupzz * axz; + aupzy = gupxz * axy + gupyz * ayy + gupzz * ayz; + aupzz = gupxz * axz + gupyz * ayz + gupzz * azz; + if (Symmetry == 0) + { +#ifdef GaussInt + // wtcostheta is even function respect costheta + // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)) * wtcostheta[i]; - // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m - ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)) * wtcostheta[i]; - // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; -#else - // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m - ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)); - // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m - ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)); - // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); -#endif - } - else if (Symmetry == 1) - { -#ifdef GaussInt - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; -#else - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); -#endif - } - - axx = Chi * (axx + Gxx * TRK / 3.0); - axy = Chi * (axy + Gxy * TRK / 3.0); - axz = Chi * (axz + Gxz * TRK / 3.0); - ayy = Chi * (ayy + Gyy * TRK / 3.0); - ayz = Chi * (ayz + Gyz * TRK / 3.0); - azz = Chi * (azz + Gzz * TRK / 3.0); - - axx = axx - TRK; - ayy = ayy - TRK; - azz = azz - TRK; - - // 1/8\pi \int \psi^6 (K_mi - \delta_mi trK) dS^m: lower index linear momentum - if (Symmetry == 0) - { -#ifdef GaussInt - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; - p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz) * wtcostheta[i]; -#else - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); - p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz); -#endif - } - else if (Symmetry == 1) - { -#ifdef GaussInt - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; -#else - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); -#endif - } - } - - { - double scalar_out[7] = {Mass_out, ang_outx, ang_outy, ang_outz, p_outx, p_outy, p_outz}; - double scalar_in[7]; - MPI_Allreduce(scalar_out, scalar_in, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - mass = scalar_in[0]; sx = scalar_in[1]; sy = scalar_in[2]; sz = scalar_in[3]; - px = scalar_in[4]; py = scalar_in[5]; pz = scalar_in[6]; - } - -#ifdef GaussInt - mass = mass * rex * rex * dphi * factor; - - sx = sx * rex * rex * dphi * (1.0 / PI) * factor; - sy = sy * rex * rex * dphi * (1.0 / PI) * factor; - sz = sz * rex * rex * dphi * (1.0 / PI) * factor; - - px = px * rex * rex * dphi * (1.0 / PI) * factor; - py = py * rex * rex * dphi * (1.0 / PI) * factor; - pz = pz * rex * rex * dphi * (1.0 / PI) * factor; -#else - mass = mass * rex * rex * dphi * dcostheta * factor; - - sx = sx * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - sy = sy * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - sz = sz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - - px = px * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - py = py * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - pz = pz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; -#endif - - Rout[0] = mass; - Rout[1] = px; - Rout[2] = py; - Rout[3] = pz; - Rout[4] = sx; - Rout[5] = sy; - Rout[6] = sz; - + // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m + ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)) * wtcostheta[i]; + // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; +#else + // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m + ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)); + // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m + ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)); + // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); +#endif + } + else if (Symmetry == 1) + { +#ifdef GaussInt + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; +#else + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); +#endif + } + + axx = Chi * (axx + Gxx * TRK / 3.0); + axy = Chi * (axy + Gxy * TRK / 3.0); + axz = Chi * (axz + Gxz * TRK / 3.0); + ayy = Chi * (ayy + Gyy * TRK / 3.0); + ayz = Chi * (ayz + Gyz * TRK / 3.0); + azz = Chi * (azz + Gzz * TRK / 3.0); + + axx = axx - TRK; + ayy = ayy - TRK; + azz = azz - TRK; + + // 1/8\pi \int \psi^6 (K_mi - \delta_mi trK) dS^m: lower index linear momentum + if (Symmetry == 0) + { +#ifdef GaussInt + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; + p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz) * wtcostheta[i]; +#else + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); + p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz); +#endif + } + else if (Symmetry == 1) + { +#ifdef GaussInt + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; +#else + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); +#endif + } + } + + { + double scalar_out[7] = {Mass_out, ang_outx, ang_outy, ang_outz, p_outx, p_outy, p_outz}; + double scalar_in[7]; + MPI_Allreduce(scalar_out, scalar_in, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + mass = scalar_in[0]; sx = scalar_in[1]; sy = scalar_in[2]; sz = scalar_in[3]; + px = scalar_in[4]; py = scalar_in[5]; pz = scalar_in[6]; + } + +#ifdef GaussInt + mass = mass * rex * rex * dphi * factor; + + sx = sx * rex * rex * dphi * (1.0 / PI) * factor; + sy = sy * rex * rex * dphi * (1.0 / PI) * factor; + sz = sz * rex * rex * dphi * (1.0 / PI) * factor; + + px = px * rex * rex * dphi * (1.0 / PI) * factor; + py = py * rex * rex * dphi * (1.0 / PI) * factor; + pz = pz * rex * rex * dphi * (1.0 / PI) * factor; +#else + mass = mass * rex * rex * dphi * dcostheta * factor; + + sx = sx * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + sy = sy * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + sz = sz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + + px = px * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + py = py * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + pz = pz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; +#endif + + Rout[0] = mass; + Rout[1] = px; + Rout[2] = py; + Rout[3] = pz; + Rout[4] = sx; + Rout[5] = sy; + Rout[6] = sz; + delete[] pox[0]; delete[] pox[1]; delete[] pox[2]; @@ -2724,10 +2724,10 @@ void surface_integral::surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var int lmyrank; MPI_Comm_rank(Comm_here, &lmyrank); if (lmyrank == 0 && GH->grids[lev] != 1) - if (Monitor && Monitor->outfile) - Monitor->outfile << "WARNING: surface integral on multipatches" << endl; - else - cout << "WARNING: surface integral on multipatches" << endl; + if (Monitor && Monitor->outfile) + Monitor->outfile << "WARNING: surface integral on multipatches" << endl; + else + cout << "WARNING: surface integral on multipatches" << endl; double mass, px, py, pz, sx, sy, sz; @@ -2757,23 +2757,23 @@ void surface_integral::surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var Pp = Pp->next; } } - - const int InList = 17; - - MyList *DG_List = new MyList(Sfx_rhs); - DG_List->insert(Sfy_rhs); - DG_List->insert(Sfz_rhs); - DG_List->insert(chi); - DG_List->insert(trK); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - DG_List->insert(Axx); - DG_List->insert(Axy); - DG_List->insert(Axz); + + const int InList = 17; + + MyList *DG_List = new MyList(Sfx_rhs); + DG_List->insert(Sfy_rhs); + DG_List->insert(Sfz_rhs); + DG_List->insert(chi); + DG_List->insert(trK); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + DG_List->insert(Axx); + DG_List->insert(Axy); + DG_List->insert(Axz); DG_List->insert(Ayy); DG_List->insert(Ayz); DG_List->insert(Azz); @@ -2791,204 +2791,204 @@ void surface_integral::surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var double *shellf; shellf = new double[n_tot * InList]; - - // we have assumed there is only one box on this level, - // so we do not need loop boxes - GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry, Comm_here); - - double Mass_out = 0; - double ang_outx, ang_outy, ang_outz; - double p_outx, p_outy, p_outz; - ang_outx = ang_outy = ang_outz = 0.0; - p_outx = p_outy = p_outz = 0.0; - const double f1o8 = 0.125; - - int mp, Lp, Nmin, Nmax; - - int cpusize_here; - MPI_Comm_size(Comm_here, &cpusize_here); - - mp = n_tot / cpusize_here; - Lp = n_tot - cpusize_here * mp; - - if (Lp > lmyrank) - { - Nmin = lmyrank * mp + lmyrank; - Nmax = Nmin + mp; - } - else - { - Nmin = lmyrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - double Chi, Psi; - double Gxx, Gxy, Gxz, Gyy, Gyz, Gzz; - double gupxx, gupxy, gupxz, gupyy, gupyz, gupzz; - double TRK, axx, axy, axz, ayy, ayz, azz; - double aupxx, aupxy, aupxz, aupyx, aupyy, aupyz, aupzx, aupzy, aupzz; - int i; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - - Chi = shellf[InList * n + 3]; // chi in fact - TRK = shellf[InList * n + 4]; - Gxx = shellf[InList * n + 5] + 1.0; - Gxy = shellf[InList * n + 6]; - Gxz = shellf[InList * n + 7]; - Gyy = shellf[InList * n + 8] + 1.0; - Gyz = shellf[InList * n + 9]; - Gzz = shellf[InList * n + 10] + 1.0; - axx = shellf[InList * n + 11]; - axy = shellf[InList * n + 12]; - axz = shellf[InList * n + 13]; - ayy = shellf[InList * n + 14]; - ayz = shellf[InList * n + 15]; - azz = shellf[InList * n + 16]; - - Chi = 1.0 / (1.0 + Chi); // exp(4*phi) - Psi = Chi * sqrt(Chi); // Psi^6 - -// Chi^2 corresponds to metric determinant -// but this factor has been considered in f_admmass_bssn -#ifdef GaussInt - // wtcostheta is even function respect costheta - Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]) * wtcostheta[i]; -#else - Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]); -#endif - - gupzz = Gxx * Gyy * Gzz + Gxy * Gyz * Gxz + Gxz * Gxy * Gyz - - Gxz * Gyy * Gxz - Gxy * Gxy * Gzz - Gxx * Gyz * Gyz; - gupxx = (Gyy * Gzz - Gyz * Gyz) / gupzz; - gupxy = -(Gxy * Gzz - Gyz * Gxz) / gupzz; - gupxz = (Gxy * Gyz - Gyy * Gxz) / gupzz; - gupyy = (Gxx * Gzz - Gxz * Gxz) / gupzz; - gupyz = -(Gxx * Gyz - Gxy * Gxz) / gupzz; - gupzz = (Gxx * Gyy - Gxy * Gxy) / gupzz; - - aupxx = gupxx * axx + gupxy * axy + gupxz * axz; - aupxy = gupxx * axy + gupxy * ayy + gupxz * ayz; - aupxz = gupxx * axz + gupxy * ayz + gupxz * azz; - aupyx = gupxy * axx + gupyy * axy + gupyz * axz; - aupyy = gupxy * axy + gupyy * ayy + gupyz * ayz; - aupyz = gupxy * axz + gupyy * ayz + gupyz * azz; - aupzx = gupxz * axx + gupyz * axy + gupzz * axz; - aupzy = gupxz * axy + gupyz * ayy + gupzz * ayz; - aupzz = gupxz * axz + gupyz * ayz + gupzz * azz; - if (Symmetry == 0) - { -#ifdef GaussInt - // wtcostheta is even function respect costheta - // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m - ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)) * wtcostheta[i]; - // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m - ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)) * wtcostheta[i]; - // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; -#else - // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m - ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)); - // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m - ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)); - // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); -#endif - } - else if (Symmetry == 1) - { -#ifdef GaussInt - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; -#else - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); -#endif - } - - axx = Chi * (axx + Gxx * TRK / 3.0); - axy = Chi * (axy + Gxy * TRK / 3.0); - axz = Chi * (axz + Gxz * TRK / 3.0); - ayy = Chi * (ayy + Gyy * TRK / 3.0); - ayz = Chi * (ayz + Gyz * TRK / 3.0); - azz = Chi * (azz + Gzz * TRK / 3.0); - - axx = axx - TRK; - ayy = ayy - TRK; - azz = azz - TRK; - - // 1/8\pi \int \psi^6 (K_mi - \delta_mi trK) dS^m: lower index linear momentum - if (Symmetry == 0) - { -#ifdef GaussInt - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; - p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz) * wtcostheta[i]; -#else - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); - p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz); -#endif - } - else if (Symmetry == 1) - { -#ifdef GaussInt - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; -#else - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); -#endif - } - } - - { - double scalar_out[7] = {Mass_out, ang_outx, ang_outy, ang_outz, p_outx, p_outy, p_outz}; - double scalar_in[7]; - MPI_Allreduce(scalar_out, scalar_in, 7, MPI_DOUBLE, MPI_SUM, Comm_here); - mass = scalar_in[0]; sx = scalar_in[1]; sy = scalar_in[2]; sz = scalar_in[3]; - px = scalar_in[4]; py = scalar_in[5]; pz = scalar_in[6]; - } - -#ifdef GaussInt - mass = mass * rex * rex * dphi * factor; - - sx = sx * rex * rex * dphi * (1.0 / PI) * factor; - sy = sy * rex * rex * dphi * (1.0 / PI) * factor; - sz = sz * rex * rex * dphi * (1.0 / PI) * factor; - - px = px * rex * rex * dphi * (1.0 / PI) * factor; - py = py * rex * rex * dphi * (1.0 / PI) * factor; - pz = pz * rex * rex * dphi * (1.0 / PI) * factor; -#else - mass = mass * rex * rex * dphi * dcostheta * factor; - - sx = sx * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - sy = sy * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - sz = sz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - - px = px * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - py = py * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - pz = pz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; -#endif - - Rout[0] = mass; - Rout[1] = px; - Rout[2] = py; - Rout[3] = pz; - Rout[4] = sx; - Rout[5] = sy; - Rout[6] = sz; - + + // we have assumed there is only one box on this level, + // so we do not need loop boxes + GH->PatL[lev]->data->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry, Comm_here); + + double Mass_out = 0; + double ang_outx, ang_outy, ang_outz; + double p_outx, p_outy, p_outz; + ang_outx = ang_outy = ang_outz = 0.0; + p_outx = p_outy = p_outz = 0.0; + const double f1o8 = 0.125; + + int mp, Lp, Nmin, Nmax; + + int cpusize_here; + MPI_Comm_size(Comm_here, &cpusize_here); + + mp = n_tot / cpusize_here; + Lp = n_tot - cpusize_here * mp; + + if (Lp > lmyrank) + { + Nmin = lmyrank * mp + lmyrank; + Nmax = Nmin + mp; + } + else + { + Nmin = lmyrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + double Chi, Psi; + double Gxx, Gxy, Gxz, Gyy, Gyz, Gzz; + double gupxx, gupxy, gupxz, gupyy, gupyz, gupzz; + double TRK, axx, axy, axz, ayy, ayz, azz; + double aupxx, aupxy, aupxz, aupyx, aupyy, aupyz, aupzx, aupzy, aupzz; + int i; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + + Chi = shellf[InList * n + 3]; // chi in fact + TRK = shellf[InList * n + 4]; + Gxx = shellf[InList * n + 5] + 1.0; + Gxy = shellf[InList * n + 6]; + Gxz = shellf[InList * n + 7]; + Gyy = shellf[InList * n + 8] + 1.0; + Gyz = shellf[InList * n + 9]; + Gzz = shellf[InList * n + 10] + 1.0; + axx = shellf[InList * n + 11]; + axy = shellf[InList * n + 12]; + axz = shellf[InList * n + 13]; + ayy = shellf[InList * n + 14]; + ayz = shellf[InList * n + 15]; + azz = shellf[InList * n + 16]; + + Chi = 1.0 / (1.0 + Chi); // exp(4*phi) + Psi = Chi * sqrt(Chi); // Psi^6 + +// Chi^2 corresponds to metric determinant +// but this factor has been considered in f_admmass_bssn +#ifdef GaussInt + // wtcostheta is even function respect costheta + Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]) * wtcostheta[i]; +#else + Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]); +#endif + + gupzz = Gxx * Gyy * Gzz + Gxy * Gyz * Gxz + Gxz * Gxy * Gyz - + Gxz * Gyy * Gxz - Gxy * Gxy * Gzz - Gxx * Gyz * Gyz; + gupxx = (Gyy * Gzz - Gyz * Gyz) / gupzz; + gupxy = -(Gxy * Gzz - Gyz * Gxz) / gupzz; + gupxz = (Gxy * Gyz - Gyy * Gxz) / gupzz; + gupyy = (Gxx * Gzz - Gxz * Gxz) / gupzz; + gupyz = -(Gxx * Gyz - Gxy * Gxz) / gupzz; + gupzz = (Gxx * Gyy - Gxy * Gxy) / gupzz; + + aupxx = gupxx * axx + gupxy * axy + gupxz * axz; + aupxy = gupxx * axy + gupxy * ayy + gupxz * ayz; + aupxz = gupxx * axz + gupxy * ayz + gupxz * azz; + aupyx = gupxy * axx + gupyy * axy + gupyz * axz; + aupyy = gupxy * axy + gupyy * ayy + gupyz * ayz; + aupyz = gupxy * axz + gupyy * ayz + gupyz * azz; + aupzx = gupxz * axx + gupyz * axy + gupzz * axz; + aupzy = gupxz * axy + gupyz * ayy + gupzz * ayz; + aupzz = gupxz * axz + gupyz * ayz + gupzz * azz; + if (Symmetry == 0) + { +#ifdef GaussInt + // wtcostheta is even function respect costheta + // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m + ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)) * wtcostheta[i]; + // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m + ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)) * wtcostheta[i]; + // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; +#else + // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m + ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)); + // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m + ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)); + // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); +#endif + } + else if (Symmetry == 1) + { +#ifdef GaussInt + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; +#else + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); +#endif + } + + axx = Chi * (axx + Gxx * TRK / 3.0); + axy = Chi * (axy + Gxy * TRK / 3.0); + axz = Chi * (axz + Gxz * TRK / 3.0); + ayy = Chi * (ayy + Gyy * TRK / 3.0); + ayz = Chi * (ayz + Gyz * TRK / 3.0); + azz = Chi * (azz + Gzz * TRK / 3.0); + + axx = axx - TRK; + ayy = ayy - TRK; + azz = azz - TRK; + + // 1/8\pi \int \psi^6 (K_mi - \delta_mi trK) dS^m: lower index linear momentum + if (Symmetry == 0) + { +#ifdef GaussInt + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; + p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz) * wtcostheta[i]; +#else + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); + p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz); +#endif + } + else if (Symmetry == 1) + { +#ifdef GaussInt + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; +#else + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); +#endif + } + } + + { + double scalar_out[7] = {Mass_out, ang_outx, ang_outy, ang_outz, p_outx, p_outy, p_outz}; + double scalar_in[7]; + MPI_Allreduce(scalar_out, scalar_in, 7, MPI_DOUBLE, MPI_SUM, Comm_here); + mass = scalar_in[0]; sx = scalar_in[1]; sy = scalar_in[2]; sz = scalar_in[3]; + px = scalar_in[4]; py = scalar_in[5]; pz = scalar_in[6]; + } + +#ifdef GaussInt + mass = mass * rex * rex * dphi * factor; + + sx = sx * rex * rex * dphi * (1.0 / PI) * factor; + sy = sy * rex * rex * dphi * (1.0 / PI) * factor; + sz = sz * rex * rex * dphi * (1.0 / PI) * factor; + + px = px * rex * rex * dphi * (1.0 / PI) * factor; + py = py * rex * rex * dphi * (1.0 / PI) * factor; + pz = pz * rex * rex * dphi * (1.0 / PI) * factor; +#else + mass = mass * rex * rex * dphi * dcostheta * factor; + + sx = sx * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + sy = sy * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + sz = sz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + + px = px * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + py = py * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + pz = pz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; +#endif + + Rout[0] = mass; + Rout[1] = px; + Rout[2] = py; + Rout[3] = pz; + Rout[4] = sx; + Rout[5] = sy; + Rout[6] = sz; + delete[] pox[0]; delete[] pox[1]; delete[] pox[2]; delete[] shellf; DG_List->clearList(); } -//|---------------------------------------------------------------- -// for shell patch -//|---------------------------------------------------------------- +//|---------------------------------------------------------------- +// for shell patch +//|---------------------------------------------------------------- void surface_integral::surf_MassPAng(double rex, int lev, ShellPatch *GH, var *chi, var *trK, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, @@ -2998,15 +2998,15 @@ void surface_integral::surf_MassPAng(double rex, int lev, ShellPatch *GH, var *c { if (lev != 0) { - if (myrank == 0) - { - if (Monitor && Monitor->outfile) - Monitor->outfile << "WARNING: shell surface integral not on level 0" << endl; - else - cout << "WARNING: shell surface integral not on level 0" << endl; - } - return; - } + if (myrank == 0) + { + if (Monitor && Monitor->outfile) + Monitor->outfile << "WARNING: shell surface integral not on level 0" << endl; + else + cout << "WARNING: shell surface integral not on level 0" << endl; + } + return; + } double mass, px, py, pz, sx, sy, sz; @@ -3047,23 +3047,23 @@ void surface_integral::surf_MassPAng(double rex, int lev, ShellPatch *GH, var *c Pp = Pp->next; } } - - const int InList = 17; - - MyList *DG_List = new MyList(Sfx_rhs); - DG_List->insert(Sfy_rhs); - DG_List->insert(Sfz_rhs); - DG_List->insert(chi); - DG_List->insert(trK); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - DG_List->insert(Axx); - DG_List->insert(Axy); - DG_List->insert(Axz); + + const int InList = 17; + + MyList *DG_List = new MyList(Sfx_rhs); + DG_List->insert(Sfy_rhs); + DG_List->insert(Sfz_rhs); + DG_List->insert(chi); + DG_List->insert(trK); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + DG_List->insert(Axx); + DG_List->insert(Axy); + DG_List->insert(Axz); DG_List->insert(Ayy); DG_List->insert(Ayz); DG_List->insert(Azz); @@ -3081,191 +3081,191 @@ void surface_integral::surf_MassPAng(double rex, int lev, ShellPatch *GH, var *c double *shellf; shellf = new double[n_tot * InList]; - - // we have assumed there is only one box on this level, - // so we do not need loop boxes - GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); - - double Mass_out = 0; - double ang_outx, ang_outy, ang_outz; - double p_outx, p_outy, p_outz; - ang_outx = ang_outy = ang_outz = 0.0; - p_outx = p_outy = p_outz = 0.0; - const double f1o8 = 0.125; - - int mp, Lp, Nmin, Nmax; - - mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - double Chi, Psi; - double Gxx, Gxy, Gxz, Gyy, Gyz, Gzz; - double gupxx, gupxy, gupxz, gupyy, gupyz, gupzz; - double TRK, axx, axy, axz, ayy, ayz, azz; - double aupxx, aupxy, aupxz, aupyx, aupyy, aupyz, aupzx, aupzy, aupzz; - int i; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - - Chi = shellf[InList * n + 3]; // chi in fact - TRK = shellf[InList * n + 4]; - Gxx = shellf[InList * n + 5] + 1.0; - Gxy = shellf[InList * n + 6]; - Gxz = shellf[InList * n + 7]; - Gyy = shellf[InList * n + 8] + 1.0; - Gyz = shellf[InList * n + 9]; - Gzz = shellf[InList * n + 10] + 1.0; - axx = shellf[InList * n + 11]; - axy = shellf[InList * n + 12]; - axz = shellf[InList * n + 13]; - ayy = shellf[InList * n + 14]; - ayz = shellf[InList * n + 15]; - azz = shellf[InList * n + 16]; - - Chi = 1.0 / (1.0 + Chi); // exp(4*phi) - Psi = Chi * sqrt(Chi); // Psi^6 -// Chi^2 corresponds to metric determinant -// but this factor has been considered in f_admmass_bssn -#ifdef GaussInt - // wtcostheta is even function respect costheta - Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]) * wtcostheta[i]; -#else - Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]); -#endif - - gupzz = Gxx * Gyy * Gzz + Gxy * Gyz * Gxz + Gxz * Gxy * Gyz - - Gxz * Gyy * Gxz - Gxy * Gxy * Gzz - Gxx * Gyz * Gyz; - gupxx = (Gyy * Gzz - Gyz * Gyz) / gupzz; - gupxy = -(Gxy * Gzz - Gyz * Gxz) / gupzz; - gupxz = (Gxy * Gyz - Gyy * Gxz) / gupzz; - gupyy = (Gxx * Gzz - Gxz * Gxz) / gupzz; - gupyz = -(Gxx * Gyz - Gxy * Gxz) / gupzz; - gupzz = (Gxx * Gyy - Gxy * Gxy) / gupzz; - - aupxx = gupxx * axx + gupxy * axy + gupxz * axz; - aupxy = gupxx * axy + gupxy * ayy + gupxz * ayz; - aupxz = gupxx * axz + gupxy * ayz + gupxz * azz; - aupyx = gupxy * axx + gupyy * axy + gupyz * axz; - aupyy = gupxy * axy + gupyy * ayy + gupyz * ayz; - aupyz = gupxy * axz + gupyy * ayz + gupyz * azz; - aupzx = gupxz * axx + gupyz * axy + gupzz * axz; - aupzy = gupxz * axy + gupyz * ayy + gupzz * ayz; - aupzz = gupxz * axz + gupyz * ayz + gupzz * azz; - if (Symmetry == 0) - { -#ifdef GaussInt - // wtcostheta is even function respect costheta - // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m - ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)) * wtcostheta[i]; - // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m - ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)) * wtcostheta[i]; - // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; -#else - // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m - ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)); - // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m - ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)); - // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); -#endif - } - else if (Symmetry == 1) - { -#ifdef GaussInt - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; -#else - ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); -#endif - } - - axx = Chi * (axx + Gxx * TRK / 3.0); - axy = Chi * (axy + Gxy * TRK / 3.0); - axz = Chi * (axz + Gxz * TRK / 3.0); - ayy = Chi * (ayy + Gyy * TRK / 3.0); - ayz = Chi * (ayz + Gyz * TRK / 3.0); - azz = Chi * (azz + Gzz * TRK / 3.0); - - axx = axx - TRK; - ayy = ayy - TRK; - azz = azz - TRK; - - // 1/8\pi \int \psi^6 (K_mi - \delta_mi trK) dS^m: lower index linear momentum - if (Symmetry == 0) - { -#ifdef GaussInt - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; - p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz) * wtcostheta[i]; -#else - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); - p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz); -#endif - } - else if (Symmetry == 1) - { -#ifdef GaussInt - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; -#else - p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); - p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); -#endif - } - } - - { - double scalar_out[7] = {Mass_out, ang_outx, ang_outy, ang_outz, p_outx, p_outy, p_outz}; - double scalar_in[7]; - MPI_Allreduce(scalar_out, scalar_in, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - mass = scalar_in[0]; sx = scalar_in[1]; sy = scalar_in[2]; sz = scalar_in[3]; - px = scalar_in[4]; py = scalar_in[5]; pz = scalar_in[6]; - } - -#ifdef GaussInt - mass = mass * rex * rex * dphi * factor; - - sx = sx * rex * rex * dphi * (1.0 / PI) * factor; - sy = sy * rex * rex * dphi * (1.0 / PI) * factor; - sz = sz * rex * rex * dphi * (1.0 / PI) * factor; - - px = px * rex * rex * dphi * (1.0 / PI) * factor; - py = py * rex * rex * dphi * (1.0 / PI) * factor; - pz = pz * rex * rex * dphi * (1.0 / PI) * factor; -#else - mass = mass * rex * rex * dphi * dcostheta * factor; - - sx = sx * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - sy = sy * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - sz = sz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - - px = px * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - py = py * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; - pz = pz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; -#endif - - Rout[0] = mass; - Rout[1] = px; - Rout[2] = py; - Rout[3] = pz; - Rout[4] = sx; - Rout[5] = sy; - Rout[6] = sz; - + + // we have assumed there is only one box on this level, + // so we do not need loop boxes + GH->Interp_Points(DG_List, n_tot, pox, shellf, Symmetry); + + double Mass_out = 0; + double ang_outx, ang_outy, ang_outz; + double p_outx, p_outy, p_outz; + ang_outx = ang_outy = ang_outz = 0.0; + p_outx = p_outy = p_outz = 0.0; + const double f1o8 = 0.125; + + int mp, Lp, Nmin, Nmax; + + mp = n_tot / cpusize; + Lp = n_tot - cpusize * mp; + + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + double Chi, Psi; + double Gxx, Gxy, Gxz, Gyy, Gyz, Gzz; + double gupxx, gupxy, gupxz, gupyy, gupyz, gupzz; + double TRK, axx, axy, axz, ayy, ayz, azz; + double aupxx, aupxy, aupxz, aupyx, aupyy, aupyz, aupzx, aupzy, aupzz; + int i; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + + Chi = shellf[InList * n + 3]; // chi in fact + TRK = shellf[InList * n + 4]; + Gxx = shellf[InList * n + 5] + 1.0; + Gxy = shellf[InList * n + 6]; + Gxz = shellf[InList * n + 7]; + Gyy = shellf[InList * n + 8] + 1.0; + Gyz = shellf[InList * n + 9]; + Gzz = shellf[InList * n + 10] + 1.0; + axx = shellf[InList * n + 11]; + axy = shellf[InList * n + 12]; + axz = shellf[InList * n + 13]; + ayy = shellf[InList * n + 14]; + ayz = shellf[InList * n + 15]; + azz = shellf[InList * n + 16]; + + Chi = 1.0 / (1.0 + Chi); // exp(4*phi) + Psi = Chi * sqrt(Chi); // Psi^6 +// Chi^2 corresponds to metric determinant +// but this factor has been considered in f_admmass_bssn +#ifdef GaussInt + // wtcostheta is even function respect costheta + Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]) * wtcostheta[i]; +#else + Mass_out = Mass_out + (shellf[InList * n] * nx_g[n] + shellf[InList * n + 1] * ny_g[n] + shellf[InList * n + 2] * nz_g[n]); +#endif + + gupzz = Gxx * Gyy * Gzz + Gxy * Gyz * Gxz + Gxz * Gxy * Gyz - + Gxz * Gyy * Gxz - Gxy * Gxy * Gzz - Gxx * Gyz * Gyz; + gupxx = (Gyy * Gzz - Gyz * Gyz) / gupzz; + gupxy = -(Gxy * Gzz - Gyz * Gxz) / gupzz; + gupxz = (Gxy * Gyz - Gyy * Gxz) / gupzz; + gupyy = (Gxx * Gzz - Gxz * Gxz) / gupzz; + gupyz = -(Gxx * Gyz - Gxy * Gxz) / gupzz; + gupzz = (Gxx * Gyy - Gxy * Gxy) / gupzz; + + aupxx = gupxx * axx + gupxy * axy + gupxz * axz; + aupxy = gupxx * axy + gupxy * ayy + gupxz * ayz; + aupxz = gupxx * axz + gupxy * ayz + gupxz * azz; + aupyx = gupxy * axx + gupyy * axy + gupyz * axz; + aupyy = gupxy * axy + gupyy * ayy + gupyz * ayz; + aupyz = gupxy * axz + gupyy * ayz + gupyz * azz; + aupzx = gupxz * axx + gupyz * axy + gupzz * axz; + aupzy = gupxz * axy + gupyz * ayy + gupzz * ayz; + aupzz = gupxz * axz + gupyz * ayz + gupzz * azz; + if (Symmetry == 0) + { +#ifdef GaussInt + // wtcostheta is even function respect costheta + // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m + ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)) * wtcostheta[i]; + // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m + ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)) * wtcostheta[i]; + // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; +#else + // 1/8\pi \int \psi^6 (y A^m_z - zA^m_y) dS_m + ang_outx = ang_outx + f1o8 * Psi * (nx_g[n] * (pox[1][n] * aupxz - pox[2][n] * aupxy) + ny_g[n] * (pox[1][n] * aupyz - pox[2][n] * aupyy) + nz_g[n] * (pox[1][n] * aupzz - pox[2][n] * aupzy)); + // 1/8\pi \int \psi^6 (z A^m_x - xA^m_z) dS_m + ang_outy = ang_outy + f1o8 * Psi * (nx_g[n] * (pox[2][n] * aupxx - pox[0][n] * aupxz) + ny_g[n] * (pox[2][n] * aupyx - pox[0][n] * aupyz) + nz_g[n] * (pox[2][n] * aupzx - pox[0][n] * aupzz)); + // 1/8\pi \int \psi^6 (x A^m_y - yA^m_x) dS_m + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); +#endif + } + else if (Symmetry == 1) + { +#ifdef GaussInt + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)) * wtcostheta[i]; +#else + ang_outz = ang_outz + f1o8 * Psi * (nx_g[n] * (pox[0][n] * aupxy - pox[1][n] * aupxx) + ny_g[n] * (pox[0][n] * aupyy - pox[1][n] * aupyx) + nz_g[n] * (pox[0][n] * aupzy - pox[1][n] * aupzx)); +#endif + } + + axx = Chi * (axx + Gxx * TRK / 3.0); + axy = Chi * (axy + Gxy * TRK / 3.0); + axz = Chi * (axz + Gxz * TRK / 3.0); + ayy = Chi * (ayy + Gyy * TRK / 3.0); + ayz = Chi * (ayz + Gyz * TRK / 3.0); + azz = Chi * (azz + Gzz * TRK / 3.0); + + axx = axx - TRK; + ayy = ayy - TRK; + azz = azz - TRK; + + // 1/8\pi \int \psi^6 (K_mi - \delta_mi trK) dS^m: lower index linear momentum + if (Symmetry == 0) + { +#ifdef GaussInt + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; + p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz) * wtcostheta[i]; +#else + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); + p_outz = p_outz + f1o8 * Psi * (nx_g[n] * axz + ny_g[n] * ayz + nz_g[n] * azz); +#endif + } + else if (Symmetry == 1) + { +#ifdef GaussInt + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz) * wtcostheta[i]; + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz) * wtcostheta[i]; +#else + p_outx = p_outx + f1o8 * Psi * (nx_g[n] * axx + ny_g[n] * axy + nz_g[n] * axz); + p_outy = p_outy + f1o8 * Psi * (nx_g[n] * axy + ny_g[n] * ayy + nz_g[n] * ayz); +#endif + } + } + + { + double scalar_out[7] = {Mass_out, ang_outx, ang_outy, ang_outz, p_outx, p_outy, p_outz}; + double scalar_in[7]; + MPI_Allreduce(scalar_out, scalar_in, 7, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + mass = scalar_in[0]; sx = scalar_in[1]; sy = scalar_in[2]; sz = scalar_in[3]; + px = scalar_in[4]; py = scalar_in[5]; pz = scalar_in[6]; + } + +#ifdef GaussInt + mass = mass * rex * rex * dphi * factor; + + sx = sx * rex * rex * dphi * (1.0 / PI) * factor; + sy = sy * rex * rex * dphi * (1.0 / PI) * factor; + sz = sz * rex * rex * dphi * (1.0 / PI) * factor; + + px = px * rex * rex * dphi * (1.0 / PI) * factor; + py = py * rex * rex * dphi * (1.0 / PI) * factor; + pz = pz * rex * rex * dphi * (1.0 / PI) * factor; +#else + mass = mass * rex * rex * dphi * dcostheta * factor; + + sx = sx * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + sy = sy * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + sz = sz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + + px = px * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + py = py * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; + pz = pz * rex * rex * dphi * dcostheta * (1.0 / PI) * factor; +#endif + + Rout[0] = mass; + Rout[1] = px; + Rout[2] = py; + Rout[3] = pz; + Rout[4] = sx; + Rout[5] = sy; + Rout[6] = sz; + delete[] pox[0]; delete[] pox[1]; delete[] pox[2]; @@ -3895,621 +3895,621 @@ void surface_integral::surf_WaveMassPAng(double rex, int lev, ShellPatch *GH, //|---------------------------------------------------------------- // do not discriminate box and shell // for Gravitational wave specially symmetric case -//|---------------------------------------------------------------- -void surface_integral::surf_Wave(double rex, cgh *GH, ShellPatch *SH, - var *chi, var *trK, - var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, - var *chix, var *chiy, var *chiz, - var *trKx, var *trKy, var *trKz, - var *Axxx, var *Axxy, var *Axxz, - var *Axyx, var *Axyy, var *Axyz, - var *Axzx, var *Axzy, var *Axzz, - var *Ayyx, var *Ayyy, var *Ayyz, - var *Ayzx, var *Ayzy, var *Ayzz, - var *Azzx, var *Azzy, var *Azzz, - var *Gamxxx, var *Gamxxy, var *Gamxxz, var *Gamxyy, var *Gamxyz, var *Gamxzz, - var *Gamyxx, var *Gamyxy, var *Gamyxz, var *Gamyyy, var *Gamyyz, var *Gamyzz, - var *Gamzxx, var *Gamzxy, var *Gamzxz, var *Gamzyy, var *Gamzyz, var *Gamzzz, - var *Rxx, var *Rxy, var *Rxz, var *Ryy, var *Ryz, var *Rzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor) // NN is the length of RP and IP -{ - const int InList = 62; - - MyList *DG_List = new MyList(chi); - DG_List->insert(trK); - DG_List->insert(gxx); - DG_List->insert(gxy); - DG_List->insert(gxz); - DG_List->insert(gyy); - DG_List->insert(gyz); - DG_List->insert(gzz); - DG_List->insert(Axx); - DG_List->insert(Axy); - DG_List->insert(Axz); - DG_List->insert(Ayy); - DG_List->insert(Ayz); - DG_List->insert(Azz); - DG_List->insert(chix); - DG_List->insert(chiy); - DG_List->insert(chiz); - DG_List->insert(trKx); - DG_List->insert(trKy); - DG_List->insert(trKz); - DG_List->insert(Axxx); - DG_List->insert(Axxy); - DG_List->insert(Axxz); - DG_List->insert(Axyx); - DG_List->insert(Axyy); - DG_List->insert(Axyz); - DG_List->insert(Axzx); - DG_List->insert(Axzy); - DG_List->insert(Axzz); - DG_List->insert(Ayyx); - DG_List->insert(Ayyy); - DG_List->insert(Ayyz); - DG_List->insert(Ayzx); - DG_List->insert(Ayzy); - DG_List->insert(Ayzz); - DG_List->insert(Azzx); - DG_List->insert(Azzy); - DG_List->insert(Azzz); - DG_List->insert(Gamxxx); - DG_List->insert(Gamxxy); - DG_List->insert(Gamxxz); - DG_List->insert(Gamxyy); - DG_List->insert(Gamxyz); - DG_List->insert(Gamxzz); - DG_List->insert(Gamyxx); - DG_List->insert(Gamyxy); - DG_List->insert(Gamyxz); - DG_List->insert(Gamyyy); - DG_List->insert(Gamyyz); - DG_List->insert(Gamyzz); - DG_List->insert(Gamzxx); - DG_List->insert(Gamzxy); - DG_List->insert(Gamzxz); - DG_List->insert(Gamzyy); - DG_List->insert(Gamzyz); - DG_List->insert(Gamzzz); - DG_List->insert(Rxx); - DG_List->insert(Rxy); - DG_List->insert(Rxz); - DG_List->insert(Ryy); - DG_List->insert(Ryz); - DG_List->insert(Rzz); - - int n; - double *pox[3]; - for (int i = 0; i < 3; i++) - pox[i] = new double[n_tot]; - for (n = 0; n < n_tot; n++) - { - pox[0][n] = rex * nx_g[n]; - pox[1][n] = rex * ny_g[n]; - pox[2][n] = rex * nz_g[n]; - } - - double *shellf; - shellf = new double[n_tot * InList]; - - SR_Interp_Points(DG_List, GH, SH, n_tot, pox, shellf); - - double *RP_out, *IP_out; - RP_out = new double[NN]; - IP_out = new double[NN]; - - for (int ii = 0; ii < NN; ii++) - { - RP_out[ii] = 0; - IP_out[ii] = 0; - } - - int mp, Lp, Nmin, Nmax; - - mp = n_tot / cpusize; - Lp = n_tot - cpusize * mp; - - if (Lp > myrank) - { - Nmin = myrank * mp + myrank; - Nmax = Nmin + mp; - } - else - { - Nmin = myrank * mp + Lp; - Nmax = Nmin + mp - 1; - } - - // theta part - double costheta, thetap; - double cosmphi, sinmphi; - - int i, j; - int lpsy = 0; - if (Symmetry == 0) - lpsy = 1; - else if (Symmetry == 1) - lpsy = 2; - else if (Symmetry == 2) - lpsy = 8; - - double psi4RR, psi4II; - double px, py, pz; - double pchi, ptrK, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; - double pAxx, pAxy, pAxz, pAyy, pAyz, pAzz; - double pchix, pchiy, pchiz; - double ptrKx, ptrKy, ptrKz; - double pAxxx, pAxxy, pAxxz; - double pAxyx, pAxyy, pAxyz; - double pAxzx, pAxzy, pAxzz; - double pAyyx, pAyyy, pAyyz; - double pAyzx, pAyzy, pAyzz; - double pAzzx, pAzzy, pAzzz; - double pGamxxx, pGamxxy, pGamxxz, pGamxyy, pGamxyz, pGamxzz; - double pGamyxx, pGamyxy, pGamyxz, pGamyyy, pGamyyz, pGamyzz; - double pGamzxx, pGamzxy, pGamzxz, pGamzyy, pGamzyz, pGamzzz; - double pRxx, pRxy, pRxz, pRyy, pRyz, pRzz; - for (n = Nmin; n <= Nmax; n++) - { - // need round off always - i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 - j = n - i * N_phi; - - int countlm = 0; - for (int pl = spinw; pl < maxl + 1; pl++) - for (int pm = -pl; pm < pl + 1; pm++) - { - for (int lp = 0; lp < lpsy; lp++) - { - px = pox[0][n]; - py = pox[1][n]; - pz = pox[2][n]; - pchi = shellf[InList * n]; - ptrK = shellf[InList * n + 1]; - pgxx = shellf[InList * n + 2]; - pgxy = shellf[InList * n + 3]; - pgxz = shellf[InList * n + 4]; - pgyy = shellf[InList * n + 5]; - pgyz = shellf[InList * n + 6]; - pgzz = shellf[InList * n + 7]; - pAxx = shellf[InList * n + 8]; - pAxy = shellf[InList * n + 9]; - pAxz = shellf[InList * n + 10]; - pAyy = shellf[InList * n + 11]; - pAyz = shellf[InList * n + 12]; - pAzz = shellf[InList * n + 13]; - pchix = shellf[InList * n + 14]; - pchiy = shellf[InList * n + 15]; - pchiz = shellf[InList * n + 16]; - ptrKx = shellf[InList * n + 17]; - ptrKy = shellf[InList * n + 18]; - ptrKz = shellf[InList * n + 19]; - pAxxx = shellf[InList * n + 20]; - pAxxy = shellf[InList * n + 21]; - pAxxz = shellf[InList * n + 22]; - pAxyx = shellf[InList * n + 23]; - pAxyy = shellf[InList * n + 24]; - pAxyz = shellf[InList * n + 25]; - pAxzx = shellf[InList * n + 26]; - pAxzy = shellf[InList * n + 27]; - pAxzz = shellf[InList * n + 28]; - pAyyx = shellf[InList * n + 29]; - pAyyy = shellf[InList * n + 30]; - pAyyz = shellf[InList * n + 31]; - pAyzx = shellf[InList * n + 32]; - pAyzy = shellf[InList * n + 33]; - pAyzz = shellf[InList * n + 34]; - pAzzx = shellf[InList * n + 35]; - pAzzy = shellf[InList * n + 36]; - pAzzz = shellf[InList * n + 37]; - pGamxxx = shellf[InList * n + 38]; - pGamxxy = shellf[InList * n + 39]; - pGamxxz = shellf[InList * n + 40]; - pGamxyy = shellf[InList * n + 41]; - pGamxyz = shellf[InList * n + 42]; - pGamxzz = shellf[InList * n + 43]; - pGamyxx = shellf[InList * n + 44]; - pGamyxy = shellf[InList * n + 45]; - pGamyxz = shellf[InList * n + 46]; - pGamyyy = shellf[InList * n + 47]; - pGamyyz = shellf[InList * n + 48]; - pGamyzz = shellf[InList * n + 49]; - pGamzxx = shellf[InList * n + 50]; - pGamzxy = shellf[InList * n + 51]; - pGamzxz = shellf[InList * n + 52]; - pGamzyy = shellf[InList * n + 53]; - pGamzyz = shellf[InList * n + 54]; - pGamzzz = shellf[InList * n + 55]; - pRxx = shellf[InList * n + 56]; - pRxy = shellf[InList * n + 57]; - pRxz = shellf[InList * n + 58]; - pRyy = shellf[InList * n + 59]; - pRyz = shellf[InList * n + 60]; - pRzz = shellf[InList * n + 61]; - switch (lp) - { - case 0: //+++ (theta, phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - break; - case 1: //++- (pi-theta, phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = sin(pm * (j + 0.5) * dphi); - pz = -pz; - pgxz = -pgxz; - pgyz = -pgyz; - pAxz = -pAxz; - pAyz = -pAyz; - pchiz = -pchiz; - ptrKz = -ptrKz; - pAxxz = -pAxxz; - pAxyz = -pAxyz; - pAxzx = -pAxzx; - pAxzy = -pAxzy; - pAyyz = -pAyyz; - pAyzx = -pAyzx; - pAyzy = -pAyzy; - pAzzz = -pAzzz; - pGamxxz = -pGamxxz; - pGamxyz = -pGamxyz; - pGamyxz = -pGamyxz; - pGamyyz = -pGamyyz; - pGamzxx = -pGamzxx; - pGamzxy = -pGamzxy; - pGamzyy = -pGamzyy; - pGamzzz = -pGamzzz; - pRxz = -pRxz; - pRyz = -pRyz; - break; - case 2: //+-+ (theta, 2*pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pgxy = -pgxy; - pgyz = -pgyz; - pAxy = -pAxy; - pAyz = -pAyz; - pchiy = -pchiy; - ptrKy = -ptrKy; - pAxxy = -pAxxy; - pAxyx = -pAxyx; - pAxyz = -pAxyz; - pAxzy = -pAxzy; - pAyyy = -pAyyy; - pAyzx = -pAyzx; - pAyzz = -pAyzz; - pAzzy = -pAzzy; - pGamxxy = -pGamxxy; - pGamxyz = -pGamxyz; - pGamyxx = -pGamyxx; - pGamyxz = -pGamyxz; - pGamyyy = -pGamyyy; - pGamyzz = -pGamyzz; - pGamzxy = -pGamzxy; - pGamzyz = -pGamzyz; - pRxy = -pRxy; - pRyz = -pRyz; - break; - case 3: //+-- (pi-theta, 2*pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (j + 0.5) * dphi); - sinmphi = -sin(pm * (j + 0.5) * dphi); - py = -py; - pz = -pz; - pgxy = -pgxy; - pgxz = -pgxz; - pAxy = -pAxy; - pAxz = -pAxz; - pchiy = -pchiy; - pchiz = -pchiz; - ptrKy = -ptrKy; - ptrKz = -ptrKz; - pAxxy = -pAxxy; - pAxxz = -pAxxz; - pAxyx = -pAxyx; - pAxzx = -pAxzx; - pAyyy = -pAyyy; - pAyyz = -pAyyz; - pAyzy = -pAyzy; - pAyzz = -pAyzz; - pAzzy = -pAzzy; - pAzzz = -pAzzz; - pGamxxy = -pGamxxy; - pGamxxz = -pGamxxz; - pGamyxx = -pGamyxx; - pGamyyy = -pGamyyy; - pGamyyz = -pGamyyz; - pGamyzz = -pGamyzz; - pGamzxx = -pGamzxx; - pGamzyy = -pGamzyy; - pGamzyz = -pGamzyz; - pGamzzz = -pGamzzz; - pRxy = -pRxy; - pRxz = -pRxz; - break; - case 4: //-++ (theta, pi-phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - px = -px; - pgxy = -pgxy; - pgxz = -pgxz; - pAxy = -pAxy; - pAxz = -pAxz; - pchix = -pchix; - ptrKx = -ptrKx; - pAxxx = -pAxxx; - pAxyy = -pAxyy; - pAxyz = -pAxyz; - pAxzy = -pAxzy; - pAxzz = -pAxzz; - pAyyx = -pAyyx; - pAyzx = -pAyzx; - pAzzx = -pAzzx; - pGamxxx = -pGamxxx; - pGamxyy = -pGamxyy; - pGamxyz = -pGamxyz; - pGamxzz = -pGamxzz; - pGamyxy = -pGamyxy; - pGamyxz = -pGamyxz; - pGamzxy = -pGamzxy; - pGamzxz = -pGamzxz; - pRxy = -pRxy; - pRxz = -pRxz; - break; - case 5: //-+- (pi-theta, pi-phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); - px = -px; - pz = -pz; - pgxy = -pgxy; - pgyz = -pgyz; - pAxy = -pAxy; - pAyz = -pAyz; - pchix = -pchix; - pchiz = -pchiz; - ptrKx = -ptrKx; - ptrKz = -ptrKz; - pAxxx = -pAxxx; - pAxxz = -pAxxz; - pAxyy = -pAxyy; - pAxzx = -pAxzx; - pAxzz = -pAxzz; - pAyyx = -pAyyx; - pAyyz = -pAyyz; - pAyzy = -pAyzy; - pAzzx = -pAzzx; - pAzzz = -pAzzz; - pGamxxx = -pGamxxx; - pGamxxz = -pGamxxz; - pGamxyy = -pGamxyy; - pGamxzz = -pGamxzz; - pGamyxy = -pGamyxy; - pGamyyz = -pGamyyz; - pGamzxx = -pGamzxx; - pGamzxz = -pGamzxz; - pGamzyy = -pGamzyy; - pGamzzz = -pGamzzz; - pRxy = -pRxy; - pRyz = -pRyz; - break; - case 6: //--+ (theta, pi+phi) - costheta = arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pgxz = -pgxz; - pgyz = -pgyz; - pAxz = -pAxz; - pAyz = -pAyz; - pchix = -pchix; - pchiy = -pchiy; - ptrKx = -ptrKx; - ptrKy = -ptrKy; - pAxxx = -pAxxx; - pAxxy = -pAxxy; - pAxyx = -pAxyx; - pAxyy = -pAxyy; - pAxzz = -pAxzz; - pAyyx = -pAyyx; - pAyyy = -pAyyy; - pAyzz = -pAyzz; - pAzzx = -pAzzx; - pAzzy = -pAzzy; - pGamxxx = -pGamxxx; - pGamxxy = -pGamxxy; - pGamxyy = -pGamxyy; - pGamxzz = -pGamxzz; - pGamyxx = -pGamyxx; - pGamyxy = -pGamyxy; - pGamyyy = -pGamyyy; - pGamyzz = -pGamyzz; - pGamzxz = -pGamzxz; - pGamzyz = -pGamzyz; - pRxz = -pRxz; - pRyz = -pRyz; - break; - case 7: //--- (pi-theta, pi+phi) - costheta = -arcostheta[i]; - cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); - sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); - px = -px; - py = -py; - pz = -pz; - pchix = -pchix; - pchiy = -pchiy; - pchiz = -pchiz; - ptrKx = -ptrKx; - ptrKy = -ptrKy; - ptrKz = -ptrKz; - pAxxx = -pAxxx; - pAxxy = -pAxxy; - pAxxz = -pAxxz; - pAxyx = -pAxyx; - pAxyy = -pAxyy; - pAxyz = -pAxyz; - pAxzx = -pAxzx; - pAxzy = -pAxzy; - pAxzz = -pAxzz; - pAyyx = -pAyyx; - pAyyy = -pAyyy; - pAyyz = -pAyyz; - pAyzx = -pAyzx; - pAyzy = -pAyzy; - pAyzz = -pAyzz; - pAzzx = -pAzzx; - pAzzy = -pAzzy; - pAzzz = -pAzzz; - pGamxxx = -pGamxxx; - pGamxxy = -pGamxxy; - pGamxxz = -pGamxxz; - pGamxyy = -pGamxyy; - pGamxyz = -pGamxyz; - pGamxzz = -pGamxzz; - pGamyxx = -pGamyxx; - pGamyxy = -pGamyxy; - pGamyxz = -pGamyxz; - pGamyyy = -pGamyyy; - pGamyyz = -pGamyyz; - pGamyzz = -pGamyzz; - pGamzxx = -pGamzxx; - pGamzxy = -pGamzxy; - pGamzxz = -pGamzxz; - pGamzyy = -pGamzyy; - pGamzyz = -pGamzyz; - pGamzzz = -pGamzzz; - } - - f_getnp4_point(px, py, pz, pchi, ptrK, - pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, - pAxx, pAxy, pAxz, pAyy, pAyz, pAzz, - pchix, pchiy, pchiz, - ptrKx, ptrKy, ptrKz, - pAxxx, pAxxy, pAxxz, - pAxyx, pAxyy, pAxyz, - pAxzx, pAxzy, pAxzz, - pAyyx, pAyyy, pAyyz, - pAyzx, pAyzy, pAyzz, - pAzzx, pAzzy, pAzzz, - pGamxxx, pGamxxy, pGamxxz, pGamxyy, pGamxyz, pGamxzz, - pGamyxx, pGamyxy, pGamyxz, pGamyyy, pGamyyz, pGamyzz, - pGamzxx, pGamzxy, pGamzxz, pGamzyy, pGamzyz, pGamzzz, - pRxx, pRxy, pRxz, pRyy, pRyz, pRzz, - psi4RR, psi4II); - - thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 - - // find back the one - pchi = pchi + 1; -#ifdef GaussInt - // wtcostheta is even function respect costheta - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; -#else - RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); - IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); -#endif - } - countlm++; // no sanity check for countlm and NN which should be noted in the input parameters - } - } - - for (int ii = 0; ii < NN; ii++) - { -#ifdef GaussInt - RP_out[ii] = RP_out[ii] * rex * dphi; - IP_out[ii] = IP_out[ii] * rex * dphi; -#else - RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; - IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; -#endif - } - //|------+ Communicate and sum the results from each processor. - - { - double *RPIP_out = new double[2 * NN]; - double *RPIP = new double[2 * NN]; - memcpy(RPIP_out, RP_out, NN * sizeof(double)); - memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); - MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - memcpy(RP, RPIP, NN * sizeof(double)); - memcpy(IP, RPIP + NN, NN * sizeof(double)); - delete[] RPIP_out; - delete[] RPIP; - } - - //|------= Free memory. - - delete[] pox[0]; - delete[] pox[1]; - delete[] pox[2]; - delete[] shellf; - delete[] RP_out; - delete[] IP_out; - DG_List->clearList(); -} -//|---------------------------------------------------------------- -// do not discriminate box and shell -//|---------------------------------------------------------------- -bool surface_integral::SR_Interp_Points(MyList *VarList, cgh *GH, ShellPatch *SH, - int NN, double **XX, double *Shellf) -{ - MyList *varl; - int num_var = 0; - varl = VarList; - while (varl) - { - num_var++; - varl = varl->next; - } - - double pox[3]; - for (int i = 0; i < NN; i++) - { - for (int j = 0; j < 3; j++) - pox[j] = XX[j][i]; - int lev = GH->levels - 1; - bool notfound = true; - - while (notfound) - { - if (lev < 0) - { - if (SH) - { - if (SH->Interp_One_Point(VarList, pox, Shellf + i * num_var, Symmetry)) - { - return true; - } - if (myrank == 0) - cout << "surface_integral::SR_Interp_Points point (" << pox[0] << "," << pox[1] << "," << pox[2] << ") is out of cgh and shell domain!" << endl; - } - else - { - if (myrank == 0) - cout << "surface_integral::SR_Interp_Points: point (" << pox[0] << "," << pox[1] << "," << pox[2] << ") is out of cgh domain!" << endl; - } - return false; - } - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - if (Pp->data->Interp_ONE_Point(VarList, pox, Shellf + i * num_var, Symmetry)) - { - notfound = false; - break; - } - Pp = Pp->next; - } - lev--; - } - } - return true; -} +//|---------------------------------------------------------------- +void surface_integral::surf_Wave(double rex, cgh *GH, ShellPatch *SH, + var *chi, var *trK, + var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, + var *chix, var *chiy, var *chiz, + var *trKx, var *trKy, var *trKz, + var *Axxx, var *Axxy, var *Axxz, + var *Axyx, var *Axyy, var *Axyz, + var *Axzx, var *Axzy, var *Axzz, + var *Ayyx, var *Ayyy, var *Ayyz, + var *Ayzx, var *Ayzy, var *Ayzz, + var *Azzx, var *Azzy, var *Azzz, + var *Gamxxx, var *Gamxxy, var *Gamxxz, var *Gamxyy, var *Gamxyz, var *Gamxzz, + var *Gamyxx, var *Gamyxy, var *Gamyxz, var *Gamyyy, var *Gamyyz, var *Gamyzz, + var *Gamzxx, var *Gamzxy, var *Gamzxz, var *Gamzyy, var *Gamzyz, var *Gamzzz, + var *Rxx, var *Rxy, var *Rxz, var *Ryy, var *Ryz, var *Rzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor) // NN is the length of RP and IP +{ + const int InList = 62; + + MyList *DG_List = new MyList(chi); + DG_List->insert(trK); + DG_List->insert(gxx); + DG_List->insert(gxy); + DG_List->insert(gxz); + DG_List->insert(gyy); + DG_List->insert(gyz); + DG_List->insert(gzz); + DG_List->insert(Axx); + DG_List->insert(Axy); + DG_List->insert(Axz); + DG_List->insert(Ayy); + DG_List->insert(Ayz); + DG_List->insert(Azz); + DG_List->insert(chix); + DG_List->insert(chiy); + DG_List->insert(chiz); + DG_List->insert(trKx); + DG_List->insert(trKy); + DG_List->insert(trKz); + DG_List->insert(Axxx); + DG_List->insert(Axxy); + DG_List->insert(Axxz); + DG_List->insert(Axyx); + DG_List->insert(Axyy); + DG_List->insert(Axyz); + DG_List->insert(Axzx); + DG_List->insert(Axzy); + DG_List->insert(Axzz); + DG_List->insert(Ayyx); + DG_List->insert(Ayyy); + DG_List->insert(Ayyz); + DG_List->insert(Ayzx); + DG_List->insert(Ayzy); + DG_List->insert(Ayzz); + DG_List->insert(Azzx); + DG_List->insert(Azzy); + DG_List->insert(Azzz); + DG_List->insert(Gamxxx); + DG_List->insert(Gamxxy); + DG_List->insert(Gamxxz); + DG_List->insert(Gamxyy); + DG_List->insert(Gamxyz); + DG_List->insert(Gamxzz); + DG_List->insert(Gamyxx); + DG_List->insert(Gamyxy); + DG_List->insert(Gamyxz); + DG_List->insert(Gamyyy); + DG_List->insert(Gamyyz); + DG_List->insert(Gamyzz); + DG_List->insert(Gamzxx); + DG_List->insert(Gamzxy); + DG_List->insert(Gamzxz); + DG_List->insert(Gamzyy); + DG_List->insert(Gamzyz); + DG_List->insert(Gamzzz); + DG_List->insert(Rxx); + DG_List->insert(Rxy); + DG_List->insert(Rxz); + DG_List->insert(Ryy); + DG_List->insert(Ryz); + DG_List->insert(Rzz); + + int n; + double *pox[3]; + for (int i = 0; i < 3; i++) + pox[i] = new double[n_tot]; + for (n = 0; n < n_tot; n++) + { + pox[0][n] = rex * nx_g[n]; + pox[1][n] = rex * ny_g[n]; + pox[2][n] = rex * nz_g[n]; + } + + double *shellf; + shellf = new double[n_tot * InList]; + + SR_Interp_Points(DG_List, GH, SH, n_tot, pox, shellf); + + double *RP_out, *IP_out; + RP_out = new double[NN]; + IP_out = new double[NN]; + + for (int ii = 0; ii < NN; ii++) + { + RP_out[ii] = 0; + IP_out[ii] = 0; + } + + int mp, Lp, Nmin, Nmax; + + mp = n_tot / cpusize; + Lp = n_tot - cpusize * mp; + + if (Lp > myrank) + { + Nmin = myrank * mp + myrank; + Nmax = Nmin + mp; + } + else + { + Nmin = myrank * mp + Lp; + Nmax = Nmin + mp - 1; + } + + // theta part + double costheta, thetap; + double cosmphi, sinmphi; + + int i, j; + int lpsy = 0; + if (Symmetry == 0) + lpsy = 1; + else if (Symmetry == 1) + lpsy = 2; + else if (Symmetry == 2) + lpsy = 8; + + double psi4RR, psi4II; + double px, py, pz; + double pchi, ptrK, pgxx, pgxy, pgxz, pgyy, pgyz, pgzz; + double pAxx, pAxy, pAxz, pAyy, pAyz, pAzz; + double pchix, pchiy, pchiz; + double ptrKx, ptrKy, ptrKz; + double pAxxx, pAxxy, pAxxz; + double pAxyx, pAxyy, pAxyz; + double pAxzx, pAxzy, pAxzz; + double pAyyx, pAyyy, pAyyz; + double pAyzx, pAyzy, pAyzz; + double pAzzx, pAzzy, pAzzz; + double pGamxxx, pGamxxy, pGamxxz, pGamxyy, pGamxyz, pGamxzz; + double pGamyxx, pGamyxy, pGamyxz, pGamyyy, pGamyyz, pGamyzz; + double pGamzxx, pGamzxy, pGamzxz, pGamzyy, pGamzyz, pGamzzz; + double pRxx, pRxy, pRxz, pRyy, pRyz, pRzz; + for (n = Nmin; n <= Nmax; n++) + { + // need round off always + i = int(n / N_phi); // int(1.723) = 1, int(-1.732) = -1 + j = n - i * N_phi; + + int countlm = 0; + for (int pl = spinw; pl < maxl + 1; pl++) + for (int pm = -pl; pm < pl + 1; pm++) + { + for (int lp = 0; lp < lpsy; lp++) + { + px = pox[0][n]; + py = pox[1][n]; + pz = pox[2][n]; + pchi = shellf[InList * n]; + ptrK = shellf[InList * n + 1]; + pgxx = shellf[InList * n + 2]; + pgxy = shellf[InList * n + 3]; + pgxz = shellf[InList * n + 4]; + pgyy = shellf[InList * n + 5]; + pgyz = shellf[InList * n + 6]; + pgzz = shellf[InList * n + 7]; + pAxx = shellf[InList * n + 8]; + pAxy = shellf[InList * n + 9]; + pAxz = shellf[InList * n + 10]; + pAyy = shellf[InList * n + 11]; + pAyz = shellf[InList * n + 12]; + pAzz = shellf[InList * n + 13]; + pchix = shellf[InList * n + 14]; + pchiy = shellf[InList * n + 15]; + pchiz = shellf[InList * n + 16]; + ptrKx = shellf[InList * n + 17]; + ptrKy = shellf[InList * n + 18]; + ptrKz = shellf[InList * n + 19]; + pAxxx = shellf[InList * n + 20]; + pAxxy = shellf[InList * n + 21]; + pAxxz = shellf[InList * n + 22]; + pAxyx = shellf[InList * n + 23]; + pAxyy = shellf[InList * n + 24]; + pAxyz = shellf[InList * n + 25]; + pAxzx = shellf[InList * n + 26]; + pAxzy = shellf[InList * n + 27]; + pAxzz = shellf[InList * n + 28]; + pAyyx = shellf[InList * n + 29]; + pAyyy = shellf[InList * n + 30]; + pAyyz = shellf[InList * n + 31]; + pAyzx = shellf[InList * n + 32]; + pAyzy = shellf[InList * n + 33]; + pAyzz = shellf[InList * n + 34]; + pAzzx = shellf[InList * n + 35]; + pAzzy = shellf[InList * n + 36]; + pAzzz = shellf[InList * n + 37]; + pGamxxx = shellf[InList * n + 38]; + pGamxxy = shellf[InList * n + 39]; + pGamxxz = shellf[InList * n + 40]; + pGamxyy = shellf[InList * n + 41]; + pGamxyz = shellf[InList * n + 42]; + pGamxzz = shellf[InList * n + 43]; + pGamyxx = shellf[InList * n + 44]; + pGamyxy = shellf[InList * n + 45]; + pGamyxz = shellf[InList * n + 46]; + pGamyyy = shellf[InList * n + 47]; + pGamyyz = shellf[InList * n + 48]; + pGamyzz = shellf[InList * n + 49]; + pGamzxx = shellf[InList * n + 50]; + pGamzxy = shellf[InList * n + 51]; + pGamzxz = shellf[InList * n + 52]; + pGamzyy = shellf[InList * n + 53]; + pGamzyz = shellf[InList * n + 54]; + pGamzzz = shellf[InList * n + 55]; + pRxx = shellf[InList * n + 56]; + pRxy = shellf[InList * n + 57]; + pRxz = shellf[InList * n + 58]; + pRyy = shellf[InList * n + 59]; + pRyz = shellf[InList * n + 60]; + pRzz = shellf[InList * n + 61]; + switch (lp) + { + case 0: //+++ (theta, phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + break; + case 1: //++- (pi-theta, phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = sin(pm * (j + 0.5) * dphi); + pz = -pz; + pgxz = -pgxz; + pgyz = -pgyz; + pAxz = -pAxz; + pAyz = -pAyz; + pchiz = -pchiz; + ptrKz = -ptrKz; + pAxxz = -pAxxz; + pAxyz = -pAxyz; + pAxzx = -pAxzx; + pAxzy = -pAxzy; + pAyyz = -pAyyz; + pAyzx = -pAyzx; + pAyzy = -pAyzy; + pAzzz = -pAzzz; + pGamxxz = -pGamxxz; + pGamxyz = -pGamxyz; + pGamyxz = -pGamyxz; + pGamyyz = -pGamyyz; + pGamzxx = -pGamzxx; + pGamzxy = -pGamzxy; + pGamzyy = -pGamzyy; + pGamzzz = -pGamzzz; + pRxz = -pRxz; + pRyz = -pRyz; + break; + case 2: //+-+ (theta, 2*pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pgxy = -pgxy; + pgyz = -pgyz; + pAxy = -pAxy; + pAyz = -pAyz; + pchiy = -pchiy; + ptrKy = -ptrKy; + pAxxy = -pAxxy; + pAxyx = -pAxyx; + pAxyz = -pAxyz; + pAxzy = -pAxzy; + pAyyy = -pAyyy; + pAyzx = -pAyzx; + pAyzz = -pAyzz; + pAzzy = -pAzzy; + pGamxxy = -pGamxxy; + pGamxyz = -pGamxyz; + pGamyxx = -pGamyxx; + pGamyxz = -pGamyxz; + pGamyyy = -pGamyyy; + pGamyzz = -pGamyzz; + pGamzxy = -pGamzxy; + pGamzyz = -pGamzyz; + pRxy = -pRxy; + pRyz = -pRyz; + break; + case 3: //+-- (pi-theta, 2*pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (j + 0.5) * dphi); + sinmphi = -sin(pm * (j + 0.5) * dphi); + py = -py; + pz = -pz; + pgxy = -pgxy; + pgxz = -pgxz; + pAxy = -pAxy; + pAxz = -pAxz; + pchiy = -pchiy; + pchiz = -pchiz; + ptrKy = -ptrKy; + ptrKz = -ptrKz; + pAxxy = -pAxxy; + pAxxz = -pAxxz; + pAxyx = -pAxyx; + pAxzx = -pAxzx; + pAyyy = -pAyyy; + pAyyz = -pAyyz; + pAyzy = -pAyzy; + pAyzz = -pAyzz; + pAzzy = -pAzzy; + pAzzz = -pAzzz; + pGamxxy = -pGamxxy; + pGamxxz = -pGamxxz; + pGamyxx = -pGamyxx; + pGamyyy = -pGamyyy; + pGamyyz = -pGamyyz; + pGamyzz = -pGamyzz; + pGamzxx = -pGamzxx; + pGamzyy = -pGamzyy; + pGamzyz = -pGamzyz; + pGamzzz = -pGamzzz; + pRxy = -pRxy; + pRxz = -pRxz; + break; + case 4: //-++ (theta, pi-phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + px = -px; + pgxy = -pgxy; + pgxz = -pgxz; + pAxy = -pAxy; + pAxz = -pAxz; + pchix = -pchix; + ptrKx = -ptrKx; + pAxxx = -pAxxx; + pAxyy = -pAxyy; + pAxyz = -pAxyz; + pAxzy = -pAxzy; + pAxzz = -pAxzz; + pAyyx = -pAyyx; + pAyzx = -pAyzx; + pAzzx = -pAzzx; + pGamxxx = -pGamxxx; + pGamxyy = -pGamxyy; + pGamxyz = -pGamxyz; + pGamxzz = -pGamxzz; + pGamyxy = -pGamyxy; + pGamyxz = -pGamyxz; + pGamzxy = -pGamzxy; + pGamzxz = -pGamzxz; + pRxy = -pRxy; + pRxz = -pRxz; + break; + case 5: //-+- (pi-theta, pi-phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI - (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI - (j + 0.5) * dphi)); + px = -px; + pz = -pz; + pgxy = -pgxy; + pgyz = -pgyz; + pAxy = -pAxy; + pAyz = -pAyz; + pchix = -pchix; + pchiz = -pchiz; + ptrKx = -ptrKx; + ptrKz = -ptrKz; + pAxxx = -pAxxx; + pAxxz = -pAxxz; + pAxyy = -pAxyy; + pAxzx = -pAxzx; + pAxzz = -pAxzz; + pAyyx = -pAyyx; + pAyyz = -pAyyz; + pAyzy = -pAyzy; + pAzzx = -pAzzx; + pAzzz = -pAzzz; + pGamxxx = -pGamxxx; + pGamxxz = -pGamxxz; + pGamxyy = -pGamxyy; + pGamxzz = -pGamxzz; + pGamyxy = -pGamyxy; + pGamyyz = -pGamyyz; + pGamzxx = -pGamzxx; + pGamzxz = -pGamzxz; + pGamzyy = -pGamzyy; + pGamzzz = -pGamzzz; + pRxy = -pRxy; + pRyz = -pRyz; + break; + case 6: //--+ (theta, pi+phi) + costheta = arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pgxz = -pgxz; + pgyz = -pgyz; + pAxz = -pAxz; + pAyz = -pAyz; + pchix = -pchix; + pchiy = -pchiy; + ptrKx = -ptrKx; + ptrKy = -ptrKy; + pAxxx = -pAxxx; + pAxxy = -pAxxy; + pAxyx = -pAxyx; + pAxyy = -pAxyy; + pAxzz = -pAxzz; + pAyyx = -pAyyx; + pAyyy = -pAyyy; + pAyzz = -pAyzz; + pAzzx = -pAzzx; + pAzzy = -pAzzy; + pGamxxx = -pGamxxx; + pGamxxy = -pGamxxy; + pGamxyy = -pGamxyy; + pGamxzz = -pGamxzz; + pGamyxx = -pGamyxx; + pGamyxy = -pGamyxy; + pGamyyy = -pGamyyy; + pGamyzz = -pGamyzz; + pGamzxz = -pGamzxz; + pGamzyz = -pGamzyz; + pRxz = -pRxz; + pRyz = -pRyz; + break; + case 7: //--- (pi-theta, pi+phi) + costheta = -arcostheta[i]; + cosmphi = cos(pm * (PI + (j + 0.5) * dphi)); + sinmphi = sin(pm * (PI + (j + 0.5) * dphi)); + px = -px; + py = -py; + pz = -pz; + pchix = -pchix; + pchiy = -pchiy; + pchiz = -pchiz; + ptrKx = -ptrKx; + ptrKy = -ptrKy; + ptrKz = -ptrKz; + pAxxx = -pAxxx; + pAxxy = -pAxxy; + pAxxz = -pAxxz; + pAxyx = -pAxyx; + pAxyy = -pAxyy; + pAxyz = -pAxyz; + pAxzx = -pAxzx; + pAxzy = -pAxzy; + pAxzz = -pAxzz; + pAyyx = -pAyyx; + pAyyy = -pAyyy; + pAyyz = -pAyyz; + pAyzx = -pAyzx; + pAyzy = -pAyzy; + pAyzz = -pAyzz; + pAzzx = -pAzzx; + pAzzy = -pAzzy; + pAzzz = -pAzzz; + pGamxxx = -pGamxxx; + pGamxxy = -pGamxxy; + pGamxxz = -pGamxxz; + pGamxyy = -pGamxyy; + pGamxyz = -pGamxyz; + pGamxzz = -pGamxzz; + pGamyxx = -pGamyxx; + pGamyxy = -pGamyxy; + pGamyxz = -pGamyxz; + pGamyyy = -pGamyyy; + pGamyyz = -pGamyyz; + pGamyzz = -pGamyzz; + pGamzxx = -pGamzxx; + pGamzxy = -pGamzxy; + pGamzxz = -pGamzxz; + pGamzyy = -pGamzyy; + pGamzyz = -pGamzyz; + pGamzzz = -pGamzzz; + } + + f_getnp4_point(px, py, pz, pchi, ptrK, + pgxx, pgxy, pgxz, pgyy, pgyz, pgzz, + pAxx, pAxy, pAxz, pAyy, pAyz, pAzz, + pchix, pchiy, pchiz, + ptrKx, ptrKy, ptrKz, + pAxxx, pAxxy, pAxxz, + pAxyx, pAxyy, pAxyz, + pAxzx, pAxzy, pAxzz, + pAyyx, pAyyy, pAyyz, + pAyzx, pAyzy, pAyzz, + pAzzx, pAzzy, pAzzz, + pGamxxx, pGamxxy, pGamxxz, pGamxyy, pGamxyz, pGamxzz, + pGamyxx, pGamyxy, pGamyxz, pGamyyy, pGamyyz, pGamyzz, + pGamzxx, pGamzxy, pGamzxz, pGamzyy, pGamzyz, pGamzzz, + pRxx, pRxy, pRxz, pRyy, pRyz, pRzz, + psi4RR, psi4II); + + thetap = sqrt((2 * pl + 1.0) / 4.0 / PI) * misc::Wigner_d_function(pl, pm, spinw, costheta); // note the variation from -2 to 2 + + // find back the one + pchi = pchi + 1; +#ifdef GaussInt + // wtcostheta is even function respect costheta + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi) * wtcostheta[i]; + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi) * wtcostheta[i]; +#else + RP_out[countlm] = RP_out[countlm] + thetap / pchi / pchi * (psi4RR * cosmphi + psi4II * sinmphi); + IP_out[countlm] = IP_out[countlm] + thetap / pchi / pchi * (psi4II * cosmphi - psi4RR * sinmphi); +#endif + } + countlm++; // no sanity check for countlm and NN which should be noted in the input parameters + } + } + + for (int ii = 0; ii < NN; ii++) + { +#ifdef GaussInt + RP_out[ii] = RP_out[ii] * rex * dphi; + IP_out[ii] = IP_out[ii] * rex * dphi; +#else + RP_out[ii] = RP_out[ii] * rex * dphi * dcostheta; + IP_out[ii] = IP_out[ii] * rex * dphi * dcostheta; +#endif + } + //|------+ Communicate and sum the results from each processor. + + { + double *RPIP_out = new double[2 * NN]; + double *RPIP = new double[2 * NN]; + memcpy(RPIP_out, RP_out, NN * sizeof(double)); + memcpy(RPIP_out + NN, IP_out, NN * sizeof(double)); + MPI_Allreduce(RPIP_out, RPIP, 2 * NN, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + memcpy(RP, RPIP, NN * sizeof(double)); + memcpy(IP, RPIP + NN, NN * sizeof(double)); + delete[] RPIP_out; + delete[] RPIP; + } + + //|------= Free memory. + + delete[] pox[0]; + delete[] pox[1]; + delete[] pox[2]; + delete[] shellf; + delete[] RP_out; + delete[] IP_out; + DG_List->clearList(); +} +//|---------------------------------------------------------------- +// do not discriminate box and shell +//|---------------------------------------------------------------- +bool surface_integral::SR_Interp_Points(MyList *VarList, cgh *GH, ShellPatch *SH, + int NN, double **XX, double *Shellf) +{ + MyList *varl; + int num_var = 0; + varl = VarList; + while (varl) + { + num_var++; + varl = varl->next; + } + + double pox[3]; + for (int i = 0; i < NN; i++) + { + for (int j = 0; j < 3; j++) + pox[j] = XX[j][i]; + int lev = GH->levels - 1; + bool notfound = true; + + while (notfound) + { + if (lev < 0) + { + if (SH) + { + if (SH->Interp_One_Point(VarList, pox, Shellf + i * num_var, Symmetry)) + { + return true; + } + if (myrank == 0) + cout << "surface_integral::SR_Interp_Points point (" << pox[0] << "," << pox[1] << "," << pox[2] << ") is out of cgh and shell domain!" << endl; + } + else + { + if (myrank == 0) + cout << "surface_integral::SR_Interp_Points: point (" << pox[0] << "," << pox[1] << "," << pox[2] << ") is out of cgh domain!" << endl; + } + return false; + } + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + if (Pp->data->Interp_ONE_Point(VarList, pox, Shellf + i * num_var, Symmetry)) + { + notfound = false; + break; + } + Pp = Pp->next; + } + lev--; + } + } + return true; +} diff --git a/AMSS_NCKU_source/surface_integral.h b/AMSS_NCKU_source/Surface_Integral/surface_integral.h similarity index 98% rename from AMSS_NCKU_source/surface_integral.h rename to AMSS_NCKU_source/Surface_Integral/surface_integral.h index 1b2d287..418e0eb 100644 --- a/AMSS_NCKU_source/surface_integral.h +++ b/AMSS_NCKU_source/Surface_Integral/surface_integral.h @@ -1,32 +1,32 @@ -//$Id: surface_integral.h,v 1.9 2013/08/20 11:49:05 zjcao Exp $ -#ifndef SURFACE_INTEGRAL_H -#define SURFACE_INTEGRAL_H - -#ifdef newc -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#endif - -#include "cgh.h" -#include "ShellPatch.h" -#include "NullShellPatch.h" -#include "NullShellPatch2.h" -#include "var.h" -#include "monitor.h" - -class surface_integral -{ - +//$Id: surface_integral.h,v 1.9 2013/08/20 11:49:05 zjcao Exp $ +#ifndef SURFACE_INTEGRAL_H +#define SURFACE_INTEGRAL_H + +#ifdef newc +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#endif + +#include "cgh.h" +#include "ShellPatch.h" +#include "NullShellPatch.h" +#include "NullShellPatch2.h" +#include "var.h" +#include "monitor.h" + +class surface_integral +{ + private: int Symmetry, factor; int N_theta, N_phi; // Number of points in Theta & Phi directions @@ -45,43 +45,43 @@ private: public: surface_integral(int iSymmetry); ~surface_integral(); - - void surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor); // NN is the length of RP and IP - // this routine can only deal with the symmetry of Psi4 - void surf_Wave(double rex, int lev, ShellPatch *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor); - void surf_Wave(double rex, int lev, NullShellPatch *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor); - void surf_Wave(double rex, int lev, NullShellPatch2 *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor); - void surf_Wave(double rex, int lev, ShellPatch *GH, - var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, - var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor); // NN is the length of RP and IP - void surf_Wave(double rex, int lev, cgh *GH, - var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, - var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor, - void (*funcs)(double &, double &, double &, - double &, double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &)); // NN is the length of RP and IP - void surf_Wave(double rex, int lev, ShellPatch *GH, - var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, - var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor, - void (*funcs)(double &, double &, double &, - double &, double &, double &, double &, double &, double &, double &, - double &, double &, double &, double &, double &, double &, - double &, double &)); // NN is the length of RP and IP + + void surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor); // NN is the length of RP and IP + // this routine can only deal with the symmetry of Psi4 + void surf_Wave(double rex, int lev, ShellPatch *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor); + void surf_Wave(double rex, int lev, NullShellPatch *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor); + void surf_Wave(double rex, int lev, NullShellPatch2 *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor); + void surf_Wave(double rex, int lev, ShellPatch *GH, + var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, + var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor); // NN is the length of RP and IP + void surf_Wave(double rex, int lev, cgh *GH, + var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, + var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor, + void (*funcs)(double &, double &, double &, + double &, double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &)); // NN is the length of RP and IP + void surf_Wave(double rex, int lev, ShellPatch *GH, + var *Ex, var *Ey, var *Ez, var *Bx, var *By, var *Bz, + var *chi, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor, + void (*funcs)(double &, double &, double &, + double &, double &, double &, double &, double &, double &, double &, + double &, double &, double &, double &, double &, double &, + double &, double &)); // NN is the length of RP and IP void surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var *trK, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, @@ -113,32 +113,32 @@ public: void surf_Wave(double rex, cgh *GH, ShellPatch *SH, var *chi, var *trK, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, - var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, - var *chix, var *chiy, var *chiz, - var *trKx, var *trKy, var *trKz, - var *Axxx, var *Axxy, var *Axxz, - var *Axyx, var *Axyy, var *Axyz, - var *Axzx, var *Axzy, var *Axzz, - var *Ayyx, var *Ayyy, var *Ayyz, - var *Ayzx, var *Ayzy, var *Ayzz, - var *Azzx, var *Azzy, var *Azzz, - var *Gamxxx, var *Gamxxy, var *Gamxxz, var *Gamxyy, var *Gamxyz, var *Gamxzz, - var *Gamyxx, var *Gamyxy, var *Gamyxz, var *Gamyyy, var *Gamyyz, var *Gamyzz, - var *Gamzxx, var *Gamzxy, var *Gamzxz, var *Gamzyy, var *Gamzyz, var *Gamzzz, - var *Rxx, var *Rxy, var *Rxz, var *Ryy, var *Ryz, var *Rzz, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor); - bool SR_Interp_Points(MyList *VarList, cgh *GH, ShellPatch *SH, - int NN, double **XX, double *Shellf); - + var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, + var *chix, var *chiy, var *chiz, + var *trKx, var *trKy, var *trKz, + var *Axxx, var *Axxy, var *Axxz, + var *Axyx, var *Axyy, var *Axyz, + var *Axzx, var *Axzy, var *Axzz, + var *Ayyx, var *Ayyy, var *Ayyz, + var *Ayzx, var *Ayzy, var *Ayzz, + var *Azzx, var *Azzy, var *Azzz, + var *Gamxxx, var *Gamxxy, var *Gamxxz, var *Gamxyy, var *Gamxyz, var *Gamxzz, + var *Gamyxx, var *Gamyxy, var *Gamyxz, var *Gamyyy, var *Gamyyz, var *Gamyzz, + var *Gamzxx, var *Gamzxy, var *Gamzxz, var *Gamzyy, var *Gamzyz, var *Gamzzz, + var *Rxx, var *Rxy, var *Rxz, var *Ryy, var *Ryz, var *Rzz, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor); + bool SR_Interp_Points(MyList *VarList, cgh *GH, ShellPatch *SH, + int NN, double **XX, double *Shellf); + void surf_MassPAng(double rex, int lev, cgh *GH, var *chi, var *trK, var *gxx, var *gxy, var *gxz, var *gyy, var *gyz, var *gzz, var *Axx, var *Axy, var *Axz, var *Ayy, var *Ayz, var *Azz, var *Gmx, var *Gmy, var *Gmz, var *Sfx_rhs, var *Sfy_rhs, var *Sfz_rhs, // temparay memory for mass^i double *Rout, monitor *Monitor, MPI_Comm Comm_here, bool refresh_mass_fields = true); - void surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, - int spinw, int maxl, int NN, double *RP, double *IP, - monitor *Monitor, MPI_Comm Comm_here); -}; -#endif /* SURFACE_INTEGRAL_H */ + void surf_Wave(double rex, int lev, cgh *GH, var *Rpsi4, var *Ipsi4, + int spinw, int maxl, int NN, double *RP, double *IP, + monitor *Monitor, MPI_Comm Comm_here); +}; +#endif /* SURFACE_INTEGRAL_H */ diff --git a/AMSS_NCKU_source/perf.C b/AMSS_NCKU_source/System_Performance/perf.C similarity index 96% rename from AMSS_NCKU_source/perf.C rename to AMSS_NCKU_source/System_Performance/perf.C index 447c2bd..a6aac3f 100644 --- a/AMSS_NCKU_source/perf.C +++ b/AMSS_NCKU_source/System_Performance/perf.C @@ -1,116 +1,116 @@ - -#include "perf.h" - -// initialize staic members -size_t perf::mem_peak = 0; -size_t perf::mem_current = 0; -int perf::sampling_interval = 200; -bool perf::have_statm = false; -char perf::statm[40] = " "; -struct itimerval perf::new_it; -struct itimerval perf::old; -struct sigaction perf::sa; -struct sigaction perf::old_sa; - -perf::perf() -{ - int fd; - sprintf(statm, "/proc/%d/statm", (int)getpid()); - if ((fd = open(statm, O_RDONLY)) != -1) - { - have_statm = true; - close(fd); - } - - if (sampling_interval > 0) - { - /* setup timer to sample memory usage */ - sa.sa_handler = &perf::sample_mem_usage; - sigemptyset(&sa.sa_mask); - /*sigfillset (&sa.sa_mask);*/ - sa.sa_flags = SA_RESTART; - if (sigaction(TimerSignal, &sa, &old_sa)) - perror("sigaction 0"); - new_it.it_value.tv_sec = sampling_interval / 1000; - new_it.it_value.tv_usec = (sampling_interval % 1000) * 1000; - new_it.it_interval = new_it.it_value; - if (setitimer(TimerType, &new_it, &old)) - perror("setitimer 0"); - } -} -perf::~perf() -{ -} -void perf::sample_mem_usage(int dummy) -{ - int fd; - struct rusage RU; - size_t mem; - static bool locked = false; - - if (locked) - return; - locked = true; - - /* TODO: configure checks for different systems */ - - /* first, try /proc/pid/statm for Linux systems */ - if (have_statm && (fd = open(statm, O_RDONLY)) != -1) - { - int rsspages; - static char buffer[256]; - char *p = buffer; - /* see linux-2.6.15/Documentation/filesystems/proc.txt */ - rsspages = read(fd, buffer, sizeof(buffer) - 1); - close(fd); - buffer[rsspages] = '\0'; - - strtol(p, &p, 10); /* first number () */ - rsspages = strtol(p, &p, 10); /* second number */ - - mem = (size_t)rsspages * (size_t)getpagesize(); - } - else - { - /* next, try getrusage() */ - if (getrusage(RUSAGE_SELF, &RU)) - cout << "perf::sample_mem_usage calling getrusage fail" << endl; - else - mem = RU.ru_maxrss * (size_t)1024; - /*mem = RU.ru_maxrss * getpagesize();*/ - } - - if (mem > mem_peak) - mem_peak = mem; - mem_current = mem; - locked = false; -} -size_t perf::MemoryUsage(size_t *current_min, size_t *current_avg, size_t *current_max, - size_t *peak_min, size_t *peak_avg, size_t *peak_max, - int nprocs) -{ - sample_mem_usage(0); - - double a[2][3], b[2][3]; - a[0][0] = a[0][1] = a[0][2] = mem_current; - a[1][0] = a[1][1] = a[1][2] = mem_peak; - MPI_Allreduce(a, b, 6, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); - b[0][1] /= nprocs; - b[1][1] /= nprocs; - - if (current_min != NULL) - *current_min = (size_t)(b[0][0] + 0.5); - if (current_avg != NULL) - *current_avg = (size_t)(b[0][1] + 0.5); - if (current_max != NULL) - *current_max = (size_t)(b[0][2] + 0.5); - - if (peak_min != NULL) - *peak_min = (size_t)(b[1][0] + 0.5); - if (peak_avg != NULL) - *peak_avg = (size_t)(b[1][1] + 0.5); - if (peak_max != NULL) - *peak_max = (size_t)(b[1][2] + 0.5); - - return (size_t)b[0][2]; /* return max(mem_current) */ -} + +#include "perf.h" + +// initialize staic members +size_t perf::mem_peak = 0; +size_t perf::mem_current = 0; +int perf::sampling_interval = 200; +bool perf::have_statm = false; +char perf::statm[40] = " "; +struct itimerval perf::new_it; +struct itimerval perf::old; +struct sigaction perf::sa; +struct sigaction perf::old_sa; + +perf::perf() +{ + int fd; + sprintf(statm, "/proc/%d/statm", (int)getpid()); + if ((fd = open(statm, O_RDONLY)) != -1) + { + have_statm = true; + close(fd); + } + + if (sampling_interval > 0) + { + /* setup timer to sample memory usage */ + sa.sa_handler = &perf::sample_mem_usage; + sigemptyset(&sa.sa_mask); + /*sigfillset (&sa.sa_mask);*/ + sa.sa_flags = SA_RESTART; + if (sigaction(TimerSignal, &sa, &old_sa)) + perror("sigaction 0"); + new_it.it_value.tv_sec = sampling_interval / 1000; + new_it.it_value.tv_usec = (sampling_interval % 1000) * 1000; + new_it.it_interval = new_it.it_value; + if (setitimer(TimerType, &new_it, &old)) + perror("setitimer 0"); + } +} +perf::~perf() +{ +} +void perf::sample_mem_usage(int dummy) +{ + int fd; + struct rusage RU; + size_t mem; + static bool locked = false; + + if (locked) + return; + locked = true; + + /* TODO: configure checks for different systems */ + + /* first, try /proc/pid/statm for Linux systems */ + if (have_statm && (fd = open(statm, O_RDONLY)) != -1) + { + int rsspages; + static char buffer[256]; + char *p = buffer; + /* see linux-2.6.15/Documentation/filesystems/proc.txt */ + rsspages = read(fd, buffer, sizeof(buffer) - 1); + close(fd); + buffer[rsspages] = '\0'; + + strtol(p, &p, 10); /* first number () */ + rsspages = strtol(p, &p, 10); /* second number */ + + mem = (size_t)rsspages * (size_t)getpagesize(); + } + else + { + /* next, try getrusage() */ + if (getrusage(RUSAGE_SELF, &RU)) + cout << "perf::sample_mem_usage calling getrusage fail" << endl; + else + mem = RU.ru_maxrss * (size_t)1024; + /*mem = RU.ru_maxrss * getpagesize();*/ + } + + if (mem > mem_peak) + mem_peak = mem; + mem_current = mem; + locked = false; +} +size_t perf::MemoryUsage(size_t *current_min, size_t *current_avg, size_t *current_max, + size_t *peak_min, size_t *peak_avg, size_t *peak_max, + int nprocs) +{ + sample_mem_usage(0); + + double a[2][3], b[2][3]; + a[0][0] = a[0][1] = a[0][2] = mem_current; + a[1][0] = a[1][1] = a[1][2] = mem_peak; + MPI_Allreduce(a, b, 6, MPI_DOUBLE, MPI_SUM, MPI_COMM_WORLD); + b[0][1] /= nprocs; + b[1][1] /= nprocs; + + if (current_min != NULL) + *current_min = (size_t)(b[0][0] + 0.5); + if (current_avg != NULL) + *current_avg = (size_t)(b[0][1] + 0.5); + if (current_max != NULL) + *current_max = (size_t)(b[0][2] + 0.5); + + if (peak_min != NULL) + *peak_min = (size_t)(b[1][0] + 0.5); + if (peak_avg != NULL) + *peak_avg = (size_t)(b[1][1] + 0.5); + if (peak_max != NULL) + *peak_max = (size_t)(b[1][2] + 0.5); + + return (size_t)b[0][2]; /* return max(mem_current) */ +} diff --git a/AMSS_NCKU_source/perf.h b/AMSS_NCKU_source/System_Performance/perf.h similarity index 95% rename from AMSS_NCKU_source/perf.h rename to AMSS_NCKU_source/System_Performance/perf.h index c16723d..1b383c4 100644 --- a/AMSS_NCKU_source/perf.h +++ b/AMSS_NCKU_source/System_Performance/perf.h @@ -1,59 +1,59 @@ - -#ifndef PERF_H -#define PERF_H -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -/* for open/read/close */ -#include -#include -#include -#include - -#include -#include -#include - -#include - -/* Real time */ -#define TimerSignal SIGALRM -#define TimerType ITIMER_REAL - -class perf -{ -public: - static size_t mem_peak; - static size_t mem_current; - /* The sampling interval of the timer in ms, <= 0 disables the timer. */ - static int sampling_interval; - static char statm[40]; - static bool have_statm; - static struct itimerval new_it, old; - static struct sigaction sa, old_sa; - -public: - perf(); - ~perf(); - static void sample_mem_usage(int dummy); - size_t MemoryUsage(size_t *current_min, size_t *current_avg, size_t *current_max, - size_t *peak_min, size_t *peak_avg, size_t *peak_max, - int nprocs); -}; -#endif /* PERF_H */ + +#ifndef PERF_H +#define PERF_H +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +/* for open/read/close */ +#include +#include +#include +#include + +#include +#include +#include + +#include + +/* Real time */ +#define TimerSignal SIGALRM +#define TimerType ITIMER_REAL + +class perf +{ +public: + static size_t mem_peak; + static size_t mem_current; + /* The sampling interval of the timer in ms, <= 0 disables the timer. */ + static int sampling_interval; + static char statm[40]; + static bool have_statm; + static struct itimerval new_it, old; + static struct sigaction sa, old_sa; + +public: + perf(); + ~perf(); + static void sample_mem_usage(int dummy); + size_t MemoryUsage(size_t *current_min, size_t *current_avg, size_t *current_max, + size_t *peak_min, size_t *peak_avg, size_t *peak_max, + int nprocs); +}; +#endif /* PERF_H */ diff --git a/AMSS_NCKU_source/TwoPunctureABE.C b/AMSS_NCKU_source/Two_Puncture/TwoPunctureABE.C similarity index 96% rename from AMSS_NCKU_source/TwoPunctureABE.C rename to AMSS_NCKU_source/Two_Puncture/TwoPunctureABE.C index c59a01e..a318976 100644 --- a/AMSS_NCKU_source/TwoPunctureABE.C +++ b/AMSS_NCKU_source/Two_Puncture/TwoPunctureABE.C @@ -1,221 +1,221 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include "TwoPunctures.h" - -inline string &lTrim(string &ss) -{ - string::iterator p = find_if(ss.begin(), ss.end(), not1(ptr_fun(isspace))); - ss.erase(ss.begin(), p); - return ss; -} -inline string &rTrim(string &ss) -{ - string::reverse_iterator p = find_if(ss.rbegin(), ss.rend(), not1(ptr_fun(isspace))); - ss.erase(p.base(), ss.end()); - return ss; -} -inline string &Trim(string &st) -{ - lTrim(rTrim(st)); - return st; -} - -int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind) -{ - int pos1, pos2; - string s0; - - ind = 0; - - // remove comments - str = str.substr(0, str.find("#")); - if (rTrim(str).empty()) - return 0; // continue; - - // parse {group, key, val} - pos1 = str.find("::"); - pos2 = str.find("="); - if (pos1 == string::npos || pos2 == string::npos) - return -1; - - s0 = str.substr(0, pos1); - sgrp = lTrim(s0); - s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); - skey = rTrim(s0); - s0 = str.substr(pos2 + 1); - sval = Trim(s0); - - pos1 = sval.find("\""); - pos2 = sval.rfind("\""); - if (pos1 != string::npos) - { - sval = sval.substr(1, pos2 - 1); - } - - pos1 = skey.find("["); - pos2 = skey.find("]"); - if (pos1 != string::npos) - { - s0 = skey.substr(0, pos1); - ind = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - skey = s0; - } - - return 1; -} -//======================================= -int main(int argc, char *argv[]) -{ - double mp, mm, b, Mp, Mm, admtol, Newtontol; - int nA, nB, nphi, Newtonmaxit; - double P_plusx, P_plusy, P_plusz; - double P_minusx, P_minusy, P_minusz; - double S_plusx, S_plusy, S_plusz; - double S_minusx, S_minusy, S_minusz; - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - const char pname[] = "TwoPunctureinput.par"; - ifstream inf(pname, ifstream::in); - if (!inf.good()) - { - cout << "Can not open parameter file " << pname << endl; - exit(0); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - cout << "error reading parameter file " << pname << " in line " << i << endl; - exit(0); - } - else if (status == 0) - continue; - // we assume input in Brugmann's convention - if (sgrp == "ABE") - { - if (skey == "mm") - mm = atof(sval.c_str()); - else if (skey == "mp") - mp = atof(sval.c_str()); - else if (skey == "b") - b = atof(sval.c_str()); - else if (skey == "P_plusx") - P_plusy = -atof(sval.c_str()); - else if (skey == "P_plusy") - P_plusx = atof(sval.c_str()); - else if (skey == "P_plusz") - P_plusz = atof(sval.c_str()); - else if (skey == "P_minusx") - P_minusy = -atof(sval.c_str()); - else if (skey == "P_minusy") - P_minusx = atof(sval.c_str()); - else if (skey == "P_minusz") - P_minusz = atof(sval.c_str()); - else if (skey == "S_plusx") - S_plusy = -atof(sval.c_str()); - else if (skey == "S_plusy") - S_plusx = atof(sval.c_str()); - else if (skey == "S_plusz") - S_plusz = atof(sval.c_str()); - else if (skey == "S_minusx") - S_minusy = -atof(sval.c_str()); - else if (skey == "S_minusy") - S_minusx = atof(sval.c_str()); - else if (skey == "S_minusz") - S_minusz = atof(sval.c_str()); - else if (skey == "Mp") - Mp = atof(sval.c_str()); - else if (skey == "Mm") - Mm = atof(sval.c_str()); - else if (skey == "admtol") - admtol = atof(sval.c_str()); - else if (skey == "Newtontol") - Newtontol = atof(sval.c_str()); - else if (skey == "nA") - nA = atoi(sval.c_str()); - else if (skey == "nB") - nB = atoi(sval.c_str()); - else if (skey == "nphi") - nphi = atoi(sval.c_str()); - else if (skey == "Newtonmaxit") - Newtonmaxit = atoi(sval.c_str()); - } - } - inf.close(); - } - // echo parameters - { - cout << "///////////////////////////////////////////////////////////////" << endl; - cout << " mp = " << mp << endl; - cout << " mm = " << mm << endl; - cout << " b = " << b << endl; - cout << " P_plusx = " << P_plusx << endl; - cout << " P_plusy = " << P_plusy << endl; - cout << " P_plusz = " << P_plusz << endl; - cout << " P_minusx = " << P_minusx << endl; - cout << " P_minusy = " << P_minusy << endl; - cout << " P_minusz = " << P_minusz << endl; - cout << " S_plusx = " << S_plusx << endl; - cout << " S_plusy = " << S_plusy << endl; - cout << " S_plusz = " << S_plusz << endl; - cout << " S_minusx = " << S_minusx << endl; - cout << " S_minusy = " << S_minusy << endl; - cout << " S_minusz = " << S_minusz << endl; - cout << " Mp = " << Mp << endl; - cout << " Mm = " << Mm << endl; - cout << " admtol = " << admtol << endl; - cout << " Newtontol = " << Newtontol << endl; - cout << " nA = " << nA << endl; - cout << " nB = " << nB << endl; - cout << " nphi = " << nphi << endl; - cout << "Newtonmaxit = " << Newtonmaxit << endl; - cout << "///////////////////////////////////////////////////////////////" << endl; - } - //===========================the computation body==================================================== - TwoPunctures *ADM; - - ADM = new TwoPunctures(mp, mm, b, P_plusx, P_plusy, P_plusz, S_plusx, S_plusy, S_plusz, - P_minusx, P_minusy, P_minusz, S_minusx, S_minusy, S_minusz, - nA, nB, nphi, Mp, Mm, admtol, Newtontol, Newtonmaxit); - ADM->Solve(); - ADM->Save("Ansorg.psid"); - - delete ADM; - //=======================caculation done============================================================= - cout << "===============================================================" << endl; - cout << "Initial data is successfully producede!!" << endl; - - exit(0); -} + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include "TwoPunctures.h" + +inline string &lTrim(string &ss) +{ + string::iterator p = find_if(ss.begin(), ss.end(), not1(ptr_fun(isspace))); + ss.erase(ss.begin(), p); + return ss; +} +inline string &rTrim(string &ss) +{ + string::reverse_iterator p = find_if(ss.rbegin(), ss.rend(), not1(ptr_fun(isspace))); + ss.erase(p.base(), ss.end()); + return ss; +} +inline string &Trim(string &st) +{ + lTrim(rTrim(st)); + return st; +} + +int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind) +{ + int pos1, pos2; + string s0; + + ind = 0; + + // remove comments + str = str.substr(0, str.find("#")); + if (rTrim(str).empty()) + return 0; // continue; + + // parse {group, key, val} + pos1 = str.find("::"); + pos2 = str.find("="); + if (pos1 == string::npos || pos2 == string::npos) + return -1; + + s0 = str.substr(0, pos1); + sgrp = lTrim(s0); + s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); + skey = rTrim(s0); + s0 = str.substr(pos2 + 1); + sval = Trim(s0); + + pos1 = sval.find("\""); + pos2 = sval.rfind("\""); + if (pos1 != string::npos) + { + sval = sval.substr(1, pos2 - 1); + } + + pos1 = skey.find("["); + pos2 = skey.find("]"); + if (pos1 != string::npos) + { + s0 = skey.substr(0, pos1); + ind = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + skey = s0; + } + + return 1; +} +//======================================= +int main(int argc, char *argv[]) +{ + double mp, mm, b, Mp, Mm, admtol, Newtontol; + int nA, nB, nphi, Newtonmaxit; + double P_plusx, P_plusy, P_plusz; + double P_minusx, P_minusy, P_minusz; + double S_plusx, S_plusy, S_plusz; + double S_minusx, S_minusy, S_minusz; + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + const char pname[] = "TwoPunctureinput.par"; + ifstream inf(pname, ifstream::in); + if (!inf.good()) + { + cout << "Can not open parameter file " << pname << endl; + exit(0); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + cout << "error reading parameter file " << pname << " in line " << i << endl; + exit(0); + } + else if (status == 0) + continue; + // we assume input in Brugmann's convention + if (sgrp == "ABE") + { + if (skey == "mm") + mm = atof(sval.c_str()); + else if (skey == "mp") + mp = atof(sval.c_str()); + else if (skey == "b") + b = atof(sval.c_str()); + else if (skey == "P_plusx") + P_plusy = -atof(sval.c_str()); + else if (skey == "P_plusy") + P_plusx = atof(sval.c_str()); + else if (skey == "P_plusz") + P_plusz = atof(sval.c_str()); + else if (skey == "P_minusx") + P_minusy = -atof(sval.c_str()); + else if (skey == "P_minusy") + P_minusx = atof(sval.c_str()); + else if (skey == "P_minusz") + P_minusz = atof(sval.c_str()); + else if (skey == "S_plusx") + S_plusy = -atof(sval.c_str()); + else if (skey == "S_plusy") + S_plusx = atof(sval.c_str()); + else if (skey == "S_plusz") + S_plusz = atof(sval.c_str()); + else if (skey == "S_minusx") + S_minusy = -atof(sval.c_str()); + else if (skey == "S_minusy") + S_minusx = atof(sval.c_str()); + else if (skey == "S_minusz") + S_minusz = atof(sval.c_str()); + else if (skey == "Mp") + Mp = atof(sval.c_str()); + else if (skey == "Mm") + Mm = atof(sval.c_str()); + else if (skey == "admtol") + admtol = atof(sval.c_str()); + else if (skey == "Newtontol") + Newtontol = atof(sval.c_str()); + else if (skey == "nA") + nA = atoi(sval.c_str()); + else if (skey == "nB") + nB = atoi(sval.c_str()); + else if (skey == "nphi") + nphi = atoi(sval.c_str()); + else if (skey == "Newtonmaxit") + Newtonmaxit = atoi(sval.c_str()); + } + } + inf.close(); + } + // echo parameters + { + cout << "///////////////////////////////////////////////////////////////" << endl; + cout << " mp = " << mp << endl; + cout << " mm = " << mm << endl; + cout << " b = " << b << endl; + cout << " P_plusx = " << P_plusx << endl; + cout << " P_plusy = " << P_plusy << endl; + cout << " P_plusz = " << P_plusz << endl; + cout << " P_minusx = " << P_minusx << endl; + cout << " P_minusy = " << P_minusy << endl; + cout << " P_minusz = " << P_minusz << endl; + cout << " S_plusx = " << S_plusx << endl; + cout << " S_plusy = " << S_plusy << endl; + cout << " S_plusz = " << S_plusz << endl; + cout << " S_minusx = " << S_minusx << endl; + cout << " S_minusy = " << S_minusy << endl; + cout << " S_minusz = " << S_minusz << endl; + cout << " Mp = " << Mp << endl; + cout << " Mm = " << Mm << endl; + cout << " admtol = " << admtol << endl; + cout << " Newtontol = " << Newtontol << endl; + cout << " nA = " << nA << endl; + cout << " nB = " << nB << endl; + cout << " nphi = " << nphi << endl; + cout << "Newtonmaxit = " << Newtonmaxit << endl; + cout << "///////////////////////////////////////////////////////////////" << endl; + } + //===========================the computation body==================================================== + TwoPunctures *ADM; + + ADM = new TwoPunctures(mp, mm, b, P_plusx, P_plusy, P_plusz, S_plusx, S_plusy, S_plusz, + P_minusx, P_minusy, P_minusz, S_minusx, S_minusy, S_minusz, + nA, nB, nphi, Mp, Mm, admtol, Newtontol, Newtonmaxit); + ADM->Solve(); + ADM->Save("Ansorg.psid"); + + delete ADM; + //=======================caculation done============================================================= + cout << "===============================================================" << endl; + cout << "Initial data is successfully producede!!" << endl; + + exit(0); +} diff --git a/AMSS_NCKU_source/TwoPunctures.C b/AMSS_NCKU_source/Two_Puncture/TwoPunctures.C similarity index 97% rename from AMSS_NCKU_source/TwoPunctures.C rename to AMSS_NCKU_source/Two_Puncture/TwoPunctures.C index 1b6e590..8670da1 100644 --- a/AMSS_NCKU_source/TwoPunctures.C +++ b/AMSS_NCKU_source/Two_Puncture/TwoPunctures.C @@ -1,3201 +1,3201 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#endif - -#include "TwoPunctures.h" -#include - -TwoPunctures::TwoPunctures(double mp, double mm, double b, - double P_plusx, double P_plusy, double P_plusz, - double S_plusx, double S_plusy, double S_plusz, - double P_minusx, double P_minusy, double P_minusz, - double S_minusx, double S_minusy, double S_minusz, - int nA, int nB, int nphi, - double Mp, double Mm, double admtol, double Newtontol, - int Newtonmaxit) : par_m_plus(mp), par_m_minus(mm), par_b(b), npoints_A(nA), - npoints_B(nB), npoints_phi(nphi), target_M_plus(Mp), target_M_minus(Mm), - adm_tol(admtol), Newton_tol(Newtontol), Newton_maxit(Newtonmaxit) -{ - par_P_plus[0] = P_plusx; - par_P_plus[1] = P_plusy; - par_P_plus[2] = P_plusz; - par_P_minus[0] = P_minusx; - par_P_minus[1] = P_minusy; - par_P_minus[2] = P_minusz; - par_S_plus[0] = S_plusx; - par_S_plus[1] = S_plusy; - par_S_plus[2] = S_plusz; - par_S_minus[0] = S_minusx; - par_S_minus[1] = S_minusy; - par_S_minus[2] = S_minusz; - - int const nvar = 1, n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; - - ntotal = n1 * n2 * n3 * nvar; - - F = dvector(0, ntotal - 1); - allocate_derivs(&u, ntotal); - allocate_derivs(&v, ntotal); - D1_A = NULL; D2_A = NULL; D1_B = NULL; D2_B = NULL; - DF1_phi = NULL; DF2_phi = NULL; - precompute_derivative_matrices(); - allocate_workspace(); -} - -TwoPunctures::~TwoPunctures() -{ - free_dvector(F, 0, ntotal - 1); - free_derivs(&u, ntotal); - free_derivs(&v, ntotal); - free_workspace(); - if (D1_A) delete[] D1_A; - if (D2_A) delete[] D2_A; - if (D1_B) delete[] D1_B; - if (D2_B) delete[] D2_B; - if (DF1_phi) delete[] DF1_phi; - if (DF2_phi) delete[] DF2_phi; -} - -void TwoPunctures::Solve() -{ - - double mp = par_m_plus; - double mm = par_m_minus; - - enum GRID_SETUP_METHOD - { - GSM_Taylor_expansion, - GSM_evaluation - }; - enum GRID_SETUP_METHOD gsm; - - int antisymmetric_lapse, averaged_lapse, pmn_lapse, brownsville_lapse; - - int const nvar = 1, n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; - - int imin[3], imax[3]; - int const ntotal = n1 * n2 * n3 * nvar; - - // double admMass; - - /* initialise to 0 */ - for (int j = 0; j < ntotal; j++) - { - v.d0[j] = 0.0; - v.d1[j] = 0.0; - v.d2[j] = 0.0; - v.d3[j] = 0.0; - v.d11[j] = 0.0; - v.d12[j] = 0.0; - v.d13[j] = 0.0; - v.d22[j] = 0.0; - v.d23[j] = 0.0; - v.d33[j] = 0.0; - } - - double tmp, Mp_adm, Mm_adm, Mp_adm_err, Mm_adm_err, up, um; - - double M_p = target_M_plus; - double M_m = target_M_minus; - /* If bare masses are not given, iteratively solve for them given the - target ADM masses target_M_plus and target_M_minus and with initial - guesses given by par_m_plus and par_m_minus. */ - if (par_m_plus < 0 || par_m_minus < 0) - { - - par_m_plus = target_M_plus; - par_m_minus = target_M_minus; - cout << "Attempting to find bare masses." << endl; - cout << "Target ADM masses: M_p=" << M_p << " and M_m=" << M_m << endl; - cout << "ADM mass tolerance: " << adm_tol << endl; - - /* Loop until both ADM masses are within adm_tol of their target */ - do - { - cout << "Bare masses: mp=" << mp << ", mm=" << mm << endl; - Newton(nvar, n1, n2, n3, v, Newton_tol, 1); - - F_of_v(nvar, n1, n2, n3, v, F, u); - - up = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, par_b, 0., 0.); - um = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, -par_b, 0., 0.); - - /* Calculate the ADM masses from the current bare mass guess PRD 70, 064011 (2004) Eq.(83)*/ - Mp_adm = (1 + up) * mp + mp * mm / (4. * par_b); - Mm_adm = (1 + um) * mm + mp * mm / (4. * par_b); - - /* Check how far the current ADM masses are from the target */ - Mp_adm_err = fabs(M_p - Mp_adm); - Mm_adm_err = fabs(M_m - Mm_adm); - cout << "ADM mass error: M_p_err=" << Mp_adm_err << ", M_m_err=" << Mm_adm_err << endl; - - /* Invert the ADM mass equation and update the bare mass guess so that - it gives the correct target ADM masses */ - tmp = -4 * par_b * (1 + um + up + um * up) + - sqrt(16 * par_b * M_m * (1 + um) * (1 + up) + - pow(-M_m + M_p + 4 * par_b * (1 + um) * (1 + up), 2)); - par_m_plus = mp = (tmp + M_p - M_m) / (2. * (1 + up)); - par_m_minus = mm = (tmp - M_p + M_m) / (2. * (1 + um)); - - } while ((Mp_adm_err > adm_tol) || - (Mm_adm_err > adm_tol)); - - cout << "Found bare masses resulted Mp = " << Mp_adm << " and Mm = " << Mm_adm << endl; - } - - Newton(nvar, n1, n2, n3, v, Newton_tol, Newton_maxit); - - F_of_v(nvar, n1, n2, n3, v, F, u); - - up = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, par_b, 0., 0.); - um = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, -par_b, 0., 0.); - - /* Calculate the ADM masses from the current bare mass guess PRD 70, 064011 (2004) Eq.(83)*/ - Mp_adm = (1 + up) * mp + mp * mm / (4. * par_b); - Mm_adm = (1 + um) * mm + mp * mm / (4. * par_b); - - cout << "The two puncture masses are mp = " << mp << " and mm = " << mm << endl; - cout << " resulted Mp = " << Mp_adm << " and Mm = " << Mm_adm << endl; - - /* print out ADM mass, eq.: \Delta M_ADM=2*r*u=4*b*V for A=1,B=0,phi=0 PRD 70, 064011 (2004) Eq.(81)*/ - admMass = (mp + mm - 4 * par_b * PunctEvalAtArbitPosition(v.d0, 0, 1, 0, 0, nvar, n1, n2, n3)); - cout << "The total ADM mass is " << admMass << endl; - - target_M_plus = Mp_adm; - target_M_minus = Mm_adm; -} -void TwoPunctures::Save(char *fname) -{ - ofstream outfile; - outfile.open(fname, ios::trunc); - - time_t tnow; - time(&tnow); - struct tm *loc_time; - loc_time = localtime(&tnow); - outfile << "#File created on " << asctime(loc_time); - outfile << "#Newton_tol = " << Newton_tol << endl; - outfile << "#Mp = " << target_M_plus << endl; - outfile << "#Mm = " << target_M_minus << endl; - double D = 2 * par_b, x1, x2; - x1 = D * target_M_minus / (target_M_plus + target_M_minus); - x2 = -D * target_M_plus / (target_M_plus + target_M_minus); - // in order to relate Brugmann's convention, rotate xy - outfile << "bhmass1 = " << par_m_plus << endl; - outfile << "bhx1 = " << 0 << endl; - outfile << "bhy1 = " << x1 << endl; - outfile << "bhz1 = " << 0 << endl; - outfile << "bhpx1 = " << -par_P_plus[1] << endl; - outfile << "bhpy1 = " << par_P_plus[0] << endl; - outfile << "bhpz1 = " << par_P_plus[2] << endl; - outfile << "bhsx1 = " << -par_S_plus[1] << endl; - outfile << "bhsy1 = " << par_S_plus[0] << endl; - outfile << "bhsz1 = " << par_S_plus[2] << endl; - outfile << "bhmass2 = " << par_m_minus << endl; - outfile << "bhx2 = " << 0 << endl; - outfile << "bhy2 = " << x2 << endl; - outfile << "bhz2 = " << 0 << endl; - outfile << "bhpx2 = " << -par_P_minus[1] << endl; - outfile << "bhpy2 = " << par_P_minus[0] << endl; - outfile << "bhpz2 = " << par_P_minus[2] << endl; - outfile << "bhsx2 = " << -par_S_minus[1] << endl; - outfile << "bhsy2 = " << par_S_minus[0] << endl; - outfile << "bhsz2 = " << par_S_minus[2] << endl; - int const n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; - outfile << "data " << n1 << " " << n2 << " " << n3 << endl; - int ntotal = n1 * n2 * n3; - - outfile.setf(ios::scientific, ios::floatfield); - outfile.precision(16); - for (int i = 0; i < ntotal; i++) - outfile << v.d0[i] << endl; - - outfile.close(); - - // add output to facilitate python reading of puncture data, by Xiaoqu 2024/12/04 - ofstream outfile2; - outfile2.open("puncture_parameters_new.txt", ios::trunc); - - // note that in this program the xy plane has been rotated - outfile2 << setw(18) << setprecision(10) << par_m_plus - << setw(18) << setprecision(10) << target_M_plus - << setw(18) << setprecision(10) << admMass << " # bare mass 1 mass 1 ADM mass" << endl; - outfile2 << setw(18) << setprecision(10) << 0.0 - << setw(18) << setprecision(10) << x1 - << setw(18) << setprecision(10) << 0.0 << " # position 1" << endl; - outfile2 << setw(18) << setprecision(10) << -par_P_plus[1] - << setw(18) << setprecision(10) << par_P_plus[0] - << setw(18) << setprecision(10) << par_P_plus[2] << " # momentum 1" << endl; - outfile2 << setw(18) << setprecision(10) << -par_S_plus[1] - << setw(18) << setprecision(10) << par_S_plus[0] - << setw(18) << setprecision(10) << par_S_plus[2] << " # angular mumentum 1" << endl; - outfile2 << setw(18) << setprecision(10) << par_m_minus - << setw(18) << setprecision(10) << target_M_minus - << setw(18) << setprecision(10) << admMass << " # bare mass 2 mass 2 ADM mass" << endl; - outfile2 << setw(18) << setprecision(10) << 0.0 - << setw(18) << setprecision(10) << x2 - << setw(18) << setprecision(10) << 0.0 << " # position 2" << endl; - outfile2 << setw(18) << setprecision(10) << -par_P_minus[1] - << setw(18) << setprecision(10) << par_P_minus[0] - << setw(18) << setprecision(10) << par_P_minus[2] << " # momentum 2" << endl; - outfile2 << setw(18) << setprecision(10) << -par_S_minus[1] - << setw(18) << setprecision(10) << par_S_minus[0] - << setw(18) << setprecision(10) << par_S_minus[2] << " # angular mumentum 2" << endl; - - outfile2.close(); -} - -void TwoPunctures::set_initial_guess(derivs v) -{ - - int nvar = 1, n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; - - double *s_x, *s_y, *s_z; // Cartesian x,y,z - double al, A, Am1, be, B, phi, R, r, X; - int ivar, i, j, k, i3D, indx; - derivs U; - FILE *debug_file; - - s_x = (double *)calloc(n1 * n2 * n3, sizeof(double)); - s_y = (double *)calloc(n1 * n2 * n3, sizeof(double)); - s_z = (double *)calloc(n1 * n2 * n3, sizeof(double)); - allocate_derivs(&U, nvar); - for (ivar = 0; ivar < nvar; ivar++) - for (i = 0; i < n1; i++) - for (j = 0; j < n2; j++) - for (k = 0; k < n3; k++) - { - i3D = Index(ivar, i, j, k, 1, n1, n2, n3); - - al = Pih * (2 * i + 1) / n1; - A = -cos(al); - be = Pih * (2 * j + 1) / n2; - B = -cos(be); - phi = 2. * Pi * k / n3; - - /* Calculation of (X,R)*/ - AB_To_XR(nvar, A, B, &X, &R, U); - /* Calculation of (x,r)*/ - C_To_c(nvar, X, R, &(s_x[i3D]), &r, U); - /* Calculation of (y,z)*/ - rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[i3D]), &(s_z[i3D]), U); - } - // Set_Initial_Guess_for_u(n1*n2*n3, v.d0, s_x, s_y, s_z); //extern fortran code to set initial guess - for (ivar = 0; ivar < nvar; ivar++) - for (i = 0; i < n1; i++) - for (j = 0; j < n2; j++) - for (k = 0; k < n3; k++) - { - indx = Index(ivar, i, j, k, 1, n1, n2, n3); - v.d0[indx] = 0; // set initial guess 0 - v.d0[indx] /= (-cos(Pih * (2 * i + 1) / n1) - 1.0); // PRD 70, 064011 (2004) Eq.(5), from u to U - } - Derivatives_AB3_MatMul(nvar, n1, n2, n3, v); - if (0) - { - debug_file = fopen("initial.dat", "w"); - assert(debug_file); - for (ivar = 0; ivar < nvar; ivar++) - for (i = 0; i < n1; i++) - for (j = 0; j < n2; j++) - { - al = Pih * (2 * i + 1) / n1; - A = -cos(al); - Am1 = A - 1.0; - be = Pih * (2 * j + 1) / n2; - B = -cos(be); - phi = 0.0; - indx = Index(ivar, i, j, 0, 1, n1, n2, n3); - U.d0[0] = Am1 * v.d0[indx]; /* U*/ - U.d1[0] = v.d0[indx] + Am1 * v.d1[indx]; /* U_A*/ - U.d2[0] = Am1 * v.d2[indx]; /* U_B*/ - U.d3[0] = Am1 * v.d3[indx]; /* U_3*/ - U.d11[0] = 2 * v.d1[indx] + Am1 * v.d11[indx]; /* U_AA*/ - U.d12[0] = v.d2[indx] + Am1 * v.d12[indx]; /* U_AB*/ - U.d13[0] = v.d3[indx] + Am1 * v.d13[indx]; /* U_AB*/ - U.d22[0] = Am1 * v.d22[indx]; /* U_BB*/ - U.d23[0] = Am1 * v.d23[indx]; /* U_B3*/ - U.d33[0] = Am1 * v.d33[indx]; /* U_33*/ - /* Calculation of (X,R)*/ - AB_To_XR(nvar, A, B, &X, &R, U); - /* Calculation of (x,r)*/ - C_To_c(nvar, X, R, &(s_x[indx]), &r, U); - /* Calculation of (y,z)*/ - rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[indx]), &(s_z[indx]), U); - fprintf(debug_file, - "%.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g " - "%.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g\n", - (double)s_x[indx], (double)s_y[indx], - (double)A, (double)B, - (double)U.d0[0], - (double)(-cos(Pih * (2 * i + 1) / n1) - 1.0), - (double)U.d1[0], - (double)U.d2[0], - (double)U.d3[0], - (double)U.d11[0], - (double)U.d22[0], - (double)U.d33[0], - (double)v.d0[indx], - (double)v.d1[indx], - (double)v.d2[indx], - (double)v.d3[indx], - (double)v.d11[indx], - (double)v.d22[indx], - (double)v.d33[indx]); - } - fprintf(debug_file, "\n\n"); - for (i = n2 - 10; i < n2; i++) - { - double d; - indx = Index(0, 0, i, 0, 1, n1, n2, n3); - d = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, - s_x[indx], 0.0, 0.0); - fprintf(debug_file, "%.16g %.16g\n", - (double)s_x[indx], (double)d); - } - fprintf(debug_file, "\n\n"); - for (i = n2 - 10; i < n2 - 1; i++) - { - double d; - int ip = Index(0, 0, i + 1, 0, 1, n1, n2, n3); - indx = Index(0, 0, i, 0, 1, n1, n2, n3); - for (j = -10; j < 10; j++) - { - d = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, - s_x[indx] + (s_x[ip] - s_x[indx]) * j / 10, - 0.0, 0.0); - fprintf(debug_file, "%.16g %.16g\n", - (double)(s_x[indx] + (s_x[ip] - s_x[indx]) * j / 10), (double)d); - } - } - fprintf(debug_file, "\n\n"); - for (i = 0; i < n1; i++) - for (j = 0; j < n2; j++) - { - X = 2 * (2.0 * i / n1 - 1.0); - R = 2 * (1.0 * j / n2); - if (X * X + R * R > 1.0) - { - C_To_c(nvar, X, R, &(s_x[indx]), &r, U); - rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[indx]), &(s_z[indx]), U); - *U.d0 = s_x[indx] * s_x[indx]; - *U.d1 = 2 * s_x[indx]; - *U.d2 = 0.0; - *U.d3 = 0.0; - *U.d11 = 2.0; - *U.d22 = 0.0; - *U.d33 = *U.d12 = *U.d23 = *U.d13 = 0.0; - C_To_c(nvar, X, R, &(s_x[indx]), &r, U); - fprintf(debug_file, - "%.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g\n", - (double)s_x[indx], (double)r, (double)X, (double)R, (double)U.d0[0], - (double)U.d1[0], - (double)U.d2[0], - (double)U.d3[0], - (double)U.d11[0], - (double)U.d22[0], - (double)U.d33[0]); - } - } - fclose(debug_file); - } - free(s_z); - free(s_y); - free(s_x); - free_derivs(&U, nvar); -} - -// some tools -/*---------------------------------------------------------------------------*/ -int TwoPunctures::index(int i, int j, int k, int l, int a, int b, int c, int d) -{ - int rr = 0; - rr = l + k * d + j * d * c + i * d * c * b; - return rr; -} -/*---------------------------------------------------------------------------*/ -int *TwoPunctures::ivector(long nl, long nh) -/* allocate an int vector with subscript range v[nl..nh] */ -{ - int *retval; - - retval = (int *)malloc(sizeof(int) * (nh - nl + 1)); - if (retval == NULL) - cout << "allocation failure in ivector()" << endl; - - return retval - nl; -} - -/*---------------------------------------------------------------------------*/ -double *TwoPunctures::dvector(long nl, long nh) -/* allocate a double vector with subscript range v[nl..nh] */ -{ - double *retval; - - retval = (double *)malloc(sizeof(double) * (nh - nl + 1)); - if (retval == NULL) - cout << "allocation failure in dvector()" << endl; - - return retval - nl; -} - -/*---------------------------------------------------------------------------*/ -int **TwoPunctures::imatrix(long nrl, long nrh, long ncl, long nch) -/* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */ -{ - int **retval; - - retval = (int **)malloc(sizeof(int *) * (nrh - nrl + 1)); - if (retval == NULL) - cout << "allocation failure (1) in imatrix()" << endl; - - /* get all memory for the matrix in on chunk */ - retval[0] = (int *)malloc(sizeof(int) * (nrh - nrl + 1) * (nch - ncl + 1)); - if (retval[0] == NULL) - cout << "allocation failure (2) in imatrix()" << endl; - - /* apply column and row offsets */ - retval[0] -= ncl; - retval -= nrl; - - /* slice chunk into rows */ - long width = (nch - ncl + 1); - for (long i = nrl + 1; i <= nrh; i++) - retval[i] = retval[i - 1] + width; - assert(retval[nrh] - retval[nrl] == (nrh - nrl) * width); - - return retval; -} - -/*---------------------------------------------------------------------------*/ -double **TwoPunctures::dmatrix(long nrl, long nrh, long ncl, long nch) -/* allocate a double matrix with subscript range m[nrl..nrh][ncl..nch] */ -{ - double **retval; - - retval = (double **)malloc(sizeof(double *) * (nrh - nrl + 1)); - if (retval == NULL) - cout << "allocation failure (1) in dmatrix()" << endl; - - /* get all memory for the matrix in on chunk */ - retval[0] = (double *)malloc(sizeof(double) * (nrh - nrl + 1) * (nch - ncl + 1)); - if (retval[0] == NULL) - cout << "allocation failure (2) in dmatrix()" << endl; - - /* apply column and row offsets */ - retval[0] -= ncl; - retval -= nrl; - - /* slice chunk into rows */ - long width = (nch - ncl + 1); - for (long i = nrl + 1; i <= nrh; i++) - retval[i] = retval[i - 1] + width; - assert(retval[nrh] - retval[nrl] == (nrh - nrl) * width); - - return retval; -} - -/*---------------------------------------------------------------------------*/ -double ***TwoPunctures::d3tensor(long nrl, long nrh, long ncl, long nch, long ndl, long ndh) -/* allocate a double 3tensor with range t[nrl..nrh][ncl..nch][ndl..ndh] */ -{ - double ***retval; - - /* get memory for index structures */ - retval = (double ***)malloc(sizeof(double **) * (nrh - nrl + 1)); - if (retval == NULL) - cout << "allocation failure (1) in dmatrix()" << endl; - - retval[0] = (double **)malloc(sizeof(double *) * (nrh - nrl + 1) * (nch - ncl + 1)); - if (retval[0] == NULL) - cout << "allocation failure (2) in dmatrix()" << endl; - - /* get all memory for the tensor in on chunk */ - retval[0][0] = (double *)malloc(sizeof(double) * (nrh - nrl + 1) * (nch - ncl + 1) * (nrh - nrl + 1)); - if (retval[0][0] == NULL) - cout << "allocation failure (3) in dmatrix()" << endl; - - /* apply all offsets */ - retval[0][0] -= ndl; - retval[0] -= ncl; - retval -= nrl; - - /* slice chunk into rows and columns */ - long width = (nch - ncl + 1); - long depth = (ndh - ndl + 1); - for (long j = ncl + 1; j <= nch; j++) - { /* first row of columns */ - retval[nrl][j] = retval[nrl][j - 1] + depth; - } - assert(retval[nrl][nch] - retval[nrl][ncl] == (nch - ncl) * depth); - for (long i = nrl + 1; i <= nrh; i++) - { - retval[i] = retval[i - 1] + width; - retval[i][ncl] = retval[i - 1][ncl] + width * depth; /* first cell in column */ - for (long j = ncl + 1; j <= nch; j++) - { - retval[i][j] = retval[i][j - 1] + depth; - } - assert(retval[i][nch] - retval[i][ncl] == (nch - ncl) * depth); - } - assert(retval[nrh] - retval[nrl] == (nrh - nrl) * width); - assert(&retval[nrh][nch][ndh] - &retval[nrl][ncl][ndl] == (nrh - nrl + 1) * (nch - ncl + 1) * (ndh - ndl + 1) - 1); - - return retval; -} - -/*--------------------------------------------------------------------------*/ -void TwoPunctures::free_ivector(int *v, long nl, long nh) -/* free an int vector allocated with ivector() */ -{ - free(v + nl); -} - -/*--------------------------------------------------------------------------*/ -void TwoPunctures::free_dvector(double *v, long nl, long nh) -/* free an double vector allocated with dvector() */ -{ - free(v + nl); -} - -/*--------------------------------------------------------------------------*/ -void TwoPunctures::free_imatrix(int **m, long nrl, long nrh, long ncl, long nch) -/* free an int matrix allocated by imatrix() */ -{ - free(m[nrl] + ncl); - free(m + nrl); -} - -/*--------------------------------------------------------------------------*/ -void TwoPunctures::free_dmatrix(double **m, long nrl, long nrh, long ncl, long nch) -/* free a double matrix allocated by dmatrix() */ -{ - free(m[nrl] + ncl); - free(m + nrl); -} - -/*--------------------------------------------------------------------------*/ -void TwoPunctures::free_d3tensor(double ***t, long nrl, long nrh, long ncl, long nch, - long ndl, long ndh) -/* free a double f3tensor allocated by f3tensor() */ -{ - free(t[nrl][ncl] + ndl); - free(t[nrl] + ncl); - free(t + nrl); -} - -/*--------------------------------------------------------------------------*/ -int TwoPunctures::minimum2(int i, int j) -{ - int result = i; - if (j < result) - result = j; - return result; -} - -/*-------------------------------------------------------------------------*/ -int TwoPunctures::minimum3(int i, int j, int k) -{ - int result = i; - if (j < result) - result = j; - if (k < result) - result = k; - return result; -} - -/*--------------------------------------------------------------------------*/ -int TwoPunctures::maximum2(int i, int j) -{ - int result = i; - if (j > result) - result = j; - return result; -} - -/*--------------------------------------------------------------------------*/ -int TwoPunctures::maximum3(int i, int j, int k) -{ - int result = i; - if (j > result) - result = j; - if (k > result) - result = k; - return result; -} - -/*--------------------------------------------------------------------------*/ -int TwoPunctures::pow_int(int mantisse, int exponent) -{ - int i, result = 1; - - for (i = 1; i <= exponent; i++) - result *= mantisse; - - return result; -} - -/*--------------------------------------------------------------------------*/ -void TwoPunctures::chebft_Zeros(double u[], int n, int inv) -/* eq. 5.8.7 and 5.8.8 at x = (5.8.4) of 2nd edition C++ NR */ -{ - int k, j, isignum; - double fac, sum, Pion, *c; - - c = dvector(0, n); - Pion = Pi / n; - if (inv == 0) - { - fac = 2.0 / n; - isignum = 1; - for (j = 0; j < n; j++) - { - sum = 0.0; - for (k = 0; k < n; k++) - sum += u[k] * cos(Pion * j * (k + 0.5)); - c[j] = fac * sum * isignum; - isignum = -isignum; - } - } - else - { - for (j = 0; j < n; j++) - { - sum = -0.5 * u[0]; - isignum = 1; - for (k = 0; k < n; k++) - { - sum += u[k] * cos(Pion * (j + 0.5) * k) * isignum; - isignum = -isignum; - } - c[j] = sum; - } - } - for (j = 0; j < n; j++) - u[j] = c[j]; - free_dvector(c, 0, n); -} - -/* --------------------------------------------------------------------------*/ -void TwoPunctures::chebft_Extremes(double u[], int n, int inv) -/* eq. 5.8.7 and 5.8.8 at x = (5.8.5) of 2nd edition C++ NR */ -{ - int k, j, isignum, N = n - 1; - double fac, sum, PioN, *c; - - c = dvector(0, N); - PioN = Pi / N; - if (inv == 0) - { - fac = 2.0 / N; - isignum = 1; - for (j = 0; j < n; j++) - { - sum = 0.5 * (u[0] + u[N] * isignum); - for (k = 1; k < N; k++) - sum += u[k] * cos(PioN * j * k); - c[j] = fac * sum * isignum; - isignum = -isignum; - } - c[N] = 0.5 * c[N]; - } - else - { - for (j = 0; j < n; j++) - { - sum = -0.5 * u[0]; - isignum = 1; - for (k = 0; k < n; k++) - { - sum += u[k] * cos(PioN * j * k) * isignum; - isignum = -isignum; - } - c[j] = sum; - } - } - for (j = 0; j < n; j++) - u[j] = c[j]; - free_dvector(c, 0, N); -} - -/* --------------------------------------------------------------------------*/ - -void TwoPunctures::chder(double *c, double *cder, int n) -{ - int j; - - cder[n] = 0.0; - cder[n - 1] = 0.0; - for (j = n - 2; j >= 0; j--) - cder[j] = cder[j + 2] + 2 * (j + 1) * c[j + 1]; -} - -/* --------------------------------------------------------------------------*/ -double TwoPunctures::chebev(double a, double b, double c[], int m, double x) -/* eq. 5.8.11 of C++ NR (2nd ed) */ -{ - int j; - double djp2, djp1, dj; /* d_{j+2}, d_{j+1} and d_j */ - double y; - - /* rescale input to lie within [-1,1] */ - y = 2 * (x - 0.5 * (b + a)) / (b - a); - - dj = djp1 = 0; - for (j = m - 1; j >= 1; j--) - { - /* advance the coefficients */ - djp2 = djp1; - djp1 = dj; - dj = 2 * y * djp1 - djp2 + c[j]; - } - - return y * dj - djp1 + 0.5 * c[0]; -} - -/* --------------------------------------------------------------------------*/ -void TwoPunctures::fourft(double *u, int N, int inv) -/* a (slow) Fourier transform, seems to be just eq. 12.1.6 and 12.1.9 of C++ NR (2nd ed) */ -{ - int l, k, iy, M; - double x, x1, fac, Pi_fac, *a, *b; - - M = N / 2; - a = dvector(0, M); - b = dvector(1, M); /* Actually: b=vector(1,M-1) but this is problematic if M=1*/ - fac = 1. / M; - Pi_fac = Pi * fac; - if (inv == 0) - { - for (l = 0; l <= M; l++) - { - a[l] = 0; - if (l > 0 && l < M) - b[l] = 0; - x1 = Pi_fac * l; - for (k = 0; k < N; k++) - { - x = x1 * k; - a[l] += fac * u[k] * cos(x); - if (l > 0 && l < M) - b[l] += fac * u[k] * sin(x); - } - } - u[0] = a[0]; - u[M] = a[M]; - for (l = 1; l < M; l++) - { - u[l] = a[l]; - u[l + M] = b[l]; - } - } - else - { - a[0] = u[0]; - a[M] = u[M]; - for (l = 1; l < M; l++) - { - a[l] = u[l]; - b[l] = u[M + l]; - } - iy = 1; - for (k = 0; k < N; k++) - { - u[k] = 0.5 * (a[0] + a[M] * iy); - x1 = Pi_fac * k; - for (l = 1; l < M; l++) - { - x = x1 * l; - u[k] += a[l] * cos(x) + b[l] * sin(x); - } - iy = -iy; - } - } - free_dvector(a, 0, M); - free_dvector(b, 1, M); -} - -/* -----------------------------------------*/ -void TwoPunctures::fourder(double u[], double du[], int N) -{ - int l, M, lpM; - - M = N / 2; - du[0] = 0.; - du[M] = 0.; - for (l = 1; l < M; l++) - { - lpM = l + M; - du[l] = u[lpM] * l; - du[lpM] = -u[l] * l; - } -} - -/* -----------------------------------------*/ -void TwoPunctures::fourder2(double u[], double d2u[], int N) -{ - int l, l2, M, lpM; - - d2u[0] = 0.; - M = N / 2; - for (l = 1; l <= M; l++) - { - l2 = l * l; - lpM = l + M; - d2u[l] = -u[l] * l2; - if (l < M) - d2u[lpM] = -u[lpM] * l2; - } -} - -/* ----------------------------------------- */ -double TwoPunctures::fourev(double *u, int N, double x) -{ - int l, M = N / 2; - double xl, result; - - result = 0.5 * (u[0] + u[M] * cos(x * M)); - for (l = 1; l < M; l++) - { - xl = x * l; - result += u[l] * cos(xl) + u[M + l] * sin(xl); - } - return result; -} - -/* ------------------------------------------------------------------------*/ -double TwoPunctures::norm1(double *v, int n) -{ - int i; - double result = -1; - - for (i = 0; i < n; i++) - if (fabs(v[i]) > result) - result = fabs(v[i]); - - return result; -} - -/* -------------------------------------------------------------------------*/ -double TwoPunctures::norm2(double *v, int n) -{ - // Optimized with oneMKL BLAS DNRM2 - // Computes: sqrt(sum(v[i]^2)) - return cblas_dnrm2(n, v, 1); -} - -/* -------------------------------------------------------------------------*/ -double TwoPunctures::scalarproduct(double *v, double *w, int n) -{ - // Optimized with oneMKL BLAS DDOT - // Computes: sum(v[i] * w[i]) - return cblas_ddot(n, v, 1, w, 1); -} - -/* -------------------------------------------------------------------------*/ -/* Calculates the value of v at an arbitrary position (x,y,z)*/ -double TwoPunctures::PunctIntPolAtArbitPosition(int ivar, int nvar, int n1, - int n2, int n3, derivs v, double x, double y, - double z) -{ - double xs, ys, zs, rs2, phi, X, R, A, B, aux1, aux2, result, Ui; - - xs = x / par_b; - ys = y / par_b; - zs = z / par_b; - rs2 = ys * ys + zs * zs; - phi = atan2(z, y); - if (phi < 0) - phi += 2 * Pi; - - aux1 = 0.5 * (xs * xs + rs2 - 1); - aux2 = sqrt(aux1 * aux1 + rs2); - X = asinh(sqrt(aux1 + aux2)); - R = asin(min(1.0, sqrt(-aux1 + aux2))); - if (x < 0) - R = Pi - R; - - A = 2 * tanh(0.5 * X) - 1; - B = tan(0.5 * R - Piq); - - result = PunctEvalAtArbitPosition(v.d0, ivar, A, B, phi, nvar, n1, n2, n3); - - Ui = (A - 1) * result; - - return Ui; -} -/* Calculates the value of v at an arbitrary position (A,B,phi)*/ -double TwoPunctures::PunctEvalAtArbitPosition(double *v, int ivar, double A, double B, double phi, - int nvar, int n1, int n2, int n3) -{ - int i, j, k, N; - double *p, *values1, **values2, result; - - N = maximum3(n1, n2, n3); - p = dvector(0, N); - values1 = dvector(0, N); - values2 = dmatrix(0, N, 0, N); - - for (k = 0; k < n3; k++) - { - for (j = 0; j < n2; j++) - { - for (i = 0; i < n1; i++) - p[i] = v[ivar + nvar * (i + n1 * (j + n2 * k))]; - chebft_Zeros(p, n1, 0); - values2[j][k] = chebev(-1, 1, p, n1, A); - } - } - - for (k = 0; k < n3; k++) - { - for (j = 0; j < n2; j++) - p[j] = values2[j][k]; - chebft_Zeros(p, n2, 0); - values1[k] = chebev(-1, 1, p, n2, B); - } - - fourft(values1, n3, 0); - result = fourev(values1, n3, phi); - - free_dvector(p, 0, N); - free_dvector(values1, 0, N); - free_dmatrix(values2, 0, N, 0, N); - - return result; -} -/*-----------------------------------------------------------*/ -void TwoPunctures::AB_To_XR(int nvar, double A, double B, double *X, double *R, - derivs U) -/* On Entrance: U.d0[]=U[]; U.d1[] =U[]_A; U.d2[] =U[]_B; U.d3[] =U[]_3; */ -/* U.d11[]=U[]_AA; U.d12[]=U[]_AB; U.d13[]=U[]_A3; */ -/* U.d22[]=U[]_BB; U.d23[]=U[]_B3; U.d33[]=U[]_33; */ -/* At Exit: U.d0[]=U[]; U.d1[] =U[]_X; U.d2[] =U[]_R; U.d3[] =U[]_3; */ -/* U.d11[]=U[]_XX; U.d12[]=U[]_XR; U.d13[]=U[]_X3; */ -/* U.d22[]=U[]_RR; U.d23[]=U[]_R3; U.d33[]=U[]_33; */ -{ - double At = 0.5 * (A + 1), A_X, A_XX, B_R, B_RR; - int ivar; - - *X = 2 * atanh(At); - *R = Pih + 2 * atan(B); - - A_X = 1 - At * At; - A_XX = -At * A_X; - B_R = 0.5 * (1 + B * B); - B_RR = B * B_R; - - for (ivar = 0; ivar < nvar; ivar++) - { - U.d11[ivar] = A_X * A_X * U.d11[ivar] + A_XX * U.d1[ivar]; - U.d12[ivar] = A_X * B_R * U.d12[ivar]; - U.d13[ivar] = A_X * U.d13[ivar]; - U.d22[ivar] = B_R * B_R * U.d22[ivar] + B_RR * U.d2[ivar]; - U.d23[ivar] = B_R * U.d23[ivar]; - U.d1[ivar] = A_X * U.d1[ivar]; - U.d2[ivar] = B_R * U.d2[ivar]; - } -} -/*-----------------------------------------------------------*/ -void TwoPunctures::C_To_c(int nvar, double X, double R, double *x, double *r, - derivs U) -/* On Entrance: U.d0[]=U[]; U.d1[] =U[]_X; U.d2[] =U[]_R; U.d3[] =U[]_3; */ -/* U.d11[]=U[]_XX; U.d12[]=U[]_XR; U.d13[]=U[]_X3; */ -/* U.d22[]=U[]_RR; U.d23[]=U[]_R3; U.d33[]=U[]_33; */ -/* At Exit: U.d0[]=U[]; U.d1[] =U[]_x; U.d2[] =U[]_r; U.d3[] =U[]_3; */ -/* U.d11[]=U[]_xx; U.d12[]=U[]_xr; U.d13[]=U[]_x3; */ -/* U.d22[]=U[]_rr; U.d23[]=U[]_r3; U.d33[]=U[]_33; */ -{ - double C_c2, U_cb, U_CB; - complex C, C_c, C_cc, c, c_C, c_CC, U_c, U_cc, U_C, U_CC; - int ivar; - - C = complex(X, R); - - c = cosh(C) * par_b; /* c=b*cosh(C)*/ - c_C = sinh(C) * par_b; - c_CC = c; - - C_c = complex(1, 0) / c_C; - C_cc = -C_c * C_c * C_c * c_CC; - C_c2 = abs(C_c); - C_c2 = C_c2 * C_c2; - - for (ivar = 0; ivar < nvar; ivar++) - { - /* U_C = 0.5*(U_X3-i*U_R3)*/ - /* U_c = U_C*C_c = 0.5*(U_x3-i*U_r3)*/ - U_C = complex(0.5 * U.d13[ivar], -0.5 * U.d23[ivar]); - U_c = U_C * C_c; - U.d13[ivar] = 2. * real(U_c); - U.d23[ivar] = -2. * imag(U_c); - - /* U_C = 0.5*(U_X-i*U_R)*/ - /* U_c = U_C*C_c = 0.5*(U_x-i*U_r)*/ - U_C = complex(0.5 * U.d1[ivar], -0.5 * U.d2[ivar]); - U_c = U_C * C_c; - U.d1[ivar] = 2. * real(U_c); - U.d2[ivar] = -2. * imag(U_c); - - /* U_CC = 0.25*(U_XX-U_RR-2*i*U_XR)*/ - /* U_CB = d^2(U)/(dC*d\bar{C}) = 0.25*(U_XX+U_RR)*/ - U_CC = complex(0.25 * (U.d11[ivar] - U.d22[ivar]), -0.5 * U.d12[ivar]); - U_CB = 0.25 * (U.d11[ivar] + U.d22[ivar]); - - /* U_cc = C_cc*U_C+(C_c)^2*U_CC*/ - U_cb = U_CB * C_c2; - U_cc = C_cc * U_C + C_c * C_c * U_CC; - - /* U_xx = 2*(U_cb+Re[U_cc])*/ - /* U_rr = 2*(U_cb-Re[U_cc])*/ - /* U_rx = -2*Im[U_cc]*/ - U.d11[ivar] = 2 * (U_cb + real(U_cc)); - U.d22[ivar] = 2 * (U_cb - real(U_cc)); - U.d12[ivar] = -2 * imag(U_cc); - } - - *x = real(c); - *r = imag(c); -} -/*-----------------------------------------------------------*/ -void TwoPunctures::rx3_To_xyz(int nvar, double x, double r, double phi, - double *y, double *z, derivs U) -/* On Entrance: U.d0[]=U[]; U.d1[] =U[]_x; U.d2[] =U[]_r; U.d3[] =U[]_3; */ -/* U.d11[]=U[]_xx; U.d12[]=U[]_xr; U.d13[]=U[]_x3; */ -/* U.d22[]=U[]_rr; U.d23[]=U[]_r3; U.d33[]=U[]_33; */ -/* At Exit: U.d0[]=U[]; U.d1[] =U[]_x; U.d2[] =U[]_y; U.dz[] =U[]_z; */ -/* U.d11[]=U[]_xx; U.d12[]=U[]_xy; U.d1z[]=U[]_xz; */ -/* U.d22[]=U[]_yy; U.d2z[]=U[]_yz; U.dzz[]=U[]_zz; */ -{ - int jvar; - double - sin_phi = sin(phi), - cos_phi = cos(phi), - sin2_phi = sin_phi * sin_phi, - cos2_phi = cos_phi * cos_phi, - sin_2phi = 2 * sin_phi * cos_phi, - cos_2phi = cos2_phi - sin2_phi, r_inv = 1 / r, r_inv2 = r_inv * r_inv; - - *y = r * cos_phi; - *z = r * sin_phi; - - for (jvar = 0; jvar < nvar; jvar++) - { - double U_x = U.d1[jvar], U_r = U.d2[jvar], U_3 = U.d3[jvar], - U_xx = U.d11[jvar], U_xr = U.d12[jvar], U_x3 = U.d13[jvar], - U_rr = U.d22[jvar], U_r3 = U.d23[jvar], U_33 = U.d33[jvar]; - U.d1[jvar] = U_x; /* U_x*/ - U.d2[jvar] = U_r * cos_phi - U_3 * r_inv * sin_phi; /* U_y*/ - U.d3[jvar] = U_r * sin_phi + U_3 * r_inv * cos_phi; /* U_z*/ - U.d11[jvar] = U_xx; /* U_xx*/ - U.d12[jvar] = U_xr * cos_phi - U_x3 * r_inv * sin_phi; /* U_xy*/ - U.d13[jvar] = U_xr * sin_phi + U_x3 * r_inv * cos_phi; /* U_xz*/ - U.d22[jvar] = U_rr * cos2_phi + r_inv2 * sin2_phi * (U_33 + r * U_r) /* U_yy*/ - + sin_2phi * r_inv2 * (U_3 - r * U_r3); - U.d23[jvar] = 0.5 * sin_2phi * (U_rr - r_inv * U_r - r_inv2 * U_33) /* U_yz*/ - - cos_2phi * r_inv2 * (U_3 - r * U_r3); - U.d33[jvar] = U_rr * sin2_phi + r_inv2 * cos2_phi * (U_33 + r * U_r) /* U_zz*/ - - sin_2phi * r_inv2 * (U_3 - r * U_r3); - } -} -/* --------------------------------------------------------------------------*/ -void TwoPunctures::Derivatives_AB3(int nvar, int n1, int n2, int n3, derivs v) -{ - int i, j, k, ivar, N, *indx; - double *p, *dp, *d2p, *q, *dq, *r, *dr; - - N = maximum3(n1, n2, n3); - p = dvector(0, N); - dp = dvector(0, N); - d2p = dvector(0, N); - q = dvector(0, N); - dq = dvector(0, N); - r = dvector(0, N); - dr = dvector(0, N); - indx = ivector(0, N); - - for (ivar = 0; ivar < nvar; ivar++) - { - for (k = 0; k < n3; k++) - { /* Calculation of Derivatives w.r.t. A-Dir. */ - for (j = 0; j < n2; j++) - { /* (Chebyshev_Zeros)*/ - for (i = 0; i < n1; i++) - { - indx[i] = Index(ivar, i, j, k, nvar, n1, n2, n3); - p[i] = v.d0[indx[i]]; - } - chebft_Zeros(p, n1, 0); - chder(p, dp, n1); - chder(dp, d2p, n1); - chebft_Zeros(dp, n1, 1); - chebft_Zeros(d2p, n1, 1); - for (i = 0; i < n1; i++) - { - v.d1[indx[i]] = dp[i]; - v.d11[indx[i]] = d2p[i]; - } - } - } - for (k = 0; k < n3; k++) - { /* Calculation of Derivatives w.r.t. B-Dir. */ - for (i = 0; i < n1; i++) - { /* (Chebyshev_Zeros)*/ - for (j = 0; j < n2; j++) - { - indx[j] = Index(ivar, i, j, k, nvar, n1, n2, n3); - p[j] = v.d0[indx[j]]; - q[j] = v.d1[indx[j]]; - } - chebft_Zeros(p, n2, 0); - chebft_Zeros(q, n2, 0); - chder(p, dp, n2); - chder(dp, d2p, n2); - chder(q, dq, n2); - chebft_Zeros(dp, n2, 1); - chebft_Zeros(d2p, n2, 1); - chebft_Zeros(dq, n2, 1); - for (j = 0; j < n2; j++) - { - v.d2[indx[j]] = dp[j]; - v.d22[indx[j]] = d2p[j]; - v.d12[indx[j]] = dq[j]; - } - } - } - for (i = 0; i < n1; i++) - { /* Calculation of Derivatives w.r.t. phi-Dir. (Fourier)*/ - for (j = 0; j < n2; j++) - { - for (k = 0; k < n3; k++) - { - indx[k] = Index(ivar, i, j, k, nvar, n1, n2, n3); - p[k] = v.d0[indx[k]]; - q[k] = v.d1[indx[k]]; - r[k] = v.d2[indx[k]]; - } - fourft(p, n3, 0); - fourder(p, dp, n3); - fourder2(p, d2p, n3); - fourft(dp, n3, 1); - fourft(d2p, n3, 1); - fourft(q, n3, 0); - fourder(q, dq, n3); - fourft(dq, n3, 1); - fourft(r, n3, 0); - fourder(r, dr, n3); - fourft(dr, n3, 1); - for (k = 0; k < n3; k++) - { - v.d3[indx[k]] = dp[k]; - v.d33[indx[k]] = d2p[k]; - v.d13[indx[k]] = dq[k]; - v.d23[indx[k]] = dr[k]; - } - } - } - } - free_dvector(p, 0, N); - free_dvector(dp, 0, N); - free_dvector(d2p, 0, N); - free_dvector(q, 0, N); - free_dvector(dq, 0, N); - free_dvector(r, 0, N); - free_dvector(dr, 0, N); - free_ivector(indx, 0, N); -} -/* --------------------------------------------------------------------------*/ -void TwoPunctures::Newton(int const nvar, int const n1, int const n2, int const n3, - derivs v, double const tol, int const itmax) -{ - int ntotal = n1 * n2 * n3 * nvar, ii, it; - double *F, dmax, normres; - derivs u, dv; - - F = dvector(0, ntotal - 1); - allocate_derivs(&dv, ntotal); - allocate_derivs(&u, ntotal); - - it = 0; - dmax = 1; - while (dmax > tol && it < itmax) - { - if (it == 0) - { - F_of_v(nvar, n1, n2, n3, v, F, u); - dmax = norm_inf(F, ntotal); - } - for (int j = 0; j < ntotal; j++) - dv.d0[j] = 0; - - { - printf("Newton: it=%d \t |F|=%e\n", it, (double)dmax); - printf("bare mass: mp=%g \t mm=%g\n", (double)par_m_plus, (double)par_m_minus); - } - - fflush(stdout); - ii = bicgstab(nvar, n1, n2, n3, v, dv, 100, dmax * 1.e-3, &normres); - - for (int j = 0; j < ntotal; j++) - v.d0[j] -= dv.d0[j]; - F_of_v(nvar, n1, n2, n3, v, F, u); - dmax = norm_inf(F, ntotal); - it += 1; - } - if (itmax == 0) - { - F_of_v(nvar, n1, n2, n3, v, F, u); - dmax = norm_inf(F, ntotal); - } - - printf("Newton: it=%d \t |F|=%e \n", it, (double)dmax); - - fflush(stdout); - - free_dvector(F, 0, ntotal - 1); - free_derivs(&dv, ntotal); - free_derivs(&u, ntotal); -} -#define FAC sin(al) * sin(be) * sin(al) * sin(be) * sin(al) * sin(be) -/* --------------------------------------------------------------------------*/ -void TwoPunctures::F_of_v(int nvar, int n1, int n2, int n3, derivs v, double *F, - derivs u) -{ - /* Calculates the left hand sides of the non-linear equations F_m(v_n)=0*/ - /* and the function u (u.d0[]) as well as its derivatives*/ - /* (u.d1[], u.d2[], u.d3[], u.d11[], u.d12[], u.d13[], u.d22[], u.d23[], u.d33[])*/ - /* at interior points and at the boundaries "+/-"*/ - - int i, j, k, ivar, indx; - double al, be, A, B, X, R, x, r, phi, y, z, Am1, *values; - derivs U; - double *sources; - - sources = (double *)calloc(n1 * n2 * n3, sizeof(double)); - if (0) - { - double *s_x, *s_y, *s_z; - int i3D; - s_x = (double *)calloc(n1 * n2 * n3, sizeof(double)); - s_y = (double *)calloc(n1 * n2 * n3, sizeof(double)); - s_z = (double *)calloc(n1 * n2 * n3, sizeof(double)); - for (i = 0; i < n1; i++) - for (j = 0; j < n2; j++) - for (k = 0; k < n3; k++) - { - i3D = Index(0, i, j, k, 1, n1, n2, n3); - - al = Pih * (2 * i + 1) / n1; - A = -cos(al); - be = Pih * (2 * j + 1) / n2; - B = -cos(be); - phi = 2. * Pi * k / n3; - - Am1 = A - 1; - for (ivar = 0; ivar < nvar; ivar++) - { - indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - U.d0[ivar] = Am1 * v.d0[indx]; /* U*/ - U.d1[ivar] = v.d0[indx] + Am1 * v.d1[indx]; /* U_A*/ - U.d2[ivar] = Am1 * v.d2[indx]; /* U_B*/ - U.d3[ivar] = Am1 * v.d3[indx]; /* U_3*/ - U.d11[ivar] = 2 * v.d1[indx] + Am1 * v.d11[indx]; /* U_AA*/ - U.d12[ivar] = v.d2[indx] + Am1 * v.d12[indx]; /* U_AB*/ - U.d13[ivar] = v.d3[indx] + Am1 * v.d13[indx]; /* U_AB*/ - U.d22[ivar] = Am1 * v.d22[indx]; /* U_BB*/ - U.d23[ivar] = Am1 * v.d23[indx]; /* U_B3*/ - U.d33[ivar] = Am1 * v.d33[indx]; /* U_33*/ - } - /* Calculation of (X,R) and*/ - /* (U_X, U_R, U_3, U_XX, U_XR, U_X3, U_RR, U_R3, U_33)*/ - AB_To_XR(nvar, A, B, &X, &R, U); - /* Calculation of (x,r) and*/ - /* (U, U_x, U_r, U_3, U_xx, U_xr, U_x3, U_rr, U_r3, U_33)*/ - C_To_c(nvar, X, R, &(s_x[i3D]), &r, U); - /* Calculation of (y,z) and*/ - /* (U, U_x, U_y, U_z, U_xx, U_xy, U_xz, U_yy, U_yz, U_zz)*/ - rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[i3D]), &(s_z[i3D]), U); - } - // Set_Rho_ADM(cctkGH, n1*n2*n3, sources, s_x, s_y, s_z); //external fortran code - free(s_z); - free(s_y); - free(s_x); - } - else - for (i = 0; i < n1; i++) - for (j = 0; j < n2; j++) - for (k = 0; k < n3; k++) - sources[Index(0, i, j, k, 1, n1, n2, n3)] = 0.0; - - Derivatives_AB3_MatMul(nvar, n1, n2, n3, v); - double psi, psi2, psi4, psi7, r_plus, r_minus; - FILE *debugfile = NULL; - if (0) - { - debugfile = fopen("res.dat", "w"); - assert(debugfile); - } - #pragma omp parallel for collapse(3) schedule(dynamic,1) \ - private(i, j, k, ivar, indx, al, be, A, B, X, R, x, r, phi, y, z, Am1, \ - psi, psi2, psi4, psi7, r_plus, r_minus) - for (i = 0; i < n1; i++) - { - for (j = 0; j < n2; j++) - { - for (k = 0; k < n3; k++) - { - double l_values[1]; // nvar=1, stack-allocated - derivs l_U; - double l_U_d0[1], l_U_d1[1], l_U_d2[1], l_U_d3[1]; - double l_U_d11[1], l_U_d12[1], l_U_d13[1], l_U_d22[1], l_U_d23[1], l_U_d33[1]; - l_U.d0 = l_U_d0; l_U.d1 = l_U_d1; l_U.d2 = l_U_d2; l_U.d3 = l_U_d3; - l_U.d11 = l_U_d11; l_U.d12 = l_U_d12; l_U.d13 = l_U_d13; - l_U.d22 = l_U_d22; l_U.d23 = l_U_d23; l_U.d33 = l_U_d33; - - al = Pih * (2 * i + 1) / n1; - A = -cos(al); - be = Pih * (2 * j + 1) / n2; - B = -cos(be); - phi = 2. * Pi * k / n3; - - Am1 = A - 1; - for (ivar = 0; ivar < nvar; ivar++) - { - indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - l_U.d0[ivar] = Am1 * v.d0[indx]; - l_U.d1[ivar] = v.d0[indx] + Am1 * v.d1[indx]; - l_U.d2[ivar] = Am1 * v.d2[indx]; - l_U.d3[ivar] = Am1 * v.d3[indx]; - l_U.d11[ivar] = 2 * v.d1[indx] + Am1 * v.d11[indx]; - l_U.d12[ivar] = v.d2[indx] + Am1 * v.d12[indx]; - l_U.d13[ivar] = v.d3[indx] + Am1 * v.d13[indx]; - l_U.d22[ivar] = Am1 * v.d22[indx]; - l_U.d23[ivar] = Am1 * v.d23[indx]; - l_U.d33[ivar] = Am1 * v.d33[indx]; - } - AB_To_XR(nvar, A, B, &X, &R, l_U); - C_To_c(nvar, X, R, &x, &r, l_U); - rx3_To_xyz(nvar, x, r, phi, &y, &z, l_U); - NonLinEquations(sources[Index(0, i, j, k, 1, n1, n2, n3)], - A, B, X, R, x, r, phi, y, z, l_U, l_values); - for (ivar = 0; ivar < nvar; ivar++) - { - indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - F[indx] = l_values[ivar] * sin(al) * sin(be) * sin(al) * sin(be) * sin(al) * sin(be); - u.d0[indx] = l_U.d0[ivar]; - u.d1[indx] = l_U.d1[ivar]; - u.d2[indx] = l_U.d2[ivar]; - u.d3[indx] = l_U.d3[ivar]; - u.d11[indx] = l_U.d11[ivar]; - u.d12[indx] = l_U.d12[ivar]; - u.d13[indx] = l_U.d13[ivar]; - u.d22[indx] = l_U.d22[ivar]; - u.d23[indx] = l_U.d23[ivar]; - u.d33[indx] = l_U.d33[ivar]; - } - } - } - } - if (debugfile) - { - fclose(debugfile); - } - free(sources); -} -/* --------------------------------------------------------------------------*/ -double TwoPunctures::norm_inf(double const *F, int const ntotal) -{ - double dmax = -1; - { - double dmax1 = -1; - for (int j = 0; j < ntotal; j++) - if (fabs(F[j]) > dmax1) - dmax1 = fabs(F[j]); - if (dmax1 > dmax) - dmax = dmax1; - } - return dmax; -} -/* --------------------------------------------------------------------------*/ -int TwoPunctures::bicgstab(int const nvar, int const n1, int const n2, int const n3, - derivs v, derivs dv, int const itmax, double const tol, - double *normres) -{ - int const output = 1; - int ntotal = n1 * n2 * n3 * nvar, ii; - double alpha = 0, beta = 0; - double rho = 0, rho1 = 1, rhotol = 1e-50; - double omega = 0, omegatol = 1e-50; - double *p, *rt, *s, *t, *r, *vv; - double **JFD; - int **cols, *ncols, maxcol = StencilSize * nvar; - double *F; - derivs u, ph, sh; - - F = dvector(0, ntotal - 1); - allocate_derivs(&u, ntotal); - - JFD = dmatrix(0, ntotal - 1, 0, maxcol - 1); - cols = imatrix(0, ntotal - 1, 0, maxcol - 1); - ncols = ivector(0, ntotal - 1); - - F_of_v(nvar, n1, n2, n3, v, F, u); - SetMatrix_JFD(nvar, n1, n2, n3, u, ncols, cols, JFD); - - /* temporary storage */ - r = dvector(0, ntotal - 1); - p = dvector(0, ntotal - 1); - allocate_derivs(&ph, ntotal); - /* ph = dvector(0, ntotal-1);*/ - rt = dvector(0, ntotal - 1); - s = dvector(0, ntotal - 1); - allocate_derivs(&sh, ntotal); - /* sh = dvector(0, ntotal-1);*/ - t = dvector(0, ntotal - 1); - vv = dvector(0, ntotal - 1); - - /* check */ - if (output == 1) - { - printf("bicgstab: itmax %d, tol %e\n", itmax, (double)tol); - fflush(stdout); - } - - /* compute initial residual rt = r = F - J*dv */ - J_times_dv(nvar, n1, n2, n3, dv, r, u); - for (int j = 0; j < ntotal; j++) - rt[j] = r[j] = F[j] - r[j]; - - *normres = norm2(r, ntotal); - if (output == 1) - { - printf("bicgstab: %5d %10.3e\n", 0, (double)*normres); - fflush(stdout); - } - - if (*normres <= tol) - return 0; - - /* cgs iteration */ - for (ii = 0; ii < itmax; ii++) - { - rho = scalarproduct(rt, r, ntotal); - if (fabs(rho) < rhotol) - break; - - /* compute direction vector p */ - if (ii == 0) - { - for (int j = 0; j < ntotal; j++) - p[j] = r[j]; - } - else - { - beta = (rho / rho1) * (alpha / omega); - for (int j = 0; j < ntotal; j++) - p[j] = r[j] + beta * (p[j] - omega * vv[j]); - } - - /* compute direction adjusting vector ph and scalar alpha */ - for (int j = 0; j < ntotal; j++) - ph.d0[j] = 0; - for (int j = 0; j < NRELAX; j++) /* solves JFD*ph = p by relaxation*/ - relax_omp(ph.d0, nvar, n1, n2, n3, p, ncols, cols, JFD); - - J_times_dv(nvar, n1, n2, n3, ph, vv, u); /* vv=J*ph*/ - alpha = rho / scalarproduct(rt, vv, ntotal); - for (int j = 0; j < ntotal; j++) - s[j] = r[j] - alpha * vv[j]; - - /* early check of tolerance */ - *normres = norm2(s, ntotal); - if (*normres <= tol) - { - for (int j = 0; j < ntotal; j++) - dv.d0[j] += alpha * ph.d0[j]; - if (output == 1) - { - printf("bicgstab: %5d %10.3e %10.3e %10.3e %10.3e\n", - ii + 1, (double)*normres, (double)alpha, (double)beta, (double)omega); - fflush(stdout); - } - break; - } - - /* compute stabilizer vector sh and scalar omega */ - for (int j = 0; j < ntotal; j++) - sh.d0[j] = 0; - for (int j = 0; j < NRELAX; j++) /* solves JFD*sh = s by relaxation*/ - relax_omp(sh.d0, nvar, n1, n2, n3, s, ncols, cols, JFD); - - J_times_dv(nvar, n1, n2, n3, sh, t, u); /* t=J*sh*/ - omega = scalarproduct(t, s, ntotal) / scalarproduct(t, t, ntotal); - - /* compute new solution approximation */ - for (int j = 0; j < ntotal; j++) - { - dv.d0[j] += alpha * ph.d0[j] + omega * sh.d0[j]; - r[j] = s[j] - omega * t[j]; - } - /* are we done? */ - *normres = norm2(r, ntotal); - if (output == 1) - { - printf("bicgstab: %5d %10.3e %10.3e %10.3e %10.3e\n", - ii + 1, (double)*normres, (double)alpha, (double)beta, (double)omega); - fflush(stdout); - } - if (*normres <= tol) - break; - rho1 = rho; - if (fabs(omega) < omegatol) - break; - } - - /* free temporary storage */ - free_dvector(r, 0, ntotal - 1); - free_dvector(p, 0, ntotal - 1); - /* free_dvector(ph, 0, ntotal-1);*/ - free_derivs(&ph, ntotal); - free_dvector(rt, 0, ntotal - 1); - free_dvector(s, 0, ntotal - 1); - /* free_dvector(sh, 0, ntotal-1);*/ - free_derivs(&sh, ntotal); - free_dvector(t, 0, ntotal - 1); - free_dvector(vv, 0, ntotal - 1); - - free_dvector(F, 0, ntotal - 1); - free_derivs(&u, ntotal); - - free_dmatrix(JFD, 0, ntotal - 1, 0, maxcol - 1); - free_imatrix(cols, 0, ntotal - 1, 0, maxcol - 1); - free_ivector(ncols, 0, ntotal - 1); - - /* iteration failed */ - if (ii > itmax) - return -1; - - /* breakdown */ - if (fabs(rho) < rhotol) - return -10; - if (fabs(omega) < omegatol) - return -11; - - /* success! */ - return ii + 1; -} -/* --------------------------------------------------------------------------*/ -void TwoPunctures::allocate_derivs(derivs *v, int n) -{ - int m = n - 1; - (*v).d0 = dvector(0, m); - (*v).d1 = dvector(0, m); - (*v).d2 = dvector(0, m); - (*v).d3 = dvector(0, m); - (*v).d11 = dvector(0, m); - (*v).d12 = dvector(0, m); - (*v).d13 = dvector(0, m); - (*v).d22 = dvector(0, m); - (*v).d23 = dvector(0, m); - (*v).d33 = dvector(0, m); -} - -/* --------------------------------------------------------------------------*/ -void TwoPunctures::free_derivs(derivs *v, int n) -{ - int m = n - 1; - free_dvector((*v).d0, 0, m); - free_dvector((*v).d1, 0, m); - free_dvector((*v).d2, 0, m); - free_dvector((*v).d3, 0, m); - free_dvector((*v).d11, 0, m); - free_dvector((*v).d12, 0, m); - free_dvector((*v).d13, 0, m); - free_dvector((*v).d22, 0, m); - free_dvector((*v).d23, 0, m); - free_dvector((*v).d33, 0, m); -} -/* --------------------------------------------------------------------------*/ -int TwoPunctures::Index(int ivar, int i, int j, int k, int nvar, int n1, int n2, int n3) -{ - int i1 = i, j1 = j, k1 = k; - - if (i1 < 0) - i1 = -(i1 + 1); - if (i1 >= n1) - i1 = 2 * n1 - (i1 + 1); - - if (j1 < 0) - j1 = -(j1 + 1); - if (j1 >= n2) - j1 = 2 * n2 - (j1 + 1); - - if (k1 < 0) - k1 = k1 + n3; - if (k1 >= n3) - k1 = k1 - n3; - - return ivar + nvar * (i1 + n1 * (j1 + n2 * k1)); -} -/*-----------------------------------------------------------*/ -/******** Nonlinear Equations ***********/ -/*-----------------------------------------------------------*/ -void TwoPunctures::NonLinEquations(double rho_adm, - double A, double B, double X, double R, - double x, double r, double phi, - double y, double z, derivs U, double *values) -{ - double r_plus, r_minus, psi, psi2, psi4, psi7; - double mu; - - r_plus = sqrt((x - par_b) * (x - par_b) + y * y + z * z); - r_minus = sqrt((x + par_b) * (x + par_b) + y * y + z * z); - - psi = 1. + 0.5 * par_m_plus / r_plus + 0.5 * par_m_minus / r_minus + U.d0[0]; - psi2 = psi * psi; - psi4 = psi2 * psi2; - psi7 = psi * psi2 * psi4; - - values[0] = U.d11[0] + U.d22[0] + U.d33[0] + 0.125 * BY_KKofxyz(x, y, z) / psi7 + 2.0 * Pi / psi2 / psi * rho_adm; -} -double TwoPunctures::BY_KKofxyz(double x, double y, double z) -{ - int i, j; - double r_plus, r2_plus, r3_plus, r_minus, r2_minus, r3_minus, np_Pp, nm_Pm, - Aij, AijAij, n_plus[3], n_minus[3], np_Sp[3], nm_Sm[3]; - - r2_plus = (x - par_b) * (x - par_b) + y * y + z * z; - r2_minus = (x + par_b) * (x + par_b) + y * y + z * z; - r_plus = sqrt(r2_plus); - r_minus = sqrt(r2_minus); - r3_plus = r_plus * r2_plus; - r3_minus = r_minus * r2_minus; - - n_plus[0] = (x - par_b) / r_plus; - n_minus[0] = (x + par_b) / r_minus; - n_plus[1] = y / r_plus; - n_minus[1] = y / r_minus; - n_plus[2] = z / r_plus; - n_minus[2] = z / r_minus; - - /* dot product: np_Pp = (n_+).(P_+); nm_Pm = (n_-).(P_-) */ - np_Pp = 0; - nm_Pm = 0; - for (i = 0; i < 3; i++) - { - np_Pp += n_plus[i] * par_P_plus[i]; - nm_Pm += n_minus[i] * par_P_minus[i]; - } - /* cross product: np_Sp[i] = [(n_+) x (S_+)]_i; nm_Sm[i] = [(n_-) x (S_-)]_i*/ - np_Sp[0] = n_plus[1] * par_S_plus[2] - n_plus[2] * par_S_plus[1]; - np_Sp[1] = n_plus[2] * par_S_plus[0] - n_plus[0] * par_S_plus[2]; - np_Sp[2] = n_plus[0] * par_S_plus[1] - n_plus[1] * par_S_plus[0]; - nm_Sm[0] = n_minus[1] * par_S_minus[2] - n_minus[2] * par_S_minus[1]; - nm_Sm[1] = n_minus[2] * par_S_minus[0] - n_minus[0] * par_S_minus[2]; - nm_Sm[2] = n_minus[0] * par_S_minus[1] - n_minus[1] * par_S_minus[0]; - AijAij = 0; - for (i = 0; i < 3; i++) - { - for (j = 0; j < 3; j++) - { /* Bowen-York-Curvature :*/ - Aij = - +1.5 * (par_P_plus[i] * n_plus[j] + par_P_plus[j] * n_plus[i] + np_Pp * n_plus[i] * n_plus[j]) / r2_plus + 1.5 * (par_P_minus[i] * n_minus[j] + par_P_minus[j] * n_minus[i] + nm_Pm * n_minus[i] * n_minus[j]) / r2_minus - 3.0 * (np_Sp[i] * n_plus[j] + np_Sp[j] * n_plus[i]) / r3_plus - 3.0 * (nm_Sm[i] * n_minus[j] + nm_Sm[j] * n_minus[i]) / r3_minus; - if (i == j) - Aij -= +1.5 * (np_Pp / r2_plus + nm_Pm / r2_minus); - AijAij += Aij * Aij; - } - } - - return AijAij; -} -void TwoPunctures::SetMatrix_JFD(int nvar, int n1, int n2, int n3, derivs u, - int *ncols, int **cols, double **Matrix) -{ - int column, row, mcol; - int i, i1, i_0, i_1, j, j1, j_0, j_1, k, k1, k_0, k_1, N1, N2, N3, - ivar, ivar1, ntotal = nvar * n1 * n2 * n3; - double *values; - derivs dv; - - values = dvector(0, nvar - 1); - allocate_derivs(&dv, ntotal); - - N1 = n1 - 1; - N2 = n2 - 1; - N3 = n3 - 1; - - for (i = 0; i < n1; i++) - { - for (j = 0; j < n2; j++) - { - for (k = 0; k < n3; k++) - { - for (ivar = 0; ivar < nvar; ivar++) - { - row = Index(ivar, i, j, k, nvar, n1, n2, n3); - ncols[row] = 0; - dv.d0[row] = 0; - } - } - } - } - for (i = 0; i < n1; i++) - { - for (j = 0; j < n2; j++) - { - for (k = 0; k < n3; k++) - { - for (ivar = 0; ivar < nvar; ivar++) - { - column = Index(ivar, i, j, k, nvar, n1, n2, n3); - dv.d0[column] = 1; - - i_0 = maximum2(0, i - 1); - i_1 = minimum2(N1, i + 1); - j_0 = maximum2(0, j - 1); - j_1 = minimum2(N2, j + 1); - k_0 = k - 1; - k_1 = k + 1; - /* i_0 = 0; - i_1 = N1; - j_0 = 0; - j_1 = N2; - k_0 = 0; - k_1 = N3;*/ - - for (i1 = i_0; i1 <= i_1; i1++) - { - for (j1 = j_0; j1 <= j_1; j1++) - { - for (k1 = k_0; k1 <= k_1; k1++) - { - JFD_times_dv(i1, j1, k1, nvar, n1, n2, n3, - dv, u, values); - for (ivar1 = 0; ivar1 < nvar; ivar1++) - { - if (values[ivar1] != 0) - { - row = Index(ivar1, i1, j1, k1, nvar, n1, n2, n3); - mcol = ncols[row]; - cols[row][mcol] = column; - Matrix[row][mcol] = values[ivar1]; - ncols[row] += 1; - } - } - } - } - } - - dv.d0[column] = 0; - } - } - } - } - free_derivs(&dv, ntotal); - free_dvector(values, 0, nvar - 1); -} -/* --------------------------------------------------------------------------*/ -void TwoPunctures::J_times_dv(int nvar, int n1, int n2, int n3, derivs dv, double *Jdv, derivs u) -{ /* Calculates the left hand sides of the non-linear equations F_m(v_n)=0*/ - /* and the function u (u.d0[]) as well as its derivatives*/ - /* (u.d1[], u.d2[], u.d3[], u.d11[], u.d12[], u.d13[], u.d22[], u.d23[], u.d33[])*/ - /* at interior points and at the boundaries "+/-"*/ - int i, j, k, ivar, indx; - double al, be, A, B, X, R, x, r, phi, y, z, Am1; - - Derivatives_AB3_MatMul(nvar, n1, n2, n3, dv); - - #pragma omp parallel for schedule(dynamic,1) \ - private(j, k, ivar, indx, al, be, A, B, X, R, x, r, phi, y, z, Am1) - for (i = 0; i < n1; i++) - { - // Thread-local derivs on stack (nvar=1) - double l_val[1]; - double l_dU_d0[1], l_dU_d1[1], l_dU_d2[1], l_dU_d3[1]; - double l_dU_d11[1], l_dU_d12[1], l_dU_d13[1], l_dU_d22[1], l_dU_d23[1], l_dU_d33[1]; - double l_U_d0[1], l_U_d1[1], l_U_d2[1], l_U_d3[1]; - double l_U_d11[1], l_U_d12[1], l_U_d13[1], l_U_d22[1], l_U_d23[1], l_U_d33[1]; - derivs l_dU, l_U; - l_dU.d0=l_dU_d0; l_dU.d1=l_dU_d1; l_dU.d2=l_dU_d2; l_dU.d3=l_dU_d3; - l_dU.d11=l_dU_d11; l_dU.d12=l_dU_d12; l_dU.d13=l_dU_d13; - l_dU.d22=l_dU_d22; l_dU.d23=l_dU_d23; l_dU.d33=l_dU_d33; - l_U.d0=l_U_d0; l_U.d1=l_U_d1; l_U.d2=l_U_d2; l_U.d3=l_U_d3; - l_U.d11=l_U_d11; l_U.d12=l_U_d12; l_U.d13=l_U_d13; - l_U.d22=l_U_d22; l_U.d23=l_U_d23; l_U.d33=l_U_d33; - - for (j = 0; j < n2; j++) - { - for (k = 0; k < n3; k++) - { - al = Pih * (2 * i + 1) / n1; - A = -cos(al); - be = Pih * (2 * j + 1) / n2; - B = -cos(be); - phi = 2. * Pi * k / n3; - - Am1 = A - 1; - for (ivar = 0; ivar < nvar; ivar++) - { - indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - l_dU.d0[ivar] = Am1 * dv.d0[indx]; - l_dU.d1[ivar] = dv.d0[indx] + Am1 * dv.d1[indx]; - l_dU.d2[ivar] = Am1 * dv.d2[indx]; - l_dU.d3[ivar] = Am1 * dv.d3[indx]; - l_dU.d11[ivar] = 2 * dv.d1[indx] + Am1 * dv.d11[indx]; - l_dU.d12[ivar] = dv.d2[indx] + Am1 * dv.d12[indx]; - l_dU.d13[ivar] = dv.d3[indx] + Am1 * dv.d13[indx]; - l_dU.d22[ivar] = Am1 * dv.d22[indx]; - l_dU.d23[ivar] = Am1 * dv.d23[indx]; - l_dU.d33[ivar] = Am1 * dv.d33[indx]; - l_U.d0[ivar] = u.d0[indx]; - l_U.d1[ivar] = u.d1[indx]; - l_U.d2[ivar] = u.d2[indx]; - l_U.d3[ivar] = u.d3[indx]; - l_U.d11[ivar] = u.d11[indx]; - l_U.d12[ivar] = u.d12[indx]; - l_U.d13[ivar] = u.d13[indx]; - l_U.d22[ivar] = u.d22[indx]; - l_U.d23[ivar] = u.d23[indx]; - l_U.d33[ivar] = u.d33[indx]; - } - AB_To_XR(nvar, A, B, &X, &R, l_dU); - C_To_c(nvar, X, R, &x, &r, l_dU); - rx3_To_xyz(nvar, x, r, phi, &y, &z, l_dU); - LinEquations(A, B, X, R, x, r, phi, y, z, l_dU, l_U, l_val); - for (ivar = 0; ivar < nvar; ivar++) - { - indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - Jdv[indx] = l_val[ivar] * sin(al) * sin(be) * sin(al) * sin(be) * sin(al) * sin(be); - } - } - } - } -} -/* --------------------------------------------------------------------------*/ -/* -------------------------------------------------------------------------- - * relax_omp: OpenMP-parallelized replacement for relax() - * - * Parallelism analysis: - * - The red-black ordering within each phi-plane means that - * same-parity lines in the i-direction are INDEPENDENT of each other - * (they only couple through the j-direction which is solved internally). - * - Similarly, same-parity lines in the j-direction are independent. - * - Different phi-planes (k) with same parity are independent. - * - * Strategy: - * - Parallelize the i-loop within each (k, parity) group for LineRelax_be - * - Parallelize the j-loop within each (k, parity) group for LineRelax_al - * - Each thread uses its own pre-allocated workspace (tid-indexed) - * --------------------------------------------------------------------------*/ -void TwoPunctures::relax_omp(double *dv, int const nvar, int const n1, int const n2, int const n3, - double const *rhs, int const *ncols, int **cols, double **JFD) -{ - int n; - - // 偶数k平面 - for (n = 0; n < N_PlaneRelax; n++) - { - // 偶数i线，所有偶数k —— 不同k平面完全独立 - int n_even_k = (n3 + 1) / 2; // 偶数k的数量 - int n_even_i = (n1 - 2 + 1) / 2; // i=2,4,...的数量 - int total_tasks = n_even_k * n_even_i; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_even_i; - int ii = task % n_even_i; - int k = ki * 2; - int i = 2 + ii * 2; - LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 奇数i线，所有偶数k - int n_odd_i = n1 / 2; // i=1,3,...的数量 - total_tasks = n_even_k * n_odd_i; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_odd_i; - int ii = task % n_odd_i; - int k = ki * 2; - int i = 1 + ii * 2; - LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 奇数j线，所有偶数k - int n_odd_j = (n2 - 1 + 1) / 2; - total_tasks = n_even_k * n_odd_j; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_odd_j; - int ji = task % n_odd_j; - int k = ki * 2; - int j = 1 + ji * 2; - LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 偶数j线，所有偶数k - int n_even_j = (n2 + 1) / 2; - total_tasks = n_even_k * n_even_j; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_even_j; - int ji = task % n_even_j; - int k = ki * 2; - int j = ji * 2; - LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 奇数k平面 — 同样的四步 - int n_odd_k = n3 / 2; - - // 偶数i线，所有奇数k - n_even_i = (n1 + 1) / 2; // i=0,2,... - total_tasks = n_odd_k * n_even_i; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_even_i; - int ii = task % n_even_i; - int k = 1 + ki * 2; - int i = ii * 2; - LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 奇数i线，所有奇数k - total_tasks = n_odd_k * n_odd_i; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_odd_i; - int ii = task % n_odd_i; - int k = 1 + ki * 2; - int i = 1 + ii * 2; - LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 奇数j线，所有奇数k - total_tasks = n_odd_k * n_odd_j; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_odd_j; - int ji = task % n_odd_j; - int k = 1 + ki * 2; - int j = 1 + ji * 2; - LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - - // 偶数j线，所有奇数k - total_tasks = n_odd_k * n_even_j; - - #pragma omp parallel for schedule(static) - for (int task = 0; task < total_tasks; task++) { - int tid = omp_get_thread_num(); - int ki = task / n_even_j; - int ji = task % n_even_j; - int k = 1 + ki * 2; - int j = ji * 2; - LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); - } - } -} -/* --------------------------------------------------------------------------*/ -void TwoPunctures::LineRelax_be_omp(double *dv, - int const i, int const k, int const nvar, - int const n1, int const n2, int const n3, - double const *rhs, int const *ncols, int **cols, - double **JFD, int tid) -{ - int j, m, Ic, Ip, Im, col, ivar; - - // Use pre-allocated per-thread workspace instead of new/delete - double *diag = ws_diag_be[tid]; - double *e = ws_e_be[tid]; - double *f = ws_f_be[tid]; - double *b = ws_b_be[tid]; - double *x = ws_x_be[tid]; - - for (ivar = 0; ivar < nvar; ivar++) - { - for (j = 0; j < n2 - 1; j++) - { - diag[j] = e[j] = f[j] = 0; - } - diag[n2 - 1] = 0; - - // gsl_vector_set_zero(diag); - // gsl_vector_set_zero(e); - // gsl_vector_set_zero(f); - for (j = 0; j < n2; j++) - { - Ip = Index(ivar, i, j + 1, k, nvar, n1, n2, n3); - Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); - Im = Index(ivar, i, j - 1, k, nvar, n1, n2, n3); - b[j] = rhs[Ic]; - // gsl_vector_set(b,j,rhs[Ic]); - for (m = 0; m < ncols[Ic]; m++) - { - col = cols[Ic][m]; - if (col != Ip && col != Ic && col != Im) - b[j] -= JFD[Ic][m] * dv[col]; - // *gsl_vector_ptr(b, j) -= JFD[Ic][m] * dv[col]; - else - { - if (col == Im && j > 0) - f[j - 1] = JFD[Ic][m]; - // gsl_vector_set(f,j-1,JFD[Ic][m]); - if (col == Ic) - diag[j] = JFD[Ic][m]; - // gsl_vector_set(diag,j,JFD[Ic][m]); - if (col == Ip && j < n2 - 1) - e[j] = JFD[Ic][m]; - // gsl_vector_set(e,j,JFD[Ic][m]); - } - } - } - ThomasAlgorithm_ws(n2, f, diag, e, x, b, - ws_l_be[tid], ws_u_be[tid], ws_d_be[tid], ws_y_be[tid]); - for (j = 0; j < n2; j++) - { - Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); - dv[Ic] = x[j]; - // dv[Ic] = gsl_vector_get(x, j); - } - } - // No delete — workspace is persistent -} -/* --------------------------------------------------------------------------*/ -void TwoPunctures::JFD_times_dv(int i, int j, int k, int nvar, int n1, int n2, - int n3, derivs dv, derivs u, double *values) -{ /* Calculates rows of the vector 'J(FD)*dv'.*/ - /* First row to be calculated: row = Index(0, i, j, k; nvar, n1, n2, n3)*/ - /* Last row to be calculated: row = Index(nvar-1, i, j, k; nvar, n1, n2, n3)*/ - /* These rows are stored in the vector JFDdv[0] ... JFDdv[nvar-1].*/ - int ivar, indx; - double al, be, A, B, X, R, x, r, phi, y, z, Am1; - double sin_al, sin_al_i1, sin_al_i2, sin_al_i3, cos_al; - double sin_be, sin_be_i1, sin_be_i2, sin_be_i3, cos_be; - double dV0, dV1, dV2, dV3, dV11, dV12, dV13, dV22, dV23, dV33, - ha, ga, ga2, hb, gb, gb2, hp, gp, gp2, gagb, gagp, gbgp; - - // Stack-allocated derivs (nvar=1) — no malloc/free! - double dU_d0[1], dU_d1[1], dU_d2[1], dU_d3[1]; - double dU_d11[1], dU_d12[1], dU_d13[1], dU_d22[1], dU_d23[1], dU_d33[1]; - double U_d0[1], U_d1[1], U_d2[1], U_d3[1]; - double U_d11[1], U_d12[1], U_d13[1], U_d22[1], U_d23[1], U_d33[1]; - derivs dU, U; - dU.d0=dU_d0; dU.d1=dU_d1; dU.d2=dU_d2; dU.d3=dU_d3; - dU.d11=dU_d11; dU.d12=dU_d12; dU.d13=dU_d13; - dU.d22=dU_d22; dU.d23=dU_d23; dU.d33=dU_d33; - U.d0=U_d0; U.d1=U_d1; U.d2=U_d2; U.d3=U_d3; - U.d11=U_d11; U.d12=U_d12; U.d13=U_d13; - U.d22=U_d22; U.d23=U_d23; U.d33=U_d33; - - if (k < 0) - k = k + n3; - if (k >= n3) - k = k - n3; - - ha = Pi / n1; /* ha: Stepsize with respect to (al)*/ - al = ha * (i + 0.5); - A = -cos(al); - ga = 1 / ha; - ga2 = ga * ga; - - hb = Pi / n2; /* hb: Stepsize with respect to (be)*/ - be = hb * (j + 0.5); - B = -cos(be); - gb = 1 / hb; - gb2 = gb * gb; - gagb = ga * gb; - - hp = 2 * Pi / n3; /* hp: Stepsize with respect to (phi)*/ - phi = hp * j; - gp = 1 / hp; - gp2 = gp * gp; - gagp = ga * gp; - gbgp = gb * gp; - - sin_al = sin(al); - sin_be = sin(be); - sin_al_i1 = 1 / sin_al; - sin_be_i1 = 1 / sin_be; - sin_al_i2 = sin_al_i1 * sin_al_i1; - sin_be_i2 = sin_be_i1 * sin_be_i1; - sin_al_i3 = sin_al_i1 * sin_al_i2; - sin_be_i3 = sin_be_i1 * sin_be_i2; - cos_al = -A; - cos_be = -B; - - Am1 = A - 1; - for (ivar = 0; ivar < nvar; ivar++) - { - int iccc = Index(ivar, i, j, k, nvar, n1, n2, n3), - ipcc = Index(ivar, i + 1, j, k, nvar, n1, n2, n3), - imcc = Index(ivar, i - 1, j, k, nvar, n1, n2, n3), - icpc = Index(ivar, i, j + 1, k, nvar, n1, n2, n3), - icmc = Index(ivar, i, j - 1, k, nvar, n1, n2, n3), - iccp = Index(ivar, i, j, k + 1, nvar, n1, n2, n3), - iccm = Index(ivar, i, j, k - 1, nvar, n1, n2, n3), - icpp = Index(ivar, i, j + 1, k + 1, nvar, n1, n2, n3), - icmp = Index(ivar, i, j - 1, k + 1, nvar, n1, n2, n3), - icpm = Index(ivar, i, j + 1, k - 1, nvar, n1, n2, n3), - icmm = Index(ivar, i, j - 1, k - 1, nvar, n1, n2, n3), - ipcp = Index(ivar, i + 1, j, k + 1, nvar, n1, n2, n3), - imcp = Index(ivar, i - 1, j, k + 1, nvar, n1, n2, n3), - ipcm = Index(ivar, i + 1, j, k - 1, nvar, n1, n2, n3), - imcm = Index(ivar, i - 1, j, k - 1, nvar, n1, n2, n3), - ippc = Index(ivar, i + 1, j + 1, k, nvar, n1, n2, n3), - impc = Index(ivar, i - 1, j + 1, k, nvar, n1, n2, n3), - ipmc = Index(ivar, i + 1, j - 1, k, nvar, n1, n2, n3), - immc = Index(ivar, i - 1, j - 1, k, nvar, n1, n2, n3); - /* Derivatives of (dv) w.r.t. (al,be,phi):*/ - dV0 = dv.d0[iccc]; - dV1 = 0.5 * ga * (dv.d0[ipcc] - dv.d0[imcc]); - dV2 = 0.5 * gb * (dv.d0[icpc] - dv.d0[icmc]); - dV3 = 0.5 * gp * (dv.d0[iccp] - dv.d0[iccm]); - dV11 = ga2 * (dv.d0[ipcc] + dv.d0[imcc] - 2 * dv.d0[iccc]); - dV22 = gb2 * (dv.d0[icpc] + dv.d0[icmc] - 2 * dv.d0[iccc]); - dV33 = gp2 * (dv.d0[iccp] + dv.d0[iccm] - 2 * dv.d0[iccc]); - dV12 = 0.25 * gagb * (dv.d0[ippc] - dv.d0[ipmc] + dv.d0[immc] - dv.d0[impc]); - dV13 = 0.25 * gagp * (dv.d0[ipcp] - dv.d0[imcp] + dv.d0[imcm] - dv.d0[ipcm]); - dV23 = 0.25 * gbgp * (dv.d0[icpp] - dv.d0[icpm] + dv.d0[icmm] - dv.d0[icmp]); - /* Derivatives of (dv) w.r.t. (A,B,phi):*/ - dV11 = sin_al_i3 * (sin_al * dV11 - cos_al * dV1); - dV12 = sin_al_i1 * sin_be_i1 * dV12; - dV13 = sin_al_i1 * dV13; - dV22 = sin_be_i3 * (sin_be * dV22 - cos_be * dV2); - dV23 = sin_be_i1 * dV23; - dV1 = sin_al_i1 * dV1; - dV2 = sin_be_i1 * dV2; - /* Derivatives of (dU) w.r.t. (A,B,phi):*/ - dU.d0[ivar] = Am1 * dV0; - dU.d1[ivar] = dV0 + Am1 * dV1; - dU.d2[ivar] = Am1 * dV2; - dU.d3[ivar] = Am1 * dV3; - dU.d11[ivar] = 2 * dV1 + Am1 * dV11; - dU.d12[ivar] = dV2 + Am1 * dV12; - dU.d13[ivar] = dV3 + Am1 * dV13; - dU.d22[ivar] = Am1 * dV22; - dU.d23[ivar] = Am1 * dV23; - dU.d33[ivar] = Am1 * dV33; - - indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - U.d0[ivar] = u.d0[indx]; /* U */ - U.d1[ivar] = u.d1[indx]; /* U_x*/ - U.d2[ivar] = u.d2[indx]; /* U_y*/ - U.d3[ivar] = u.d3[indx]; /* U_z*/ - U.d11[ivar] = u.d11[indx]; /* U_xx*/ - U.d12[ivar] = u.d12[indx]; /* U_xy*/ - U.d13[ivar] = u.d13[indx]; /* U_xz*/ - U.d22[ivar] = u.d22[indx]; /* U_yy*/ - U.d23[ivar] = u.d23[indx]; /* U_yz*/ - U.d33[ivar] = u.d33[indx]; /* U_zz*/ - } - /* Calculation of (X,R) and*/ - /* (dU_X, dU_R, dU_3, dU_XX, dU_XR, dU_X3, dU_RR, dU_R3, dU_33)*/ - AB_To_XR(nvar, A, B, &X, &R, dU); - /* Calculation of (x,r) and*/ - /* (dU, dU_x, dU_r, dU_3, dU_xx, dU_xr, dU_x3, dU_rr, dU_r3, dU_33)*/ - C_To_c(nvar, X, R, &x, &r, dU); - /* Calculation of (y,z) and*/ - /* (dU, dU_x, dU_y, dU_z, dU_xx, dU_xy, dU_xz, dU_yy, dU_yz, dU_zz)*/ - rx3_To_xyz(nvar, x, r, phi, &y, &z, dU); - LinEquations(A, B, X, R, x, r, phi, y, z, dU, U, values); - - double FAC_val = sin_al * sin_be * sin_al * sin_be * sin_al * sin_be; - for (ivar = 0; ivar < nvar; ivar++) - values[ivar] *= FAC_val; - - // No free_derivs needed — everything is on the stack -} -#undef FAC -/*-----------------------------------------------------------*/ -/******** Linear Equations ***********/ -/*-----------------------------------------------------------*/ -void TwoPunctures::LinEquations(double A, double B, double X, double R, - double x, double r, double phi, - double y, double z, derivs dU, derivs U, double *values) -{ - double r_plus, r_minus, psi, psi2, psi4, psi8; - - r_plus = sqrt((x - par_b) * (x - par_b) + y * y + z * z); - r_minus = sqrt((x + par_b) * (x + par_b) + y * y + z * z); - - psi = - 1. + 0.5 * par_m_plus / r_plus + 0.5 * par_m_minus / r_minus + U.d0[0]; - psi2 = psi * psi; - psi4 = psi2 * psi2; - psi8 = psi4 * psi4; - - values[0] = dU.d11[0] + dU.d22[0] + dU.d33[0] - 0.875 * BY_KKofxyz(x, y, z) / psi8 * dU.d0[0]; -} -/* -------------------------------------------------------------------------*/ -void TwoPunctures::LineRelax_al_omp(double *dv, - int const j, int const k, int const nvar, - int const n1, int const n2, int const n3, - double const *rhs, int const *ncols, - int **cols, double **JFD, int tid) -{ - int i, m, Ic, Ip, Im, col, ivar; - - double *diag = ws_diag_al[tid]; - double *e = ws_e_al[tid]; - double *f = ws_f_al[tid]; - double *b = ws_b_al[tid]; - double *x = ws_x_al[tid]; - - for (ivar = 0; ivar < nvar; ivar++) - { - for (i = 0; i < n1 - 1; i++) - { - diag[i] = e[i] = f[i] = 0; - } - diag[n1 - 1] = 0; - - // gsl_vector_set_zero(diag); - // gsl_vector_set_zero(e); - // gsl_vector_set_zero(f); - for (i = 0; i < n1; i++) - { - Ip = Index(ivar, i + 1, j, k, nvar, n1, n2, n3); - Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); - Im = Index(ivar, i - 1, j, k, nvar, n1, n2, n3); - b[i] = rhs[Ic]; - // gsl_vector_set(b,i,rhs[Ic]); - for (m = 0; m < ncols[Ic]; m++) - { - col = cols[Ic][m]; - if (col != Ip && col != Ic && col != Im) - b[i] -= JFD[Ic][m] * dv[col]; - // *gsl_vector_ptr(b, i) -= JFD[Ic][m] * dv[col]; - else - { - if (col == Im && i > 0) - f[i - 1] = JFD[Ic][m]; - // gsl_vector_set(f,i-1,JFD[Ic][m]); - if (col == Ic) - diag[i] = JFD[Ic][m]; - // gsl_vector_set(diag,i,JFD[Ic][m]); - if (col == Ip && i < n1 - 1) - e[i] = JFD[Ic][m]; - // gsl_vector_set(e,i,JFD[Ic][m]); - } - } - } - ThomasAlgorithm_ws(n1, f, diag, e, x, b, - ws_l_al[tid], ws_u_al[tid], ws_d_al[tid], ws_y_al[tid]); - for (i = 0; i < n1; i++) - { - Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); - dv[Ic] = x[i]; - // dv[Ic] = gsl_vector_get(x, i); - } - } -} -/* -------------------------------------------------------------------------*/ -// a[N], b[N-1], c[N-1], x[N], q[N] -// A x = q -// A = ( a_0 c_0 0 0 ) -// ( b_0 a_1 c_1 0 ) -// ( 0 b_1 a_2 c_2 ) -// ( 0 0 b_2 a_3 ) -//"Parallel Scientific Computing in C++ and MPI" P361 -void TwoPunctures::ThomasAlgorithm(int N, double *b, double *a, double *c, double *x, double *q) -{ - int i; - double *l, *u, *d, *y; - l = new double[N - 1]; - u = new double[N - 1]; - d = new double[N]; - y = new double[N]; - - /* LU Decomposition */ - d[0] = a[0]; - u[0] = c[0]; - - for (i = 0; i < N - 2; i++) - { - l[i] = b[i] / d[i]; - d[i + 1] = a[i + 1] - l[i] * u[i]; - u[i + 1] = c[i + 1]; - } - - l[N - 2] = b[N - 2] / d[N - 2]; - d[N - 1] = a[N - 1] - l[N - 2] * u[N - 2]; - - /* Forward Substitution [L][y] = [q] */ - y[0] = q[0]; - for (i = 1; i < N; i++) - y[i] = q[i] - l[i - 1] * y[i - 1]; - - /* Backward Substitution [U][x] = [y] */ - x[N - 1] = y[N - 1] / d[N - 1]; - - for (i = N - 2; i >= 0; i--) - x[i] = (y[i] - u[i] * x[i + 1]) / d[i]; - - delete[] l; - delete[] u; - delete[] d; - delete[] y; - - return; -} - -// ThomasAlgorithm with pre-allocated workspace (no new/delete) -// l[N-1], u_ws[N-1], d[N], y[N] are caller-provided workspace -void TwoPunctures::ThomasAlgorithm_ws(int N, double *b, double *a, double *c, - double *x, double *q, - double *l, double *u_ws, double *d, double *y) -{ - /* LU Decomposition */ - d[0] = a[0]; - u_ws[0] = c[0]; - - for (int i = 0; i < N - 2; i++) { - l[i] = b[i] / d[i]; - d[i + 1] = a[i + 1] - l[i] * u_ws[i]; - u_ws[i + 1] = c[i + 1]; - } - - l[N - 2] = b[N - 2] / d[N - 2]; - d[N - 1] = a[N - 1] - l[N - 2] * u_ws[N - 2]; - - /* Forward Substitution [L][y] = [q] */ - y[0] = q[0]; - for (int i = 1; i < N; i++) - y[i] = q[i] - l[i - 1] * y[i - 1]; - - /* Backward Substitution [U][x] = [y] */ - x[N - 1] = y[N - 1] / d[N - 1]; - for (int i = N - 2; i >= 0; i--) - x[i] = (y[i] - u_ws[i] * x[i + 1]) / d[i]; -} - -// --------------------------------------------------------------------------*/ -// Calculates the value of v at an arbitrary position (x,y,z) if the spectral coefficients are know*/*/ -/* --------------------------------------------------------------------------*/ -/* Calculates the value of v at an arbitrary position (A,B,phi)*/ -double TwoPunctures::Spec_IntPolABphiFast(parameters par, double *v, int ivar, double A, double B, double phi) -{ - int i, j, k, N; - double *p, *values1, **values2, result; - - int nvar = par.nvar; - int n1 = par.n1; - int n2 = par.n2; - int n3 = par.n3; - N = maximum3(n1, n2, n3); - - p = dvector(0, N); - values1 = dvector(0, N); - values2 = dmatrix(0, N, 0, N); - - for (k = 0; k < n3; k++) - { - for (j = 0; j < n2; j++) - { - for (i = 0; i < n1; i++) - p[i] = v[ivar + nvar * (i + n1 * (j + n2 * k))]; - // chebft_Zeros (p, n1, 0); - values2[j][k] = chebev(-1, 1, p, n1, A); - } - } - - for (k = 0; k < n3; k++) - { - for (j = 0; j < n2; j++) - p[j] = values2[j][k]; - // chebft_Zeros (p, n2, 0); - values1[k] = chebev(-1, 1, p, n2, B); - } - - // fourft (values1, n3, 0); - result = fourev(values1, n3, phi); - - free_dvector(p, 0, N); - free_dvector(values1, 0, N); - free_dmatrix(values2, 0, N, 0, N); - - return result; - // */ - // return 0.; -} - -/* Calculates the value of v at an arbitrary position (x,y,z) given the spectral coefficients*/ -double TwoPunctures::Spec_IntPolFast(parameters par, int ivar, double *v, double x, double y, double z) -{ - double xs, ys, zs, rs2, phi, X, R, A, B, aux1, aux2, result, Ui; - - int nvar = par.nvar; - int n1 = par.n1; - int n2 = par.n2; - int n3 = par.n3; - double par_b = par.b; - - xs = x / par.b; - ys = y / par.b; - zs = z / par.b; - rs2 = ys * ys + zs * zs; - phi = atan2(z, y); - if (phi < 0) - phi += 2. * Pi; - - aux1 = 0.5 * (xs * xs + rs2 - 1.); - aux2 = sqrt(aux1 * aux1 + rs2); - - // Note from YT: aux2-aux1 can be equal to 1. When that happens, numerical - // truncation may make it slightly larger than 1. This makes - // R NAN! I also worry that aux2-aux1 and aux1+axu2 may become negative due to - // truncation error, which gives rise to NAN for X and R. - // The following few lines attempt to fix these. - double aux2_plus_aux1, aux2_minus_aux1; - if (aux1 < 0) - { - aux2_plus_aux1 = rs2 / (aux2 - aux1); - aux2_minus_aux1 = aux2 - aux1; - } - else - { - aux2_plus_aux1 = aux2 + aux1; - aux2_minus_aux1 = rs2 / (aux2 + aux1); - } - if (fabs(aux1) + fabs(aux2) < 1.e-20) - { - aux2_plus_aux1 = 0.0; - aux2_minus_aux1 = 0.0; - } - double sqrt_aux2_minus_aux1 = sqrt(fabs(aux2_minus_aux1)); - - // Note from YT: The following two lines have replaced by the 6 lines belows. - // X = asinhd(sqrt(aux1+aux2)); - // R = asin(sqrt(fabs(-aux1+aux2))); - - X = asinh(sqrt(aux2_plus_aux1)); - if (sqrt_aux2_minus_aux1 > 1.0) - { - R = 0.5 * Pi; - } - else - { - R = asin(sqrt_aux2_minus_aux1); - } - - if (x < 0) - R = Pi - R; - - A = 2. * tanh(0.5 * X) - 1.; - B = tan(0.5 * R - Piq); - - result = Spec_IntPolABphiFast(par, v, ivar, A, B, phi); - - Ui = (A - 1) * result; - - return Ui; -} - -// Evaluates the spectral expansion coefficients of v -void TwoPunctures::SpecCoef(parameters par, int ivar, double *v, double *cf) -{ - // Here v is a pointer to the values of the variable v at the collocation points - int i, j, k, N, n, l, m; - double *p, ***values3, ***values4; - - int nvar = par.nvar; - int n1 = par.n1; - int n2 = par.n2; - int n3 = par.n3; - - N = maximum3(n1, n2, n3); - p = dvector(0, N); - values3 = d3tensor(0, n1, 0, n2, 0, n3); - values4 = d3tensor(0, n1, 0, n2, 0, n3); - - // Caclulate values3[n,j,k] = a_n^{j,k} = (sum_i^(n1-1) f(A_i,B_j,phi_k) Tn(-A_i))/k_n , k_n = N/2 or N - for (k = 0; k < n3; k++) - { - for (j = 0; j < n2; j++) - { - for (i = 0; i < n1; i++) - p[i] = v[ivar + (i + n1 * (j + n2 * k))]; - chebft_Zeros(p, n1, 0); - for (n = 0; n < n1; n++) - { - values3[n][j][k] = p[n]; - } - } - } - - // Caclulate values4[n,l,k] = a_{n,l}^{k} = (sum_j^(n2-1) a_n^{j,k} Tn(B_j))/k_l , k_l = N/2 or N - - for (n = 0; n < n1; n++) - { - for (k = 0; k < n3; k++) - { - for (j = 0; j < n2; j++) - p[j] = values3[n][j][k]; - chebft_Zeros(p, n2, 0); - for (l = 0; l < n2; l++) - { - values4[n][l][k] = p[l]; - } - } - } - - // Caclulate coefficients a_{n,l,m} = (sum_k^(n3-1) a_{n,m}^{k} fourier(phi_k))/k_m , k_m = N/2 or N - for (i = 0; i < n1; i++) - { - for (j = 0; j < n2; j++) - { - for (k = 0; k < n3; k++) - p[k] = values4[i][j][k]; - fourft(p, n3, 0); - for (k = 0; k < n3; k++) - { - cf[ivar + (i + n1 * (j + n2 * k))] = p[k]; - } - } - } - - free_dvector(p, 0, N); - free_d3tensor(values3, 0, n1, 0, n2, 0, n3); - free_d3tensor(values4, 0, n1, 0, n2, 0, n3); -} - -void TwoPunctures::allocate_workspace() -{ - int n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; - max_threads = omp_get_max_threads(); - printf("Allocating workspace for %d threads\n", max_threads); - - // LineRelax_be workspace: arrays of size n2, per thread - ws_diag_be = new double*[max_threads]; - ws_e_be = new double*[max_threads]; - ws_f_be = new double*[max_threads]; - ws_b_be = new double*[max_threads]; - ws_x_be = new double*[max_threads]; - ws_l_be = new double*[max_threads]; - ws_u_be = new double*[max_threads]; - ws_d_be = new double*[max_threads]; - ws_y_be = new double*[max_threads]; - - // LineRelax_al workspace: arrays of size n1, per thread - ws_diag_al = new double*[max_threads]; - ws_e_al = new double*[max_threads]; - ws_f_al = new double*[max_threads]; - ws_b_al = new double*[max_threads]; - ws_x_al = new double*[max_threads]; - ws_l_al = new double*[max_threads]; - ws_u_al = new double*[max_threads]; - ws_d_al = new double*[max_threads]; - ws_y_al = new double*[max_threads]; - - int N = (n1 > n2) ? n1 : n2; // max of n1, n2 - - for (int t = 0; t < max_threads; t++) { - ws_diag_be[t] = new double[n2]; - ws_e_be[t] = new double[n2]; - ws_f_be[t] = new double[n2]; - ws_b_be[t] = new double[n2]; - ws_x_be[t] = new double[n2]; - ws_l_be[t] = new double[n2]; - ws_u_be[t] = new double[n2]; - ws_d_be[t] = new double[n2]; - ws_y_be[t] = new double[n2]; - - ws_diag_al[t] = new double[n1]; - ws_e_al[t] = new double[n1]; - ws_f_al[t] = new double[n1]; - ws_b_al[t] = new double[n1]; - ws_x_al[t] = new double[n1]; - ws_l_al[t] = new double[n1]; - ws_u_al[t] = new double[n1]; - ws_d_al[t] = new double[n1]; - ws_y_al[t] = new double[n1]; - } -} - -void TwoPunctures::free_workspace() -{ - for (int t = 0; t < max_threads; t++) { - delete[] ws_diag_be[t]; delete[] ws_e_be[t]; delete[] ws_f_be[t]; - delete[] ws_b_be[t]; delete[] ws_x_be[t]; - delete[] ws_l_be[t]; delete[] ws_u_be[t]; - delete[] ws_d_be[t]; delete[] ws_y_be[t]; - - delete[] ws_diag_al[t]; delete[] ws_e_al[t]; delete[] ws_f_al[t]; - delete[] ws_b_al[t]; delete[] ws_x_al[t]; - delete[] ws_l_al[t]; delete[] ws_u_al[t]; - delete[] ws_d_al[t]; delete[] ws_y_al[t]; - } - delete[] ws_diag_be; delete[] ws_e_be; delete[] ws_f_be; - delete[] ws_b_be; delete[] ws_x_be; - delete[] ws_l_be; delete[] ws_u_be; - delete[] ws_d_be; delete[] ws_y_be; - - delete[] ws_diag_al; delete[] ws_e_al; delete[] ws_f_al; - delete[] ws_b_al; delete[] ws_x_al; - delete[] ws_l_al; delete[] ws_u_al; - delete[] ws_d_al; delete[] ws_y_al; -} - -/*========================================================================== - * Precomputed Spectral Derivative Matrices - * - * Mathematical equivalence proof: - * - * Original algorithm (per-line): - * 1. Forward Chebyshev transform: c = T * f (where T is the DCT matrix) - * 2. Spectral derivative: c' = Dhat * c (recurrence relation) - * 3. Inverse transform: f' = T^{-1} * c' - * Combined: f' = T^{-1} * Dhat * T * f = D * f - * - * The matrix D = T^{-1} * Dhat * T is precomputed once. - * Similarly D2 = T^{-1} * Dhat^2 * T for second derivatives. - * - * For Fourier: same idea with DFT matrices and frequency-domain derivatives. - * - * This converts n2*n3 separate O(n1^2) transforms into a single - * (n1 x n1) * (n1 x n2*n3) DGEMM call, which is BLAS Level-3 - * and thus optimally parallelized by MKL. - *=========================================================================*/ - -void TwoPunctures::build_cheb_deriv_matrices(int n, double *D1, double *D2) -{ - /* Build the physical-space derivative matrices for Chebyshev Zeros grid. - * - * Grid points: x_i = -cos(pi*(2i+1)/(2n)), i=0,...,n-1 - * - * Method: Construct T (forward transform), Dhat (spectral derivative), - * T^{-1} (inverse transform), then D1 = T^{-1} * Dhat * T, - * D2 = T^{-1} * Dhat^2 * T. - * - * All matrices are n x n, stored in row-major order: M[i*n+j] - */ - - double *T_fwd = new double[n * n]; // Forward transform matrix - double *T_inv = new double[n * n]; // Inverse transform matrix - double *Dhat = new double[n * n]; // Spectral derivative operator - double *Dhat2 = new double[n * n]; // Spectral second derivative operator - double *tmp1 = new double[n * n]; // Temporary - double *tmp2 = new double[n * n]; // Temporary - - double Pion = Pi / n; - - // Build forward Chebyshev transform matrix T - // c_j = (2/n) * (-1)^j * sum_k f_k * cos(pi*j*(k+0.5)/n) - // So T[j][k] = (2/n) * (-1)^j * cos(pi*j*(k+0.5)/n) - for (int j = 0; j < n; j++) { - double fac = (2.0 / n) * ((j % 2 == 0) ? 1.0 : -1.0); - for (int k = 0; k < n; k++) { - T_fwd[j * n + k] = fac * cos(Pion * j * (k + 0.5)); - } - } - - // Build inverse Chebyshev transform matrix T^{-1} - // f_j = sum_k c_k * cos(pi*(j+0.5)*k/n) * (-1)^k - 0.5*c_0 - // But the -0.5*c_0 term is part of the sum when we write it as: - // f_j = -0.5*c_0 + sum_{k=0}^{n-1} c_k * cos(pi*(j+0.5)*k) * (-1)^k - // T_inv[j][k] = cos(pi*(j+0.5)*k/n) * (-1)^k, with k=0 term having extra -0.5 - for (int j = 0; j < n; j++) { - for (int k = 0; k < n; k++) { - double sign_k = (k % 2 == 0) ? 1.0 : -1.0; - T_inv[j * n + k] = cos(Pion * (j + 0.5) * k) * sign_k; - } - // The k=0 term needs adjustment: the sum includes c_0*1 but we need -0.5*c_0 + c_0*1 = 0.5*c_0 - // Wait, let me re-examine chebft_Zeros with inv=1: - // sum = -0.5 * u[0]; - // for k: sum += u[k] * cos(Pion*(j+0.5)*k) * isignum; isignum alternates starting from 1 - // So: c[j] = -0.5*u[0] + sum_{k=0}^{n-1} u[k]*cos(...)*(-1)^k - // = -0.5*u[0] + u[0]*1*1 + sum_{k=1} ... - // = 0.5*u[0] + sum_{k=1} u[k]*cos(...)*(-1)^k - // Equivalently: T_inv[j][0] = 0.5, T_inv[j][k] = cos(...)*(-1)^k for k>=1 - // But cos(0) = 1 and (-1)^0 = 1, so the formula gives T_inv[j][0] = 1.0 - // We need it to be 0.5. Fix: - T_inv[j * n + 0] = 0.5; // This accounts for the -0.5*u[0] + u[0]*cos(0)*1 = 0.5*u[0] - } - - // Build spectral derivative matrix Dhat (in coefficient space) - // The recurrence: cder[n-1] = 0, cder[n-2] = 0, - // cder[j] = cder[j+2] + 2*(j+1)*c[j+1] for j = n-3,...,0 - // This means cder = Dhat * c, where Dhat is upper triangular-ish. - // Dhat[j][k] = coefficient of c[k] contributing to cder[j] - // - // From the recurrence: cder[j] = sum_{k=j+1, k-j odd}^{n-1} 2*k * c[k] - // (with the factor 2k, summing over k > j where k-j is odd) - // Exception: cder[0] gets an extra factor of 0.5 since c[0] has the 2/n prefactor - // Actually no: the chder function is: - // cder[n] = cder[n-1] = 0 - // cder[j] = cder[j+2] + 2*(j+1)*c[j+1] - // Unrolling: cder[j] = 2*(j+1)*c[j+1] + 2*(j+3)*c[j+3] + ... - // So Dhat[j][k] = 2*k if k > j and (k-j) is odd, else 0 - - for (int j = 0; j < n; j++) - for (int k = 0; k < n; k++) - Dhat[j * n + k] = 0.0; - - for (int j = 0; j < n; j++) { - for (int k = j + 1; k < n; k++) { - if ((k - j) % 2 == 1) { - Dhat[j * n + k] = 2.0 * k; - } - } - } - - // Build Dhat^2 = Dhat * Dhat - // D1 = T_inv * Dhat * T_fwd - // D2 = T_inv * Dhat^2 * T_fwd - - // tmp1 = Dhat * T_fwd - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n, n, n, 1.0, Dhat, n, T_fwd, n, 0.0, tmp1, n); - // D1 = T_inv * tmp1 - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n, n, n, 1.0, T_inv, n, tmp1, n, 0.0, D1, n); - - // tmp2 = Dhat * Dhat (Dhat^2 in spectral space) - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n, n, n, 1.0, Dhat, n, Dhat, n, 0.0, tmp2, n); - // tmp1 = Dhat^2 * T_fwd - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n, n, n, 1.0, tmp2, n, T_fwd, n, 0.0, tmp1, n); - // D2 = T_inv * tmp1 - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n, n, n, 1.0, T_inv, n, tmp1, n, 0.0, D2, n); - - delete[] T_fwd; - delete[] T_inv; - delete[] Dhat; - delete[] Dhat2; - delete[] tmp1; - delete[] tmp2; -} - -void TwoPunctures::build_fourier_deriv_matrices(int N, double *DF1, double *DF2) -{ - /* Build Fourier derivative matrices in physical space. - * - * Grid: phi_k = 2*pi*k/N, k=0,...,N-1 - * - * The Fourier interpolant derivative at grid points can be expressed as - * a matrix multiply. We build it by: - * 1. Forward Fourier transform matrix F - * 2. Frequency-domain derivative (multiply by il for first, -l^2 for second) - * 3. Inverse Fourier transform matrix F^{-1} - * DF1 = F^{-1} * diag(il) * F, DF2 = F^{-1} * diag(-l^2) * F - * - * But since fourft/fourev use a real representation (a_l, b_l), - * we construct directly in physical space. - */ - - int M = N / 2; - double Pi_fac = Pi / M; // = 2*Pi/N - - // DF1[j][k] = d/dphi of the interpolant at phi_j, due to value at phi_k - // Using the representation: - // f(phi) = 0.5*(a_0 + a_M*cos(M*phi)) + sum_{l=1}^{M-1} (a_l*cos(l*phi) + b_l*sin(l*phi)) - // where a_l = (2/N)*sum_k f_k*cos(l*phi_k), b_l = (2/N)*sum_k f_k*sin(l*phi_k) - // - // f'(phi) = -0.5*a_M*M*sin(M*phi) + sum_{l=1}^{M-1} l*(-a_l*sin(l*phi) + b_l*cos(l*phi)) - // - // Substituting a_l, b_l and evaluating at phi_j: - // f'(phi_j) = sum_k f_k * K(j,k) - // where K(j,k) = (2/N) * sum_{l=1}^{M-1} l * (-cos(l*phi_k)*sin(l*phi_j) + sin(l*phi_k)*cos(l*phi_j)) - // + (2/N) * (-M/2) * sin(M*phi_j) * cos(M*phi_k) [a_M term, note a_M has no factor 2] - // = (2/N) * sum_{l=1}^{M-1} l * sin(l*(phi_k - phi_j)) - // - (1/N) * M * sin(M*phi_j) * cos(M*phi_k) - // - // But the a_M coefficient in fourft has factor 1/M (not 2/M), so: - // Actually re-examining fourft: a[l] = fac * sum_k u[k]*cos(x), fac=1/M - // and a_M is stored as a[M] with same fac. The inverse uses: - // u[k] = 0.5*(a[0] + a[M]*iy) + sum_{l=1}^{M-1}(a[l]*cos + b[l]*sin) - // So the full expression needs care. Let me just compute it numerically. - - // Numerical approach: for each k, set f = delta_k, compute derivative at all j - double *p = new double[N]; - double *dp = new double[N]; - - for (int k = 0; k < N; k++) { - // Set delta function at k - for (int i = 0; i < N; i++) - p[i] = (i == k) ? 1.0 : 0.0; - - // Forward Fourier transform (using existing fourft) - fourft(p, N, 0); - // Derivative in spectral space - fourder(p, dp, N); - // Inverse Fourier transform - fourft(dp, N, 1); - - // dp[j] = derivative of delta_k interpolant at phi_j - // So DF1[j][k] = dp[j] - for (int j = 0; j < N; j++) - DF1[j * N + k] = dp[j]; - } - - // Second derivative - for (int k = 0; k < N; k++) { - for (int i = 0; i < N; i++) - p[i] = (i == k) ? 1.0 : 0.0; - - fourft(p, N, 0); - fourder2(p, dp, N); - fourft(dp, N, 1); - - for (int j = 0; j < N; j++) - DF2[j * N + k] = dp[j]; - } - - delete[] p; - delete[] dp; -} - -void TwoPunctures::precompute_derivative_matrices() -{ - int n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; - - // Allocate matrices - D1_A = new double[n1 * n1]; - D2_A = new double[n1 * n1]; - D1_B = new double[n2 * n2]; - D2_B = new double[n2 * n2]; - DF1_phi = new double[n3 * n3]; - DF2_phi = new double[n3 * n3]; - - // Build Chebyshev derivative matrices - build_cheb_deriv_matrices(n1, D1_A, D2_A); - build_cheb_deriv_matrices(n2, D1_B, D2_B); - - // Build Fourier derivative matrices - build_fourier_deriv_matrices(n3, DF1_phi, DF2_phi); - - printf("Precomputed derivative matrices: A(%d), B(%d), phi(%d)\n", n1, n2, n3); -} - -/* -------------------------------------------------------------------------- - * Derivatives_AB3_MatMul: Drop-in replacement for Derivatives_AB3 - * - * Uses precomputed derivative matrices and DGEMM to compute all spectral - * derivatives in batch. Mathematically equivalent to the original - * Derivatives_AB3. - * - * Memory layout of v.d0[Index(ivar,i,j,k)] = v.d0[ivar + nvar*(i + n1*(j + n2*k))] - * - * For A-direction derivatives (fixed j,k, varying i): - * We need to apply D1_A and D2_A to "pencils" along the i-direction. - * Collect all pencils into a matrix and use DGEMM. - * - * For B-direction derivatives (fixed i,k, varying j): - * Similarly with D1_B, D2_B. - * - * For phi-direction (fixed i,j, varying k): - * Similarly with DF1_phi, DF2_phi. - * --------------------------------------------------------------------------*/ -void TwoPunctures::Derivatives_AB3_MatMul(int nvar, int n1, int n2, int n3, derivs v) -{ - int total_pencils; - double *data_in, *data_out; - - /*===================================================== - * STEP 1: A-direction derivatives (Chebyshev, D1_A, D2_A) - * - * For each (ivar, j, k), we have a pencil of length n1: - * f[i] = v.d0[Index(ivar, i, j, k, nvar, n1, n2, n3)] - * - * We want: v.d1[...] = D1_A * f, v.d11[...] = D2_A * f - * - * Collect all n2*n3*nvar pencils as columns of a matrix: - * data_in[i, col] where col = ivar + nvar*(j + n2*k) - * Then: data_out = D1_A * data_in (DGEMM: n1 x n1 times n1 x total_pencils) - *=====================================================*/ - total_pencils = nvar * n2 * n3; - - data_in = new double[n1 * total_pencils]; - data_out = new double[n1 * total_pencils]; - - // Gather: data_in[i * total_pencils + col] = v.d0[Index(ivar,i,j,k,...)] - // where col = ivar + nvar * (j + n2 * k) - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (j + n2 * k); - for (int i = 0; i < n1; i++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - data_in[i * total_pencils + col] = v.d0[indx]; - } - } - } - } - - // First derivative: data_out = D1_A * data_in - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n1, total_pencils, n1, - 1.0, D1_A, n1, data_in, total_pencils, - 0.0, data_out, total_pencils); - - // Scatter to v.d1 - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (j + n2 * k); - for (int i = 0; i < n1; i++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d1[indx] = data_out[i * total_pencils + col]; - } - } - } - } - - // Second derivative: data_out = D2_A * data_in - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n1, total_pencils, n1, - 1.0, D2_A, n1, data_in, total_pencils, - 0.0, data_out, total_pencils); - - // Scatter to v.d11 - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (j + n2 * k); - for (int i = 0; i < n1; i++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d11[indx] = data_out[i * total_pencils + col]; - } - } - } - } - - delete[] data_in; - delete[] data_out; - - /*===================================================== - * STEP 2: B-direction derivatives (Chebyshev, D1_B, D2_B) - * - * Pencils along j for each (ivar, i, k). - * Also compute mixed derivative v.d12 = D1_B applied to v.d1 - *=====================================================*/ - total_pencils = nvar * n1 * n3; - - data_in = new double[n2 * total_pencils]; - data_out = new double[n2 * total_pencils]; - double *data_in2 = new double[n2 * total_pencils]; - double *data_out2 = new double[n2 * total_pencils]; - - // Gather v.d0 along B-direction AND v.d1 for mixed derivative - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int i = 0; i < n1; i++) { - int col = ivar + nvar * (i + n1 * k); - for (int j = 0; j < n2; j++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - data_in[j * total_pencils + col] = v.d0[indx]; - data_in2[j * total_pencils + col] = v.d1[indx]; // for d/dB of (dv/dA) - } - } - } - } - - // v.d2 = D1_B * v.d0 (along B) - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n2, total_pencils, n2, - 1.0, D1_B, n2, data_in, total_pencils, - 0.0, data_out, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int i = 0; i < n1; i++) { - int col = ivar + nvar * (i + n1 * k); - for (int j = 0; j < n2; j++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d2[indx] = data_out[j * total_pencils + col]; - } - } - } - } - - // v.d22 = D2_B * v.d0 - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n2, total_pencils, n2, - 1.0, D2_B, n2, data_in, total_pencils, - 0.0, data_out, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int i = 0; i < n1; i++) { - int col = ivar + nvar * (i + n1 * k); - for (int j = 0; j < n2; j++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d22[indx] = data_out[j * total_pencils + col]; - } - } - } - } - - // v.d12 = D1_B * v.d1 (mixed: d/dB of dv/dA) - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n2, total_pencils, n2, - 1.0, D1_B, n2, data_in2, total_pencils, - 0.0, data_out2, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int k = 0; k < n3; k++) { - for (int i = 0; i < n1; i++) { - int col = ivar + nvar * (i + n1 * k); - for (int j = 0; j < n2; j++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d12[indx] = data_out2[j * total_pencils + col]; - } - } - } - } - - delete[] data_in; - delete[] data_out; - delete[] data_in2; - delete[] data_out2; - - /*===================================================== - * STEP 3: phi-direction derivatives (Fourier, DF1_phi, DF2_phi) - * - * Pencils along k for each (ivar, i, j). - * Also compute mixed derivatives v.d13, v.d23 - *=====================================================*/ - total_pencils = nvar * n1 * n2; - - data_in = new double[n3 * total_pencils]; - data_out = new double[n3 * total_pencils]; - data_in2 = new double[n3 * total_pencils]; // for v.d1 → v.d13 - data_out2 = new double[n3 * total_pencils]; - double *data_in3 = new double[n3 * total_pencils]; // for v.d2 → v.d23 - double *data_out3 = new double[n3 * total_pencils]; - - // Gather v.d0, v.d1, v.d2 along phi-direction - for (int ivar = 0; ivar < nvar; ivar++) { - for (int i = 0; i < n1; i++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (i + n1 * j); - for (int k = 0; k < n3; k++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - data_in[k * total_pencils + col] = v.d0[indx]; - data_in2[k * total_pencils + col] = v.d1[indx]; - data_in3[k * total_pencils + col] = v.d2[indx]; - } - } - } - } - - // v.d3 = DF1_phi * v.d0 - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n3, total_pencils, n3, - 1.0, DF1_phi, n3, data_in, total_pencils, - 0.0, data_out, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int i = 0; i < n1; i++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (i + n1 * j); - for (int k = 0; k < n3; k++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d3[indx] = data_out[k * total_pencils + col]; - } - } - } - } - - // v.d33 = DF2_phi * v.d0 - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n3, total_pencils, n3, - 1.0, DF2_phi, n3, data_in, total_pencils, - 0.0, data_out, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int i = 0; i < n1; i++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (i + n1 * j); - for (int k = 0; k < n3; k++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d33[indx] = data_out[k * total_pencils + col]; - } - } - } - } - - // v.d13 = DF1_phi * v.d1 (mixed: d/dphi of dv/dA) - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n3, total_pencils, n3, - 1.0, DF1_phi, n3, data_in2, total_pencils, - 0.0, data_out2, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int i = 0; i < n1; i++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (i + n1 * j); - for (int k = 0; k < n3; k++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d13[indx] = data_out2[k * total_pencils + col]; - } - } - } - } - - // v.d23 = DF1_phi * v.d2 (mixed: d/dphi of dv/dB) - cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, - n3, total_pencils, n3, - 1.0, DF1_phi, n3, data_in3, total_pencils, - 0.0, data_out3, total_pencils); - - for (int ivar = 0; ivar < nvar; ivar++) { - for (int i = 0; i < n1; i++) { - for (int j = 0; j < n2; j++) { - int col = ivar + nvar * (i + n1 * j); - for (int k = 0; k < n3; k++) { - int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); - v.d23[indx] = data_out3[k * total_pencils + col]; - } - } - } - } - - delete[] data_in; - delete[] data_out; - delete[] data_in2; - delete[] data_out2; - delete[] data_in3; - delete[] data_out3; -} - + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#include "TwoPunctures.h" +#include + +TwoPunctures::TwoPunctures(double mp, double mm, double b, + double P_plusx, double P_plusy, double P_plusz, + double S_plusx, double S_plusy, double S_plusz, + double P_minusx, double P_minusy, double P_minusz, + double S_minusx, double S_minusy, double S_minusz, + int nA, int nB, int nphi, + double Mp, double Mm, double admtol, double Newtontol, + int Newtonmaxit) : par_m_plus(mp), par_m_minus(mm), par_b(b), npoints_A(nA), + npoints_B(nB), npoints_phi(nphi), target_M_plus(Mp), target_M_minus(Mm), + adm_tol(admtol), Newton_tol(Newtontol), Newton_maxit(Newtonmaxit) +{ + par_P_plus[0] = P_plusx; + par_P_plus[1] = P_plusy; + par_P_plus[2] = P_plusz; + par_P_minus[0] = P_minusx; + par_P_minus[1] = P_minusy; + par_P_minus[2] = P_minusz; + par_S_plus[0] = S_plusx; + par_S_plus[1] = S_plusy; + par_S_plus[2] = S_plusz; + par_S_minus[0] = S_minusx; + par_S_minus[1] = S_minusy; + par_S_minus[2] = S_minusz; + + int const nvar = 1, n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; + + ntotal = n1 * n2 * n3 * nvar; + + F = dvector(0, ntotal - 1); + allocate_derivs(&u, ntotal); + allocate_derivs(&v, ntotal); + D1_A = NULL; D2_A = NULL; D1_B = NULL; D2_B = NULL; + DF1_phi = NULL; DF2_phi = NULL; + precompute_derivative_matrices(); + allocate_workspace(); +} + +TwoPunctures::~TwoPunctures() +{ + free_dvector(F, 0, ntotal - 1); + free_derivs(&u, ntotal); + free_derivs(&v, ntotal); + free_workspace(); + if (D1_A) delete[] D1_A; + if (D2_A) delete[] D2_A; + if (D1_B) delete[] D1_B; + if (D2_B) delete[] D2_B; + if (DF1_phi) delete[] DF1_phi; + if (DF2_phi) delete[] DF2_phi; +} + +void TwoPunctures::Solve() +{ + + double mp = par_m_plus; + double mm = par_m_minus; + + enum GRID_SETUP_METHOD + { + GSM_Taylor_expansion, + GSM_evaluation + }; + enum GRID_SETUP_METHOD gsm; + + int antisymmetric_lapse, averaged_lapse, pmn_lapse, brownsville_lapse; + + int const nvar = 1, n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; + + int imin[3], imax[3]; + int const ntotal = n1 * n2 * n3 * nvar; + + // double admMass; + + /* initialise to 0 */ + for (int j = 0; j < ntotal; j++) + { + v.d0[j] = 0.0; + v.d1[j] = 0.0; + v.d2[j] = 0.0; + v.d3[j] = 0.0; + v.d11[j] = 0.0; + v.d12[j] = 0.0; + v.d13[j] = 0.0; + v.d22[j] = 0.0; + v.d23[j] = 0.0; + v.d33[j] = 0.0; + } + + double tmp, Mp_adm, Mm_adm, Mp_adm_err, Mm_adm_err, up, um; + + double M_p = target_M_plus; + double M_m = target_M_minus; + /* If bare masses are not given, iteratively solve for them given the + target ADM masses target_M_plus and target_M_minus and with initial + guesses given by par_m_plus and par_m_minus. */ + if (par_m_plus < 0 || par_m_minus < 0) + { + + par_m_plus = target_M_plus; + par_m_minus = target_M_minus; + cout << "Attempting to find bare masses." << endl; + cout << "Target ADM masses: M_p=" << M_p << " and M_m=" << M_m << endl; + cout << "ADM mass tolerance: " << adm_tol << endl; + + /* Loop until both ADM masses are within adm_tol of their target */ + do + { + cout << "Bare masses: mp=" << mp << ", mm=" << mm << endl; + Newton(nvar, n1, n2, n3, v, Newton_tol, 1); + + F_of_v(nvar, n1, n2, n3, v, F, u); + + up = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, par_b, 0., 0.); + um = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, -par_b, 0., 0.); + + /* Calculate the ADM masses from the current bare mass guess PRD 70, 064011 (2004) Eq.(83)*/ + Mp_adm = (1 + up) * mp + mp * mm / (4. * par_b); + Mm_adm = (1 + um) * mm + mp * mm / (4. * par_b); + + /* Check how far the current ADM masses are from the target */ + Mp_adm_err = fabs(M_p - Mp_adm); + Mm_adm_err = fabs(M_m - Mm_adm); + cout << "ADM mass error: M_p_err=" << Mp_adm_err << ", M_m_err=" << Mm_adm_err << endl; + + /* Invert the ADM mass equation and update the bare mass guess so that + it gives the correct target ADM masses */ + tmp = -4 * par_b * (1 + um + up + um * up) + + sqrt(16 * par_b * M_m * (1 + um) * (1 + up) + + pow(-M_m + M_p + 4 * par_b * (1 + um) * (1 + up), 2)); + par_m_plus = mp = (tmp + M_p - M_m) / (2. * (1 + up)); + par_m_minus = mm = (tmp - M_p + M_m) / (2. * (1 + um)); + + } while ((Mp_adm_err > adm_tol) || + (Mm_adm_err > adm_tol)); + + cout << "Found bare masses resulted Mp = " << Mp_adm << " and Mm = " << Mm_adm << endl; + } + + Newton(nvar, n1, n2, n3, v, Newton_tol, Newton_maxit); + + F_of_v(nvar, n1, n2, n3, v, F, u); + + up = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, par_b, 0., 0.); + um = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, -par_b, 0., 0.); + + /* Calculate the ADM masses from the current bare mass guess PRD 70, 064011 (2004) Eq.(83)*/ + Mp_adm = (1 + up) * mp + mp * mm / (4. * par_b); + Mm_adm = (1 + um) * mm + mp * mm / (4. * par_b); + + cout << "The two puncture masses are mp = " << mp << " and mm = " << mm << endl; + cout << " resulted Mp = " << Mp_adm << " and Mm = " << Mm_adm << endl; + + /* print out ADM mass, eq.: \Delta M_ADM=2*r*u=4*b*V for A=1,B=0,phi=0 PRD 70, 064011 (2004) Eq.(81)*/ + admMass = (mp + mm - 4 * par_b * PunctEvalAtArbitPosition(v.d0, 0, 1, 0, 0, nvar, n1, n2, n3)); + cout << "The total ADM mass is " << admMass << endl; + + target_M_plus = Mp_adm; + target_M_minus = Mm_adm; +} +void TwoPunctures::Save(char *fname) +{ + ofstream outfile; + outfile.open(fname, ios::trunc); + + time_t tnow; + time(&tnow); + struct tm *loc_time; + loc_time = localtime(&tnow); + outfile << "#File created on " << asctime(loc_time); + outfile << "#Newton_tol = " << Newton_tol << endl; + outfile << "#Mp = " << target_M_plus << endl; + outfile << "#Mm = " << target_M_minus << endl; + double D = 2 * par_b, x1, x2; + x1 = D * target_M_minus / (target_M_plus + target_M_minus); + x2 = -D * target_M_plus / (target_M_plus + target_M_minus); + // in order to relate Brugmann's convention, rotate xy + outfile << "bhmass1 = " << par_m_plus << endl; + outfile << "bhx1 = " << 0 << endl; + outfile << "bhy1 = " << x1 << endl; + outfile << "bhz1 = " << 0 << endl; + outfile << "bhpx1 = " << -par_P_plus[1] << endl; + outfile << "bhpy1 = " << par_P_plus[0] << endl; + outfile << "bhpz1 = " << par_P_plus[2] << endl; + outfile << "bhsx1 = " << -par_S_plus[1] << endl; + outfile << "bhsy1 = " << par_S_plus[0] << endl; + outfile << "bhsz1 = " << par_S_plus[2] << endl; + outfile << "bhmass2 = " << par_m_minus << endl; + outfile << "bhx2 = " << 0 << endl; + outfile << "bhy2 = " << x2 << endl; + outfile << "bhz2 = " << 0 << endl; + outfile << "bhpx2 = " << -par_P_minus[1] << endl; + outfile << "bhpy2 = " << par_P_minus[0] << endl; + outfile << "bhpz2 = " << par_P_minus[2] << endl; + outfile << "bhsx2 = " << -par_S_minus[1] << endl; + outfile << "bhsy2 = " << par_S_minus[0] << endl; + outfile << "bhsz2 = " << par_S_minus[2] << endl; + int const n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; + outfile << "data " << n1 << " " << n2 << " " << n3 << endl; + int ntotal = n1 * n2 * n3; + + outfile.setf(ios::scientific, ios::floatfield); + outfile.precision(16); + for (int i = 0; i < ntotal; i++) + outfile << v.d0[i] << endl; + + outfile.close(); + + // add output to facilitate python reading of puncture data, by Xiaoqu 2024/12/04 + ofstream outfile2; + outfile2.open("puncture_parameters_new.txt", ios::trunc); + + // note that in this program the xy plane has been rotated + outfile2 << setw(18) << setprecision(10) << par_m_plus + << setw(18) << setprecision(10) << target_M_plus + << setw(18) << setprecision(10) << admMass << " # bare mass 1 mass 1 ADM mass" << endl; + outfile2 << setw(18) << setprecision(10) << 0.0 + << setw(18) << setprecision(10) << x1 + << setw(18) << setprecision(10) << 0.0 << " # position 1" << endl; + outfile2 << setw(18) << setprecision(10) << -par_P_plus[1] + << setw(18) << setprecision(10) << par_P_plus[0] + << setw(18) << setprecision(10) << par_P_plus[2] << " # momentum 1" << endl; + outfile2 << setw(18) << setprecision(10) << -par_S_plus[1] + << setw(18) << setprecision(10) << par_S_plus[0] + << setw(18) << setprecision(10) << par_S_plus[2] << " # angular mumentum 1" << endl; + outfile2 << setw(18) << setprecision(10) << par_m_minus + << setw(18) << setprecision(10) << target_M_minus + << setw(18) << setprecision(10) << admMass << " # bare mass 2 mass 2 ADM mass" << endl; + outfile2 << setw(18) << setprecision(10) << 0.0 + << setw(18) << setprecision(10) << x2 + << setw(18) << setprecision(10) << 0.0 << " # position 2" << endl; + outfile2 << setw(18) << setprecision(10) << -par_P_minus[1] + << setw(18) << setprecision(10) << par_P_minus[0] + << setw(18) << setprecision(10) << par_P_minus[2] << " # momentum 2" << endl; + outfile2 << setw(18) << setprecision(10) << -par_S_minus[1] + << setw(18) << setprecision(10) << par_S_minus[0] + << setw(18) << setprecision(10) << par_S_minus[2] << " # angular mumentum 2" << endl; + + outfile2.close(); +} + +void TwoPunctures::set_initial_guess(derivs v) +{ + + int nvar = 1, n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; + + double *s_x, *s_y, *s_z; // Cartesian x,y,z + double al, A, Am1, be, B, phi, R, r, X; + int ivar, i, j, k, i3D, indx; + derivs U; + FILE *debug_file; + + s_x = (double *)calloc(n1 * n2 * n3, sizeof(double)); + s_y = (double *)calloc(n1 * n2 * n3, sizeof(double)); + s_z = (double *)calloc(n1 * n2 * n3, sizeof(double)); + allocate_derivs(&U, nvar); + for (ivar = 0; ivar < nvar; ivar++) + for (i = 0; i < n1; i++) + for (j = 0; j < n2; j++) + for (k = 0; k < n3; k++) + { + i3D = Index(ivar, i, j, k, 1, n1, n2, n3); + + al = Pih * (2 * i + 1) / n1; + A = -cos(al); + be = Pih * (2 * j + 1) / n2; + B = -cos(be); + phi = 2. * Pi * k / n3; + + /* Calculation of (X,R)*/ + AB_To_XR(nvar, A, B, &X, &R, U); + /* Calculation of (x,r)*/ + C_To_c(nvar, X, R, &(s_x[i3D]), &r, U); + /* Calculation of (y,z)*/ + rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[i3D]), &(s_z[i3D]), U); + } + // Set_Initial_Guess_for_u(n1*n2*n3, v.d0, s_x, s_y, s_z); //extern fortran code to set initial guess + for (ivar = 0; ivar < nvar; ivar++) + for (i = 0; i < n1; i++) + for (j = 0; j < n2; j++) + for (k = 0; k < n3; k++) + { + indx = Index(ivar, i, j, k, 1, n1, n2, n3); + v.d0[indx] = 0; // set initial guess 0 + v.d0[indx] /= (-cos(Pih * (2 * i + 1) / n1) - 1.0); // PRD 70, 064011 (2004) Eq.(5), from u to U + } + Derivatives_AB3_MatMul(nvar, n1, n2, n3, v); + if (0) + { + debug_file = fopen("initial.dat", "w"); + assert(debug_file); + for (ivar = 0; ivar < nvar; ivar++) + for (i = 0; i < n1; i++) + for (j = 0; j < n2; j++) + { + al = Pih * (2 * i + 1) / n1; + A = -cos(al); + Am1 = A - 1.0; + be = Pih * (2 * j + 1) / n2; + B = -cos(be); + phi = 0.0; + indx = Index(ivar, i, j, 0, 1, n1, n2, n3); + U.d0[0] = Am1 * v.d0[indx]; /* U*/ + U.d1[0] = v.d0[indx] + Am1 * v.d1[indx]; /* U_A*/ + U.d2[0] = Am1 * v.d2[indx]; /* U_B*/ + U.d3[0] = Am1 * v.d3[indx]; /* U_3*/ + U.d11[0] = 2 * v.d1[indx] + Am1 * v.d11[indx]; /* U_AA*/ + U.d12[0] = v.d2[indx] + Am1 * v.d12[indx]; /* U_AB*/ + U.d13[0] = v.d3[indx] + Am1 * v.d13[indx]; /* U_AB*/ + U.d22[0] = Am1 * v.d22[indx]; /* U_BB*/ + U.d23[0] = Am1 * v.d23[indx]; /* U_B3*/ + U.d33[0] = Am1 * v.d33[indx]; /* U_33*/ + /* Calculation of (X,R)*/ + AB_To_XR(nvar, A, B, &X, &R, U); + /* Calculation of (x,r)*/ + C_To_c(nvar, X, R, &(s_x[indx]), &r, U); + /* Calculation of (y,z)*/ + rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[indx]), &(s_z[indx]), U); + fprintf(debug_file, + "%.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g " + "%.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g\n", + (double)s_x[indx], (double)s_y[indx], + (double)A, (double)B, + (double)U.d0[0], + (double)(-cos(Pih * (2 * i + 1) / n1) - 1.0), + (double)U.d1[0], + (double)U.d2[0], + (double)U.d3[0], + (double)U.d11[0], + (double)U.d22[0], + (double)U.d33[0], + (double)v.d0[indx], + (double)v.d1[indx], + (double)v.d2[indx], + (double)v.d3[indx], + (double)v.d11[indx], + (double)v.d22[indx], + (double)v.d33[indx]); + } + fprintf(debug_file, "\n\n"); + for (i = n2 - 10; i < n2; i++) + { + double d; + indx = Index(0, 0, i, 0, 1, n1, n2, n3); + d = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, + s_x[indx], 0.0, 0.0); + fprintf(debug_file, "%.16g %.16g\n", + (double)s_x[indx], (double)d); + } + fprintf(debug_file, "\n\n"); + for (i = n2 - 10; i < n2 - 1; i++) + { + double d; + int ip = Index(0, 0, i + 1, 0, 1, n1, n2, n3); + indx = Index(0, 0, i, 0, 1, n1, n2, n3); + for (j = -10; j < 10; j++) + { + d = PunctIntPolAtArbitPosition(0, nvar, n1, n2, n3, v, + s_x[indx] + (s_x[ip] - s_x[indx]) * j / 10, + 0.0, 0.0); + fprintf(debug_file, "%.16g %.16g\n", + (double)(s_x[indx] + (s_x[ip] - s_x[indx]) * j / 10), (double)d); + } + } + fprintf(debug_file, "\n\n"); + for (i = 0; i < n1; i++) + for (j = 0; j < n2; j++) + { + X = 2 * (2.0 * i / n1 - 1.0); + R = 2 * (1.0 * j / n2); + if (X * X + R * R > 1.0) + { + C_To_c(nvar, X, R, &(s_x[indx]), &r, U); + rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[indx]), &(s_z[indx]), U); + *U.d0 = s_x[indx] * s_x[indx]; + *U.d1 = 2 * s_x[indx]; + *U.d2 = 0.0; + *U.d3 = 0.0; + *U.d11 = 2.0; + *U.d22 = 0.0; + *U.d33 = *U.d12 = *U.d23 = *U.d13 = 0.0; + C_To_c(nvar, X, R, &(s_x[indx]), &r, U); + fprintf(debug_file, + "%.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g %.16g\n", + (double)s_x[indx], (double)r, (double)X, (double)R, (double)U.d0[0], + (double)U.d1[0], + (double)U.d2[0], + (double)U.d3[0], + (double)U.d11[0], + (double)U.d22[0], + (double)U.d33[0]); + } + } + fclose(debug_file); + } + free(s_z); + free(s_y); + free(s_x); + free_derivs(&U, nvar); +} + +// some tools +/*---------------------------------------------------------------------------*/ +int TwoPunctures::index(int i, int j, int k, int l, int a, int b, int c, int d) +{ + int rr = 0; + rr = l + k * d + j * d * c + i * d * c * b; + return rr; +} +/*---------------------------------------------------------------------------*/ +int *TwoPunctures::ivector(long nl, long nh) +/* allocate an int vector with subscript range v[nl..nh] */ +{ + int *retval; + + retval = (int *)malloc(sizeof(int) * (nh - nl + 1)); + if (retval == NULL) + cout << "allocation failure in ivector()" << endl; + + return retval - nl; +} + +/*---------------------------------------------------------------------------*/ +double *TwoPunctures::dvector(long nl, long nh) +/* allocate a double vector with subscript range v[nl..nh] */ +{ + double *retval; + + retval = (double *)malloc(sizeof(double) * (nh - nl + 1)); + if (retval == NULL) + cout << "allocation failure in dvector()" << endl; + + return retval - nl; +} + +/*---------------------------------------------------------------------------*/ +int **TwoPunctures::imatrix(long nrl, long nrh, long ncl, long nch) +/* allocate a int matrix with subscript range m[nrl..nrh][ncl..nch] */ +{ + int **retval; + + retval = (int **)malloc(sizeof(int *) * (nrh - nrl + 1)); + if (retval == NULL) + cout << "allocation failure (1) in imatrix()" << endl; + + /* get all memory for the matrix in on chunk */ + retval[0] = (int *)malloc(sizeof(int) * (nrh - nrl + 1) * (nch - ncl + 1)); + if (retval[0] == NULL) + cout << "allocation failure (2) in imatrix()" << endl; + + /* apply column and row offsets */ + retval[0] -= ncl; + retval -= nrl; + + /* slice chunk into rows */ + long width = (nch - ncl + 1); + for (long i = nrl + 1; i <= nrh; i++) + retval[i] = retval[i - 1] + width; + assert(retval[nrh] - retval[nrl] == (nrh - nrl) * width); + + return retval; +} + +/*---------------------------------------------------------------------------*/ +double **TwoPunctures::dmatrix(long nrl, long nrh, long ncl, long nch) +/* allocate a double matrix with subscript range m[nrl..nrh][ncl..nch] */ +{ + double **retval; + + retval = (double **)malloc(sizeof(double *) * (nrh - nrl + 1)); + if (retval == NULL) + cout << "allocation failure (1) in dmatrix()" << endl; + + /* get all memory for the matrix in on chunk */ + retval[0] = (double *)malloc(sizeof(double) * (nrh - nrl + 1) * (nch - ncl + 1)); + if (retval[0] == NULL) + cout << "allocation failure (2) in dmatrix()" << endl; + + /* apply column and row offsets */ + retval[0] -= ncl; + retval -= nrl; + + /* slice chunk into rows */ + long width = (nch - ncl + 1); + for (long i = nrl + 1; i <= nrh; i++) + retval[i] = retval[i - 1] + width; + assert(retval[nrh] - retval[nrl] == (nrh - nrl) * width); + + return retval; +} + +/*---------------------------------------------------------------------------*/ +double ***TwoPunctures::d3tensor(long nrl, long nrh, long ncl, long nch, long ndl, long ndh) +/* allocate a double 3tensor with range t[nrl..nrh][ncl..nch][ndl..ndh] */ +{ + double ***retval; + + /* get memory for index structures */ + retval = (double ***)malloc(sizeof(double **) * (nrh - nrl + 1)); + if (retval == NULL) + cout << "allocation failure (1) in dmatrix()" << endl; + + retval[0] = (double **)malloc(sizeof(double *) * (nrh - nrl + 1) * (nch - ncl + 1)); + if (retval[0] == NULL) + cout << "allocation failure (2) in dmatrix()" << endl; + + /* get all memory for the tensor in on chunk */ + retval[0][0] = (double *)malloc(sizeof(double) * (nrh - nrl + 1) * (nch - ncl + 1) * (nrh - nrl + 1)); + if (retval[0][0] == NULL) + cout << "allocation failure (3) in dmatrix()" << endl; + + /* apply all offsets */ + retval[0][0] -= ndl; + retval[0] -= ncl; + retval -= nrl; + + /* slice chunk into rows and columns */ + long width = (nch - ncl + 1); + long depth = (ndh - ndl + 1); + for (long j = ncl + 1; j <= nch; j++) + { /* first row of columns */ + retval[nrl][j] = retval[nrl][j - 1] + depth; + } + assert(retval[nrl][nch] - retval[nrl][ncl] == (nch - ncl) * depth); + for (long i = nrl + 1; i <= nrh; i++) + { + retval[i] = retval[i - 1] + width; + retval[i][ncl] = retval[i - 1][ncl] + width * depth; /* first cell in column */ + for (long j = ncl + 1; j <= nch; j++) + { + retval[i][j] = retval[i][j - 1] + depth; + } + assert(retval[i][nch] - retval[i][ncl] == (nch - ncl) * depth); + } + assert(retval[nrh] - retval[nrl] == (nrh - nrl) * width); + assert(&retval[nrh][nch][ndh] - &retval[nrl][ncl][ndl] == (nrh - nrl + 1) * (nch - ncl + 1) * (ndh - ndl + 1) - 1); + + return retval; +} + +/*--------------------------------------------------------------------------*/ +void TwoPunctures::free_ivector(int *v, long nl, long nh) +/* free an int vector allocated with ivector() */ +{ + free(v + nl); +} + +/*--------------------------------------------------------------------------*/ +void TwoPunctures::free_dvector(double *v, long nl, long nh) +/* free an double vector allocated with dvector() */ +{ + free(v + nl); +} + +/*--------------------------------------------------------------------------*/ +void TwoPunctures::free_imatrix(int **m, long nrl, long nrh, long ncl, long nch) +/* free an int matrix allocated by imatrix() */ +{ + free(m[nrl] + ncl); + free(m + nrl); +} + +/*--------------------------------------------------------------------------*/ +void TwoPunctures::free_dmatrix(double **m, long nrl, long nrh, long ncl, long nch) +/* free a double matrix allocated by dmatrix() */ +{ + free(m[nrl] + ncl); + free(m + nrl); +} + +/*--------------------------------------------------------------------------*/ +void TwoPunctures::free_d3tensor(double ***t, long nrl, long nrh, long ncl, long nch, + long ndl, long ndh) +/* free a double f3tensor allocated by f3tensor() */ +{ + free(t[nrl][ncl] + ndl); + free(t[nrl] + ncl); + free(t + nrl); +} + +/*--------------------------------------------------------------------------*/ +int TwoPunctures::minimum2(int i, int j) +{ + int result = i; + if (j < result) + result = j; + return result; +} + +/*-------------------------------------------------------------------------*/ +int TwoPunctures::minimum3(int i, int j, int k) +{ + int result = i; + if (j < result) + result = j; + if (k < result) + result = k; + return result; +} + +/*--------------------------------------------------------------------------*/ +int TwoPunctures::maximum2(int i, int j) +{ + int result = i; + if (j > result) + result = j; + return result; +} + +/*--------------------------------------------------------------------------*/ +int TwoPunctures::maximum3(int i, int j, int k) +{ + int result = i; + if (j > result) + result = j; + if (k > result) + result = k; + return result; +} + +/*--------------------------------------------------------------------------*/ +int TwoPunctures::pow_int(int mantisse, int exponent) +{ + int i, result = 1; + + for (i = 1; i <= exponent; i++) + result *= mantisse; + + return result; +} + +/*--------------------------------------------------------------------------*/ +void TwoPunctures::chebft_Zeros(double u[], int n, int inv) +/* eq. 5.8.7 and 5.8.8 at x = (5.8.4) of 2nd edition C++ NR */ +{ + int k, j, isignum; + double fac, sum, Pion, *c; + + c = dvector(0, n); + Pion = Pi / n; + if (inv == 0) + { + fac = 2.0 / n; + isignum = 1; + for (j = 0; j < n; j++) + { + sum = 0.0; + for (k = 0; k < n; k++) + sum += u[k] * cos(Pion * j * (k + 0.5)); + c[j] = fac * sum * isignum; + isignum = -isignum; + } + } + else + { + for (j = 0; j < n; j++) + { + sum = -0.5 * u[0]; + isignum = 1; + for (k = 0; k < n; k++) + { + sum += u[k] * cos(Pion * (j + 0.5) * k) * isignum; + isignum = -isignum; + } + c[j] = sum; + } + } + for (j = 0; j < n; j++) + u[j] = c[j]; + free_dvector(c, 0, n); +} + +/* --------------------------------------------------------------------------*/ +void TwoPunctures::chebft_Extremes(double u[], int n, int inv) +/* eq. 5.8.7 and 5.8.8 at x = (5.8.5) of 2nd edition C++ NR */ +{ + int k, j, isignum, N = n - 1; + double fac, sum, PioN, *c; + + c = dvector(0, N); + PioN = Pi / N; + if (inv == 0) + { + fac = 2.0 / N; + isignum = 1; + for (j = 0; j < n; j++) + { + sum = 0.5 * (u[0] + u[N] * isignum); + for (k = 1; k < N; k++) + sum += u[k] * cos(PioN * j * k); + c[j] = fac * sum * isignum; + isignum = -isignum; + } + c[N] = 0.5 * c[N]; + } + else + { + for (j = 0; j < n; j++) + { + sum = -0.5 * u[0]; + isignum = 1; + for (k = 0; k < n; k++) + { + sum += u[k] * cos(PioN * j * k) * isignum; + isignum = -isignum; + } + c[j] = sum; + } + } + for (j = 0; j < n; j++) + u[j] = c[j]; + free_dvector(c, 0, N); +} + +/* --------------------------------------------------------------------------*/ + +void TwoPunctures::chder(double *c, double *cder, int n) +{ + int j; + + cder[n] = 0.0; + cder[n - 1] = 0.0; + for (j = n - 2; j >= 0; j--) + cder[j] = cder[j + 2] + 2 * (j + 1) * c[j + 1]; +} + +/* --------------------------------------------------------------------------*/ +double TwoPunctures::chebev(double a, double b, double c[], int m, double x) +/* eq. 5.8.11 of C++ NR (2nd ed) */ +{ + int j; + double djp2, djp1, dj; /* d_{j+2}, d_{j+1} and d_j */ + double y; + + /* rescale input to lie within [-1,1] */ + y = 2 * (x - 0.5 * (b + a)) / (b - a); + + dj = djp1 = 0; + for (j = m - 1; j >= 1; j--) + { + /* advance the coefficients */ + djp2 = djp1; + djp1 = dj; + dj = 2 * y * djp1 - djp2 + c[j]; + } + + return y * dj - djp1 + 0.5 * c[0]; +} + +/* --------------------------------------------------------------------------*/ +void TwoPunctures::fourft(double *u, int N, int inv) +/* a (slow) Fourier transform, seems to be just eq. 12.1.6 and 12.1.9 of C++ NR (2nd ed) */ +{ + int l, k, iy, M; + double x, x1, fac, Pi_fac, *a, *b; + + M = N / 2; + a = dvector(0, M); + b = dvector(1, M); /* Actually: b=vector(1,M-1) but this is problematic if M=1*/ + fac = 1. / M; + Pi_fac = Pi * fac; + if (inv == 0) + { + for (l = 0; l <= M; l++) + { + a[l] = 0; + if (l > 0 && l < M) + b[l] = 0; + x1 = Pi_fac * l; + for (k = 0; k < N; k++) + { + x = x1 * k; + a[l] += fac * u[k] * cos(x); + if (l > 0 && l < M) + b[l] += fac * u[k] * sin(x); + } + } + u[0] = a[0]; + u[M] = a[M]; + for (l = 1; l < M; l++) + { + u[l] = a[l]; + u[l + M] = b[l]; + } + } + else + { + a[0] = u[0]; + a[M] = u[M]; + for (l = 1; l < M; l++) + { + a[l] = u[l]; + b[l] = u[M + l]; + } + iy = 1; + for (k = 0; k < N; k++) + { + u[k] = 0.5 * (a[0] + a[M] * iy); + x1 = Pi_fac * k; + for (l = 1; l < M; l++) + { + x = x1 * l; + u[k] += a[l] * cos(x) + b[l] * sin(x); + } + iy = -iy; + } + } + free_dvector(a, 0, M); + free_dvector(b, 1, M); +} + +/* -----------------------------------------*/ +void TwoPunctures::fourder(double u[], double du[], int N) +{ + int l, M, lpM; + + M = N / 2; + du[0] = 0.; + du[M] = 0.; + for (l = 1; l < M; l++) + { + lpM = l + M; + du[l] = u[lpM] * l; + du[lpM] = -u[l] * l; + } +} + +/* -----------------------------------------*/ +void TwoPunctures::fourder2(double u[], double d2u[], int N) +{ + int l, l2, M, lpM; + + d2u[0] = 0.; + M = N / 2; + for (l = 1; l <= M; l++) + { + l2 = l * l; + lpM = l + M; + d2u[l] = -u[l] * l2; + if (l < M) + d2u[lpM] = -u[lpM] * l2; + } +} + +/* ----------------------------------------- */ +double TwoPunctures::fourev(double *u, int N, double x) +{ + int l, M = N / 2; + double xl, result; + + result = 0.5 * (u[0] + u[M] * cos(x * M)); + for (l = 1; l < M; l++) + { + xl = x * l; + result += u[l] * cos(xl) + u[M + l] * sin(xl); + } + return result; +} + +/* ------------------------------------------------------------------------*/ +double TwoPunctures::norm1(double *v, int n) +{ + int i; + double result = -1; + + for (i = 0; i < n; i++) + if (fabs(v[i]) > result) + result = fabs(v[i]); + + return result; +} + +/* -------------------------------------------------------------------------*/ +double TwoPunctures::norm2(double *v, int n) +{ + // Optimized with oneMKL BLAS DNRM2 + // Computes: sqrt(sum(v[i]^2)) + return cblas_dnrm2(n, v, 1); +} + +/* -------------------------------------------------------------------------*/ +double TwoPunctures::scalarproduct(double *v, double *w, int n) +{ + // Optimized with oneMKL BLAS DDOT + // Computes: sum(v[i] * w[i]) + return cblas_ddot(n, v, 1, w, 1); +} + +/* -------------------------------------------------------------------------*/ +/* Calculates the value of v at an arbitrary position (x,y,z)*/ +double TwoPunctures::PunctIntPolAtArbitPosition(int ivar, int nvar, int n1, + int n2, int n3, derivs v, double x, double y, + double z) +{ + double xs, ys, zs, rs2, phi, X, R, A, B, aux1, aux2, result, Ui; + + xs = x / par_b; + ys = y / par_b; + zs = z / par_b; + rs2 = ys * ys + zs * zs; + phi = atan2(z, y); + if (phi < 0) + phi += 2 * Pi; + + aux1 = 0.5 * (xs * xs + rs2 - 1); + aux2 = sqrt(aux1 * aux1 + rs2); + X = asinh(sqrt(aux1 + aux2)); + R = asin(min(1.0, sqrt(-aux1 + aux2))); + if (x < 0) + R = Pi - R; + + A = 2 * tanh(0.5 * X) - 1; + B = tan(0.5 * R - Piq); + + result = PunctEvalAtArbitPosition(v.d0, ivar, A, B, phi, nvar, n1, n2, n3); + + Ui = (A - 1) * result; + + return Ui; +} +/* Calculates the value of v at an arbitrary position (A,B,phi)*/ +double TwoPunctures::PunctEvalAtArbitPosition(double *v, int ivar, double A, double B, double phi, + int nvar, int n1, int n2, int n3) +{ + int i, j, k, N; + double *p, *values1, **values2, result; + + N = maximum3(n1, n2, n3); + p = dvector(0, N); + values1 = dvector(0, N); + values2 = dmatrix(0, N, 0, N); + + for (k = 0; k < n3; k++) + { + for (j = 0; j < n2; j++) + { + for (i = 0; i < n1; i++) + p[i] = v[ivar + nvar * (i + n1 * (j + n2 * k))]; + chebft_Zeros(p, n1, 0); + values2[j][k] = chebev(-1, 1, p, n1, A); + } + } + + for (k = 0; k < n3; k++) + { + for (j = 0; j < n2; j++) + p[j] = values2[j][k]; + chebft_Zeros(p, n2, 0); + values1[k] = chebev(-1, 1, p, n2, B); + } + + fourft(values1, n3, 0); + result = fourev(values1, n3, phi); + + free_dvector(p, 0, N); + free_dvector(values1, 0, N); + free_dmatrix(values2, 0, N, 0, N); + + return result; +} +/*-----------------------------------------------------------*/ +void TwoPunctures::AB_To_XR(int nvar, double A, double B, double *X, double *R, + derivs U) +/* On Entrance: U.d0[]=U[]; U.d1[] =U[]_A; U.d2[] =U[]_B; U.d3[] =U[]_3; */ +/* U.d11[]=U[]_AA; U.d12[]=U[]_AB; U.d13[]=U[]_A3; */ +/* U.d22[]=U[]_BB; U.d23[]=U[]_B3; U.d33[]=U[]_33; */ +/* At Exit: U.d0[]=U[]; U.d1[] =U[]_X; U.d2[] =U[]_R; U.d3[] =U[]_3; */ +/* U.d11[]=U[]_XX; U.d12[]=U[]_XR; U.d13[]=U[]_X3; */ +/* U.d22[]=U[]_RR; U.d23[]=U[]_R3; U.d33[]=U[]_33; */ +{ + double At = 0.5 * (A + 1), A_X, A_XX, B_R, B_RR; + int ivar; + + *X = 2 * atanh(At); + *R = Pih + 2 * atan(B); + + A_X = 1 - At * At; + A_XX = -At * A_X; + B_R = 0.5 * (1 + B * B); + B_RR = B * B_R; + + for (ivar = 0; ivar < nvar; ivar++) + { + U.d11[ivar] = A_X * A_X * U.d11[ivar] + A_XX * U.d1[ivar]; + U.d12[ivar] = A_X * B_R * U.d12[ivar]; + U.d13[ivar] = A_X * U.d13[ivar]; + U.d22[ivar] = B_R * B_R * U.d22[ivar] + B_RR * U.d2[ivar]; + U.d23[ivar] = B_R * U.d23[ivar]; + U.d1[ivar] = A_X * U.d1[ivar]; + U.d2[ivar] = B_R * U.d2[ivar]; + } +} +/*-----------------------------------------------------------*/ +void TwoPunctures::C_To_c(int nvar, double X, double R, double *x, double *r, + derivs U) +/* On Entrance: U.d0[]=U[]; U.d1[] =U[]_X; U.d2[] =U[]_R; U.d3[] =U[]_3; */ +/* U.d11[]=U[]_XX; U.d12[]=U[]_XR; U.d13[]=U[]_X3; */ +/* U.d22[]=U[]_RR; U.d23[]=U[]_R3; U.d33[]=U[]_33; */ +/* At Exit: U.d0[]=U[]; U.d1[] =U[]_x; U.d2[] =U[]_r; U.d3[] =U[]_3; */ +/* U.d11[]=U[]_xx; U.d12[]=U[]_xr; U.d13[]=U[]_x3; */ +/* U.d22[]=U[]_rr; U.d23[]=U[]_r3; U.d33[]=U[]_33; */ +{ + double C_c2, U_cb, U_CB; + complex C, C_c, C_cc, c, c_C, c_CC, U_c, U_cc, U_C, U_CC; + int ivar; + + C = complex(X, R); + + c = cosh(C) * par_b; /* c=b*cosh(C)*/ + c_C = sinh(C) * par_b; + c_CC = c; + + C_c = complex(1, 0) / c_C; + C_cc = -C_c * C_c * C_c * c_CC; + C_c2 = abs(C_c); + C_c2 = C_c2 * C_c2; + + for (ivar = 0; ivar < nvar; ivar++) + { + /* U_C = 0.5*(U_X3-i*U_R3)*/ + /* U_c = U_C*C_c = 0.5*(U_x3-i*U_r3)*/ + U_C = complex(0.5 * U.d13[ivar], -0.5 * U.d23[ivar]); + U_c = U_C * C_c; + U.d13[ivar] = 2. * real(U_c); + U.d23[ivar] = -2. * imag(U_c); + + /* U_C = 0.5*(U_X-i*U_R)*/ + /* U_c = U_C*C_c = 0.5*(U_x-i*U_r)*/ + U_C = complex(0.5 * U.d1[ivar], -0.5 * U.d2[ivar]); + U_c = U_C * C_c; + U.d1[ivar] = 2. * real(U_c); + U.d2[ivar] = -2. * imag(U_c); + + /* U_CC = 0.25*(U_XX-U_RR-2*i*U_XR)*/ + /* U_CB = d^2(U)/(dC*d\bar{C}) = 0.25*(U_XX+U_RR)*/ + U_CC = complex(0.25 * (U.d11[ivar] - U.d22[ivar]), -0.5 * U.d12[ivar]); + U_CB = 0.25 * (U.d11[ivar] + U.d22[ivar]); + + /* U_cc = C_cc*U_C+(C_c)^2*U_CC*/ + U_cb = U_CB * C_c2; + U_cc = C_cc * U_C + C_c * C_c * U_CC; + + /* U_xx = 2*(U_cb+Re[U_cc])*/ + /* U_rr = 2*(U_cb-Re[U_cc])*/ + /* U_rx = -2*Im[U_cc]*/ + U.d11[ivar] = 2 * (U_cb + real(U_cc)); + U.d22[ivar] = 2 * (U_cb - real(U_cc)); + U.d12[ivar] = -2 * imag(U_cc); + } + + *x = real(c); + *r = imag(c); +} +/*-----------------------------------------------------------*/ +void TwoPunctures::rx3_To_xyz(int nvar, double x, double r, double phi, + double *y, double *z, derivs U) +/* On Entrance: U.d0[]=U[]; U.d1[] =U[]_x; U.d2[] =U[]_r; U.d3[] =U[]_3; */ +/* U.d11[]=U[]_xx; U.d12[]=U[]_xr; U.d13[]=U[]_x3; */ +/* U.d22[]=U[]_rr; U.d23[]=U[]_r3; U.d33[]=U[]_33; */ +/* At Exit: U.d0[]=U[]; U.d1[] =U[]_x; U.d2[] =U[]_y; U.dz[] =U[]_z; */ +/* U.d11[]=U[]_xx; U.d12[]=U[]_xy; U.d1z[]=U[]_xz; */ +/* U.d22[]=U[]_yy; U.d2z[]=U[]_yz; U.dzz[]=U[]_zz; */ +{ + int jvar; + double + sin_phi = sin(phi), + cos_phi = cos(phi), + sin2_phi = sin_phi * sin_phi, + cos2_phi = cos_phi * cos_phi, + sin_2phi = 2 * sin_phi * cos_phi, + cos_2phi = cos2_phi - sin2_phi, r_inv = 1 / r, r_inv2 = r_inv * r_inv; + + *y = r * cos_phi; + *z = r * sin_phi; + + for (jvar = 0; jvar < nvar; jvar++) + { + double U_x = U.d1[jvar], U_r = U.d2[jvar], U_3 = U.d3[jvar], + U_xx = U.d11[jvar], U_xr = U.d12[jvar], U_x3 = U.d13[jvar], + U_rr = U.d22[jvar], U_r3 = U.d23[jvar], U_33 = U.d33[jvar]; + U.d1[jvar] = U_x; /* U_x*/ + U.d2[jvar] = U_r * cos_phi - U_3 * r_inv * sin_phi; /* U_y*/ + U.d3[jvar] = U_r * sin_phi + U_3 * r_inv * cos_phi; /* U_z*/ + U.d11[jvar] = U_xx; /* U_xx*/ + U.d12[jvar] = U_xr * cos_phi - U_x3 * r_inv * sin_phi; /* U_xy*/ + U.d13[jvar] = U_xr * sin_phi + U_x3 * r_inv * cos_phi; /* U_xz*/ + U.d22[jvar] = U_rr * cos2_phi + r_inv2 * sin2_phi * (U_33 + r * U_r) /* U_yy*/ + + sin_2phi * r_inv2 * (U_3 - r * U_r3); + U.d23[jvar] = 0.5 * sin_2phi * (U_rr - r_inv * U_r - r_inv2 * U_33) /* U_yz*/ + - cos_2phi * r_inv2 * (U_3 - r * U_r3); + U.d33[jvar] = U_rr * sin2_phi + r_inv2 * cos2_phi * (U_33 + r * U_r) /* U_zz*/ + - sin_2phi * r_inv2 * (U_3 - r * U_r3); + } +} +/* --------------------------------------------------------------------------*/ +void TwoPunctures::Derivatives_AB3(int nvar, int n1, int n2, int n3, derivs v) +{ + int i, j, k, ivar, N, *indx; + double *p, *dp, *d2p, *q, *dq, *r, *dr; + + N = maximum3(n1, n2, n3); + p = dvector(0, N); + dp = dvector(0, N); + d2p = dvector(0, N); + q = dvector(0, N); + dq = dvector(0, N); + r = dvector(0, N); + dr = dvector(0, N); + indx = ivector(0, N); + + for (ivar = 0; ivar < nvar; ivar++) + { + for (k = 0; k < n3; k++) + { /* Calculation of Derivatives w.r.t. A-Dir. */ + for (j = 0; j < n2; j++) + { /* (Chebyshev_Zeros)*/ + for (i = 0; i < n1; i++) + { + indx[i] = Index(ivar, i, j, k, nvar, n1, n2, n3); + p[i] = v.d0[indx[i]]; + } + chebft_Zeros(p, n1, 0); + chder(p, dp, n1); + chder(dp, d2p, n1); + chebft_Zeros(dp, n1, 1); + chebft_Zeros(d2p, n1, 1); + for (i = 0; i < n1; i++) + { + v.d1[indx[i]] = dp[i]; + v.d11[indx[i]] = d2p[i]; + } + } + } + for (k = 0; k < n3; k++) + { /* Calculation of Derivatives w.r.t. B-Dir. */ + for (i = 0; i < n1; i++) + { /* (Chebyshev_Zeros)*/ + for (j = 0; j < n2; j++) + { + indx[j] = Index(ivar, i, j, k, nvar, n1, n2, n3); + p[j] = v.d0[indx[j]]; + q[j] = v.d1[indx[j]]; + } + chebft_Zeros(p, n2, 0); + chebft_Zeros(q, n2, 0); + chder(p, dp, n2); + chder(dp, d2p, n2); + chder(q, dq, n2); + chebft_Zeros(dp, n2, 1); + chebft_Zeros(d2p, n2, 1); + chebft_Zeros(dq, n2, 1); + for (j = 0; j < n2; j++) + { + v.d2[indx[j]] = dp[j]; + v.d22[indx[j]] = d2p[j]; + v.d12[indx[j]] = dq[j]; + } + } + } + for (i = 0; i < n1; i++) + { /* Calculation of Derivatives w.r.t. phi-Dir. (Fourier)*/ + for (j = 0; j < n2; j++) + { + for (k = 0; k < n3; k++) + { + indx[k] = Index(ivar, i, j, k, nvar, n1, n2, n3); + p[k] = v.d0[indx[k]]; + q[k] = v.d1[indx[k]]; + r[k] = v.d2[indx[k]]; + } + fourft(p, n3, 0); + fourder(p, dp, n3); + fourder2(p, d2p, n3); + fourft(dp, n3, 1); + fourft(d2p, n3, 1); + fourft(q, n3, 0); + fourder(q, dq, n3); + fourft(dq, n3, 1); + fourft(r, n3, 0); + fourder(r, dr, n3); + fourft(dr, n3, 1); + for (k = 0; k < n3; k++) + { + v.d3[indx[k]] = dp[k]; + v.d33[indx[k]] = d2p[k]; + v.d13[indx[k]] = dq[k]; + v.d23[indx[k]] = dr[k]; + } + } + } + } + free_dvector(p, 0, N); + free_dvector(dp, 0, N); + free_dvector(d2p, 0, N); + free_dvector(q, 0, N); + free_dvector(dq, 0, N); + free_dvector(r, 0, N); + free_dvector(dr, 0, N); + free_ivector(indx, 0, N); +} +/* --------------------------------------------------------------------------*/ +void TwoPunctures::Newton(int const nvar, int const n1, int const n2, int const n3, + derivs v, double const tol, int const itmax) +{ + int ntotal = n1 * n2 * n3 * nvar, ii, it; + double *F, dmax, normres; + derivs u, dv; + + F = dvector(0, ntotal - 1); + allocate_derivs(&dv, ntotal); + allocate_derivs(&u, ntotal); + + it = 0; + dmax = 1; + while (dmax > tol && it < itmax) + { + if (it == 0) + { + F_of_v(nvar, n1, n2, n3, v, F, u); + dmax = norm_inf(F, ntotal); + } + for (int j = 0; j < ntotal; j++) + dv.d0[j] = 0; + + { + printf("Newton: it=%d \t |F|=%e\n", it, (double)dmax); + printf("bare mass: mp=%g \t mm=%g\n", (double)par_m_plus, (double)par_m_minus); + } + + fflush(stdout); + ii = bicgstab(nvar, n1, n2, n3, v, dv, 100, dmax * 1.e-3, &normres); + + for (int j = 0; j < ntotal; j++) + v.d0[j] -= dv.d0[j]; + F_of_v(nvar, n1, n2, n3, v, F, u); + dmax = norm_inf(F, ntotal); + it += 1; + } + if (itmax == 0) + { + F_of_v(nvar, n1, n2, n3, v, F, u); + dmax = norm_inf(F, ntotal); + } + + printf("Newton: it=%d \t |F|=%e \n", it, (double)dmax); + + fflush(stdout); + + free_dvector(F, 0, ntotal - 1); + free_derivs(&dv, ntotal); + free_derivs(&u, ntotal); +} +#define FAC sin(al) * sin(be) * sin(al) * sin(be) * sin(al) * sin(be) +/* --------------------------------------------------------------------------*/ +void TwoPunctures::F_of_v(int nvar, int n1, int n2, int n3, derivs v, double *F, + derivs u) +{ + /* Calculates the left hand sides of the non-linear equations F_m(v_n)=0*/ + /* and the function u (u.d0[]) as well as its derivatives*/ + /* (u.d1[], u.d2[], u.d3[], u.d11[], u.d12[], u.d13[], u.d22[], u.d23[], u.d33[])*/ + /* at interior points and at the boundaries "+/-"*/ + + int i, j, k, ivar, indx; + double al, be, A, B, X, R, x, r, phi, y, z, Am1, *values; + derivs U; + double *sources; + + sources = (double *)calloc(n1 * n2 * n3, sizeof(double)); + if (0) + { + double *s_x, *s_y, *s_z; + int i3D; + s_x = (double *)calloc(n1 * n2 * n3, sizeof(double)); + s_y = (double *)calloc(n1 * n2 * n3, sizeof(double)); + s_z = (double *)calloc(n1 * n2 * n3, sizeof(double)); + for (i = 0; i < n1; i++) + for (j = 0; j < n2; j++) + for (k = 0; k < n3; k++) + { + i3D = Index(0, i, j, k, 1, n1, n2, n3); + + al = Pih * (2 * i + 1) / n1; + A = -cos(al); + be = Pih * (2 * j + 1) / n2; + B = -cos(be); + phi = 2. * Pi * k / n3; + + Am1 = A - 1; + for (ivar = 0; ivar < nvar; ivar++) + { + indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + U.d0[ivar] = Am1 * v.d0[indx]; /* U*/ + U.d1[ivar] = v.d0[indx] + Am1 * v.d1[indx]; /* U_A*/ + U.d2[ivar] = Am1 * v.d2[indx]; /* U_B*/ + U.d3[ivar] = Am1 * v.d3[indx]; /* U_3*/ + U.d11[ivar] = 2 * v.d1[indx] + Am1 * v.d11[indx]; /* U_AA*/ + U.d12[ivar] = v.d2[indx] + Am1 * v.d12[indx]; /* U_AB*/ + U.d13[ivar] = v.d3[indx] + Am1 * v.d13[indx]; /* U_AB*/ + U.d22[ivar] = Am1 * v.d22[indx]; /* U_BB*/ + U.d23[ivar] = Am1 * v.d23[indx]; /* U_B3*/ + U.d33[ivar] = Am1 * v.d33[indx]; /* U_33*/ + } + /* Calculation of (X,R) and*/ + /* (U_X, U_R, U_3, U_XX, U_XR, U_X3, U_RR, U_R3, U_33)*/ + AB_To_XR(nvar, A, B, &X, &R, U); + /* Calculation of (x,r) and*/ + /* (U, U_x, U_r, U_3, U_xx, U_xr, U_x3, U_rr, U_r3, U_33)*/ + C_To_c(nvar, X, R, &(s_x[i3D]), &r, U); + /* Calculation of (y,z) and*/ + /* (U, U_x, U_y, U_z, U_xx, U_xy, U_xz, U_yy, U_yz, U_zz)*/ + rx3_To_xyz(nvar, s_x[i3D], r, phi, &(s_y[i3D]), &(s_z[i3D]), U); + } + // Set_Rho_ADM(cctkGH, n1*n2*n3, sources, s_x, s_y, s_z); //external fortran code + free(s_z); + free(s_y); + free(s_x); + } + else + for (i = 0; i < n1; i++) + for (j = 0; j < n2; j++) + for (k = 0; k < n3; k++) + sources[Index(0, i, j, k, 1, n1, n2, n3)] = 0.0; + + Derivatives_AB3_MatMul(nvar, n1, n2, n3, v); + double psi, psi2, psi4, psi7, r_plus, r_minus; + FILE *debugfile = NULL; + if (0) + { + debugfile = fopen("res.dat", "w"); + assert(debugfile); + } + #pragma omp parallel for collapse(3) schedule(dynamic,1) \ + private(i, j, k, ivar, indx, al, be, A, B, X, R, x, r, phi, y, z, Am1, \ + psi, psi2, psi4, psi7, r_plus, r_minus) + for (i = 0; i < n1; i++) + { + for (j = 0; j < n2; j++) + { + for (k = 0; k < n3; k++) + { + double l_values[1]; // nvar=1, stack-allocated + derivs l_U; + double l_U_d0[1], l_U_d1[1], l_U_d2[1], l_U_d3[1]; + double l_U_d11[1], l_U_d12[1], l_U_d13[1], l_U_d22[1], l_U_d23[1], l_U_d33[1]; + l_U.d0 = l_U_d0; l_U.d1 = l_U_d1; l_U.d2 = l_U_d2; l_U.d3 = l_U_d3; + l_U.d11 = l_U_d11; l_U.d12 = l_U_d12; l_U.d13 = l_U_d13; + l_U.d22 = l_U_d22; l_U.d23 = l_U_d23; l_U.d33 = l_U_d33; + + al = Pih * (2 * i + 1) / n1; + A = -cos(al); + be = Pih * (2 * j + 1) / n2; + B = -cos(be); + phi = 2. * Pi * k / n3; + + Am1 = A - 1; + for (ivar = 0; ivar < nvar; ivar++) + { + indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + l_U.d0[ivar] = Am1 * v.d0[indx]; + l_U.d1[ivar] = v.d0[indx] + Am1 * v.d1[indx]; + l_U.d2[ivar] = Am1 * v.d2[indx]; + l_U.d3[ivar] = Am1 * v.d3[indx]; + l_U.d11[ivar] = 2 * v.d1[indx] + Am1 * v.d11[indx]; + l_U.d12[ivar] = v.d2[indx] + Am1 * v.d12[indx]; + l_U.d13[ivar] = v.d3[indx] + Am1 * v.d13[indx]; + l_U.d22[ivar] = Am1 * v.d22[indx]; + l_U.d23[ivar] = Am1 * v.d23[indx]; + l_U.d33[ivar] = Am1 * v.d33[indx]; + } + AB_To_XR(nvar, A, B, &X, &R, l_U); + C_To_c(nvar, X, R, &x, &r, l_U); + rx3_To_xyz(nvar, x, r, phi, &y, &z, l_U); + NonLinEquations(sources[Index(0, i, j, k, 1, n1, n2, n3)], + A, B, X, R, x, r, phi, y, z, l_U, l_values); + for (ivar = 0; ivar < nvar; ivar++) + { + indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + F[indx] = l_values[ivar] * sin(al) * sin(be) * sin(al) * sin(be) * sin(al) * sin(be); + u.d0[indx] = l_U.d0[ivar]; + u.d1[indx] = l_U.d1[ivar]; + u.d2[indx] = l_U.d2[ivar]; + u.d3[indx] = l_U.d3[ivar]; + u.d11[indx] = l_U.d11[ivar]; + u.d12[indx] = l_U.d12[ivar]; + u.d13[indx] = l_U.d13[ivar]; + u.d22[indx] = l_U.d22[ivar]; + u.d23[indx] = l_U.d23[ivar]; + u.d33[indx] = l_U.d33[ivar]; + } + } + } + } + if (debugfile) + { + fclose(debugfile); + } + free(sources); +} +/* --------------------------------------------------------------------------*/ +double TwoPunctures::norm_inf(double const *F, int const ntotal) +{ + double dmax = -1; + { + double dmax1 = -1; + for (int j = 0; j < ntotal; j++) + if (fabs(F[j]) > dmax1) + dmax1 = fabs(F[j]); + if (dmax1 > dmax) + dmax = dmax1; + } + return dmax; +} +/* --------------------------------------------------------------------------*/ +int TwoPunctures::bicgstab(int const nvar, int const n1, int const n2, int const n3, + derivs v, derivs dv, int const itmax, double const tol, + double *normres) +{ + int const output = 1; + int ntotal = n1 * n2 * n3 * nvar, ii; + double alpha = 0, beta = 0; + double rho = 0, rho1 = 1, rhotol = 1e-50; + double omega = 0, omegatol = 1e-50; + double *p, *rt, *s, *t, *r, *vv; + double **JFD; + int **cols, *ncols, maxcol = StencilSize * nvar; + double *F; + derivs u, ph, sh; + + F = dvector(0, ntotal - 1); + allocate_derivs(&u, ntotal); + + JFD = dmatrix(0, ntotal - 1, 0, maxcol - 1); + cols = imatrix(0, ntotal - 1, 0, maxcol - 1); + ncols = ivector(0, ntotal - 1); + + F_of_v(nvar, n1, n2, n3, v, F, u); + SetMatrix_JFD(nvar, n1, n2, n3, u, ncols, cols, JFD); + + /* temporary storage */ + r = dvector(0, ntotal - 1); + p = dvector(0, ntotal - 1); + allocate_derivs(&ph, ntotal); + /* ph = dvector(0, ntotal-1);*/ + rt = dvector(0, ntotal - 1); + s = dvector(0, ntotal - 1); + allocate_derivs(&sh, ntotal); + /* sh = dvector(0, ntotal-1);*/ + t = dvector(0, ntotal - 1); + vv = dvector(0, ntotal - 1); + + /* check */ + if (output == 1) + { + printf("bicgstab: itmax %d, tol %e\n", itmax, (double)tol); + fflush(stdout); + } + + /* compute initial residual rt = r = F - J*dv */ + J_times_dv(nvar, n1, n2, n3, dv, r, u); + for (int j = 0; j < ntotal; j++) + rt[j] = r[j] = F[j] - r[j]; + + *normres = norm2(r, ntotal); + if (output == 1) + { + printf("bicgstab: %5d %10.3e\n", 0, (double)*normres); + fflush(stdout); + } + + if (*normres <= tol) + return 0; + + /* cgs iteration */ + for (ii = 0; ii < itmax; ii++) + { + rho = scalarproduct(rt, r, ntotal); + if (fabs(rho) < rhotol) + break; + + /* compute direction vector p */ + if (ii == 0) + { + for (int j = 0; j < ntotal; j++) + p[j] = r[j]; + } + else + { + beta = (rho / rho1) * (alpha / omega); + for (int j = 0; j < ntotal; j++) + p[j] = r[j] + beta * (p[j] - omega * vv[j]); + } + + /* compute direction adjusting vector ph and scalar alpha */ + for (int j = 0; j < ntotal; j++) + ph.d0[j] = 0; + for (int j = 0; j < NRELAX; j++) /* solves JFD*ph = p by relaxation*/ + relax_omp(ph.d0, nvar, n1, n2, n3, p, ncols, cols, JFD); + + J_times_dv(nvar, n1, n2, n3, ph, vv, u); /* vv=J*ph*/ + alpha = rho / scalarproduct(rt, vv, ntotal); + for (int j = 0; j < ntotal; j++) + s[j] = r[j] - alpha * vv[j]; + + /* early check of tolerance */ + *normres = norm2(s, ntotal); + if (*normres <= tol) + { + for (int j = 0; j < ntotal; j++) + dv.d0[j] += alpha * ph.d0[j]; + if (output == 1) + { + printf("bicgstab: %5d %10.3e %10.3e %10.3e %10.3e\n", + ii + 1, (double)*normres, (double)alpha, (double)beta, (double)omega); + fflush(stdout); + } + break; + } + + /* compute stabilizer vector sh and scalar omega */ + for (int j = 0; j < ntotal; j++) + sh.d0[j] = 0; + for (int j = 0; j < NRELAX; j++) /* solves JFD*sh = s by relaxation*/ + relax_omp(sh.d0, nvar, n1, n2, n3, s, ncols, cols, JFD); + + J_times_dv(nvar, n1, n2, n3, sh, t, u); /* t=J*sh*/ + omega = scalarproduct(t, s, ntotal) / scalarproduct(t, t, ntotal); + + /* compute new solution approximation */ + for (int j = 0; j < ntotal; j++) + { + dv.d0[j] += alpha * ph.d0[j] + omega * sh.d0[j]; + r[j] = s[j] - omega * t[j]; + } + /* are we done? */ + *normres = norm2(r, ntotal); + if (output == 1) + { + printf("bicgstab: %5d %10.3e %10.3e %10.3e %10.3e\n", + ii + 1, (double)*normres, (double)alpha, (double)beta, (double)omega); + fflush(stdout); + } + if (*normres <= tol) + break; + rho1 = rho; + if (fabs(omega) < omegatol) + break; + } + + /* free temporary storage */ + free_dvector(r, 0, ntotal - 1); + free_dvector(p, 0, ntotal - 1); + /* free_dvector(ph, 0, ntotal-1);*/ + free_derivs(&ph, ntotal); + free_dvector(rt, 0, ntotal - 1); + free_dvector(s, 0, ntotal - 1); + /* free_dvector(sh, 0, ntotal-1);*/ + free_derivs(&sh, ntotal); + free_dvector(t, 0, ntotal - 1); + free_dvector(vv, 0, ntotal - 1); + + free_dvector(F, 0, ntotal - 1); + free_derivs(&u, ntotal); + + free_dmatrix(JFD, 0, ntotal - 1, 0, maxcol - 1); + free_imatrix(cols, 0, ntotal - 1, 0, maxcol - 1); + free_ivector(ncols, 0, ntotal - 1); + + /* iteration failed */ + if (ii > itmax) + return -1; + + /* breakdown */ + if (fabs(rho) < rhotol) + return -10; + if (fabs(omega) < omegatol) + return -11; + + /* success! */ + return ii + 1; +} +/* --------------------------------------------------------------------------*/ +void TwoPunctures::allocate_derivs(derivs *v, int n) +{ + int m = n - 1; + (*v).d0 = dvector(0, m); + (*v).d1 = dvector(0, m); + (*v).d2 = dvector(0, m); + (*v).d3 = dvector(0, m); + (*v).d11 = dvector(0, m); + (*v).d12 = dvector(0, m); + (*v).d13 = dvector(0, m); + (*v).d22 = dvector(0, m); + (*v).d23 = dvector(0, m); + (*v).d33 = dvector(0, m); +} + +/* --------------------------------------------------------------------------*/ +void TwoPunctures::free_derivs(derivs *v, int n) +{ + int m = n - 1; + free_dvector((*v).d0, 0, m); + free_dvector((*v).d1, 0, m); + free_dvector((*v).d2, 0, m); + free_dvector((*v).d3, 0, m); + free_dvector((*v).d11, 0, m); + free_dvector((*v).d12, 0, m); + free_dvector((*v).d13, 0, m); + free_dvector((*v).d22, 0, m); + free_dvector((*v).d23, 0, m); + free_dvector((*v).d33, 0, m); +} +/* --------------------------------------------------------------------------*/ +int TwoPunctures::Index(int ivar, int i, int j, int k, int nvar, int n1, int n2, int n3) +{ + int i1 = i, j1 = j, k1 = k; + + if (i1 < 0) + i1 = -(i1 + 1); + if (i1 >= n1) + i1 = 2 * n1 - (i1 + 1); + + if (j1 < 0) + j1 = -(j1 + 1); + if (j1 >= n2) + j1 = 2 * n2 - (j1 + 1); + + if (k1 < 0) + k1 = k1 + n3; + if (k1 >= n3) + k1 = k1 - n3; + + return ivar + nvar * (i1 + n1 * (j1 + n2 * k1)); +} +/*-----------------------------------------------------------*/ +/******** Nonlinear Equations ***********/ +/*-----------------------------------------------------------*/ +void TwoPunctures::NonLinEquations(double rho_adm, + double A, double B, double X, double R, + double x, double r, double phi, + double y, double z, derivs U, double *values) +{ + double r_plus, r_minus, psi, psi2, psi4, psi7; + double mu; + + r_plus = sqrt((x - par_b) * (x - par_b) + y * y + z * z); + r_minus = sqrt((x + par_b) * (x + par_b) + y * y + z * z); + + psi = 1. + 0.5 * par_m_plus / r_plus + 0.5 * par_m_minus / r_minus + U.d0[0]; + psi2 = psi * psi; + psi4 = psi2 * psi2; + psi7 = psi * psi2 * psi4; + + values[0] = U.d11[0] + U.d22[0] + U.d33[0] + 0.125 * BY_KKofxyz(x, y, z) / psi7 + 2.0 * Pi / psi2 / psi * rho_adm; +} +double TwoPunctures::BY_KKofxyz(double x, double y, double z) +{ + int i, j; + double r_plus, r2_plus, r3_plus, r_minus, r2_minus, r3_minus, np_Pp, nm_Pm, + Aij, AijAij, n_plus[3], n_minus[3], np_Sp[3], nm_Sm[3]; + + r2_plus = (x - par_b) * (x - par_b) + y * y + z * z; + r2_minus = (x + par_b) * (x + par_b) + y * y + z * z; + r_plus = sqrt(r2_plus); + r_minus = sqrt(r2_minus); + r3_plus = r_plus * r2_plus; + r3_minus = r_minus * r2_minus; + + n_plus[0] = (x - par_b) / r_plus; + n_minus[0] = (x + par_b) / r_minus; + n_plus[1] = y / r_plus; + n_minus[1] = y / r_minus; + n_plus[2] = z / r_plus; + n_minus[2] = z / r_minus; + + /* dot product: np_Pp = (n_+).(P_+); nm_Pm = (n_-).(P_-) */ + np_Pp = 0; + nm_Pm = 0; + for (i = 0; i < 3; i++) + { + np_Pp += n_plus[i] * par_P_plus[i]; + nm_Pm += n_minus[i] * par_P_minus[i]; + } + /* cross product: np_Sp[i] = [(n_+) x (S_+)]_i; nm_Sm[i] = [(n_-) x (S_-)]_i*/ + np_Sp[0] = n_plus[1] * par_S_plus[2] - n_plus[2] * par_S_plus[1]; + np_Sp[1] = n_plus[2] * par_S_plus[0] - n_plus[0] * par_S_plus[2]; + np_Sp[2] = n_plus[0] * par_S_plus[1] - n_plus[1] * par_S_plus[0]; + nm_Sm[0] = n_minus[1] * par_S_minus[2] - n_minus[2] * par_S_minus[1]; + nm_Sm[1] = n_minus[2] * par_S_minus[0] - n_minus[0] * par_S_minus[2]; + nm_Sm[2] = n_minus[0] * par_S_minus[1] - n_minus[1] * par_S_minus[0]; + AijAij = 0; + for (i = 0; i < 3; i++) + { + for (j = 0; j < 3; j++) + { /* Bowen-York-Curvature :*/ + Aij = + +1.5 * (par_P_plus[i] * n_plus[j] + par_P_plus[j] * n_plus[i] + np_Pp * n_plus[i] * n_plus[j]) / r2_plus + 1.5 * (par_P_minus[i] * n_minus[j] + par_P_minus[j] * n_minus[i] + nm_Pm * n_minus[i] * n_minus[j]) / r2_minus - 3.0 * (np_Sp[i] * n_plus[j] + np_Sp[j] * n_plus[i]) / r3_plus - 3.0 * (nm_Sm[i] * n_minus[j] + nm_Sm[j] * n_minus[i]) / r3_minus; + if (i == j) + Aij -= +1.5 * (np_Pp / r2_plus + nm_Pm / r2_minus); + AijAij += Aij * Aij; + } + } + + return AijAij; +} +void TwoPunctures::SetMatrix_JFD(int nvar, int n1, int n2, int n3, derivs u, + int *ncols, int **cols, double **Matrix) +{ + int column, row, mcol; + int i, i1, i_0, i_1, j, j1, j_0, j_1, k, k1, k_0, k_1, N1, N2, N3, + ivar, ivar1, ntotal = nvar * n1 * n2 * n3; + double *values; + derivs dv; + + values = dvector(0, nvar - 1); + allocate_derivs(&dv, ntotal); + + N1 = n1 - 1; + N2 = n2 - 1; + N3 = n3 - 1; + + for (i = 0; i < n1; i++) + { + for (j = 0; j < n2; j++) + { + for (k = 0; k < n3; k++) + { + for (ivar = 0; ivar < nvar; ivar++) + { + row = Index(ivar, i, j, k, nvar, n1, n2, n3); + ncols[row] = 0; + dv.d0[row] = 0; + } + } + } + } + for (i = 0; i < n1; i++) + { + for (j = 0; j < n2; j++) + { + for (k = 0; k < n3; k++) + { + for (ivar = 0; ivar < nvar; ivar++) + { + column = Index(ivar, i, j, k, nvar, n1, n2, n3); + dv.d0[column] = 1; + + i_0 = maximum2(0, i - 1); + i_1 = minimum2(N1, i + 1); + j_0 = maximum2(0, j - 1); + j_1 = minimum2(N2, j + 1); + k_0 = k - 1; + k_1 = k + 1; + /* i_0 = 0; + i_1 = N1; + j_0 = 0; + j_1 = N2; + k_0 = 0; + k_1 = N3;*/ + + for (i1 = i_0; i1 <= i_1; i1++) + { + for (j1 = j_0; j1 <= j_1; j1++) + { + for (k1 = k_0; k1 <= k_1; k1++) + { + JFD_times_dv(i1, j1, k1, nvar, n1, n2, n3, + dv, u, values); + for (ivar1 = 0; ivar1 < nvar; ivar1++) + { + if (values[ivar1] != 0) + { + row = Index(ivar1, i1, j1, k1, nvar, n1, n2, n3); + mcol = ncols[row]; + cols[row][mcol] = column; + Matrix[row][mcol] = values[ivar1]; + ncols[row] += 1; + } + } + } + } + } + + dv.d0[column] = 0; + } + } + } + } + free_derivs(&dv, ntotal); + free_dvector(values, 0, nvar - 1); +} +/* --------------------------------------------------------------------------*/ +void TwoPunctures::J_times_dv(int nvar, int n1, int n2, int n3, derivs dv, double *Jdv, derivs u) +{ /* Calculates the left hand sides of the non-linear equations F_m(v_n)=0*/ + /* and the function u (u.d0[]) as well as its derivatives*/ + /* (u.d1[], u.d2[], u.d3[], u.d11[], u.d12[], u.d13[], u.d22[], u.d23[], u.d33[])*/ + /* at interior points and at the boundaries "+/-"*/ + int i, j, k, ivar, indx; + double al, be, A, B, X, R, x, r, phi, y, z, Am1; + + Derivatives_AB3_MatMul(nvar, n1, n2, n3, dv); + + #pragma omp parallel for schedule(dynamic,1) \ + private(j, k, ivar, indx, al, be, A, B, X, R, x, r, phi, y, z, Am1) + for (i = 0; i < n1; i++) + { + // Thread-local derivs on stack (nvar=1) + double l_val[1]; + double l_dU_d0[1], l_dU_d1[1], l_dU_d2[1], l_dU_d3[1]; + double l_dU_d11[1], l_dU_d12[1], l_dU_d13[1], l_dU_d22[1], l_dU_d23[1], l_dU_d33[1]; + double l_U_d0[1], l_U_d1[1], l_U_d2[1], l_U_d3[1]; + double l_U_d11[1], l_U_d12[1], l_U_d13[1], l_U_d22[1], l_U_d23[1], l_U_d33[1]; + derivs l_dU, l_U; + l_dU.d0=l_dU_d0; l_dU.d1=l_dU_d1; l_dU.d2=l_dU_d2; l_dU.d3=l_dU_d3; + l_dU.d11=l_dU_d11; l_dU.d12=l_dU_d12; l_dU.d13=l_dU_d13; + l_dU.d22=l_dU_d22; l_dU.d23=l_dU_d23; l_dU.d33=l_dU_d33; + l_U.d0=l_U_d0; l_U.d1=l_U_d1; l_U.d2=l_U_d2; l_U.d3=l_U_d3; + l_U.d11=l_U_d11; l_U.d12=l_U_d12; l_U.d13=l_U_d13; + l_U.d22=l_U_d22; l_U.d23=l_U_d23; l_U.d33=l_U_d33; + + for (j = 0; j < n2; j++) + { + for (k = 0; k < n3; k++) + { + al = Pih * (2 * i + 1) / n1; + A = -cos(al); + be = Pih * (2 * j + 1) / n2; + B = -cos(be); + phi = 2. * Pi * k / n3; + + Am1 = A - 1; + for (ivar = 0; ivar < nvar; ivar++) + { + indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + l_dU.d0[ivar] = Am1 * dv.d0[indx]; + l_dU.d1[ivar] = dv.d0[indx] + Am1 * dv.d1[indx]; + l_dU.d2[ivar] = Am1 * dv.d2[indx]; + l_dU.d3[ivar] = Am1 * dv.d3[indx]; + l_dU.d11[ivar] = 2 * dv.d1[indx] + Am1 * dv.d11[indx]; + l_dU.d12[ivar] = dv.d2[indx] + Am1 * dv.d12[indx]; + l_dU.d13[ivar] = dv.d3[indx] + Am1 * dv.d13[indx]; + l_dU.d22[ivar] = Am1 * dv.d22[indx]; + l_dU.d23[ivar] = Am1 * dv.d23[indx]; + l_dU.d33[ivar] = Am1 * dv.d33[indx]; + l_U.d0[ivar] = u.d0[indx]; + l_U.d1[ivar] = u.d1[indx]; + l_U.d2[ivar] = u.d2[indx]; + l_U.d3[ivar] = u.d3[indx]; + l_U.d11[ivar] = u.d11[indx]; + l_U.d12[ivar] = u.d12[indx]; + l_U.d13[ivar] = u.d13[indx]; + l_U.d22[ivar] = u.d22[indx]; + l_U.d23[ivar] = u.d23[indx]; + l_U.d33[ivar] = u.d33[indx]; + } + AB_To_XR(nvar, A, B, &X, &R, l_dU); + C_To_c(nvar, X, R, &x, &r, l_dU); + rx3_To_xyz(nvar, x, r, phi, &y, &z, l_dU); + LinEquations(A, B, X, R, x, r, phi, y, z, l_dU, l_U, l_val); + for (ivar = 0; ivar < nvar; ivar++) + { + indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + Jdv[indx] = l_val[ivar] * sin(al) * sin(be) * sin(al) * sin(be) * sin(al) * sin(be); + } + } + } + } +} +/* --------------------------------------------------------------------------*/ +/* -------------------------------------------------------------------------- + * relax_omp: OpenMP-parallelized replacement for relax() + * + * Parallelism analysis: + * - The red-black ordering within each phi-plane means that + * same-parity lines in the i-direction are INDEPENDENT of each other + * (they only couple through the j-direction which is solved internally). + * - Similarly, same-parity lines in the j-direction are independent. + * - Different phi-planes (k) with same parity are independent. + * + * Strategy: + * - Parallelize the i-loop within each (k, parity) group for LineRelax_be + * - Parallelize the j-loop within each (k, parity) group for LineRelax_al + * - Each thread uses its own pre-allocated workspace (tid-indexed) + * --------------------------------------------------------------------------*/ +void TwoPunctures::relax_omp(double *dv, int const nvar, int const n1, int const n2, int const n3, + double const *rhs, int const *ncols, int **cols, double **JFD) +{ + int n; + + // 偶数k平面 + for (n = 0; n < N_PlaneRelax; n++) + { + // 偶数i线，所有偶数k —— 不同k平面完全独立 + int n_even_k = (n3 + 1) / 2; // 偶数k的数量 + int n_even_i = (n1 - 2 + 1) / 2; // i=2,4,...的数量 + int total_tasks = n_even_k * n_even_i; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_even_i; + int ii = task % n_even_i; + int k = ki * 2; + int i = 2 + ii * 2; + LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 奇数i线，所有偶数k + int n_odd_i = n1 / 2; // i=1,3,...的数量 + total_tasks = n_even_k * n_odd_i; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_odd_i; + int ii = task % n_odd_i; + int k = ki * 2; + int i = 1 + ii * 2; + LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 奇数j线，所有偶数k + int n_odd_j = (n2 - 1 + 1) / 2; + total_tasks = n_even_k * n_odd_j; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_odd_j; + int ji = task % n_odd_j; + int k = ki * 2; + int j = 1 + ji * 2; + LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 偶数j线，所有偶数k + int n_even_j = (n2 + 1) / 2; + total_tasks = n_even_k * n_even_j; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_even_j; + int ji = task % n_even_j; + int k = ki * 2; + int j = ji * 2; + LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 奇数k平面 — 同样的四步 + int n_odd_k = n3 / 2; + + // 偶数i线，所有奇数k + n_even_i = (n1 + 1) / 2; // i=0,2,... + total_tasks = n_odd_k * n_even_i; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_even_i; + int ii = task % n_even_i; + int k = 1 + ki * 2; + int i = ii * 2; + LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 奇数i线，所有奇数k + total_tasks = n_odd_k * n_odd_i; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_odd_i; + int ii = task % n_odd_i; + int k = 1 + ki * 2; + int i = 1 + ii * 2; + LineRelax_be_omp(dv, i, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 奇数j线，所有奇数k + total_tasks = n_odd_k * n_odd_j; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_odd_j; + int ji = task % n_odd_j; + int k = 1 + ki * 2; + int j = 1 + ji * 2; + LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + + // 偶数j线，所有奇数k + total_tasks = n_odd_k * n_even_j; + + #pragma omp parallel for schedule(static) + for (int task = 0; task < total_tasks; task++) { + int tid = omp_get_thread_num(); + int ki = task / n_even_j; + int ji = task % n_even_j; + int k = 1 + ki * 2; + int j = ji * 2; + LineRelax_al_omp(dv, j, k, nvar, n1, n2, n3, rhs, ncols, cols, JFD, tid); + } + } +} +/* --------------------------------------------------------------------------*/ +void TwoPunctures::LineRelax_be_omp(double *dv, + int const i, int const k, int const nvar, + int const n1, int const n2, int const n3, + double const *rhs, int const *ncols, int **cols, + double **JFD, int tid) +{ + int j, m, Ic, Ip, Im, col, ivar; + + // Use pre-allocated per-thread workspace instead of new/delete + double *diag = ws_diag_be[tid]; + double *e = ws_e_be[tid]; + double *f = ws_f_be[tid]; + double *b = ws_b_be[tid]; + double *x = ws_x_be[tid]; + + for (ivar = 0; ivar < nvar; ivar++) + { + for (j = 0; j < n2 - 1; j++) + { + diag[j] = e[j] = f[j] = 0; + } + diag[n2 - 1] = 0; + + // gsl_vector_set_zero(diag); + // gsl_vector_set_zero(e); + // gsl_vector_set_zero(f); + for (j = 0; j < n2; j++) + { + Ip = Index(ivar, i, j + 1, k, nvar, n1, n2, n3); + Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); + Im = Index(ivar, i, j - 1, k, nvar, n1, n2, n3); + b[j] = rhs[Ic]; + // gsl_vector_set(b,j,rhs[Ic]); + for (m = 0; m < ncols[Ic]; m++) + { + col = cols[Ic][m]; + if (col != Ip && col != Ic && col != Im) + b[j] -= JFD[Ic][m] * dv[col]; + // *gsl_vector_ptr(b, j) -= JFD[Ic][m] * dv[col]; + else + { + if (col == Im && j > 0) + f[j - 1] = JFD[Ic][m]; + // gsl_vector_set(f,j-1,JFD[Ic][m]); + if (col == Ic) + diag[j] = JFD[Ic][m]; + // gsl_vector_set(diag,j,JFD[Ic][m]); + if (col == Ip && j < n2 - 1) + e[j] = JFD[Ic][m]; + // gsl_vector_set(e,j,JFD[Ic][m]); + } + } + } + ThomasAlgorithm_ws(n2, f, diag, e, x, b, + ws_l_be[tid], ws_u_be[tid], ws_d_be[tid], ws_y_be[tid]); + for (j = 0; j < n2; j++) + { + Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); + dv[Ic] = x[j]; + // dv[Ic] = gsl_vector_get(x, j); + } + } + // No delete — workspace is persistent +} +/* --------------------------------------------------------------------------*/ +void TwoPunctures::JFD_times_dv(int i, int j, int k, int nvar, int n1, int n2, + int n3, derivs dv, derivs u, double *values) +{ /* Calculates rows of the vector 'J(FD)*dv'.*/ + /* First row to be calculated: row = Index(0, i, j, k; nvar, n1, n2, n3)*/ + /* Last row to be calculated: row = Index(nvar-1, i, j, k; nvar, n1, n2, n3)*/ + /* These rows are stored in the vector JFDdv[0] ... JFDdv[nvar-1].*/ + int ivar, indx; + double al, be, A, B, X, R, x, r, phi, y, z, Am1; + double sin_al, sin_al_i1, sin_al_i2, sin_al_i3, cos_al; + double sin_be, sin_be_i1, sin_be_i2, sin_be_i3, cos_be; + double dV0, dV1, dV2, dV3, dV11, dV12, dV13, dV22, dV23, dV33, + ha, ga, ga2, hb, gb, gb2, hp, gp, gp2, gagb, gagp, gbgp; + + // Stack-allocated derivs (nvar=1) — no malloc/free! + double dU_d0[1], dU_d1[1], dU_d2[1], dU_d3[1]; + double dU_d11[1], dU_d12[1], dU_d13[1], dU_d22[1], dU_d23[1], dU_d33[1]; + double U_d0[1], U_d1[1], U_d2[1], U_d3[1]; + double U_d11[1], U_d12[1], U_d13[1], U_d22[1], U_d23[1], U_d33[1]; + derivs dU, U; + dU.d0=dU_d0; dU.d1=dU_d1; dU.d2=dU_d2; dU.d3=dU_d3; + dU.d11=dU_d11; dU.d12=dU_d12; dU.d13=dU_d13; + dU.d22=dU_d22; dU.d23=dU_d23; dU.d33=dU_d33; + U.d0=U_d0; U.d1=U_d1; U.d2=U_d2; U.d3=U_d3; + U.d11=U_d11; U.d12=U_d12; U.d13=U_d13; + U.d22=U_d22; U.d23=U_d23; U.d33=U_d33; + + if (k < 0) + k = k + n3; + if (k >= n3) + k = k - n3; + + ha = Pi / n1; /* ha: Stepsize with respect to (al)*/ + al = ha * (i + 0.5); + A = -cos(al); + ga = 1 / ha; + ga2 = ga * ga; + + hb = Pi / n2; /* hb: Stepsize with respect to (be)*/ + be = hb * (j + 0.5); + B = -cos(be); + gb = 1 / hb; + gb2 = gb * gb; + gagb = ga * gb; + + hp = 2 * Pi / n3; /* hp: Stepsize with respect to (phi)*/ + phi = hp * j; + gp = 1 / hp; + gp2 = gp * gp; + gagp = ga * gp; + gbgp = gb * gp; + + sin_al = sin(al); + sin_be = sin(be); + sin_al_i1 = 1 / sin_al; + sin_be_i1 = 1 / sin_be; + sin_al_i2 = sin_al_i1 * sin_al_i1; + sin_be_i2 = sin_be_i1 * sin_be_i1; + sin_al_i3 = sin_al_i1 * sin_al_i2; + sin_be_i3 = sin_be_i1 * sin_be_i2; + cos_al = -A; + cos_be = -B; + + Am1 = A - 1; + for (ivar = 0; ivar < nvar; ivar++) + { + int iccc = Index(ivar, i, j, k, nvar, n1, n2, n3), + ipcc = Index(ivar, i + 1, j, k, nvar, n1, n2, n3), + imcc = Index(ivar, i - 1, j, k, nvar, n1, n2, n3), + icpc = Index(ivar, i, j + 1, k, nvar, n1, n2, n3), + icmc = Index(ivar, i, j - 1, k, nvar, n1, n2, n3), + iccp = Index(ivar, i, j, k + 1, nvar, n1, n2, n3), + iccm = Index(ivar, i, j, k - 1, nvar, n1, n2, n3), + icpp = Index(ivar, i, j + 1, k + 1, nvar, n1, n2, n3), + icmp = Index(ivar, i, j - 1, k + 1, nvar, n1, n2, n3), + icpm = Index(ivar, i, j + 1, k - 1, nvar, n1, n2, n3), + icmm = Index(ivar, i, j - 1, k - 1, nvar, n1, n2, n3), + ipcp = Index(ivar, i + 1, j, k + 1, nvar, n1, n2, n3), + imcp = Index(ivar, i - 1, j, k + 1, nvar, n1, n2, n3), + ipcm = Index(ivar, i + 1, j, k - 1, nvar, n1, n2, n3), + imcm = Index(ivar, i - 1, j, k - 1, nvar, n1, n2, n3), + ippc = Index(ivar, i + 1, j + 1, k, nvar, n1, n2, n3), + impc = Index(ivar, i - 1, j + 1, k, nvar, n1, n2, n3), + ipmc = Index(ivar, i + 1, j - 1, k, nvar, n1, n2, n3), + immc = Index(ivar, i - 1, j - 1, k, nvar, n1, n2, n3); + /* Derivatives of (dv) w.r.t. (al,be,phi):*/ + dV0 = dv.d0[iccc]; + dV1 = 0.5 * ga * (dv.d0[ipcc] - dv.d0[imcc]); + dV2 = 0.5 * gb * (dv.d0[icpc] - dv.d0[icmc]); + dV3 = 0.5 * gp * (dv.d0[iccp] - dv.d0[iccm]); + dV11 = ga2 * (dv.d0[ipcc] + dv.d0[imcc] - 2 * dv.d0[iccc]); + dV22 = gb2 * (dv.d0[icpc] + dv.d0[icmc] - 2 * dv.d0[iccc]); + dV33 = gp2 * (dv.d0[iccp] + dv.d0[iccm] - 2 * dv.d0[iccc]); + dV12 = 0.25 * gagb * (dv.d0[ippc] - dv.d0[ipmc] + dv.d0[immc] - dv.d0[impc]); + dV13 = 0.25 * gagp * (dv.d0[ipcp] - dv.d0[imcp] + dv.d0[imcm] - dv.d0[ipcm]); + dV23 = 0.25 * gbgp * (dv.d0[icpp] - dv.d0[icpm] + dv.d0[icmm] - dv.d0[icmp]); + /* Derivatives of (dv) w.r.t. (A,B,phi):*/ + dV11 = sin_al_i3 * (sin_al * dV11 - cos_al * dV1); + dV12 = sin_al_i1 * sin_be_i1 * dV12; + dV13 = sin_al_i1 * dV13; + dV22 = sin_be_i3 * (sin_be * dV22 - cos_be * dV2); + dV23 = sin_be_i1 * dV23; + dV1 = sin_al_i1 * dV1; + dV2 = sin_be_i1 * dV2; + /* Derivatives of (dU) w.r.t. (A,B,phi):*/ + dU.d0[ivar] = Am1 * dV0; + dU.d1[ivar] = dV0 + Am1 * dV1; + dU.d2[ivar] = Am1 * dV2; + dU.d3[ivar] = Am1 * dV3; + dU.d11[ivar] = 2 * dV1 + Am1 * dV11; + dU.d12[ivar] = dV2 + Am1 * dV12; + dU.d13[ivar] = dV3 + Am1 * dV13; + dU.d22[ivar] = Am1 * dV22; + dU.d23[ivar] = Am1 * dV23; + dU.d33[ivar] = Am1 * dV33; + + indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + U.d0[ivar] = u.d0[indx]; /* U */ + U.d1[ivar] = u.d1[indx]; /* U_x*/ + U.d2[ivar] = u.d2[indx]; /* U_y*/ + U.d3[ivar] = u.d3[indx]; /* U_z*/ + U.d11[ivar] = u.d11[indx]; /* U_xx*/ + U.d12[ivar] = u.d12[indx]; /* U_xy*/ + U.d13[ivar] = u.d13[indx]; /* U_xz*/ + U.d22[ivar] = u.d22[indx]; /* U_yy*/ + U.d23[ivar] = u.d23[indx]; /* U_yz*/ + U.d33[ivar] = u.d33[indx]; /* U_zz*/ + } + /* Calculation of (X,R) and*/ + /* (dU_X, dU_R, dU_3, dU_XX, dU_XR, dU_X3, dU_RR, dU_R3, dU_33)*/ + AB_To_XR(nvar, A, B, &X, &R, dU); + /* Calculation of (x,r) and*/ + /* (dU, dU_x, dU_r, dU_3, dU_xx, dU_xr, dU_x3, dU_rr, dU_r3, dU_33)*/ + C_To_c(nvar, X, R, &x, &r, dU); + /* Calculation of (y,z) and*/ + /* (dU, dU_x, dU_y, dU_z, dU_xx, dU_xy, dU_xz, dU_yy, dU_yz, dU_zz)*/ + rx3_To_xyz(nvar, x, r, phi, &y, &z, dU); + LinEquations(A, B, X, R, x, r, phi, y, z, dU, U, values); + + double FAC_val = sin_al * sin_be * sin_al * sin_be * sin_al * sin_be; + for (ivar = 0; ivar < nvar; ivar++) + values[ivar] *= FAC_val; + + // No free_derivs needed — everything is on the stack +} +#undef FAC +/*-----------------------------------------------------------*/ +/******** Linear Equations ***********/ +/*-----------------------------------------------------------*/ +void TwoPunctures::LinEquations(double A, double B, double X, double R, + double x, double r, double phi, + double y, double z, derivs dU, derivs U, double *values) +{ + double r_plus, r_minus, psi, psi2, psi4, psi8; + + r_plus = sqrt((x - par_b) * (x - par_b) + y * y + z * z); + r_minus = sqrt((x + par_b) * (x + par_b) + y * y + z * z); + + psi = + 1. + 0.5 * par_m_plus / r_plus + 0.5 * par_m_minus / r_minus + U.d0[0]; + psi2 = psi * psi; + psi4 = psi2 * psi2; + psi8 = psi4 * psi4; + + values[0] = dU.d11[0] + dU.d22[0] + dU.d33[0] - 0.875 * BY_KKofxyz(x, y, z) / psi8 * dU.d0[0]; +} +/* -------------------------------------------------------------------------*/ +void TwoPunctures::LineRelax_al_omp(double *dv, + int const j, int const k, int const nvar, + int const n1, int const n2, int const n3, + double const *rhs, int const *ncols, + int **cols, double **JFD, int tid) +{ + int i, m, Ic, Ip, Im, col, ivar; + + double *diag = ws_diag_al[tid]; + double *e = ws_e_al[tid]; + double *f = ws_f_al[tid]; + double *b = ws_b_al[tid]; + double *x = ws_x_al[tid]; + + for (ivar = 0; ivar < nvar; ivar++) + { + for (i = 0; i < n1 - 1; i++) + { + diag[i] = e[i] = f[i] = 0; + } + diag[n1 - 1] = 0; + + // gsl_vector_set_zero(diag); + // gsl_vector_set_zero(e); + // gsl_vector_set_zero(f); + for (i = 0; i < n1; i++) + { + Ip = Index(ivar, i + 1, j, k, nvar, n1, n2, n3); + Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); + Im = Index(ivar, i - 1, j, k, nvar, n1, n2, n3); + b[i] = rhs[Ic]; + // gsl_vector_set(b,i,rhs[Ic]); + for (m = 0; m < ncols[Ic]; m++) + { + col = cols[Ic][m]; + if (col != Ip && col != Ic && col != Im) + b[i] -= JFD[Ic][m] * dv[col]; + // *gsl_vector_ptr(b, i) -= JFD[Ic][m] * dv[col]; + else + { + if (col == Im && i > 0) + f[i - 1] = JFD[Ic][m]; + // gsl_vector_set(f,i-1,JFD[Ic][m]); + if (col == Ic) + diag[i] = JFD[Ic][m]; + // gsl_vector_set(diag,i,JFD[Ic][m]); + if (col == Ip && i < n1 - 1) + e[i] = JFD[Ic][m]; + // gsl_vector_set(e,i,JFD[Ic][m]); + } + } + } + ThomasAlgorithm_ws(n1, f, diag, e, x, b, + ws_l_al[tid], ws_u_al[tid], ws_d_al[tid], ws_y_al[tid]); + for (i = 0; i < n1; i++) + { + Ic = Index(ivar, i, j, k, nvar, n1, n2, n3); + dv[Ic] = x[i]; + // dv[Ic] = gsl_vector_get(x, i); + } + } +} +/* -------------------------------------------------------------------------*/ +// a[N], b[N-1], c[N-1], x[N], q[N] +// A x = q +// A = ( a_0 c_0 0 0 ) +// ( b_0 a_1 c_1 0 ) +// ( 0 b_1 a_2 c_2 ) +// ( 0 0 b_2 a_3 ) +//"Parallel Scientific Computing in C++ and MPI" P361 +void TwoPunctures::ThomasAlgorithm(int N, double *b, double *a, double *c, double *x, double *q) +{ + int i; + double *l, *u, *d, *y; + l = new double[N - 1]; + u = new double[N - 1]; + d = new double[N]; + y = new double[N]; + + /* LU Decomposition */ + d[0] = a[0]; + u[0] = c[0]; + + for (i = 0; i < N - 2; i++) + { + l[i] = b[i] / d[i]; + d[i + 1] = a[i + 1] - l[i] * u[i]; + u[i + 1] = c[i + 1]; + } + + l[N - 2] = b[N - 2] / d[N - 2]; + d[N - 1] = a[N - 1] - l[N - 2] * u[N - 2]; + + /* Forward Substitution [L][y] = [q] */ + y[0] = q[0]; + for (i = 1; i < N; i++) + y[i] = q[i] - l[i - 1] * y[i - 1]; + + /* Backward Substitution [U][x] = [y] */ + x[N - 1] = y[N - 1] / d[N - 1]; + + for (i = N - 2; i >= 0; i--) + x[i] = (y[i] - u[i] * x[i + 1]) / d[i]; + + delete[] l; + delete[] u; + delete[] d; + delete[] y; + + return; +} + +// ThomasAlgorithm with pre-allocated workspace (no new/delete) +// l[N-1], u_ws[N-1], d[N], y[N] are caller-provided workspace +void TwoPunctures::ThomasAlgorithm_ws(int N, double *b, double *a, double *c, + double *x, double *q, + double *l, double *u_ws, double *d, double *y) +{ + /* LU Decomposition */ + d[0] = a[0]; + u_ws[0] = c[0]; + + for (int i = 0; i < N - 2; i++) { + l[i] = b[i] / d[i]; + d[i + 1] = a[i + 1] - l[i] * u_ws[i]; + u_ws[i + 1] = c[i + 1]; + } + + l[N - 2] = b[N - 2] / d[N - 2]; + d[N - 1] = a[N - 1] - l[N - 2] * u_ws[N - 2]; + + /* Forward Substitution [L][y] = [q] */ + y[0] = q[0]; + for (int i = 1; i < N; i++) + y[i] = q[i] - l[i - 1] * y[i - 1]; + + /* Backward Substitution [U][x] = [y] */ + x[N - 1] = y[N - 1] / d[N - 1]; + for (int i = N - 2; i >= 0; i--) + x[i] = (y[i] - u_ws[i] * x[i + 1]) / d[i]; +} + +// --------------------------------------------------------------------------*/ +// Calculates the value of v at an arbitrary position (x,y,z) if the spectral coefficients are know*/*/ +/* --------------------------------------------------------------------------*/ +/* Calculates the value of v at an arbitrary position (A,B,phi)*/ +double TwoPunctures::Spec_IntPolABphiFast(parameters par, double *v, int ivar, double A, double B, double phi) +{ + int i, j, k, N; + double *p, *values1, **values2, result; + + int nvar = par.nvar; + int n1 = par.n1; + int n2 = par.n2; + int n3 = par.n3; + N = maximum3(n1, n2, n3); + + p = dvector(0, N); + values1 = dvector(0, N); + values2 = dmatrix(0, N, 0, N); + + for (k = 0; k < n3; k++) + { + for (j = 0; j < n2; j++) + { + for (i = 0; i < n1; i++) + p[i] = v[ivar + nvar * (i + n1 * (j + n2 * k))]; + // chebft_Zeros (p, n1, 0); + values2[j][k] = chebev(-1, 1, p, n1, A); + } + } + + for (k = 0; k < n3; k++) + { + for (j = 0; j < n2; j++) + p[j] = values2[j][k]; + // chebft_Zeros (p, n2, 0); + values1[k] = chebev(-1, 1, p, n2, B); + } + + // fourft (values1, n3, 0); + result = fourev(values1, n3, phi); + + free_dvector(p, 0, N); + free_dvector(values1, 0, N); + free_dmatrix(values2, 0, N, 0, N); + + return result; + // */ + // return 0.; +} + +/* Calculates the value of v at an arbitrary position (x,y,z) given the spectral coefficients*/ +double TwoPunctures::Spec_IntPolFast(parameters par, int ivar, double *v, double x, double y, double z) +{ + double xs, ys, zs, rs2, phi, X, R, A, B, aux1, aux2, result, Ui; + + int nvar = par.nvar; + int n1 = par.n1; + int n2 = par.n2; + int n3 = par.n3; + double par_b = par.b; + + xs = x / par.b; + ys = y / par.b; + zs = z / par.b; + rs2 = ys * ys + zs * zs; + phi = atan2(z, y); + if (phi < 0) + phi += 2. * Pi; + + aux1 = 0.5 * (xs * xs + rs2 - 1.); + aux2 = sqrt(aux1 * aux1 + rs2); + + // Note from YT: aux2-aux1 can be equal to 1. When that happens, numerical + // truncation may make it slightly larger than 1. This makes + // R NAN! I also worry that aux2-aux1 and aux1+axu2 may become negative due to + // truncation error, which gives rise to NAN for X and R. + // The following few lines attempt to fix these. + double aux2_plus_aux1, aux2_minus_aux1; + if (aux1 < 0) + { + aux2_plus_aux1 = rs2 / (aux2 - aux1); + aux2_minus_aux1 = aux2 - aux1; + } + else + { + aux2_plus_aux1 = aux2 + aux1; + aux2_minus_aux1 = rs2 / (aux2 + aux1); + } + if (fabs(aux1) + fabs(aux2) < 1.e-20) + { + aux2_plus_aux1 = 0.0; + aux2_minus_aux1 = 0.0; + } + double sqrt_aux2_minus_aux1 = sqrt(fabs(aux2_minus_aux1)); + + // Note from YT: The following two lines have replaced by the 6 lines belows. + // X = asinhd(sqrt(aux1+aux2)); + // R = asin(sqrt(fabs(-aux1+aux2))); + + X = asinh(sqrt(aux2_plus_aux1)); + if (sqrt_aux2_minus_aux1 > 1.0) + { + R = 0.5 * Pi; + } + else + { + R = asin(sqrt_aux2_minus_aux1); + } + + if (x < 0) + R = Pi - R; + + A = 2. * tanh(0.5 * X) - 1.; + B = tan(0.5 * R - Piq); + + result = Spec_IntPolABphiFast(par, v, ivar, A, B, phi); + + Ui = (A - 1) * result; + + return Ui; +} + +// Evaluates the spectral expansion coefficients of v +void TwoPunctures::SpecCoef(parameters par, int ivar, double *v, double *cf) +{ + // Here v is a pointer to the values of the variable v at the collocation points + int i, j, k, N, n, l, m; + double *p, ***values3, ***values4; + + int nvar = par.nvar; + int n1 = par.n1; + int n2 = par.n2; + int n3 = par.n3; + + N = maximum3(n1, n2, n3); + p = dvector(0, N); + values3 = d3tensor(0, n1, 0, n2, 0, n3); + values4 = d3tensor(0, n1, 0, n2, 0, n3); + + // Caclulate values3[n,j,k] = a_n^{j,k} = (sum_i^(n1-1) f(A_i,B_j,phi_k) Tn(-A_i))/k_n , k_n = N/2 or N + for (k = 0; k < n3; k++) + { + for (j = 0; j < n2; j++) + { + for (i = 0; i < n1; i++) + p[i] = v[ivar + (i + n1 * (j + n2 * k))]; + chebft_Zeros(p, n1, 0); + for (n = 0; n < n1; n++) + { + values3[n][j][k] = p[n]; + } + } + } + + // Caclulate values4[n,l,k] = a_{n,l}^{k} = (sum_j^(n2-1) a_n^{j,k} Tn(B_j))/k_l , k_l = N/2 or N + + for (n = 0; n < n1; n++) + { + for (k = 0; k < n3; k++) + { + for (j = 0; j < n2; j++) + p[j] = values3[n][j][k]; + chebft_Zeros(p, n2, 0); + for (l = 0; l < n2; l++) + { + values4[n][l][k] = p[l]; + } + } + } + + // Caclulate coefficients a_{n,l,m} = (sum_k^(n3-1) a_{n,m}^{k} fourier(phi_k))/k_m , k_m = N/2 or N + for (i = 0; i < n1; i++) + { + for (j = 0; j < n2; j++) + { + for (k = 0; k < n3; k++) + p[k] = values4[i][j][k]; + fourft(p, n3, 0); + for (k = 0; k < n3; k++) + { + cf[ivar + (i + n1 * (j + n2 * k))] = p[k]; + } + } + } + + free_dvector(p, 0, N); + free_d3tensor(values3, 0, n1, 0, n2, 0, n3); + free_d3tensor(values4, 0, n1, 0, n2, 0, n3); +} + +void TwoPunctures::allocate_workspace() +{ + int n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; + max_threads = omp_get_max_threads(); + printf("Allocating workspace for %d threads\n", max_threads); + + // LineRelax_be workspace: arrays of size n2, per thread + ws_diag_be = new double*[max_threads]; + ws_e_be = new double*[max_threads]; + ws_f_be = new double*[max_threads]; + ws_b_be = new double*[max_threads]; + ws_x_be = new double*[max_threads]; + ws_l_be = new double*[max_threads]; + ws_u_be = new double*[max_threads]; + ws_d_be = new double*[max_threads]; + ws_y_be = new double*[max_threads]; + + // LineRelax_al workspace: arrays of size n1, per thread + ws_diag_al = new double*[max_threads]; + ws_e_al = new double*[max_threads]; + ws_f_al = new double*[max_threads]; + ws_b_al = new double*[max_threads]; + ws_x_al = new double*[max_threads]; + ws_l_al = new double*[max_threads]; + ws_u_al = new double*[max_threads]; + ws_d_al = new double*[max_threads]; + ws_y_al = new double*[max_threads]; + + int N = (n1 > n2) ? n1 : n2; // max of n1, n2 + + for (int t = 0; t < max_threads; t++) { + ws_diag_be[t] = new double[n2]; + ws_e_be[t] = new double[n2]; + ws_f_be[t] = new double[n2]; + ws_b_be[t] = new double[n2]; + ws_x_be[t] = new double[n2]; + ws_l_be[t] = new double[n2]; + ws_u_be[t] = new double[n2]; + ws_d_be[t] = new double[n2]; + ws_y_be[t] = new double[n2]; + + ws_diag_al[t] = new double[n1]; + ws_e_al[t] = new double[n1]; + ws_f_al[t] = new double[n1]; + ws_b_al[t] = new double[n1]; + ws_x_al[t] = new double[n1]; + ws_l_al[t] = new double[n1]; + ws_u_al[t] = new double[n1]; + ws_d_al[t] = new double[n1]; + ws_y_al[t] = new double[n1]; + } +} + +void TwoPunctures::free_workspace() +{ + for (int t = 0; t < max_threads; t++) { + delete[] ws_diag_be[t]; delete[] ws_e_be[t]; delete[] ws_f_be[t]; + delete[] ws_b_be[t]; delete[] ws_x_be[t]; + delete[] ws_l_be[t]; delete[] ws_u_be[t]; + delete[] ws_d_be[t]; delete[] ws_y_be[t]; + + delete[] ws_diag_al[t]; delete[] ws_e_al[t]; delete[] ws_f_al[t]; + delete[] ws_b_al[t]; delete[] ws_x_al[t]; + delete[] ws_l_al[t]; delete[] ws_u_al[t]; + delete[] ws_d_al[t]; delete[] ws_y_al[t]; + } + delete[] ws_diag_be; delete[] ws_e_be; delete[] ws_f_be; + delete[] ws_b_be; delete[] ws_x_be; + delete[] ws_l_be; delete[] ws_u_be; + delete[] ws_d_be; delete[] ws_y_be; + + delete[] ws_diag_al; delete[] ws_e_al; delete[] ws_f_al; + delete[] ws_b_al; delete[] ws_x_al; + delete[] ws_l_al; delete[] ws_u_al; + delete[] ws_d_al; delete[] ws_y_al; +} + +/*========================================================================== + * Precomputed Spectral Derivative Matrices + * + * Mathematical equivalence proof: + * + * Original algorithm (per-line): + * 1. Forward Chebyshev transform: c = T * f (where T is the DCT matrix) + * 2. Spectral derivative: c' = Dhat * c (recurrence relation) + * 3. Inverse transform: f' = T^{-1} * c' + * Combined: f' = T^{-1} * Dhat * T * f = D * f + * + * The matrix D = T^{-1} * Dhat * T is precomputed once. + * Similarly D2 = T^{-1} * Dhat^2 * T for second derivatives. + * + * For Fourier: same idea with DFT matrices and frequency-domain derivatives. + * + * This converts n2*n3 separate O(n1^2) transforms into a single + * (n1 x n1) * (n1 x n2*n3) DGEMM call, which is BLAS Level-3 + * and thus optimally parallelized by MKL. + *=========================================================================*/ + +void TwoPunctures::build_cheb_deriv_matrices(int n, double *D1, double *D2) +{ + /* Build the physical-space derivative matrices for Chebyshev Zeros grid. + * + * Grid points: x_i = -cos(pi*(2i+1)/(2n)), i=0,...,n-1 + * + * Method: Construct T (forward transform), Dhat (spectral derivative), + * T^{-1} (inverse transform), then D1 = T^{-1} * Dhat * T, + * D2 = T^{-1} * Dhat^2 * T. + * + * All matrices are n x n, stored in row-major order: M[i*n+j] + */ + + double *T_fwd = new double[n * n]; // Forward transform matrix + double *T_inv = new double[n * n]; // Inverse transform matrix + double *Dhat = new double[n * n]; // Spectral derivative operator + double *Dhat2 = new double[n * n]; // Spectral second derivative operator + double *tmp1 = new double[n * n]; // Temporary + double *tmp2 = new double[n * n]; // Temporary + + double Pion = Pi / n; + + // Build forward Chebyshev transform matrix T + // c_j = (2/n) * (-1)^j * sum_k f_k * cos(pi*j*(k+0.5)/n) + // So T[j][k] = (2/n) * (-1)^j * cos(pi*j*(k+0.5)/n) + for (int j = 0; j < n; j++) { + double fac = (2.0 / n) * ((j % 2 == 0) ? 1.0 : -1.0); + for (int k = 0; k < n; k++) { + T_fwd[j * n + k] = fac * cos(Pion * j * (k + 0.5)); + } + } + + // Build inverse Chebyshev transform matrix T^{-1} + // f_j = sum_k c_k * cos(pi*(j+0.5)*k/n) * (-1)^k - 0.5*c_0 + // But the -0.5*c_0 term is part of the sum when we write it as: + // f_j = -0.5*c_0 + sum_{k=0}^{n-1} c_k * cos(pi*(j+0.5)*k) * (-1)^k + // T_inv[j][k] = cos(pi*(j+0.5)*k/n) * (-1)^k, with k=0 term having extra -0.5 + for (int j = 0; j < n; j++) { + for (int k = 0; k < n; k++) { + double sign_k = (k % 2 == 0) ? 1.0 : -1.0; + T_inv[j * n + k] = cos(Pion * (j + 0.5) * k) * sign_k; + } + // The k=0 term needs adjustment: the sum includes c_0*1 but we need -0.5*c_0 + c_0*1 = 0.5*c_0 + // Wait, let me re-examine chebft_Zeros with inv=1: + // sum = -0.5 * u[0]; + // for k: sum += u[k] * cos(Pion*(j+0.5)*k) * isignum; isignum alternates starting from 1 + // So: c[j] = -0.5*u[0] + sum_{k=0}^{n-1} u[k]*cos(...)*(-1)^k + // = -0.5*u[0] + u[0]*1*1 + sum_{k=1} ... + // = 0.5*u[0] + sum_{k=1} u[k]*cos(...)*(-1)^k + // Equivalently: T_inv[j][0] = 0.5, T_inv[j][k] = cos(...)*(-1)^k for k>=1 + // But cos(0) = 1 and (-1)^0 = 1, so the formula gives T_inv[j][0] = 1.0 + // We need it to be 0.5. Fix: + T_inv[j * n + 0] = 0.5; // This accounts for the -0.5*u[0] + u[0]*cos(0)*1 = 0.5*u[0] + } + + // Build spectral derivative matrix Dhat (in coefficient space) + // The recurrence: cder[n-1] = 0, cder[n-2] = 0, + // cder[j] = cder[j+2] + 2*(j+1)*c[j+1] for j = n-3,...,0 + // This means cder = Dhat * c, where Dhat is upper triangular-ish. + // Dhat[j][k] = coefficient of c[k] contributing to cder[j] + // + // From the recurrence: cder[j] = sum_{k=j+1, k-j odd}^{n-1} 2*k * c[k] + // (with the factor 2k, summing over k > j where k-j is odd) + // Exception: cder[0] gets an extra factor of 0.5 since c[0] has the 2/n prefactor + // Actually no: the chder function is: + // cder[n] = cder[n-1] = 0 + // cder[j] = cder[j+2] + 2*(j+1)*c[j+1] + // Unrolling: cder[j] = 2*(j+1)*c[j+1] + 2*(j+3)*c[j+3] + ... + // So Dhat[j][k] = 2*k if k > j and (k-j) is odd, else 0 + + for (int j = 0; j < n; j++) + for (int k = 0; k < n; k++) + Dhat[j * n + k] = 0.0; + + for (int j = 0; j < n; j++) { + for (int k = j + 1; k < n; k++) { + if ((k - j) % 2 == 1) { + Dhat[j * n + k] = 2.0 * k; + } + } + } + + // Build Dhat^2 = Dhat * Dhat + // D1 = T_inv * Dhat * T_fwd + // D2 = T_inv * Dhat^2 * T_fwd + + // tmp1 = Dhat * T_fwd + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n, n, n, 1.0, Dhat, n, T_fwd, n, 0.0, tmp1, n); + // D1 = T_inv * tmp1 + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n, n, n, 1.0, T_inv, n, tmp1, n, 0.0, D1, n); + + // tmp2 = Dhat * Dhat (Dhat^2 in spectral space) + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n, n, n, 1.0, Dhat, n, Dhat, n, 0.0, tmp2, n); + // tmp1 = Dhat^2 * T_fwd + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n, n, n, 1.0, tmp2, n, T_fwd, n, 0.0, tmp1, n); + // D2 = T_inv * tmp1 + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n, n, n, 1.0, T_inv, n, tmp1, n, 0.0, D2, n); + + delete[] T_fwd; + delete[] T_inv; + delete[] Dhat; + delete[] Dhat2; + delete[] tmp1; + delete[] tmp2; +} + +void TwoPunctures::build_fourier_deriv_matrices(int N, double *DF1, double *DF2) +{ + /* Build Fourier derivative matrices in physical space. + * + * Grid: phi_k = 2*pi*k/N, k=0,...,N-1 + * + * The Fourier interpolant derivative at grid points can be expressed as + * a matrix multiply. We build it by: + * 1. Forward Fourier transform matrix F + * 2. Frequency-domain derivative (multiply by il for first, -l^2 for second) + * 3. Inverse Fourier transform matrix F^{-1} + * DF1 = F^{-1} * diag(il) * F, DF2 = F^{-1} * diag(-l^2) * F + * + * But since fourft/fourev use a real representation (a_l, b_l), + * we construct directly in physical space. + */ + + int M = N / 2; + double Pi_fac = Pi / M; // = 2*Pi/N + + // DF1[j][k] = d/dphi of the interpolant at phi_j, due to value at phi_k + // Using the representation: + // f(phi) = 0.5*(a_0 + a_M*cos(M*phi)) + sum_{l=1}^{M-1} (a_l*cos(l*phi) + b_l*sin(l*phi)) + // where a_l = (2/N)*sum_k f_k*cos(l*phi_k), b_l = (2/N)*sum_k f_k*sin(l*phi_k) + // + // f'(phi) = -0.5*a_M*M*sin(M*phi) + sum_{l=1}^{M-1} l*(-a_l*sin(l*phi) + b_l*cos(l*phi)) + // + // Substituting a_l, b_l and evaluating at phi_j: + // f'(phi_j) = sum_k f_k * K(j,k) + // where K(j,k) = (2/N) * sum_{l=1}^{M-1} l * (-cos(l*phi_k)*sin(l*phi_j) + sin(l*phi_k)*cos(l*phi_j)) + // + (2/N) * (-M/2) * sin(M*phi_j) * cos(M*phi_k) [a_M term, note a_M has no factor 2] + // = (2/N) * sum_{l=1}^{M-1} l * sin(l*(phi_k - phi_j)) + // - (1/N) * M * sin(M*phi_j) * cos(M*phi_k) + // + // But the a_M coefficient in fourft has factor 1/M (not 2/M), so: + // Actually re-examining fourft: a[l] = fac * sum_k u[k]*cos(x), fac=1/M + // and a_M is stored as a[M] with same fac. The inverse uses: + // u[k] = 0.5*(a[0] + a[M]*iy) + sum_{l=1}^{M-1}(a[l]*cos + b[l]*sin) + // So the full expression needs care. Let me just compute it numerically. + + // Numerical approach: for each k, set f = delta_k, compute derivative at all j + double *p = new double[N]; + double *dp = new double[N]; + + for (int k = 0; k < N; k++) { + // Set delta function at k + for (int i = 0; i < N; i++) + p[i] = (i == k) ? 1.0 : 0.0; + + // Forward Fourier transform (using existing fourft) + fourft(p, N, 0); + // Derivative in spectral space + fourder(p, dp, N); + // Inverse Fourier transform + fourft(dp, N, 1); + + // dp[j] = derivative of delta_k interpolant at phi_j + // So DF1[j][k] = dp[j] + for (int j = 0; j < N; j++) + DF1[j * N + k] = dp[j]; + } + + // Second derivative + for (int k = 0; k < N; k++) { + for (int i = 0; i < N; i++) + p[i] = (i == k) ? 1.0 : 0.0; + + fourft(p, N, 0); + fourder2(p, dp, N); + fourft(dp, N, 1); + + for (int j = 0; j < N; j++) + DF2[j * N + k] = dp[j]; + } + + delete[] p; + delete[] dp; +} + +void TwoPunctures::precompute_derivative_matrices() +{ + int n1 = npoints_A, n2 = npoints_B, n3 = npoints_phi; + + // Allocate matrices + D1_A = new double[n1 * n1]; + D2_A = new double[n1 * n1]; + D1_B = new double[n2 * n2]; + D2_B = new double[n2 * n2]; + DF1_phi = new double[n3 * n3]; + DF2_phi = new double[n3 * n3]; + + // Build Chebyshev derivative matrices + build_cheb_deriv_matrices(n1, D1_A, D2_A); + build_cheb_deriv_matrices(n2, D1_B, D2_B); + + // Build Fourier derivative matrices + build_fourier_deriv_matrices(n3, DF1_phi, DF2_phi); + + printf("Precomputed derivative matrices: A(%d), B(%d), phi(%d)\n", n1, n2, n3); +} + +/* -------------------------------------------------------------------------- + * Derivatives_AB3_MatMul: Drop-in replacement for Derivatives_AB3 + * + * Uses precomputed derivative matrices and DGEMM to compute all spectral + * derivatives in batch. Mathematically equivalent to the original + * Derivatives_AB3. + * + * Memory layout of v.d0[Index(ivar,i,j,k)] = v.d0[ivar + nvar*(i + n1*(j + n2*k))] + * + * For A-direction derivatives (fixed j,k, varying i): + * We need to apply D1_A and D2_A to "pencils" along the i-direction. + * Collect all pencils into a matrix and use DGEMM. + * + * For B-direction derivatives (fixed i,k, varying j): + * Similarly with D1_B, D2_B. + * + * For phi-direction (fixed i,j, varying k): + * Similarly with DF1_phi, DF2_phi. + * --------------------------------------------------------------------------*/ +void TwoPunctures::Derivatives_AB3_MatMul(int nvar, int n1, int n2, int n3, derivs v) +{ + int total_pencils; + double *data_in, *data_out; + + /*===================================================== + * STEP 1: A-direction derivatives (Chebyshev, D1_A, D2_A) + * + * For each (ivar, j, k), we have a pencil of length n1: + * f[i] = v.d0[Index(ivar, i, j, k, nvar, n1, n2, n3)] + * + * We want: v.d1[...] = D1_A * f, v.d11[...] = D2_A * f + * + * Collect all n2*n3*nvar pencils as columns of a matrix: + * data_in[i, col] where col = ivar + nvar*(j + n2*k) + * Then: data_out = D1_A * data_in (DGEMM: n1 x n1 times n1 x total_pencils) + *=====================================================*/ + total_pencils = nvar * n2 * n3; + + data_in = new double[n1 * total_pencils]; + data_out = new double[n1 * total_pencils]; + + // Gather: data_in[i * total_pencils + col] = v.d0[Index(ivar,i,j,k,...)] + // where col = ivar + nvar * (j + n2 * k) + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (j + n2 * k); + for (int i = 0; i < n1; i++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + data_in[i * total_pencils + col] = v.d0[indx]; + } + } + } + } + + // First derivative: data_out = D1_A * data_in + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n1, total_pencils, n1, + 1.0, D1_A, n1, data_in, total_pencils, + 0.0, data_out, total_pencils); + + // Scatter to v.d1 + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (j + n2 * k); + for (int i = 0; i < n1; i++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d1[indx] = data_out[i * total_pencils + col]; + } + } + } + } + + // Second derivative: data_out = D2_A * data_in + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n1, total_pencils, n1, + 1.0, D2_A, n1, data_in, total_pencils, + 0.0, data_out, total_pencils); + + // Scatter to v.d11 + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (j + n2 * k); + for (int i = 0; i < n1; i++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d11[indx] = data_out[i * total_pencils + col]; + } + } + } + } + + delete[] data_in; + delete[] data_out; + + /*===================================================== + * STEP 2: B-direction derivatives (Chebyshev, D1_B, D2_B) + * + * Pencils along j for each (ivar, i, k). + * Also compute mixed derivative v.d12 = D1_B applied to v.d1 + *=====================================================*/ + total_pencils = nvar * n1 * n3; + + data_in = new double[n2 * total_pencils]; + data_out = new double[n2 * total_pencils]; + double *data_in2 = new double[n2 * total_pencils]; + double *data_out2 = new double[n2 * total_pencils]; + + // Gather v.d0 along B-direction AND v.d1 for mixed derivative + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int i = 0; i < n1; i++) { + int col = ivar + nvar * (i + n1 * k); + for (int j = 0; j < n2; j++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + data_in[j * total_pencils + col] = v.d0[indx]; + data_in2[j * total_pencils + col] = v.d1[indx]; // for d/dB of (dv/dA) + } + } + } + } + + // v.d2 = D1_B * v.d0 (along B) + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n2, total_pencils, n2, + 1.0, D1_B, n2, data_in, total_pencils, + 0.0, data_out, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int i = 0; i < n1; i++) { + int col = ivar + nvar * (i + n1 * k); + for (int j = 0; j < n2; j++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d2[indx] = data_out[j * total_pencils + col]; + } + } + } + } + + // v.d22 = D2_B * v.d0 + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n2, total_pencils, n2, + 1.0, D2_B, n2, data_in, total_pencils, + 0.0, data_out, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int i = 0; i < n1; i++) { + int col = ivar + nvar * (i + n1 * k); + for (int j = 0; j < n2; j++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d22[indx] = data_out[j * total_pencils + col]; + } + } + } + } + + // v.d12 = D1_B * v.d1 (mixed: d/dB of dv/dA) + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n2, total_pencils, n2, + 1.0, D1_B, n2, data_in2, total_pencils, + 0.0, data_out2, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int k = 0; k < n3; k++) { + for (int i = 0; i < n1; i++) { + int col = ivar + nvar * (i + n1 * k); + for (int j = 0; j < n2; j++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d12[indx] = data_out2[j * total_pencils + col]; + } + } + } + } + + delete[] data_in; + delete[] data_out; + delete[] data_in2; + delete[] data_out2; + + /*===================================================== + * STEP 3: phi-direction derivatives (Fourier, DF1_phi, DF2_phi) + * + * Pencils along k for each (ivar, i, j). + * Also compute mixed derivatives v.d13, v.d23 + *=====================================================*/ + total_pencils = nvar * n1 * n2; + + data_in = new double[n3 * total_pencils]; + data_out = new double[n3 * total_pencils]; + data_in2 = new double[n3 * total_pencils]; // for v.d1 → v.d13 + data_out2 = new double[n3 * total_pencils]; + double *data_in3 = new double[n3 * total_pencils]; // for v.d2 → v.d23 + double *data_out3 = new double[n3 * total_pencils]; + + // Gather v.d0, v.d1, v.d2 along phi-direction + for (int ivar = 0; ivar < nvar; ivar++) { + for (int i = 0; i < n1; i++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (i + n1 * j); + for (int k = 0; k < n3; k++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + data_in[k * total_pencils + col] = v.d0[indx]; + data_in2[k * total_pencils + col] = v.d1[indx]; + data_in3[k * total_pencils + col] = v.d2[indx]; + } + } + } + } + + // v.d3 = DF1_phi * v.d0 + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n3, total_pencils, n3, + 1.0, DF1_phi, n3, data_in, total_pencils, + 0.0, data_out, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int i = 0; i < n1; i++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (i + n1 * j); + for (int k = 0; k < n3; k++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d3[indx] = data_out[k * total_pencils + col]; + } + } + } + } + + // v.d33 = DF2_phi * v.d0 + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n3, total_pencils, n3, + 1.0, DF2_phi, n3, data_in, total_pencils, + 0.0, data_out, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int i = 0; i < n1; i++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (i + n1 * j); + for (int k = 0; k < n3; k++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d33[indx] = data_out[k * total_pencils + col]; + } + } + } + } + + // v.d13 = DF1_phi * v.d1 (mixed: d/dphi of dv/dA) + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n3, total_pencils, n3, + 1.0, DF1_phi, n3, data_in2, total_pencils, + 0.0, data_out2, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int i = 0; i < n1; i++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (i + n1 * j); + for (int k = 0; k < n3; k++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d13[indx] = data_out2[k * total_pencils + col]; + } + } + } + } + + // v.d23 = DF1_phi * v.d2 (mixed: d/dphi of dv/dB) + cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, + n3, total_pencils, n3, + 1.0, DF1_phi, n3, data_in3, total_pencils, + 0.0, data_out3, total_pencils); + + for (int ivar = 0; ivar < nvar; ivar++) { + for (int i = 0; i < n1; i++) { + for (int j = 0; j < n2; j++) { + int col = ivar + nvar * (i + n1 * j); + for (int k = 0; k < n3; k++) { + int indx = Index(ivar, i, j, k, nvar, n1, n2, n3); + v.d23[indx] = data_out3[k * total_pencils + col]; + } + } + } + } + + delete[] data_in; + delete[] data_out; + delete[] data_in2; + delete[] data_out2; + delete[] data_in3; + delete[] data_out3; +} + diff --git a/AMSS_NCKU_source/TwoPunctures.h b/AMSS_NCKU_source/Two_Puncture/TwoPunctures.h similarity index 97% rename from AMSS_NCKU_source/TwoPunctures.h rename to AMSS_NCKU_source/Two_Puncture/TwoPunctures.h index 5f95797..01a217e 100644 --- a/AMSS_NCKU_source/TwoPunctures.h +++ b/AMSS_NCKU_source/Two_Puncture/TwoPunctures.h @@ -1,167 +1,167 @@ -#ifndef TWO_PUNCTURES_H -#define TWO_PUNCTURES_H - -#include - -#define StencilSize 19 -#define N_PlaneRelax 1 -#define NRELAX 200 -#define Step_Relax 1 - -#define Pi 3.14159265358979323846264338328 -#define Pih 1.57079632679489661923132169164 /* Pi/2*/ -#define Piq 0.78539816339744830961566084582 /* Pi/4*/ - -#define TINY 1.0e-20 - -class TwoPunctures -{ -public: - typedef struct DERIVS - { - double *d0, *d1, *d2, *d3, *d11, *d12, *d13, *d22, *d23, *d33; - } derivs; - - double *F; - derivs u, v; - -private: - double par_m_plus, par_m_minus, par_b; - double par_P_plus[3], par_P_minus[3]; - double par_S_plus[3], par_S_minus[3]; - - int npoints_A, npoints_B, npoints_phi; - - double target_M_plus, target_M_minus; - - double admMass; - - double adm_tol; - - double Newton_tol; - int Newton_maxit; - - int ntotal; - - // ===== Precomputed spectral derivative matrices ===== - double *D1_A, *D2_A; - double *D1_B, *D2_B; - double *DF1_phi, *DF2_phi; - - // ===== Pre-allocated workspace for LineRelax (per-thread) ===== - int max_threads; - double **ws_diag_be, **ws_e_be, **ws_f_be, **ws_b_be, **ws_x_be; - double **ws_l_be, **ws_u_be, **ws_d_be, **ws_y_be; - double **ws_diag_al, **ws_e_al, **ws_f_al, **ws_b_al, **ws_x_al; - double **ws_l_al, **ws_u_al, **ws_d_al, **ws_y_al; - - struct parameters - { - int nvar, n1, n2, n3; - double b; - }; - -public: - TwoPunctures(double mp, double mm, double b, double P_plusx, double P_plusy, double P_plusz, - double S_plusx, double S_plusy, double S_plusz, - double P_minusx, double P_minusy, double P_minusz, - double S_minusx, double S_minusy, double S_minusz, - int nA, int nB, int nphi, - double Mp, double Mm, double admtol, double Newtontol, - int Newtonmaxit); - ~TwoPunctures(); - - // 02/07: New/modified methods - void allocate_workspace(); - void free_workspace(); - void precompute_derivative_matrices(); - void build_cheb_deriv_matrices(int n, double *D1, double *D2); - void build_fourier_deriv_matrices(int N, double *DF1, double *DF2); - void Derivatives_AB3_MatMul(int nvar, int n1, int n2, int n3, derivs v); - void ThomasAlgorithm_ws(int N, double *b, double *a, double *c, double *x, double *q, - double *l, double *u_ws, double *d, double *y); - void LineRelax_be_omp(double *dv, - int const i, int const k, int const nvar, - int const n1, int const n2, int const n3, - double const *rhs, int const *ncols, int **cols, - double **JFD, int tid); - void LineRelax_al_omp(double *dv, - int const j, int const k, int const nvar, - int const n1, int const n2, int const n3, - double const *rhs, int const *ncols, - int **cols, double **JFD, int tid); - void relax_omp(double *dv, int const nvar, int const n1, int const n2, int const n3, - double const *rhs, int const *ncols, int **cols, double **JFD); - - void Solve(); - void set_initial_guess(derivs v); - int index(int i, int j, int k, int l, int a, int b, int c, int d); - int *ivector(long nl, long nh); - double *dvector(long nl, long nh); - int **imatrix(long nrl, long nrh, long ncl, long nch); - double **dmatrix(long nrl, long nrh, long ncl, long nch); - double ***d3tensor(long nrl, long nrh, long ncl, long nch, long ndl, long ndh); - void free_ivector(int *v, long nl, long nh); - void free_dvector(double *v, long nl, long nh); - void free_imatrix(int **m, long nrl, long nrh, long ncl, long nch); - void free_dmatrix(double **m, long nrl, long nrh, long ncl, long nch); - void free_d3tensor(double ***t, long nrl, long nrh, long ncl, long nch, - long ndl, long ndh); - int minimum2(int i, int j); - int minimum3(int i, int j, int k); - int maximum2(int i, int j); - int maximum3(int i, int j, int k); - int pow_int(int mantisse, int exponent); - void chebft_Zeros(double u[], int n, int inv); - void chebft_Extremes(double u[], int n, int inv); - void chder(double *c, double *cder, int n); - double chebev(double a, double b, double c[], int m, double x); - void fourft(double *u, int N, int inv); - void fourder(double u[], double du[], int N); - void fourder2(double u[], double d2u[], int N); - double fourev(double *u, int N, double x); - double norm1(double *v, int n); - double norm2(double *v, int n); - double scalarproduct(double *v, double *w, int n); - double PunctIntPolAtArbitPosition(int ivar, int nvar, int n1, - int n2, int n3, derivs v, double x, double y, - double z); - double PunctEvalAtArbitPosition(double *v, int ivar, double A, double B, double phi, - int nvar, int n1, int n2, int n3); - void AB_To_XR(int nvar, double A, double B, double *X, double *R, - derivs U); - void C_To_c(int nvar, double X, double R, double *x, double *r, - derivs U); - void rx3_To_xyz(int nvar, double x, double r, double phi, - double *y, double *z, derivs U); - void Derivatives_AB3(int nvar, int n1, int n2, int n3, derivs v); - void Newton(int const nvar, int const n1, int const n2, int const n3, - derivs v, double const tol, int const itmax); - void F_of_v(int nvar, int n1, int n2, int n3, derivs v, double *F, - derivs u); - double norm_inf(double const *F, int const ntotal); - int bicgstab(int const nvar, int const n1, int const n2, int const n3, - derivs v, derivs dv, int const itmax, double const tol, - double *normres); - void allocate_derivs(derivs *v, int n); - void free_derivs(derivs *v, int n); - int Index(int ivar, int i, int j, int k, int nvar, int n1, int n2, int n3); - void NonLinEquations(double rho_adm, double A, double B, double X, double R, double x, double r, double phi, - double y, double z, derivs U, double *values); - double BY_KKofxyz(double x, double y, double z); - void SetMatrix_JFD(int nvar, int n1, int n2, int n3, derivs u, int *ncols, int **cols, double **Matrix); - void J_times_dv(int nvar, int n1, int n2, int n3, derivs dv, double *Jdv, derivs u); - void JFD_times_dv(int i, int j, int k, int nvar, int n1, int n2, - int n3, derivs dv, derivs u, double *values); - void LinEquations(double A, double B, double X, double R, - double x, double r, double phi, - double y, double z, derivs dU, derivs U, double *values); - void ThomasAlgorithm(int N, double *b, double *a, double *c, double *x, double *q); - void Save(char *fname); - // provided by Vasileios Paschalidis (vpaschal@illinois.edu) - double Spec_IntPolABphiFast(parameters par, double *v, int ivar, double A, double B, double phi); - double Spec_IntPolFast(parameters par, int ivar, double *v, double x, double y, double z); - void SpecCoef(parameters par, int ivar, double *v, double *cf); -}; - +#ifndef TWO_PUNCTURES_H +#define TWO_PUNCTURES_H + +#include + +#define StencilSize 19 +#define N_PlaneRelax 1 +#define NRELAX 200 +#define Step_Relax 1 + +#define Pi 3.14159265358979323846264338328 +#define Pih 1.57079632679489661923132169164 /* Pi/2*/ +#define Piq 0.78539816339744830961566084582 /* Pi/4*/ + +#define TINY 1.0e-20 + +class TwoPunctures +{ +public: + typedef struct DERIVS + { + double *d0, *d1, *d2, *d3, *d11, *d12, *d13, *d22, *d23, *d33; + } derivs; + + double *F; + derivs u, v; + +private: + double par_m_plus, par_m_minus, par_b; + double par_P_plus[3], par_P_minus[3]; + double par_S_plus[3], par_S_minus[3]; + + int npoints_A, npoints_B, npoints_phi; + + double target_M_plus, target_M_minus; + + double admMass; + + double adm_tol; + + double Newton_tol; + int Newton_maxit; + + int ntotal; + + // ===== Precomputed spectral derivative matrices ===== + double *D1_A, *D2_A; + double *D1_B, *D2_B; + double *DF1_phi, *DF2_phi; + + // ===== Pre-allocated workspace for LineRelax (per-thread) ===== + int max_threads; + double **ws_diag_be, **ws_e_be, **ws_f_be, **ws_b_be, **ws_x_be; + double **ws_l_be, **ws_u_be, **ws_d_be, **ws_y_be; + double **ws_diag_al, **ws_e_al, **ws_f_al, **ws_b_al, **ws_x_al; + double **ws_l_al, **ws_u_al, **ws_d_al, **ws_y_al; + + struct parameters + { + int nvar, n1, n2, n3; + double b; + }; + +public: + TwoPunctures(double mp, double mm, double b, double P_plusx, double P_plusy, double P_plusz, + double S_plusx, double S_plusy, double S_plusz, + double P_minusx, double P_minusy, double P_minusz, + double S_minusx, double S_minusy, double S_minusz, + int nA, int nB, int nphi, + double Mp, double Mm, double admtol, double Newtontol, + int Newtonmaxit); + ~TwoPunctures(); + + // 02/07: New/modified methods + void allocate_workspace(); + void free_workspace(); + void precompute_derivative_matrices(); + void build_cheb_deriv_matrices(int n, double *D1, double *D2); + void build_fourier_deriv_matrices(int N, double *DF1, double *DF2); + void Derivatives_AB3_MatMul(int nvar, int n1, int n2, int n3, derivs v); + void ThomasAlgorithm_ws(int N, double *b, double *a, double *c, double *x, double *q, + double *l, double *u_ws, double *d, double *y); + void LineRelax_be_omp(double *dv, + int const i, int const k, int const nvar, + int const n1, int const n2, int const n3, + double const *rhs, int const *ncols, int **cols, + double **JFD, int tid); + void LineRelax_al_omp(double *dv, + int const j, int const k, int const nvar, + int const n1, int const n2, int const n3, + double const *rhs, int const *ncols, + int **cols, double **JFD, int tid); + void relax_omp(double *dv, int const nvar, int const n1, int const n2, int const n3, + double const *rhs, int const *ncols, int **cols, double **JFD); + + void Solve(); + void set_initial_guess(derivs v); + int index(int i, int j, int k, int l, int a, int b, int c, int d); + int *ivector(long nl, long nh); + double *dvector(long nl, long nh); + int **imatrix(long nrl, long nrh, long ncl, long nch); + double **dmatrix(long nrl, long nrh, long ncl, long nch); + double ***d3tensor(long nrl, long nrh, long ncl, long nch, long ndl, long ndh); + void free_ivector(int *v, long nl, long nh); + void free_dvector(double *v, long nl, long nh); + void free_imatrix(int **m, long nrl, long nrh, long ncl, long nch); + void free_dmatrix(double **m, long nrl, long nrh, long ncl, long nch); + void free_d3tensor(double ***t, long nrl, long nrh, long ncl, long nch, + long ndl, long ndh); + int minimum2(int i, int j); + int minimum3(int i, int j, int k); + int maximum2(int i, int j); + int maximum3(int i, int j, int k); + int pow_int(int mantisse, int exponent); + void chebft_Zeros(double u[], int n, int inv); + void chebft_Extremes(double u[], int n, int inv); + void chder(double *c, double *cder, int n); + double chebev(double a, double b, double c[], int m, double x); + void fourft(double *u, int N, int inv); + void fourder(double u[], double du[], int N); + void fourder2(double u[], double d2u[], int N); + double fourev(double *u, int N, double x); + double norm1(double *v, int n); + double norm2(double *v, int n); + double scalarproduct(double *v, double *w, int n); + double PunctIntPolAtArbitPosition(int ivar, int nvar, int n1, + int n2, int n3, derivs v, double x, double y, + double z); + double PunctEvalAtArbitPosition(double *v, int ivar, double A, double B, double phi, + int nvar, int n1, int n2, int n3); + void AB_To_XR(int nvar, double A, double B, double *X, double *R, + derivs U); + void C_To_c(int nvar, double X, double R, double *x, double *r, + derivs U); + void rx3_To_xyz(int nvar, double x, double r, double phi, + double *y, double *z, derivs U); + void Derivatives_AB3(int nvar, int n1, int n2, int n3, derivs v); + void Newton(int const nvar, int const n1, int const n2, int const n3, + derivs v, double const tol, int const itmax); + void F_of_v(int nvar, int n1, int n2, int n3, derivs v, double *F, + derivs u); + double norm_inf(double const *F, int const ntotal); + int bicgstab(int const nvar, int const n1, int const n2, int const n3, + derivs v, derivs dv, int const itmax, double const tol, + double *normres); + void allocate_derivs(derivs *v, int n); + void free_derivs(derivs *v, int n); + int Index(int ivar, int i, int j, int k, int nvar, int n1, int n2, int n3); + void NonLinEquations(double rho_adm, double A, double B, double X, double R, double x, double r, double phi, + double y, double z, derivs U, double *values); + double BY_KKofxyz(double x, double y, double z); + void SetMatrix_JFD(int nvar, int n1, int n2, int n3, derivs u, int *ncols, int **cols, double **Matrix); + void J_times_dv(int nvar, int n1, int n2, int n3, derivs dv, double *Jdv, derivs u); + void JFD_times_dv(int i, int j, int k, int nvar, int n1, int n2, + int n3, derivs dv, derivs u, double *values); + void LinEquations(double A, double B, double X, double R, + double x, double r, double phi, + double y, double z, derivs dU, derivs U, double *values); + void ThomasAlgorithm(int N, double *b, double *a, double *c, double *x, double *q); + void Save(char *fname); + // provided by Vasileios Paschalidis (vpaschal@illinois.edu) + double Spec_IntPolABphiFast(parameters par, double *v, int ivar, double A, double B, double phi); + double Spec_IntPolFast(parameters par, int ivar, double *v, double x, double y, double z); + void SpecCoef(parameters par, int ivar, double *v, double *cf); +}; + #endif /* TWO_PUNCTURES_H */ \ No newline at end of file diff --git a/AMSS_NCKU_source/MyList.h b/AMSS_NCKU_source/Variable/MyList.h similarity index 93% rename from AMSS_NCKU_source/MyList.h rename to AMSS_NCKU_source/Variable/MyList.h index d6eea77..933284c 100644 --- a/AMSS_NCKU_source/MyList.h +++ b/AMSS_NCKU_source/Variable/MyList.h @@ -1,109 +1,109 @@ - -#ifndef MYLIST_H -#define MYLIST_H - -// Note: There is never an implementation file (*.C) for a template class - -template -class MyList -{ - -public: - MyList *next; - T *data; - -public: - MyList(); - MyList(T *p); - ~MyList(); - void insert(T *p); - void clearList(); - void destroyList(); - void catList(MyList *p); - void CloneList(MyList *p); -}; - -template -MyList::MyList() -{ - data = 0; - next = 0; -} -template -MyList::MyList(T *p) -{ - data = p; - next = 0; -} - -template -MyList::~MyList() -{ -} -template -void MyList::insert(T *p) -{ - MyList *ct = this; - if (data == 0) - { - data = p; - } - else - { - while (ct->next) - { - ct = ct->next; - } - ct->next = new MyList(p); - ct = ct->next; - ct->next = 0; - } -} -template -void MyList::clearList() -{ - MyList *ct = this, *n; - while (ct) - { - n = ct->next; - delete ct; - ct = n; - } -} -template -void MyList::destroyList() -{ - MyList *ct = this, *n; - while (ct) - { - n = ct->next; - delete ct->data; - delete ct; - ct = n; - } -} -template -void MyList::catList(MyList *p) -{ - MyList *ct = this; - while (ct->next) - { - ct = ct->next; - } - ct->next = p; -} -template -void MyList::CloneList(MyList *p) -{ - MyList *ct = this; - p = 0; - while (ct) - { - if (!p) - p = new MyList(ct->data); - else - p->insert(ct->data); - ct = ct->next; - } -} -#endif /* MyList_H */ + +#ifndef MYLIST_H +#define MYLIST_H + +// Note: There is never an implementation file (*.C) for a template class + +template +class MyList +{ + +public: + MyList *next; + T *data; + +public: + MyList(); + MyList(T *p); + ~MyList(); + void insert(T *p); + void clearList(); + void destroyList(); + void catList(MyList *p); + void CloneList(MyList *p); +}; + +template +MyList::MyList() +{ + data = 0; + next = 0; +} +template +MyList::MyList(T *p) +{ + data = p; + next = 0; +} + +template +MyList::~MyList() +{ +} +template +void MyList::insert(T *p) +{ + MyList *ct = this; + if (data == 0) + { + data = p; + } + else + { + while (ct->next) + { + ct = ct->next; + } + ct->next = new MyList(p); + ct = ct->next; + ct->next = 0; + } +} +template +void MyList::clearList() +{ + MyList *ct = this, *n; + while (ct) + { + n = ct->next; + delete ct; + ct = n; + } +} +template +void MyList::destroyList() +{ + MyList *ct = this, *n; + while (ct) + { + n = ct->next; + delete ct->data; + delete ct; + ct = n; + } +} +template +void MyList::catList(MyList *p) +{ + MyList *ct = this; + while (ct->next) + { + ct = ct->next; + } + ct->next = p; +} +template +void MyList::CloneList(MyList *p) +{ + MyList *ct = this; + p = 0; + while (ct) + { + if (!p) + p = new MyList(ct->data); + else + p->insert(ct->data); + ct = ct->next; + } +} +#endif /* MyList_H */ diff --git a/AMSS_NCKU_source/parameters.h b/AMSS_NCKU_source/Variable/parameters.h similarity index 94% rename from AMSS_NCKU_source/parameters.h rename to AMSS_NCKU_source/Variable/parameters.h index edd0a71..e23fff5 100644 --- a/AMSS_NCKU_source/parameters.h +++ b/AMSS_NCKU_source/Variable/parameters.h @@ -1,35 +1,35 @@ - -#ifndef PARAMETERS_H -#define PARAMETERS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include - -namespace parameters -{ - extern map int_par; - extern map dou_par; - extern map str_par; -} -#endif /* PARAMETERS_H */ + +#ifndef PARAMETERS_H +#define PARAMETERS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include + +namespace parameters +{ + extern map int_par; + extern map dou_par; + extern map str_par; +} +#endif /* PARAMETERS_H */ diff --git a/AMSS_NCKU_source/var.C b/AMSS_NCKU_source/Variable/var.C similarity index 94% rename from AMSS_NCKU_source/var.C rename to AMSS_NCKU_source/Variable/var.C index 47a98ff..d734eda 100644 --- a/AMSS_NCKU_source/var.C +++ b/AMSS_NCKU_source/Variable/var.C @@ -1,38 +1,38 @@ - -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include -#include - -#include "var.h" - -var::var(const char *namei, int sgfni, - const double SYM1, const double SYM2, const double SYM3) : sgfn(sgfni) -{ - const char *p = namei; - int i = 0; - while (*(p++)) - i++; - if (i > 20) - cout << "too long name for var: " << namei << endl; - sprintf(name, namei); - SoA[0] = SYM1; - SoA[1] = SYM2; - SoA[2] = SYM3; - - propspeed = 1; -} - -var::~var() {} - -void var::setpropspeed(const double vl) -{ - propspeed = vl; -} + +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include +#include + +#include "var.h" + +var::var(const char *namei, int sgfni, + const double SYM1, const double SYM2, const double SYM3) : sgfn(sgfni) +{ + const char *p = namei; + int i = 0; + while (*(p++)) + i++; + if (i > 20) + cout << "too long name for var: " << namei << endl; + sprintf(name, namei); + SoA[0] = SYM1; + SoA[1] = SYM2; + SoA[2] = SYM3; + + propspeed = 1; +} + +var::~var() {} + +void var::setpropspeed(const double vl) +{ + propspeed = vl; +} diff --git a/AMSS_NCKU_source/var.h b/AMSS_NCKU_source/Variable/var.h similarity index 94% rename from AMSS_NCKU_source/var.h rename to AMSS_NCKU_source/Variable/var.h index 8d64a0c..0f733d8 100644 --- a/AMSS_NCKU_source/var.h +++ b/AMSS_NCKU_source/Variable/var.h @@ -1,26 +1,26 @@ - -#ifndef VAR_H -#define VAR_H - -class var -{ - -public: - char name[20]; - int sgfn; - double SoA[3]; - double propspeed; - -public: - var(const char *namei, int sgfni, - const double SYM1, const double SYM2, const double SYM3); - // original interface: - // var(char *namei, int sgfni, - // const double SYM1, const double SYM2, const double SYM3); - - ~var(); - - void setpropspeed(const double vl); -}; - -#endif /* VAR_H */ + +#ifndef VAR_H +#define VAR_H + +class var +{ + +public: + char name[20]; + int sgfn; + double SoA[3]; + double propspeed; + +public: + var(const char *namei, int sgfni, + const double SYM1, const double SYM2, const double SYM3); + // original interface: + // var(char *namei, int sgfni, + // const double SYM1, const double SYM2, const double SYM3); + + ~var(); + + void setpropspeed(const double vl); +}; + +#endif /* VAR_H */ diff --git a/AMSS_NCKU_source/Z4c_class.C b/AMSS_NCKU_source/Z4C/Z4c_class.C similarity index 97% rename from AMSS_NCKU_source/Z4c_class.C rename to AMSS_NCKU_source/Z4C/Z4c_class.C index 6f4cd27..d77c000 100644 --- a/AMSS_NCKU_source/Z4c_class.C +++ b/AMSS_NCKU_source/Z4C/Z4c_class.C @@ -1,2865 +1,2865 @@ - -#ifdef newc -#include -#include -#include -using namespace std; -#else -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "misc.h" -#include "Ansorg.h" -#include "fmisc.h" -#include "Parallel.h" -#include "Z4c_class.h" -#include "bssn_rhs.h" -#include "initial_puncture.h" -#include "enforce_algebra.h" -#include "rungekutta4_rout.h" -#include "sommerfeld_rout.h" -#include "getnp4.h" -#include "shellfunctions.h" -#include "cpbc.h" -#include "kodiss.h" -#include "parameters.h" - -#ifdef With_AHF -#include "derivatives.h" -#include "myglobal.h" -#endif - -//================================================================================================ - -// Define Z4c_class - -// This class inherits some members and methods from the parent `bssn_class` and modifies others. -// The modified members and methods are defined below (and in the header Z4c_class.h). -// The remaining members/methods are inherited from `bssn_class` (declared in bssn_class.h). - -Z4c_class::Z4c_class(double Couranti, double StartTimei, double TotalTimei, - double DumpTimei, double d2DumpTimei, - double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, - double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi) - : bssn_class(Couranti, StartTimei, TotalTimei, - DumpTimei, d2DumpTimei, CheckTimei, AnasTimei, - Symmetryi, checkruni, checkfilenamei, numepssi, numepsbi, numepshi, - a_levi, maxli, decni, maxrexi, drexi) -{ -} - -//================================================================================================ - - - -//================================================================================================ - -// this member function initializes the class - -//================================================================================================ - -void Z4c_class::Initialize() -{ - TZo = new var("TZo", ngfs++, 1, 1, 1); - TZ0 = new var("TZ0", ngfs++, 1, 1, 1); - TZ = new var("TZ", ngfs++, 1, 1, 1); - TZ1 = new var("TZ1", ngfs++, 1, 1, 1); - TZ_rhs = new var("TZ_rhs", ngfs++, 1, 1, 1); - - if (myrank == 0) - cout << "you have setted " << ngfs << " grid functions." << endl; - - OldStateList->insert(TZo); - StateList->insert(TZ0); - RHSList->insert(TZ_rhs); - SynchList_pre->insert(TZ); - SynchList_cor->insert(TZ1); - // DumpList->insert(TZ0); - ConstraintList->insert(TZ0); - - CheckPoint->addvariablelist(StateList); - CheckPoint->addvariablelist(OldStateList); - - char pname[50]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(pname, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); - if (checkrun) - CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); - else - GH->compose_cgh(nprocs); - -#ifdef WithShell - SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); - if (!checkrun) - SH->matchcheck(GH->PatL[0]); - SH->compose_sh(nprocs); - SH->setupcordtrans(); - SH->Dump_xyz(0, 0, 1); - SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); - - if (checkrun) - CheckPoint->readcheck_sh(SH, myrank); -#endif - - double h = GH->PatL[0]->data->blb->data->getdX(0); - for (int i = 1; i < dim; i++) - h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); - dT = Courant * h; - - if (checkrun) - { - CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); - } - else - { - PhysTime = StartTime; - Setup_Black_Hole_position(); - } -} - -//================================================================================================ - - - - -//================================================================================================ - -// this member function is the destructor, used to delete variables - -//================================================================================================ - -Z4c_class::~Z4c_class() -{ - delete TZo; - delete TZ0; - delete TZ; - delete TZ1; - delete TZ_rhs; -} - -//================================================================================================ - - - - -//================================================================================================ - -// This member function defines a single time step evolution in the time evolution process - -//================================================================================================ - -#define MRBD 0 // 0: fix BD for meshrefinement level; 1: sommerfeld_bam for them; 2: sommerfeld_yo for them - -#ifndef CPBC -// for sommerfeld boundary - -void Z4c_class::Step(int lev, int YN) -{ - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#if (MRBD == 0) - -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - -#elif (MRBD == 1) - // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#if (MRBD == 0) - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#elif (MRBD == 2) - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[TZ->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[TZ1->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (MRBD == 0) - -#ifndef WithShell - if (lev == 0) // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - -#elif (MRBD == 1) - // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - -#if (MRBD == 0) - -#ifndef WithShell - if (lev > 0) // fix BD point -#endif - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#elif (MRBD == 2) - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - -#ifdef WithShell - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[TZ->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[TZ1->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - // sommerfeld indeed for outter boudary while fix BD for inner boundary - f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); - - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -#endif - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } - -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - -#ifdef WithShell - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - -#endif - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#ifdef WithShell - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } -#endif - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -} -#else -// for constraint preserving boundary (CPBC) -#ifndef WithShell -#error "CPBC only supports Shell" -#endif - -// 0: extroplate rhs, 1: extroplate variable -// 2: extroplate variable but before RHS calculation -#define EXTO 1 - -// #define SMOOTHSHELL - -// change chi based on chitiny or not: 0: yes; 1: no -#define chinot 0 -void Z4c_class::Step(int lev, int YN) -{ - // Check_extrop(); - double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); -#ifdef With_AHF - AH_Step_Find(lev, dT_lev); -#endif - bool BB = fgt(PhysTime, StartTime, dT_lev / 2); - double fbeps = -0.1; - double ndeps = numepss; - if (lev < GH->movls) - ndeps = numepsb; - double TRK4 = PhysTime; - int iter_count = 0; // count RK4 substeps - int pre = 0, cor = 1; - int ERROR = 0; - - MyList *sPp; - // Predictor - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - -#if (chinot == 0) - if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } -#else - if (f_compute_rhs_Z4cnot(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre, chitiny)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } -#endif - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (MRBD == 1) - // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varlrhs->data->sgfn], - cg->fgfs[varl0->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#if (MRBD == 0) - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#elif (MRBD == 2) - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], - varl0->data->SoA, - Symmetry, pre); -#endif - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } - } -#if (chinot == 0) - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } -#if 0 -// check rhs - { - Parallel::Dump_Data(GH->PatL[lev],RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check irhs for box"<PatL[lev], StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (EXTO == 2) - // extroplate variable itself - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ0->sgfn], cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); -#endif - -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); -#endif - - if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, fbeps, sPp->data->sst, pre)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - - // rk4 substep and boundary - { - // CPBC indeed for outter boudary while fix BD for inner boundary - f_david_milton_cpbc_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[TZ0->sgfn], cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ_rhs->sgfn], cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], -#if (EXTO == 0) - Symmetry, fbeps, sPp->data->sst); - // extroplate rhs - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ_rhs->sgfn], cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); - - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[varl0->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - varl0->data->SoA, Symmetry, numepsh, sPp->data->sst); -#elif (EXTO == 1 || EXTO == 2) - Symmetry, numepsh, sPp->data->sst); - - MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varlrhs = varlrhs->next; - } -#if (EXTO == 1) - // extroplate variable itself - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ->sgfn], cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); -#endif - } -#if (chinot == 0) - f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); -#endif - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"<Dump_Data(RHSList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check rhs"<Dump_Data(SynchList_pre,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check SynchList_pre"<Dump_Data(StateList, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); - - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_pre, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - -#ifdef SMOOTHSHELL - // smooth Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - MyList *varl = SynchList_pre; - while (varl) - { - f_kodis_shcr(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl->data->sgfn], - varl->data->SoA, Symmetry, numepsh, sPp->data->sst); - varl = varl->next; - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - SH->Synch(SynchList_pre, Symmetry); - } -// end smooth -#endif - -#if 0 -// check SynchList_pre after Synch - { - SH->Dump_Data(SynchList_pre,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check SynchList_pre"< 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg[ithBH][2] = fabs(Porg[ithBH][2]); - if (Symmetry == 2) - { - Porg[ithBH][0] = fabs(Porg[ithBH][0]); - Porg[ithBH][1] = fabs(Porg[ithBH][1]); - } - if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" - << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // data analysis part - // Warning NOTE: the variables1 are used as temp storege room - if (lev == a_lev) - { - AnalysisStuff(lev, dT_lev); - } - // corrector - for (iter_count = 1; iter_count < 4; iter_count++) - { - // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; - if (iter_count == 1 || iter_count == 3) - TRK4 += dT_lev / 2; - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - -#if (chinot == 0) - if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[TZ->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[TZ1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } -#else - if (f_compute_rhs_Z4cnot(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[TZ->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[TZ1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, cor, chitiny)) - { - cout << "find NaN in domain: (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } -#endif - // rk4 substep and boundary - { - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { -#if (MRBD == 1) - // sommerfeld indeed - f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varl->data->sgfn], - varl0->data->propspeed, varl0->data->SoA, - Symmetry); -#endif - f_rungekutta4_rout(cg->shape, dT_lev, - cg->fgfs[varl0->data->sgfn], - cg->fgfs[varl1->data->sgfn], - cg->fgfs[varlrhs->data->sgfn], - iter_count); -#if (MRBD == 0) - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#elif (MRBD == 2) - f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], - Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], - Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], - dT_lev, - cg->fgfs[phi0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl0->data->SoA, - Symmetry, cor); -#endif - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } - } -#if (chinot == 0) - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); -#endif - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count - << " variables at t = " << PhysTime - << ", lev = " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - // evolve Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { -#if (EXTO == 2) - // extroplate variable itself - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ->sgfn], cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); -#endif - -#if (AGM == 0) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#elif (AGM == 1) - if (iter_count == 3) - f_enforce_ga(cg->shape, - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); -#endif - - if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[TZ->sgfn], - cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[TZ1->sgfn], - cg->fgfs[rho->sgfn], - cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, fbeps, sPp->data->sst, cor)) - { - cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" - << cg->bbox[0] << ":" << cg->bbox[3] << "," - << cg->bbox[1] << ":" << cg->bbox[4] << "," - << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; - ERROR = 1; - } - // rk4 substep and boundary - { - // CPBC indeed for outter boudary while fix BD for inner boundary - f_david_milton_cpbc_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], - sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], - cg->fgfs[TZ->sgfn], cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], - cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], - cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], - cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], - cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], - cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], - cg->fgfs[Lap->sgfn], - cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], - cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], - cg->fgfs[TZ1->sgfn], cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], -#if (EXTO == 0) - Symmetry, fbeps, sPp->data->sst); - // extroplate rhs - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ1->sgfn], cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); - - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; - // we do not check the correspondence here - - while (varl0) - { - f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], - varl->data->SoA, Symmetry, numepsh, sPp->data->sst); -#elif (EXTO == 1 || EXTO == 2) - Symmetry, numepsh, sPp->data->sst); - - MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here - while (varl0) - { -#endif - f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], - iter_count); - - varl0 = varl0->next; - varl = varl->next; - varl1 = varl1->next; - varlrhs = varlrhs->next; - } -#if (EXTO == 1) - // extroplate variable itself - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ1->sgfn], cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], - cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], - cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], - cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], - cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], - cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], - cg->fgfs[Lap1->sgfn], - cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], - cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); -#endif - } -#if (chinot == 0) - f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); -#endif - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // check error information - { - int erh = ERROR; - MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - } - if (ERROR) - { - SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); - if (myrank == 0) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count - << " variables at t = " << PhysTime << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); - - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->Synch(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " Shell stuff synchronization used " - << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } - -#ifdef SMOOTHSHELL - // smooth Shell Patches - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - MyList *varl = SynchList_cor; - while (varl) - { - f_kodis_shcr(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[varl->data->sgfn], cg->fgfs[varl->data->sgfn], - varl->data->SoA, Symmetry, numepsh, sPp->data->sst); - varl = varl->next; - } - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - SH->Synch(SynchList_cor, Symmetry); - } -// end smooth -#endif - - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); - f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); - if (Symmetry > 0) - Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); - if (Symmetry == 2) - { - Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); - Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); - } - if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) - { - if (ErrorMonitor->outfile) - ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" - << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] - << ")" << endl; - - MyList *DG_List = new MyList(Sfx0); - DG_List->insert(Sfx0); - DG_List->insert(Sfy0); - DG_List->insert(Sfz0); - Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); - DG_List->clearList(); - } - } - } - // swap time level - if (iter_count < 3) - { - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(SynchList_pre, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - // for black hole position - if (BH_num > 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg[ithBH][0] = Porg1[ithBH][0]; - Porg[ithBH][1] = Porg1[ithBH][1]; - Porg[ithBH][2] = Porg1[ithBH][2]; - } - } - } - } - -#if (RPS == 0) - // mesh refinement boundary part - RestrictProlong(lev, YN, BB); - - if (lev == 0) - { - clock_t prev_clock, curr_clock; - if (myrank == 0) - curr_clock = clock(); - SH->CS_Inter(SynchList_cor, Symmetry); - if (myrank == 0) - { - prev_clock = curr_clock; - curr_clock = clock(); - cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) - << " seconds! " << endl; - } - } -#endif - - // note the data structure before update - // SynchList_cor 1 ----------- - // - // StateList 0 ----------- - // - // OldStateList old ----------- - // update - Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - - if (lev == 0) - { - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - while (BP) - { - Block *cg = BP->data; - cg->swapList(StateList, SynchList_cor, myrank); - cg->swapList(OldStateList, SynchList_cor, myrank); - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } -#if 0 -// check StateList - { - SH->Dump_Data(StateList,0,PhysTime,dT_lev); - if(myrank == 0) - { - cout<<"check StateList"< 0 && lev == GH->levels - 1) - { - for (int ithBH = 0; ithBH < BH_num; ithBH++) - { - Porg0[ithBH][0] = Porg1[ithBH][0]; - Porg0[ithBH][1] = Porg1[ithBH][1]; - Porg0[ithBH][2] = Porg1[ithBH][2]; - } - } -#if 0 - if(lev>6) - { - char str[50]; - MyList * DG_List=new MyList(Cons_Ham); - DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); - DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); - printf(str,"lao%d",lev); - Parallel::Dump_Data(GH->PatL[6],DG_List,str,PhysTime,dT_lev); - DG_List->clearList(); - } -#endif -} -#endif -#undef MRBD - -//================================================================================================ - - - -//================================================================================================ - -// this member function is used to check the extroplation result - -//================================================================================================ - -void Z4c_class::Check_extrop() -{ - MyList *sPp; - - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[TZ0->sgfn], cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - sPp->data->bbox[2], sPp->data->bbox[5]); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - - SH->Dump_Data(StateList, "extrop", 0, 1); - if (myrank == 0) - MPI_Abort(MPI_COMM_WORLD, 1); -} - -//================================================================================================ - - - -//================================================================================================ - -// this member function is used to compute and output constraint violation - -//================================================================================================ - -void Z4c_class::Constraint_Out() -{ - // here we have to use the same variable name as in the parent class - LastConsOut += dT * pow(0.5, Mymax(0, trfls)); - - if (LastConsOut >= AnasTime) - // Constraint violation - { - // recompute least the constraint data lost for moved new grid - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - if (lev > 0) - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - SH->Synch(ConstraintList, Symmetry); -#endif - - double ConV[8]; - -#ifdef WithShell - ConV[0] = SH->L2Norm(Cons_Ham); - ConV[1] = SH->L2Norm(Cons_Px); - ConV[2] = SH->L2Norm(Cons_Py); - ConV[3] = SH->L2Norm(Cons_Pz); - ConV[4] = SH->L2Norm(Cons_Gx); - ConV[5] = SH->L2Norm(Cons_Gy); - ConV[6] = SH->L2Norm(Cons_Gz); - ConV[7] = SH->L2Norm(TZ0); - ConVMonitor->writefile(PhysTime, 8, ConV); -#endif - for (int levi = 0; levi < GH->levels; levi++) - { - ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham); - ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px); - ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py); - ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz); - ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx); - ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy); - ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz); - ConV[7] = Parallel::L2Norm(GH->PatL[levi]->data, TZ0); - ConVMonitor->writefile(PhysTime, 8, ConV); - /* - if(fabs(ConV[0])<0.00001) - { - MyList * DG_List=new MyList(Cons_Ham); - DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); - DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); - Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); - DG_List->clearList(); - if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); - } - */ - } - - LastConsOut = 0; - } -} - -//================================================================================================ - - - -//================================================================================================ - -// this member function is used to interpolate constraint data - -//================================================================================================ - -void Z4c_class::Interp_Constraint() -{ - // we do not support a_lev != 0 yet. - if (a_lev > 0) - return; - - for (int lev = 0; lev < GH->levels; lev++) - { - // make sure the data consistent for higher levels - if (lev > 0) - { - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - SH->Synch(ConstraintList, Symmetry); -#endif - // interpolate - double *x1, *y1, *z1; - const int n = 1000; - double lmax, lmin, dd; - lmin = 0; -#ifdef WithShell - lmax = SH->Rrange[1]; -#else - lmax = GH->bbox[0][0][4]; -#endif -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (lmax - lmin) / (n - 1); -#else -#ifdef Cell - dd = (lmax - lmin) / n; -#else -#error Not define Vertex nor Cell -#endif -#endif - x1 = new double[n]; - y1 = new double[n]; - z1 = new double[n]; - for (int i = 0; i < n; i++) - { - x1[i] = 0; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - y1[i] = lmin + i * dd; -#else -#ifdef Cell - y1[i] = lmin + (i + 0.5) * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - z1[i] = 0; - } - - int InList = 0; - - MyList *varl = ConstraintList; - while (varl) - { - InList++; - varl = varl->next; - } - double *shellf; - shellf = new double[n * InList]; - for (int i = 0; i < n; i++) - { - double XX[3]; - XX[0] = x1[i]; - XX[1] = y1[i]; - XX[2] = z1[i]; - bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#ifdef WithShell - if (!fg) - fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); -#endif - if (!fg && myrank == 0) - { - cout << "bssn_class::Interp_Constraint meets wrong" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } - - ofstream outfile; - char filename[50]; - sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); - // 0.5 for round off - - outfile.open(filename); - outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; - for (int i = 0; i < n; i++) - { - outfile << setw(10) << setprecision(10) << y1[i]; - for (int j = 0; j < InList; j++) - outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; - outfile << endl; - } - - delete[] shellf; -} - -//================================================================================================ - - - -//================================================================================================ - -// this member function is used to compute constraint violation - -//================================================================================================ - -void Z4c_class::Compute_Constraint() -{ - double TRK4 = PhysTime; - double ndeps = numepsb; - int pre = 0; - int lev; - - for (lev = 0; lev < GH->levels; lev++) - { - { - MyList *Pp = GH->PatL[lev]; - while (Pp) - { - MyList *BP = Pp->data->blb; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, ndeps, pre); - } - if (BP == Pp->data->ble) - break; - BP = BP->next; - } - Pp = Pp->next; - } - } - Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); - } -#ifdef WithShell - lev = 0; - { - MyList *sPp; - sPp = SH->PatL; - while (sPp) - { - MyList *BP = sPp->data->blb; - int fngfs = sPp->data->fngfs; - while (BP) - { - Block *cg = BP->data; - if (myrank == cg->rank) - { - f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], - cg->fgfs[fngfs + ShellPatch::gx], - cg->fgfs[fngfs + ShellPatch::gy], - cg->fgfs[fngfs + ShellPatch::gz], - cg->fgfs[fngfs + ShellPatch::drhodx], - cg->fgfs[fngfs + ShellPatch::drhody], - cg->fgfs[fngfs + ShellPatch::drhodz], - cg->fgfs[fngfs + ShellPatch::dsigmadx], - cg->fgfs[fngfs + ShellPatch::dsigmady], - cg->fgfs[fngfs + ShellPatch::dsigmadz], - cg->fgfs[fngfs + ShellPatch::dRdx], - cg->fgfs[fngfs + ShellPatch::dRdy], - cg->fgfs[fngfs + ShellPatch::dRdz], - cg->fgfs[fngfs + ShellPatch::drhodxx], - cg->fgfs[fngfs + ShellPatch::drhodxy], - cg->fgfs[fngfs + ShellPatch::drhodxz], - cg->fgfs[fngfs + ShellPatch::drhodyy], - cg->fgfs[fngfs + ShellPatch::drhodyz], - cg->fgfs[fngfs + ShellPatch::drhodzz], - cg->fgfs[fngfs + ShellPatch::dsigmadxx], - cg->fgfs[fngfs + ShellPatch::dsigmadxy], - cg->fgfs[fngfs + ShellPatch::dsigmadxz], - cg->fgfs[fngfs + ShellPatch::dsigmadyy], - cg->fgfs[fngfs + ShellPatch::dsigmadyz], - cg->fgfs[fngfs + ShellPatch::dsigmadzz], - cg->fgfs[fngfs + ShellPatch::dRdxx], - cg->fgfs[fngfs + ShellPatch::dRdxy], - cg->fgfs[fngfs + ShellPatch::dRdxz], - cg->fgfs[fngfs + ShellPatch::dRdyy], - cg->fgfs[fngfs + ShellPatch::dRdyz], - cg->fgfs[fngfs + ShellPatch::dRdzz], - cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], - cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], - cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], - cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], - cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], - cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], - cg->fgfs[Lap0->sgfn], - cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], - cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], - cg->fgfs[TZ0->sgfn], - cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], - cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], - cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], - cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], - cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], - cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], - cg->fgfs[Lap_rhs->sgfn], - cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], - cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], - cg->fgfs[TZ_rhs->sgfn], - cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], - cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], - cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], - cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], - cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], - cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], - cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], - cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], - cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], - cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], - cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], - cg->fgfs[Cons_Ham->sgfn], - cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], - cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], - Symmetry, lev, numepsh, sPp->data->sst, pre); - } - if (BP == sPp->data->ble) - break; - BP = BP->next; - } - sPp = sPp->next; - } - } - SH->Synch(ConstraintList, Symmetry); -#endif -} - -//================================================================================================ - + +#ifdef newc +#include +#include +#include +using namespace std; +#else +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "misc.h" +#include "Ansorg.h" +#include "fmisc.h" +#include "Parallel.h" +#include "Z4c_class.h" +#include "bssn_rhs.h" +#include "initial_puncture.h" +#include "enforce_algebra.h" +#include "rungekutta4_rout.h" +#include "sommerfeld_rout.h" +#include "getnp4.h" +#include "shellfunctions.h" +#include "cpbc.h" +#include "kodiss.h" +#include "parameters.h" + +#ifdef With_AHF +#include "derivatives.h" +#include "myglobal.h" +#endif + +//================================================================================================ + +// Define Z4c_class + +// This class inherits some members and methods from the parent `bssn_class` and modifies others. +// The modified members and methods are defined below (and in the header Z4c_class.h). +// The remaining members/methods are inherited from `bssn_class` (declared in bssn_class.h). + +Z4c_class::Z4c_class(double Couranti, double StartTimei, double TotalTimei, + double DumpTimei, double d2DumpTimei, + double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, + double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi) + : bssn_class(Couranti, StartTimei, TotalTimei, + DumpTimei, d2DumpTimei, CheckTimei, AnasTimei, + Symmetryi, checkruni, checkfilenamei, numepssi, numepsbi, numepshi, + a_levi, maxli, decni, maxrexi, drexi) +{ +} + +//================================================================================================ + + + +//================================================================================================ + +// this member function initializes the class + +//================================================================================================ + +void Z4c_class::Initialize() +{ + TZo = new var("TZo", ngfs++, 1, 1, 1); + TZ0 = new var("TZ0", ngfs++, 1, 1, 1); + TZ = new var("TZ", ngfs++, 1, 1, 1); + TZ1 = new var("TZ1", ngfs++, 1, 1, 1); + TZ_rhs = new var("TZ_rhs", ngfs++, 1, 1, 1); + + if (myrank == 0) + cout << "you have setted " << ngfs << " grid functions." << endl; + + OldStateList->insert(TZo); + StateList->insert(TZ0); + RHSList->insert(TZ_rhs); + SynchList_pre->insert(TZ); + SynchList_cor->insert(TZ1); + // DumpList->insert(TZ0); + ConstraintList->insert(TZ0); + + CheckPoint->addvariablelist(StateList); + CheckPoint->addvariablelist(OldStateList); + + char pname[50]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(pname, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + GH = new cgh(0, ngfs, Symmetry, pname, checkrun, ErrorMonitor); + if (checkrun) + CheckPoint->readcheck_cgh(PhysTime, GH, myrank, nprocs, Symmetry); + else + GH->compose_cgh(nprocs); + +#ifdef WithShell + SH = new ShellPatch(0, ngfs, pname, Symmetry, myrank, ErrorMonitor); + if (!checkrun) + SH->matchcheck(GH->PatL[0]); + SH->compose_sh(nprocs); + SH->setupcordtrans(); + SH->Dump_xyz(0, 0, 1); + SH->setupintintstuff(nprocs, GH->PatL[0], Symmetry); + + if (checkrun) + CheckPoint->readcheck_sh(SH, myrank); +#endif + + double h = GH->PatL[0]->data->blb->data->getdX(0); + for (int i = 1; i < dim; i++) + h = Mymin(h, GH->PatL[0]->data->blb->data->getdX(i)); + dT = Courant * h; + + if (checkrun) + { + CheckPoint->read_Black_Hole_position(BH_num_input, BH_num, Porg0, Pmom, Spin, Mass, Porgbr, Porg, Porg1, Porg_rhs); + } + else + { + PhysTime = StartTime; + Setup_Black_Hole_position(); + } +} + +//================================================================================================ + + + + +//================================================================================================ + +// this member function is the destructor, used to delete variables + +//================================================================================================ + +Z4c_class::~Z4c_class() +{ + delete TZo; + delete TZ0; + delete TZ; + delete TZ1; + delete TZ_rhs; +} + +//================================================================================================ + + + + +//================================================================================================ + +// This member function defines a single time step evolution in the time evolution process + +//================================================================================================ + +#define MRBD 0 // 0: fix BD for meshrefinement level; 1: sommerfeld_bam for them; 2: sommerfeld_yo for them + +#ifndef CPBC +// for sommerfeld boundary + +void Z4c_class::Step(int lev, int YN) +{ + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#if (MRBD == 0) + +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + +#elif (MRBD == 1) + // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#if (MRBD == 0) + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#elif (MRBD == 2) + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[TZ->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[TZ1->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (MRBD == 0) + +#ifndef WithShell + if (lev == 0) // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + +#elif (MRBD == 1) + // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + +#if (MRBD == 0) + +#ifndef WithShell + if (lev > 0) // fix BD point +#endif + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#elif (MRBD == 2) + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + +#ifdef WithShell + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[TZ->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[TZ1->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + // sommerfeld indeed for outter boudary while fix BD for inner boundary + f_sommerfeld_routbam_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); + + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +#endif + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } + +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + +#ifdef WithShell + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + +#endif + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#ifdef WithShell + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } +#endif + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +} +#else +// for constraint preserving boundary (CPBC) +#ifndef WithShell +#error "CPBC only supports Shell" +#endif + +// 0: extroplate rhs, 1: extroplate variable +// 2: extroplate variable but before RHS calculation +#define EXTO 1 + +// #define SMOOTHSHELL + +// change chi based on chitiny or not: 0: yes; 1: no +#define chinot 0 +void Z4c_class::Step(int lev, int YN) +{ + // Check_extrop(); + double dT_lev = dT * pow(0.5, Mymax(lev, trfls)); +#ifdef With_AHF + AH_Step_Find(lev, dT_lev); +#endif + bool BB = fgt(PhysTime, StartTime, dT_lev / 2); + double fbeps = -0.1; + double ndeps = numepss; + if (lev < GH->movls) + ndeps = numepsb; + double TRK4 = PhysTime; + int iter_count = 0; // count RK4 substeps + int pre = 0, cor = 1; + int ERROR = 0; + + MyList *sPp; + // Predictor + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + +#if (chinot == 0) + if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } +#else + if (f_compute_rhs_Z4cnot(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre, chitiny)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } +#endif + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (MRBD == 1) + // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varlrhs->data->sgfn], + cg->fgfs[varl0->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#if (MRBD == 0) + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#elif (MRBD == 2) + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl->data->sgfn], + varl0->data->SoA, + Symmetry, pre); +#endif + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } + } +#if (chinot == 0) + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } +#if 0 +// check rhs + { + Parallel::Dump_Data(GH->PatL[lev],RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check irhs for box"<PatL[lev], StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (EXTO == 2) + // extroplate variable itself + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ0->sgfn], cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); +#endif + +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn]); +#endif + + if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, fbeps, sPp->data->sst, pre)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + + // rk4 substep and boundary + { + // CPBC indeed for outter boudary while fix BD for inner boundary + f_david_milton_cpbc_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[TZ0->sgfn], cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ_rhs->sgfn], cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], +#if (EXTO == 0) + Symmetry, fbeps, sPp->data->sst); + // extroplate rhs + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ_rhs->sgfn], cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); + + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], cg->fgfs[varl0->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + varl0->data->SoA, Symmetry, numepsh, sPp->data->sst); +#elif (EXTO == 1 || EXTO == 2) + Symmetry, numepsh, sPp->data->sst); + + MyList *varl0 = StateList, *varl = SynchList_pre, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varlrhs = varlrhs->next; + } +#if (EXTO == 1) + // extroplate variable itself + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ->sgfn], cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); +#endif + } +#if (chinot == 0) + f_lowerboundset(cg->shape, cg->fgfs[phi->sgfn], chitiny); +#endif + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"<Dump_Data(RHSList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check rhs"<Dump_Data(SynchList_pre,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check SynchList_pre"<Dump_Data(StateList, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in state variables on Shell Patches at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Parallel::Sync(GH->PatL[lev], SynchList_pre, Symmetry); + + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_pre, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + +#ifdef SMOOTHSHELL + // smooth Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + MyList *varl = SynchList_pre; + while (varl) + { + f_kodis_shcr(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl->data->sgfn], + varl->data->SoA, Symmetry, numepsh, sPp->data->sst); + varl = varl->next; + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + SH->Synch(SynchList_pre, Symmetry); + } +// end smooth +#endif + +#if 0 +// check SynchList_pre after Synch + { + SH->Dump_Data(SynchList_pre,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check SynchList_pre"< 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg0, Porg_rhs, Sfx0, Sfy0, Sfz0, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg[ithBH][2] = fabs(Porg[ithBH][2]); + if (Symmetry == 2) + { + Porg[ithBH][0] = fabs(Porg[ithBH][0]); + Porg[ithBH][1] = fabs(Porg[ithBH][1]); + } + if (!finite(Porg[ithBH][0]) || !finite(Porg[ithBH][1]) || !finite(Porg[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "predictor step finds NaN for BH's position from (" + << Porg0[ithBH][0] << "," << Porg0[ithBH][1] << "," << Porg0[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // data analysis part + // Warning NOTE: the variables1 are used as temp storege room + if (lev == a_lev) + { + AnalysisStuff(lev, dT_lev); + } + // corrector + for (iter_count = 1; iter_count < 4; iter_count++) + { + // for RK4: t0, t0+dt/2, t0+dt/2, t0+dt; + if (iter_count == 1 || iter_count == 3) + TRK4 += dT_lev / 2; + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + +#if (chinot == 0) + if (f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[TZ->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[TZ1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } +#else + if (f_compute_rhs_Z4cnot(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[TZ->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[TZ1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, cor, chitiny)) + { + cout << "find NaN in domain: (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } +#endif + // rk4 substep and boundary + { + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { +#if (MRBD == 1) + // sommerfeld indeed + f_sommerfeld_routbam(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varl->data->sgfn], + varl0->data->propspeed, varl0->data->SoA, + Symmetry); +#endif + f_rungekutta4_rout(cg->shape, dT_lev, + cg->fgfs[varl0->data->sgfn], + cg->fgfs[varl1->data->sgfn], + cg->fgfs[varlrhs->data->sgfn], + iter_count); +#if (MRBD == 0) + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#elif (MRBD == 2) + f_sommerfeld_rout(cg->shape, cg->X[0], cg->X[1], cg->X[2], + Pp->data->bbox[0], Pp->data->bbox[1], Pp->data->bbox[2], + Pp->data->bbox[3], Pp->data->bbox[4], Pp->data->bbox[5], + dT_lev, + cg->fgfs[phi0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl0->data->SoA, + Symmetry, cor); +#endif + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } + } +#if (chinot == 0) + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); +#endif + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + Parallel::Dump_Data(GH->PatL[lev], SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN in RK4 substep#" << iter_count + << " variables at t = " << PhysTime + << ", lev = " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + // evolve Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { +#if (EXTO == 2) + // extroplate variable itself + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ->sgfn], cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); +#endif + +#if (AGM == 0) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#elif (AGM == 1) + if (iter_count == 3) + f_enforce_ga(cg->shape, + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn]); +#endif + + if (f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[TZ->sgfn], + cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[TZ1->sgfn], + cg->fgfs[rho->sgfn], + cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, fbeps, sPp->data->sst, cor)) + { + cout << "find NaN in Shell domain: sst = " << sPp->data->sst << ", (" + << cg->bbox[0] << ":" << cg->bbox[3] << "," + << cg->bbox[1] << ":" << cg->bbox[4] << "," + << cg->bbox[2] << ":" << cg->bbox[5] << ")" << endl; + ERROR = 1; + } + // rk4 substep and boundary + { + // CPBC indeed for outter boudary while fix BD for inner boundary + f_david_milton_cpbc_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + sPp->data->bbox[0], sPp->data->bbox[1], sPp->data->bbox[2], + sPp->data->bbox[3], sPp->data->bbox[4], sPp->data->bbox[5], + cg->fgfs[TZ->sgfn], cg->fgfs[phi->sgfn], cg->fgfs[trK->sgfn], + cg->fgfs[gxx->sgfn], cg->fgfs[gxy->sgfn], cg->fgfs[gxz->sgfn], + cg->fgfs[gyy->sgfn], cg->fgfs[gyz->sgfn], cg->fgfs[gzz->sgfn], + cg->fgfs[Axx->sgfn], cg->fgfs[Axy->sgfn], cg->fgfs[Axz->sgfn], + cg->fgfs[Ayy->sgfn], cg->fgfs[Ayz->sgfn], cg->fgfs[Azz->sgfn], + cg->fgfs[Gmx->sgfn], cg->fgfs[Gmy->sgfn], cg->fgfs[Gmz->sgfn], + cg->fgfs[Lap->sgfn], + cg->fgfs[Sfx->sgfn], cg->fgfs[Sfy->sgfn], cg->fgfs[Sfz->sgfn], + cg->fgfs[dtSfx->sgfn], cg->fgfs[dtSfy->sgfn], cg->fgfs[dtSfz->sgfn], + cg->fgfs[TZ1->sgfn], cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], +#if (EXTO == 0) + Symmetry, fbeps, sPp->data->sst); + // extroplate rhs + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ1->sgfn], cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); + + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; + // we do not check the correspondence here + + while (varl0) + { + f_kodis_sh(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl1->data->sgfn], + varl->data->SoA, Symmetry, numepsh, sPp->data->sst); +#elif (EXTO == 1 || EXTO == 2) + Symmetry, numepsh, sPp->data->sst); + + MyList *varl0 = StateList, *varl = SynchList_pre, *varl1 = SynchList_cor, *varlrhs = RHSList; // we do not check the correspondence here + while (varl0) + { +#endif + f_rungekutta4_rout(cg->shape, dT_lev, cg->fgfs[varl0->data->sgfn], cg->fgfs[varl1->data->sgfn], cg->fgfs[varlrhs->data->sgfn], + iter_count); + + varl0 = varl0->next; + varl = varl->next; + varl1 = varl1->next; + varlrhs = varlrhs->next; + } +#if (EXTO == 1) + // extroplate variable itself + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ1->sgfn], cg->fgfs[phi1->sgfn], cg->fgfs[trK1->sgfn], + cg->fgfs[gxx1->sgfn], cg->fgfs[gxy1->sgfn], cg->fgfs[gxz1->sgfn], + cg->fgfs[gyy1->sgfn], cg->fgfs[gyz1->sgfn], cg->fgfs[gzz1->sgfn], + cg->fgfs[Axx1->sgfn], cg->fgfs[Axy1->sgfn], cg->fgfs[Axz1->sgfn], + cg->fgfs[Ayy1->sgfn], cg->fgfs[Ayz1->sgfn], cg->fgfs[Azz1->sgfn], + cg->fgfs[Gmx1->sgfn], cg->fgfs[Gmy1->sgfn], cg->fgfs[Gmz1->sgfn], + cg->fgfs[Lap1->sgfn], + cg->fgfs[Sfx1->sgfn], cg->fgfs[Sfy1->sgfn], cg->fgfs[Sfz1->sgfn], + cg->fgfs[dtSfx1->sgfn], cg->fgfs[dtSfy1->sgfn], cg->fgfs[dtSfz1->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); +#endif + } +#if (chinot == 0) + f_lowerboundset(cg->shape, cg->fgfs[phi1->sgfn], chitiny); +#endif + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // check error information + { + int erh = ERROR; + MPI_Allreduce(&erh, &ERROR, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + } + if (ERROR) + { + SH->Dump_Data(SynchList_pre, 0, PhysTime, dT_lev); + if (myrank == 0) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << "find NaN on Shell Patches in RK4 substep#" << iter_count + << " variables at t = " << PhysTime << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + Parallel::Sync(GH->PatL[lev], SynchList_cor, Symmetry); + + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->Synch(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " Shell stuff synchronization used " + << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } + +#ifdef SMOOTHSHELL + // smooth Shell Patches + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + MyList *varl = SynchList_cor; + while (varl) + { + f_kodis_shcr(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[varl->data->sgfn], cg->fgfs[varl->data->sgfn], + varl->data->SoA, Symmetry, numepsh, sPp->data->sst); + varl = varl->next; + } + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + SH->Synch(SynchList_cor, Symmetry); + } +// end smooth +#endif + + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + compute_Porg_rhs(Porg, Porg1, Sfx, Sfy, Sfz, lev); + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][0], Porg1[ithBH][0], Porg_rhs[ithBH][0], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][1], Porg1[ithBH][1], Porg_rhs[ithBH][1], iter_count); + f_rungekutta4_scalar(dT_lev, Porg0[ithBH][2], Porg1[ithBH][2], Porg_rhs[ithBH][2], iter_count); + if (Symmetry > 0) + Porg1[ithBH][2] = fabs(Porg1[ithBH][2]); + if (Symmetry == 2) + { + Porg1[ithBH][0] = fabs(Porg1[ithBH][0]); + Porg1[ithBH][1] = fabs(Porg1[ithBH][1]); + } + if (!finite(Porg1[ithBH][0]) || !finite(Porg1[ithBH][1]) || !finite(Porg1[ithBH][2])) + { + if (ErrorMonitor->outfile) + ErrorMonitor->outfile << iter_count << " corrector step finds NaN for BH's position from (" + << Porg[ithBH][0] << "," << Porg[ithBH][1] << "," << Porg[ithBH][2] + << ")" << endl; + + MyList *DG_List = new MyList(Sfx0); + DG_List->insert(Sfx0); + DG_List->insert(Sfy0); + DG_List->insert(Sfz0); + Parallel::Dump_Data(GH->PatL[lev], DG_List, 0, PhysTime, dT_lev); + DG_List->clearList(); + } + } + } + // swap time level + if (iter_count < 3) + { + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(SynchList_pre, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + // for black hole position + if (BH_num > 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg[ithBH][0] = Porg1[ithBH][0]; + Porg[ithBH][1] = Porg1[ithBH][1]; + Porg[ithBH][2] = Porg1[ithBH][2]; + } + } + } + } + +#if (RPS == 0) + // mesh refinement boundary part + RestrictProlong(lev, YN, BB); + + if (lev == 0) + { + clock_t prev_clock, curr_clock; + if (myrank == 0) + curr_clock = clock(); + SH->CS_Inter(SynchList_cor, Symmetry); + if (myrank == 0) + { + prev_clock = curr_clock; + curr_clock = clock(); + cout << " CS_Inter used " << (double)(curr_clock - prev_clock) / ((double)CLOCKS_PER_SEC) + << " seconds! " << endl; + } + } +#endif + + // note the data structure before update + // SynchList_cor 1 ----------- + // + // StateList 0 ----------- + // + // OldStateList old ----------- + // update + Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + + if (lev == 0) + { + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + while (BP) + { + Block *cg = BP->data; + cg->swapList(StateList, SynchList_cor, myrank); + cg->swapList(OldStateList, SynchList_cor, myrank); + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } +#if 0 +// check StateList + { + SH->Dump_Data(StateList,0,PhysTime,dT_lev); + if(myrank == 0) + { + cout<<"check StateList"< 0 && lev == GH->levels - 1) + { + for (int ithBH = 0; ithBH < BH_num; ithBH++) + { + Porg0[ithBH][0] = Porg1[ithBH][0]; + Porg0[ithBH][1] = Porg1[ithBH][1]; + Porg0[ithBH][2] = Porg1[ithBH][2]; + } + } +#if 0 + if(lev>6) + { + char str[50]; + MyList * DG_List=new MyList(Cons_Ham); + DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); + DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); + printf(str,"lao%d",lev); + Parallel::Dump_Data(GH->PatL[6],DG_List,str,PhysTime,dT_lev); + DG_List->clearList(); + } +#endif +} +#endif +#undef MRBD + +//================================================================================================ + + + +//================================================================================================ + +// this member function is used to check the extroplation result + +//================================================================================================ + +void Z4c_class::Check_extrop() +{ + MyList *sPp; + + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_david_milton_extroplate_ss(cg->shape, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[TZ0->sgfn], cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + sPp->data->bbox[2], sPp->data->bbox[5]); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + + SH->Dump_Data(StateList, "extrop", 0, 1); + if (myrank == 0) + MPI_Abort(MPI_COMM_WORLD, 1); +} + +//================================================================================================ + + + +//================================================================================================ + +// this member function is used to compute and output constraint violation + +//================================================================================================ + +void Z4c_class::Constraint_Out() +{ + // here we have to use the same variable name as in the parent class + LastConsOut += dT * pow(0.5, Mymax(0, trfls)); + + if (LastConsOut >= AnasTime) + // Constraint violation + { + // recompute least the constraint data lost for moved new grid + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + if (lev > 0) + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + SH->Synch(ConstraintList, Symmetry); +#endif + + double ConV[8]; + +#ifdef WithShell + ConV[0] = SH->L2Norm(Cons_Ham); + ConV[1] = SH->L2Norm(Cons_Px); + ConV[2] = SH->L2Norm(Cons_Py); + ConV[3] = SH->L2Norm(Cons_Pz); + ConV[4] = SH->L2Norm(Cons_Gx); + ConV[5] = SH->L2Norm(Cons_Gy); + ConV[6] = SH->L2Norm(Cons_Gz); + ConV[7] = SH->L2Norm(TZ0); + ConVMonitor->writefile(PhysTime, 8, ConV); +#endif + for (int levi = 0; levi < GH->levels; levi++) + { + ConV[0] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Ham); + ConV[1] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Px); + ConV[2] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Py); + ConV[3] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Pz); + ConV[4] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gx); + ConV[5] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gy); + ConV[6] = Parallel::L2Norm(GH->PatL[levi]->data, Cons_Gz); + ConV[7] = Parallel::L2Norm(GH->PatL[levi]->data, TZ0); + ConVMonitor->writefile(PhysTime, 8, ConV); + /* + if(fabs(ConV[0])<0.00001) + { + MyList * DG_List=new MyList(Cons_Ham); + DG_List->insert(Cons_Px); DG_List->insert(Cons_Py); DG_List->insert(Cons_Px); + DG_List->insert(Cons_Gx); DG_List->insert(Cons_Gy); DG_List->insert(Cons_Gx); + Parallel::Dump_Data(GH->PatL[levi],DG_List,"jiu",0,1); + DG_List->clearList(); + if(myrank==0) MPI_Abort(MPI_COMM_WORLD,1); + } + */ + } + + LastConsOut = 0; + } +} + +//================================================================================================ + + + +//================================================================================================ + +// this member function is used to interpolate constraint data + +//================================================================================================ + +void Z4c_class::Interp_Constraint() +{ + // we do not support a_lev != 0 yet. + if (a_lev > 0) + return; + + for (int lev = 0; lev < GH->levels; lev++) + { + // make sure the data consistent for higher levels + if (lev > 0) + { + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_Z4c(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + SH->Synch(ConstraintList, Symmetry); +#endif + // interpolate + double *x1, *y1, *z1; + const int n = 1000; + double lmax, lmin, dd; + lmin = 0; +#ifdef WithShell + lmax = SH->Rrange[1]; +#else + lmax = GH->bbox[0][0][4]; +#endif +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (lmax - lmin) / (n - 1); +#else +#ifdef Cell + dd = (lmax - lmin) / n; +#else +#error Not define Vertex nor Cell +#endif +#endif + x1 = new double[n]; + y1 = new double[n]; + z1 = new double[n]; + for (int i = 0; i < n; i++) + { + x1[i] = 0; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + y1[i] = lmin + i * dd; +#else +#ifdef Cell + y1[i] = lmin + (i + 0.5) * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + z1[i] = 0; + } + + int InList = 0; + + MyList *varl = ConstraintList; + while (varl) + { + InList++; + varl = varl->next; + } + double *shellf; + shellf = new double[n * InList]; + for (int i = 0; i < n; i++) + { + double XX[3]; + XX[0] = x1[i]; + XX[1] = y1[i]; + XX[2] = z1[i]; + bool fg = GH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#ifdef WithShell + if (!fg) + fg = SH->Interp_One_Point(ConstraintList, XX, shellf + i * InList, Symmetry); +#endif + if (!fg && myrank == 0) + { + cout << "bssn_class::Interp_Constraint meets wrong" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } + + ofstream outfile; + char filename[50]; + sprintf(filename, "%s/interp_constraint_%05d.dat", ErrorMonitor->out_dir.c_str(), int(PhysTime / dT + 0.5)); + // 0.5 for round off + + outfile.open(filename); + outfile << "# corrdinate, H_Res, Px_Res, Py_Res, Pz_Res, Gx_Res, Gy_Res, Gz_Res, ...." << endl; + for (int i = 0; i < n; i++) + { + outfile << setw(10) << setprecision(10) << y1[i]; + for (int j = 0; j < InList; j++) + outfile << " " << setw(16) << setprecision(15) << shellf[InList * i + j]; + outfile << endl; + } + + delete[] shellf; +} + +//================================================================================================ + + + +//================================================================================================ + +// this member function is used to compute constraint violation + +//================================================================================================ + +void Z4c_class::Compute_Constraint() +{ + double TRK4 = PhysTime; + double ndeps = numepsb; + int pre = 0; + int lev; + + for (lev = 0; lev < GH->levels; lev++) + { + { + MyList *Pp = GH->PatL[lev]; + while (Pp) + { + MyList *BP = Pp->data->blb; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_bssn(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, ndeps, pre); + } + if (BP == Pp->data->ble) + break; + BP = BP->next; + } + Pp = Pp->next; + } + } + Parallel::Sync(GH->PatL[lev], ConstraintList, Symmetry); + } +#ifdef WithShell + lev = 0; + { + MyList *sPp; + sPp = SH->PatL; + while (sPp) + { + MyList *BP = sPp->data->blb; + int fngfs = sPp->data->fngfs; + while (BP) + { + Block *cg = BP->data; + if (myrank == cg->rank) + { + f_compute_rhs_Z4c_ss(cg->shape, TRK4, cg->X[0], cg->X[1], cg->X[2], + cg->fgfs[fngfs + ShellPatch::gx], + cg->fgfs[fngfs + ShellPatch::gy], + cg->fgfs[fngfs + ShellPatch::gz], + cg->fgfs[fngfs + ShellPatch::drhodx], + cg->fgfs[fngfs + ShellPatch::drhody], + cg->fgfs[fngfs + ShellPatch::drhodz], + cg->fgfs[fngfs + ShellPatch::dsigmadx], + cg->fgfs[fngfs + ShellPatch::dsigmady], + cg->fgfs[fngfs + ShellPatch::dsigmadz], + cg->fgfs[fngfs + ShellPatch::dRdx], + cg->fgfs[fngfs + ShellPatch::dRdy], + cg->fgfs[fngfs + ShellPatch::dRdz], + cg->fgfs[fngfs + ShellPatch::drhodxx], + cg->fgfs[fngfs + ShellPatch::drhodxy], + cg->fgfs[fngfs + ShellPatch::drhodxz], + cg->fgfs[fngfs + ShellPatch::drhodyy], + cg->fgfs[fngfs + ShellPatch::drhodyz], + cg->fgfs[fngfs + ShellPatch::drhodzz], + cg->fgfs[fngfs + ShellPatch::dsigmadxx], + cg->fgfs[fngfs + ShellPatch::dsigmadxy], + cg->fgfs[fngfs + ShellPatch::dsigmadxz], + cg->fgfs[fngfs + ShellPatch::dsigmadyy], + cg->fgfs[fngfs + ShellPatch::dsigmadyz], + cg->fgfs[fngfs + ShellPatch::dsigmadzz], + cg->fgfs[fngfs + ShellPatch::dRdxx], + cg->fgfs[fngfs + ShellPatch::dRdxy], + cg->fgfs[fngfs + ShellPatch::dRdxz], + cg->fgfs[fngfs + ShellPatch::dRdyy], + cg->fgfs[fngfs + ShellPatch::dRdyz], + cg->fgfs[fngfs + ShellPatch::dRdzz], + cg->fgfs[phi0->sgfn], cg->fgfs[trK0->sgfn], + cg->fgfs[gxx0->sgfn], cg->fgfs[gxy0->sgfn], cg->fgfs[gxz0->sgfn], + cg->fgfs[gyy0->sgfn], cg->fgfs[gyz0->sgfn], cg->fgfs[gzz0->sgfn], + cg->fgfs[Axx0->sgfn], cg->fgfs[Axy0->sgfn], cg->fgfs[Axz0->sgfn], + cg->fgfs[Ayy0->sgfn], cg->fgfs[Ayz0->sgfn], cg->fgfs[Azz0->sgfn], + cg->fgfs[Gmx0->sgfn], cg->fgfs[Gmy0->sgfn], cg->fgfs[Gmz0->sgfn], + cg->fgfs[Lap0->sgfn], + cg->fgfs[Sfx0->sgfn], cg->fgfs[Sfy0->sgfn], cg->fgfs[Sfz0->sgfn], + cg->fgfs[dtSfx0->sgfn], cg->fgfs[dtSfy0->sgfn], cg->fgfs[dtSfz0->sgfn], + cg->fgfs[TZ0->sgfn], + cg->fgfs[phi_rhs->sgfn], cg->fgfs[trK_rhs->sgfn], + cg->fgfs[gxx_rhs->sgfn], cg->fgfs[gxy_rhs->sgfn], cg->fgfs[gxz_rhs->sgfn], + cg->fgfs[gyy_rhs->sgfn], cg->fgfs[gyz_rhs->sgfn], cg->fgfs[gzz_rhs->sgfn], + cg->fgfs[Axx_rhs->sgfn], cg->fgfs[Axy_rhs->sgfn], cg->fgfs[Axz_rhs->sgfn], + cg->fgfs[Ayy_rhs->sgfn], cg->fgfs[Ayz_rhs->sgfn], cg->fgfs[Azz_rhs->sgfn], + cg->fgfs[Gmx_rhs->sgfn], cg->fgfs[Gmy_rhs->sgfn], cg->fgfs[Gmz_rhs->sgfn], + cg->fgfs[Lap_rhs->sgfn], + cg->fgfs[Sfx_rhs->sgfn], cg->fgfs[Sfy_rhs->sgfn], cg->fgfs[Sfz_rhs->sgfn], + cg->fgfs[dtSfx_rhs->sgfn], cg->fgfs[dtSfy_rhs->sgfn], cg->fgfs[dtSfz_rhs->sgfn], + cg->fgfs[TZ_rhs->sgfn], + cg->fgfs[rho->sgfn], cg->fgfs[Sx->sgfn], cg->fgfs[Sy->sgfn], cg->fgfs[Sz->sgfn], + cg->fgfs[Sxx->sgfn], cg->fgfs[Sxy->sgfn], cg->fgfs[Sxz->sgfn], + cg->fgfs[Syy->sgfn], cg->fgfs[Syz->sgfn], cg->fgfs[Szz->sgfn], + cg->fgfs[Gamxxx->sgfn], cg->fgfs[Gamxxy->sgfn], cg->fgfs[Gamxxz->sgfn], + cg->fgfs[Gamxyy->sgfn], cg->fgfs[Gamxyz->sgfn], cg->fgfs[Gamxzz->sgfn], + cg->fgfs[Gamyxx->sgfn], cg->fgfs[Gamyxy->sgfn], cg->fgfs[Gamyxz->sgfn], + cg->fgfs[Gamyyy->sgfn], cg->fgfs[Gamyyz->sgfn], cg->fgfs[Gamyzz->sgfn], + cg->fgfs[Gamzxx->sgfn], cg->fgfs[Gamzxy->sgfn], cg->fgfs[Gamzxz->sgfn], + cg->fgfs[Gamzyy->sgfn], cg->fgfs[Gamzyz->sgfn], cg->fgfs[Gamzzz->sgfn], + cg->fgfs[Rxx->sgfn], cg->fgfs[Rxy->sgfn], cg->fgfs[Rxz->sgfn], + cg->fgfs[Ryy->sgfn], cg->fgfs[Ryz->sgfn], cg->fgfs[Rzz->sgfn], + cg->fgfs[Cons_Ham->sgfn], + cg->fgfs[Cons_Px->sgfn], cg->fgfs[Cons_Py->sgfn], cg->fgfs[Cons_Pz->sgfn], + cg->fgfs[Cons_Gx->sgfn], cg->fgfs[Cons_Gy->sgfn], cg->fgfs[Cons_Gz->sgfn], + Symmetry, lev, numepsh, sPp->data->sst, pre); + } + if (BP == sPp->data->ble) + break; + BP = BP->next; + } + sPp = sPp->next; + } + } + SH->Synch(ConstraintList, Symmetry); +#endif +} + +//================================================================================================ + diff --git a/AMSS_NCKU_source/Z4c_class.h b/AMSS_NCKU_source/Z4C/Z4c_class.h similarity index 95% rename from AMSS_NCKU_source/Z4c_class.h rename to AMSS_NCKU_source/Z4C/Z4c_class.h index d279a1d..3ab6909 100644 --- a/AMSS_NCKU_source/Z4c_class.h +++ b/AMSS_NCKU_source/Z4C/Z4c_class.h @@ -1,64 +1,64 @@ - -#ifndef Z4c_CLASS_H -#define Z4c_CLASS_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "cgh.h" -#include "ShellPatch.h" -#include "misc.h" -#include "var.h" -#include "MyList.h" -#include "monitor.h" -#include "surface_integral.h" - -#include "macrodef.h" - -#ifdef USE_GPU -#include "bssn_gpu_class.h" -#else -#include "bssn_class.h" -#endif - -class Z4c_class : public bssn_class -{ -public: - Z4c_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, - int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, - int a_levi, int maxli, int decni, double maxrexi, double drexi); - ~Z4c_class(); - - void Initialize(); - void Check_extrop(); - // Since we have set zero to variables at very begining - // we can neglect TZ for initial data setting - void Step(int lev, int YN); - void Interp_Constraint(); - void Constraint_Out(); - void Compute_Constraint(); - -protected: - var *TZo; - var *TZ0; - var *TZ; - var *TZ1; - var *TZ_rhs; -}; -#endif /* Z4c_CLASS_H */ + +#ifndef Z4c_CLASS_H +#define Z4c_CLASS_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "cgh.h" +#include "ShellPatch.h" +#include "misc.h" +#include "var.h" +#include "MyList.h" +#include "monitor.h" +#include "surface_integral.h" + +#include "macrodef.h" + +#ifdef USE_GPU +#include "bssn_gpu_class.h" +#else +#include "bssn_class.h" +#endif + +class Z4c_class : public bssn_class +{ +public: + Z4c_class(double Couranti, double StartTimei, double TotalTimei, double DumpTimei, double d2DumpTimei, double CheckTimei, double AnasTimei, + int Symmetryi, int checkruni, char *checkfilenamei, double numepssi, double numepsbi, double numepshi, + int a_levi, int maxli, int decni, double maxrexi, double drexi); + ~Z4c_class(); + + void Initialize(); + void Check_extrop(); + // Since we have set zero to variables at very begining + // we can neglect TZ for initial data setting + void Step(int lev, int YN); + void Interp_Constraint(); + void Constraint_Out(); + void Compute_Constraint(); + +protected: + var *TZo; + var *TZ0; + var *TZ; + var *TZ1; + var *TZ_rhs; +}; +#endif /* Z4c_CLASS_H */ diff --git a/AMSS_NCKU_source/Z4c_rhs.f90 b/AMSS_NCKU_source/Z4C/Z4c_rhs.f90 similarity index 98% rename from AMSS_NCKU_source/Z4c_rhs.f90 rename to AMSS_NCKU_source/Z4C/Z4c_rhs.f90 index 3b877ea..fbcdf60 100644 --- a/AMSS_NCKU_source/Z4c_rhs.f90 +++ b/AMSS_NCKU_source/Z4C/Z4c_rhs.f90 @@ -1,1705 +1,1705 @@ - - -#include "macrodef.fh" - - function compute_rhs_z4cnot(ex, T,X, Y, Z, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - TZ_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & -! co is not used here, we always compute constraint - Symmetry,Lev,eps,co,chitiny) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,co - real*8, intent(in ):: T,chitiny - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! when out, constraint violation - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont,compute_rhs_z4c - - real*8, dimension(ex(1),ex(2),ex(3)) :: chihere - - chihere = chi - call lowerboundset(ex,chihere,chitiny) - - gont = compute_rhs_z4c(ex, T,X, Y, Z, & - chihere, trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - TZ_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & - Symmetry,Lev,eps,co) - -#if (ABV == 0) - call ricci_gamma(ex, X, Y, Z, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) -#endif - call constraint_bssn(ex, X, Y, Z,& - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & - Symmetry) - - return - - end function compute_rhs_Z4cnot - -#if 1 - function compute_rhs_z4c(ex, T,X, Y, Z, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - TZ_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & -! co is not used here, we always compute constraint - Symmetry,Lev,eps,co) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,co - real*8, intent(in ):: T - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! when out, constraint violation - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: trKd - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - -! constraint damping terms stuffs PRD 81, 084003 (2010) - real*8 :: kappa1,kappa2,kappa3,FF,eta - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & - +sum(TZ) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs.f90: find NaN in gxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs.f90: find NaN in gyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs.f90: find NaN in gzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs.f90: find NaN in betaz" - if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs.f90: find NaN in dtSfx" - if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs.f90: find NaN in dtSfy" - if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs.f90: find NaN in dtSfz" - if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs.f90: find NaN in TZ" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - trKd = trK+TWO*TZ -!this beta^i_,j will be kept till the end of this routine - call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - - div_beta = betaxx + betayy + betazz - - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - - chi_rhs = F2o3 *chin1*( alpn1 * trKd - div_beta ) !rhs for chi - - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - - gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & - TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) - - gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & - TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) - - gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & - TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) - - gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & - gxx * betaxy + gxz * betazy + & - gyy * betayx + gyz * betazx & - - gxy * betazz - - gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & - gxy * betaxz + gyy * betayz + & - gxz * betaxy + gzz * betazy & - - gyz * betaxx - - gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & - gxx * betaxz + gxy * betayz + & - gyz * betayx + gzz * betazx & - - gxz * betayy !rhs for gij - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz -! gij_,kl will be stored till end of this routine - call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) - call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z,ANTI,ANTI,SYM ,symmetry,Lev) - call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z,ANTI,SYM ,ANTI,symmetry,Lev) - call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z,SYM ,ANTI,ANTI,symmetry,Lev) -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) -! the so called Gamma_d - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - -!!!!!!!!!!!!because gij_,k will be overwrite later, we calculate TWO*d_k Z^k here -! use Gamma^i as more as possible - Gmxcon = Gamx - Gamxa - Gmycon = Gamy - Gamya - Gmzcon = Gamz - Gamza - -!Maple generated code for g^ki*g^jm*g^ln*g_mn,k*g_ij,l -! Gami_,j are used as maple temp variables - Gamyy = 3*gupxz**2*gupzz*gxzz**2+gupxx*gupxz**2*gxxz**2+2*gxyx*gupxy**3*gxyy+ & - 2*gxyx*gupxy**3*gyyx+gupxx**2*gupzz*gxzx**2+3*gupxx*gupxy**2*gxyx**2+ & - 6*gxyx*gupxy*gupxz*gupyy*gyzy+gupxx**2*gupyy*gxyx**2+ & - 2*gxyz*gupxy*gupyz**2*gyyz+2*gxxz*gupxx**2*gupyz*gxyx+ & - gupxz**2*gupyy*gyzx**2+2*gxxy*gupxx*gupxy*gupxz*gxxz+ & - 2*gyzx*gupxy*gupxz*gupzz*gzzx+3*gupyy*gupyz**2*gyzy**2+ & - 2*gyyy*gupyz**3*gzzz+2*gxxz*gupxz**3*gxzz+ & - 4*gxzy*gupxx*gupxz*gupyy*gxyx+gupyy*gupyz**2*gyyz**2 - Gamxz = Gamyy+2*gxxz*gupxy**2*gupzz*gyzy+4*gxyz*gupxx*gupxy*gupxz*gxxx+ & - 6*gxzz*gupxy*gupyz*gupzz*gyzy+2*gxxy*gupxx*gupxz*gupyz*gxzz+ & - 3*gupxy**2*gupyy*gxyy**2+2*gxyz*gupxx*gupyy*gupzz*gyzx+ & - 4*gxyy*gupxx*gupyy*gupyz*gyzx+6*gxyy*gupxy*gupxz*gupyz*gxzz+ & - 4*gxzz*gupxx*gupyz*gupzz*gyzx+3*gupxx*gupxz**2*gxzx**2+ & - 4*gxyz*gupxx*gupxy*gupyz*gxyx+2*gxxz*gupxx*gupxz*gupyz*gxyz+ & - 2*gxxy*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz*gupyz*gyyz+ & - gupyz**2*gupzz*gzzy**2+gupxz**2*gupzz*gzzx**2+ & - gupyy*gupzz**2*gyzz**2+2*gyzy*gupyz**3*gzzy+gupxx*gupzz**2*gxzz**2 - Gamyy = Gamxz+gupxx*gupyz**2*gxzy**2+2*gxzx*gupxz**3*gzzx+ & - 3*gupyz**2*gupzz*gyzz**2+2*gyzy*gupyz**3*gyzz+gupyy**2*gupzz*gyzy**2+ & - gupxy**2*gupzz*gyzx**2+2*gyyz*gupyz**3*gyzz+gupxy**2*gupyy*gyyx**2+ & - gupxx*gupyz**2*gxyz**2+gupxx*gupyy**2*gxyy**2+ & - gupxy**2*gupzz*gxzy**2+2*gxzx*gupxz**3*gxzz+ & - 2*gyyx*gupxy*gupxz*gupyy*gyzx+gupxx*gupxy**2*gxxy**2+ & - 2*gxxx*gupxz**3*gzzz+2*gxxx*gupxy**3*gyyy+gupxz**2*gupyy*gxyz**2+ & - 2*gxyy*gupxy**3*gxxy - Gamxy = Gamyy+2*gxyy*gupxz*gupyy**2*gyzy+6*gxyy*gupxx*gupxy*gupyz*gxzx+ & - 4*gxyy*gupxy*gupxz*gupyy*gxyz+2*gyzx*gupxz*gupyy*gupzz*gzzy+ & - 2*gxzy*gupxy*gupxz*gupyy*gxyy+4*gxzy*gupxy*gupxz*gupzz*gxzz+ & - 2*gyyx*gupxz*gupyy*gupyz*gyzz+6*gxyx*gupxx*gupxz*gupyz*gxzz+ & - 2*gxyz*gupxy**2*gupzz*gxzy+2*gxyz*gupxy**2*gupyz*gxyy+ & - 2*gxyz*gupxy**2*gupxz*gxxy+2*gupxy*gupxz*gupyz*gxyz**2+ & - 4*gxyy*gupxz*gupyz**2*gzzz+2*gxyy*gupxy*gupyz**2*gzzy+ & - 4*gxyy*gupxy**2*gupyz*gxzy+2*gxyy*gupxy**2*gupxz*gxxz+ & - 4*gxyy*gupxx*gupxy**2*gxxx+2*gxyx*gupxy**2*gupxz*gxzy+ & - 2*gxyx*gupxy**2*gupyz*gyzy - Gamyy = Gamxy+2*gxyx*gupxx*gupxy**2*gxxy+4*gyzz*gupyz*gupzz**2*gzzz+ & - 4*gxzy*gupxx*gupxz*gupyz*gxzx+2*gxzy*gupxx*gupyy*gupzz*gyzx+ & - 4*gxxx*gupxx*gupxy*gupxz*gyzx+2*gxyx*gupxx**2*gupyz*gxzx+ & - 2*gxyx*gupxy**2*gupxz*gxyz+2*gxzy*gupxz*gupyy*gupyz*gyyz+ & - 4*gxzy*gupxy*gupyy*gupyz*gyyy+2*gxzy*gupxx*gupyy*gupyz*gyyx+ & - 2*gyyx*gupxy*gupxz*gupyy*gxzy+2*gyyx*gupxy*gupyy*gupyz*gyyz+ & - 2*gyyx*gupxy*gupyy*gupyz*gyzy+4*gxzy*gupxz*gupyy*gupzz*gyzz+ & - 2*gyyx*gupxy*gupxz*gupyz*gxzz+2*gxyz*gupxx*gupyy*gupzz*gxzy+ & - 2*gxyy*gupxz*gupyy*gupyz*gzzy - Gamxz = Gamyy+2*gxyy*gupxy*gupxz*gupyz*gzzx+2*gxyy*gupxy*gupxz*gupyy*gyzx+ & - 2*gxyy*gupxy*gupyy*gupyz*gyyz+2*gxyy*gupxx*gupyy*gupyz*gxzy+ & - 2*gxxy*gupxy**2*gupxz*gxzy+2*gxxy*gupxy**2*gupyz*gyzy+ & - 2*gxxy*gupxy**2*gupyy*gyyy+2*gxxy*gupxx**2*gupyz*gxzx+ & - 2*gxxy*gupxx**2*gupyy*gxyx+2*gxxx*gupxx*gupxz**2*gzzx+ & - 4*gxxx*gupxy*gupxz**2*gyzz+4*gxxx*gupxy**2*gupxz*gyzy+ & - 2*gxxx*gupxx*gupxy**2*gyyx+4*gxxx*gupxx*gupxz**2*gxzz+ & - 4*gxxx*gupxx**2*gupxz*gxzx+2*gxxx*gupxx**2*gupxz*gxxz+ & - 4*gxyz*gupxz*gupyz**2*gyzz+2*gxyz*gupxy*gupyz**2*gyzy+ & - 2*gxzy*gupxy*gupyy*gupzz*gyzy - Gamyy = Gamxz+2*gxyy*gupxx*gupyy*gupyz*gxyz+6*gxzz*gupxz*gupyz*gupzz*gyzz+ & - 4*gxzy*gupxz*gupyz*gupzz*gzzz+gupyy**3*gyyy**2+ & - 2*gxzy*gupxy*gupyz*gupzz*gzzy+2*gxzy*gupxx*gupyz*gupzz*gzzx+ & - 2*gxyz*gupxx*gupyz*gupzz*gxzz+2*gxzy*gupxx*gupyz*gupzz*gxzz+ & - 2*gyzy*gupxy*gupyz*gupzz*gzzx+2*gyzy*gupxz*gupyy*gupyz*gxzy+ & - 6*gyzy*gupyy*gupyz*gupzz*gyzz+4*gyzx*gupxz*gupyy*gupyz*gyzy+ & - 4*gyzx*gupxy*gupyz*gupzz*gyzz+2*gxxy*gupxx*gupxy*gupyy*gxyy+ & - 4*gyzx*gupxz*gupyz*gupzz*gzzz+2*gyzx*gupxy*gupyy*gupzz*gyzy+ & - 2*gyyz*gupyy*gupyz*gupzz*gzzy+2*gyyz*gupxy*gupyz*gupzz*gzzx - Gamxx = Gamyy+2*gyyz*gupyy*gupyz*gupzz*gyzz+2*gyyz*gupxy*gupyy*gupzz*gyzx+ & - 2*gyyz*gupxy*gupyz*gupzz*gxzz+2*gxxy*gupxx*gupxy*gupyz*gyzx+ & - 4*gyyy*gupxy*gupyy*gupyz*gyzx+2*gyyx*gupxy*gupxz*gupyz*gzzx+ & - 2*gxyz*gupxy*gupyz*gupzz*gyzz+2*gxxz*gupxz**2*gupzz*gzzz+ & - 2*gxxz*gupxz**2*gupyz*gyzz+2*gxxz*gupxy*gupxz**2*gxzy+ & - 2*gxxz*gupxx*gupxz**2*gxzx+2*gxxz*gupxy**2*gupyz*gyyy+ & - 2*gxxz*gupxx**2*gupzz*gxzx+2*gxxy*gupxz**2*gupyz*gzzz+ & - 2*gxxy*gupxz**2*gupyy*gyzz+2*gxxy*gupxy*gupxz**2*gxzz+ & - 2*gzzx*gupxz*gupyz*gupzz*gzzy+2*gyzz*gupxz*gupyz*gupzz*gzzx+ & - 2*gxzx*gupxx*gupxz*gupzz*gzzx+2*gyzx*gupxz*gupyy*gupzz*gyzz - Gamyy = Gamxx+gupzz**3*gzzz**2+2*gxzz*gupxy*gupxz*gupzz*gyzx+ & - 6*gxzx*gupxy*gupxz*gupyz*gyzy+2*gxxy*gupxy*gupxz*gupyz*gzzy+ & - 4*gxzz*gupxy*gupyz**2*gyyy+2*gxzy*gupxz*gupyz**2*gyzz+ & - 2*gxzy*gupxz**2*gupyz*gxzz+2*gxzy*gupxz**2*gupyy*gxyz+ & - 2*gupxy*gupxz*gupyz*gxzy**2+4*gxzx*gupxz**2*gupzz*gzzz+ & - 2*gxzx*gupxz**2*gupyz*gyzz+2*gxyz*gupxy*gupxz*gupzz*gzzx+ & - 2*gxyz*gupxz*gupyy*gupzz*gzzy+2*gxyx*gupxx*gupxz*gupyy*gxyz+ & - 2*gxzz*gupxz*gupyz**2*gyyz+2*gxxy*gupxx*gupxy*gupxz*gxzx+ & - 2*gyyx*gupxy**2*gupxz*gxzx - Gamxz = Gamyy+2*gxyx*gupxy*gupxz*gupyz*gzzy+2*gyzy*gupyy*gupyz*gupzz*gzzy+ & - 2*gxyx*gupxx*gupxz*gupyy*gyzx+2*gyyx*gupxy*gupyz**2*gyzz+ & - 2*gyyx*gupxy**2*gupyz*gyzx+2*gyyx*gupxz*gupyz**2*gzzz+ & - 2*gyyx*gupxy*gupyy**2*gyyy+2*gxyz*gupxy**2*gupzz*gyzx+ & - 2*gxyz*gupxy**2*gupyz*gyyx+2*gxyy*gupxy*gupyz**2*gyzz+ & - 2*gxyy*gupxy**2*gupyz*gyzx+2*gxyy*gupxy**2*gupyy*gyyx+ & - 2*gxyx*gupxy*gupxz**2*gzzx+2*gxyx*gupxy**2*gupyz*gyyz+ & - 4*gxzz*gupxz*gupzz**2*gzzz+2*gxzz*gupxy*gupzz**2*gzzy+ & - 2*gxzz*gupxx*gupzz**2*gzzx+6*gxyx*gupxx*gupxy*gupxz*gxzx+ & - 2*gxyz*gupxy*gupxz*gupyz*gyzx - Gamyy = Gamxz+2*gyyx*gupxz*gupyy**2*gyzy+2*gyyx*gupxz*gupyy*gupyz*gzzy+ & - 2*gxxz*gupxx*gupxy*gupyz*gxyy+2*gyzx*gupxz**2*gupyy*gxzy+ & - 4*gyzx*gupxy*gupxz**2*gxzx+2*gyzx*gupxz*gupyz**2*gyzz+ & - 2*gyzx*gupxz**2*gupyz*gxzz+2*gupxy*gupxz*gupyz*gyzx**2+ & - 2*gyyz*gupyz**2*gupzz*gzzz+2*gyyz*gupyy*gupyz**2*gyzy+ & - 2*gyyz*gupxy*gupyz**2*gyzx+2*gyyz*gupyy**2*gupzz*gyzy+ & - 2*gyyz*gupxy**2*gupzz*gxzx+2*gyyy*gupyy*gupyz**2*gzzy+ & - 2*gyyy*gupxy*gupyz**2*gzzx+4*gyyy*gupyy*gupyz**2*gyzz+ & - 4*gyyy*gupyy**2*gupyz*gyzy+2*gyyy*gupyy**2*gupyz*gyyz - Gamxy = Gamyy+2*gxyz*gupxz*gupyy*gupyz*gyzy+2*gxyz*gupxx*gupyy*gupyz*gyyx+ & - 2*gzzx*gupxz*gupzz**2*gzzz+2*gxzy*gupxy*gupxz*gupyz*gyzx+ & - 2*gyzz*gupyz**2*gupzz*gzzy+2*gyzy*gupxz*gupyz**2*gzzx+ & - 2*gyzx*gupxz*gupyz**2*gzzy+2*gyzx*gupxz**2*gupyz*gzzx+ & - 2*gxzz*gupxz**2*gupzz*gzzx+2*gxzz*gupxy*gupzz**2*gyzz+ & - 2*gxzy*gupxz*gupyz**2*gzzy+2*gxzy*gupxz**2*gupyz*gzzx+ & - 2*gxzx*gupxz**2*gupyz*gzzy+2*gyzz*gupyy*gupzz**2*gzzy+ & - 2*gyzz*gupxy*gupzz**2*gzzx+4*gyzy*gupyz**2*gupzz*gzzz+ & - 2*gyzy*gupxy*gupyz**2*gyzx+2*gyzy*gupxz*gupyz**2*gxzz+ & - 2*gxzy*gupxy*gupyz*gupzz*gyzz+2*gxyx*gupxx*gupxy*gupyz*gxzy - Gamyy = Gamxy+gupxx**3*gxxx**2+2*gzzy*gupyz*gupzz**2*gzzz+ & - 6*gxyx*gupxx*gupxy*gupyy*gxyy+2*gxzz*gupxz*gupyz* gupzz*gzzy+ & - 6*gxyx*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz**2*gxzy+ & - 2*gxyx*gupxx*gupxy*gupyy*gyyx+2*gxyx*gupxx*gupxz*gupyz*gzzx+ & - 2*gxyx*gupxx*gupxy*gupxz*gxxz+4*gxyx*gupxx**2*gupxy*gxxx+ & - 2*gxyx*gupxy*gupxz*gupyy*gyyz+6*gxyy*gupxy*gupyy*gupyz*gyzy+ & - 2*gxyx*gupxx*gupxy*gupyz*gyzx+6*gxyy*gupxz*gupyy*gupyz*gyzz+ & - 4*gxyz*gupxx*gupxy*gupzz*gxzx+2*gxyz*gupxy*gupxz*gupzz*gxzz+ & - 4*gxyx*gupxy**2*gupyy*gyyy+2*gxyz*gupxz*gupyy*gupyz*gyyz - Gamxz = Gamyy+4*gxyz*gupxy*gupyy*gupyz*gyyy+2*gxyx*gupxz**2*gupyy*gyzz+ & - 2*gxyz*gupxz*gupyy*gupzz*gyzz+2*gxyx*gupxy*gupxz**2*gxzz+ & - 4*gxyz*gupxy*gupyy*gupzz*gyzy+2*gxzx*gupxy**2*gupzz*gyzy+ & - 2*gxyz*gupxx*gupxz*gupyz*gxzx+4*gxyx*gupxz**2*gupyz*gzzz+ & - 4*gxzx*gupxy**2*gupyz*gyyy+2*gyyz*gupxy*gupyy*gupzz*gxzy+ & - 2*gxyz*gupxy*gupxz*gupyz*gxzy+2*gxyz*gupxx*gupyz*gupzz*gzzx+ & - 4*gxyy*gupxy*gupyy**2*gyyy+2*gxyy*gupxx*gupyy**2*gyyx+ & - 2*gxyy*gupxx*gupyz**2*gzzx+2*gxyz*gupxy*gupyz*gupzz*gzzy+ & - 2*gxyy*gupxz*gupyy**2*gyyz+4*gxyz*gupxz*gupyz*gupzz*gzzz+ & - 2*gxxy*gupxx*gupxz*gupyy*gxyz - Gamyy = Gamxz+2*gxzx*gupxy*gupxz**2*gxyz+2*gxxy*gupxy*gupxz*gupyy*gyzy+ & - 4*gxxx*gupxx*gupxy*gupxz*gxzy+2*gxxy*gupxy*gupxz*gupyy*gyyz+ & - 2*gxxy*gupxx*gupxz*gupyy*gyzx+2*gxxy*gupxx*gupxz*gupyz*gzzx+ & - 2*gxzx*gupxy**2*gupxz*gxyy+2*gxxy*gupxx*gupxy*gupyz*gxzy+ & - 2*gxyz*gupxy*gupxz**2*gxxz+2*gxxy*gupxx*gupxy*gupyy*gyyx+ & - 2*gxyz*gupxx*gupyz**2*gyzx+4*gxyz*gupxz**2*gupyz*gxzz+ & - 2*gxxz*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxx*gupxz*gupzz*gxzz+ & - 2*gxxx*gupxx**2*gupxy*gxxy+2*gxxz*gupxx*gupxy*gupyz*gyyx+ & - 2*gxxz*gupxy*gupxz*gupzz*gyzz+2*gxxz*gupxx*gupxy*gupzz*gyzx - TZ_rhs = Gamyy+2*gxxz*gupxy*gupxz*gupyz*gyyz+2*gxxz*gupxx*gupxz*gupyz*gyzx+ & - 2*gxxz*gupxx*gupxz*gupzz*gzzx+2*gxxz*gupxy*gupxz*gupyz*gyzy+ & - 2*gxzx*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxy*gupxz*gupzz*gzzy+ & - 6*gxzx*gupxy*gupxz*gupzz*gyzz+2*gxzx*gupxx*gupxy*gupzz*gyzx+ & - 2*gxzx*gupxx*gupxy*gupyz*gyyx+6*gxzx*gupxx*gupxz*gupzz*gxzz+ & - 2*gxxx*gupxy**2*gupxz*gyyz+2*gxzx*gupxy*gupxz*gupzz*gzzy+ & - 2*gxzx*gupxx*gupxz*gupyz*gyzx+2*gxxx*gupxy*gupxz**2*gzzy+ & - 4*gxzy*gupxy*gupyz**2*gyzy+2*gxzy*gupxx*gupyz**2*gyzx+ & - 2*gxzz*gupxx*gupyz**2*gyyx+4*gxyx*gupxy**2*gupxz*gyzx+ & - 2*gxyx*gupxz**2*gupyy*gzzy+2*gxyy*gupxx*gupyz**2*gxzz - -! Gami_,j will be kept till the end of this routine - call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,Lev) - call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) - call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,Lev) - - TZ_rhs = chix*Gmxcon+chiy*Gmycon+chiz*Gmzcon & - +chin1*(Gamxx+Gamyy+Gamzz - & - (TWO*(gupxz*gupyz*gyzxz+gupxx*gupyy*gxyxy+gupxy*gupyz*gxzyy+ & - gupxx*gupxy*gxxxy+gupxx*gupxz*gxxxz+gupxx*gupxy*gxyxx+ & - gupxx*gupyz*gxyxz+gupxx*gupxz*gxzxx+gupxx*gupyz*gxzxy+ & - gupxx*gupzz*gxzxz+gupxy*gupxz*gxxyz+gupxy*gupyy*gxyyy+ & - gupxy*gupyz*gxyyz+gupxy*gupxz*gxzxy+gupxy*gupzz*gxzyz+ & - gupxy*gupxz*gxyxz+gupxz*gupyy*gxyyz+gupxz*gupyz*gxyzz+ & - gupxz*gupyz*gxzyz+gupxz*gupzz*gxzzz+gupxy*gupyy*gyyxy+ & - gupxy*gupyz*gyyxz+gupxy*gupxz*gyzxx+gupxy*gupyz*gyzxy+ & - gupxy*gupzz*gyzxz+gupyy*gupyz*gyyyz+gupxz*gupyy*gyzxy+ & - gupyy*gupyz*gyzyy+gupyy*gupzz*gyzyz+gupyz*gupzz*gyzzz+ & - gupxz*gupyz*gzzxy+gupxz*gupzz*gzzxz+gupyz*gupzz*gzzyz+ & - gupxy*gupxy*gxyxy+gupxz*gupxz*gxzxz+gupyz*gupyz*gyzyz) & - +gupxx*gupxx*gxxxx+gupxy*gupxy*gxxyy+gupxz*gupxz*gxxzz+ & - gupxy*gupxy*gyyxx+gupyy*gupyy*gyyyy+gupyz*gupyz*gyyzz+ & - gupxz*gupxz*gzzxx+gupyz*gupyz*gzzyy+gupzz*gupzz*gzzzz)+& - (gxx*Gamxa*Gamxa+gyy*Gamya*Gamya+gzz*Gamza*Gamza +& - TWO*(gxy*Gamxa*Gamya+gxz*Gamxa*Gamza+gyz*Gamya*Gamza)) + TZ_rhs) - -! Raise indices of \tilde A_{ij} and store in R_ij - - Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & - TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) - - Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & - TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) - - Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & - TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) - - Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & - (gupxx * gupyy + gupxy * gupxy)* Axy + & - (gupxx * gupyz + gupxz * gupxy)* Axz + & - (gupxy * gupyz + gupxz * gupyy)* Ayz - - Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & - (gupxx * gupyz + gupxy * gupxz)* Axy + & - (gupxx * gupzz + gupxz * gupxz)* Axz + & - (gupxy * gupzz + gupxz * gupyz)* Ayz - - Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & - (gupxy * gupyz + gupyy * gupxz)* Axy + & - (gupxy * gupzz + gupyz * gupxz)* Axz + & - (gupyy * gupzz + gupyz * gupyz)* Ayz - -! Right hand side for Gam^i without shift terms... -! Lap_,i will be kept till the end of this routine - call fderivs(ex,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) -! K_,i stored K_,i+TZ_,i/2 indeed, will be kept till the end of this routine - call fderivs(ex,trK,Kx,Ky,Kz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - call fderivs(ex,TZ,fxx,fxy,fxz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) - - Kx = Kx + fxx/TWO - Ky = Ky + fxy/TWO - Kz = Kz + fxz/TWO - - Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & - gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & - TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) - - Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & - gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & - TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) - - Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & - gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & - TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) - - call fdderivs(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,& - X,Y,Z,ANTI,SYM, SYM ,Symmetry,Lev) - call fdderivs(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,& - X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) - call fdderivs(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,& - X,Y,Z,SYM ,SYM, ANTI,Symmetry,Lev) - - fxx = gxxx + gxyy + gxzz - fxy = gxyx + gyyy + gyzz - fxz = gxzx + gyzy + gzzz - - Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & - Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & - F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & - gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & - TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) - - Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & - Gamxa * betayx - Gamya * betayy - Gamza * betayz + & - F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & - gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & - TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) - - Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & - Gamxa * betazx - Gamya * betazy - Gamza * betazz + & - F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & - gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & - TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - Rxx = gupxx * gxxxx + gupyy * gxxyy + gupzz * gxxzz + & - ( gupxy * gxxxy + gupxz * gxxxz + gupyz * gxxyz ) * TWO - - Ryy = gupxx * gyyxx + gupyy * gyyyy + gupzz * gyyzz + & - ( gupxy * gyyxy + gupxz * gyyxz + gupyz * gyyyz ) * TWO - - Rzz = gupxx * gzzxx + gupyy * gzzyy + gupzz * gzzzz + & - ( gupxy * gzzxy + gupxz * gzzxz + gupyz * gzzyz ) * TWO - - Rxy = gupxx * gxyxx + gupyy * gxyyy + gupzz * gxyzz + & - ( gupxy * gxyxy + gupxz * gxyxz + gupyz * gxyyz ) * TWO - - Rxz = gupxx * gxzxx + gupyy * gxzyy + gupzz * gxzzz + & - ( gupxy * gxzxy + gupxz * gxzxz + gupyz * gxzyz ) * TWO - - Ryz = gupxx * gyzxx + gupyy * gyzyy + gupzz * gyzzz + & - ( gupxy * gyzxy + gupxz * gyzxz + gupyz * gyzyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) - -! Add chi part to Ricci tensor: - - fxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - fyy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - fzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - fxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - fxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - fyz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO -! store R/chi in Hcon - Hcon = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) - - Rxx = fxx - Ryy = fyy - Rzz = fzz - Rxy = fxy - Rxz = fxz - Ryz = fyz - - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - -! covariant second derivatives of the lapse respect to physical metric - - call fdderivs(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & - SYM,SYM,SYM,symmetry,Lev) - - fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz - fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz - fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz - fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz - fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz - fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz - -! store D^i D_i Lap in trK_rhs upto chi - trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) -! Add lapse and S_ij parts to Ricci tensor: - - fxx = EIGHT * PI * alpn1 * Sxx + fxx - fxy = EIGHT * PI * alpn1 * Sxy + fxy - fxz = EIGHT * PI * alpn1 * Sxz + fxz - fyy = EIGHT * PI * alpn1 * Syy + fyy - fyz = EIGHT * PI * alpn1 * Syz + fyz - fzz = EIGHT * PI * alpn1 * Szz + fzz - -! Compute trace-free part (note: chi^-1 and chi cancel!): - f = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) - - f = F1o3 * (Hcon*alpn1 - f) - - fxx = alpn1 * Rxx - fxx - fxy = alpn1 * Rxy - fxy - fxz = alpn1 * Rxz - fxz - fyy = alpn1 * Ryy - fyy - fyz = alpn1 * Ryz - fyz - fzz = alpn1 * Rzz - fzz - - Axx_rhs = fxx - gxx * f - Ayy_rhs = fyy - gyy * f - Azz_rhs = fzz - gzz * f - Axy_rhs = fxy - gxy * f - Axz_rhs = fxz - gxz * f - Ayz_rhs = fyz - gyz * f - -! Now: store A_il A^l_j into fij: - - fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) - fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) - fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) - fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy *(Axx * Ayy + Axy * Axy) + & - gupxz *(Axx * Ayz + Axz * Axy) + & - gupyz *(Axy * Ayz + Axz * Ayy) - fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy *(Axx * Ayz + Axy * Axz) + & - gupxz *(Axx * Azz + Axz * Axz) + & - gupyz *(Axy * Azz + Axz * Ayz) - fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy *(Axy * Ayz + Ayy * Axz) + & - gupxz *(Axy * Azz + Ayz * Axz) + & - gupyz *(Ayy * Azz + Ayz * Ayz) - - f = chin1 -! store D^i D_i Lap in trK_rhs - trK_rhs = f*trK_rhs - - Axx_rhs = f * Axx_rhs+ alpn1 * (trKd * Axx - TWO * fxx) + & - TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx ) - & - F2o3 * Axx * div_beta - - Ayy_rhs = f * Ayy_rhs+ alpn1 * (trKd * Ayy - TWO * fyy) + & - TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy ) - & - F2o3 * Ayy * div_beta - - Azz_rhs = f * Azz_rhs+ alpn1 * (trKd * Azz - TWO * fzz) + & - TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz ) - & - F2o3 * Azz * div_beta - - Axy_rhs = f * Axy_rhs+ alpn1 *( trKd * Axy - TWO * fxy )+ & - Axx * betaxy + Axz * betazy + & - Ayy * betayx + Ayz * betazx + & - F1o3 * Axy * div_beta - Axy * betazz - - Ayz_rhs = f * Ayz_rhs+ alpn1 *( trKd * Ayz - TWO * fyz )+ & - Axy * betaxz + Ayy * betayz + & - Axz * betaxy + Azz * betazy + & - F1o3 * Ayz * div_beta - Ayz * betaxx - - Axz_rhs = f * Axz_rhs+ alpn1 *( trKd * Axz - TWO * fxz )+ & - Axx * betaxz + Axy * betayz + & - Ayz * betayx + Azz * betazx + & - F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij - -! Compute trace of S_ij - - S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & - TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) - - trK_rhs = - trK_rhs + alpn1 *( F1o3 * trKd * trKd + & - gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & - FOUR * PI * ( rho + S )) !rhs for trK - -!!!!!gauge variable part - Lap_rhs = -TWO*alpn1*trK - -#if (GAUGE == 0) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz -#elif (GAUGE == 1) - betax_rhs = Gamx - eta*betax - betay_rhs = Gamy - eta*betay - betaz_rhs = Gamz - eta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#endif -!!!!!Z4 part -! H = trR + 2/3 * trKd^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - - Hcon = chin1*Hcon + F2o3 * trKd * trKd -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho -! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,lev) - call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,lev) - call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,lev) - call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,lev) - call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,lev) - call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,lev) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 - Mxcon = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz - Mycon = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz - Mzcon = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz -! we have already considered TZ_,i in K_,i here, or to say here Micon = -! Micon+TZ_,i indeed - Mxcon = Mxcon - F2o3*Kx - F8*PI*sx - Mycon = Mycon - F2o3*Ky - F8*PI*sy - Mzcon = Mzcon - F2o3*Kz - F8*PI*sz - - f = TZ_rhs - - TZ_rhs = alpn1*Hcon/TWO -! delete TWO*Z^i_,i From Hcon' to get Hcon, this is wrong -! Hcon = Hcon - f - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI -!!!!!!!!!advection term part - call lopsided(ex,X,Y,Z,gxx,gxx_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,gxy,gxy_rhs,betax,betay,betaz,Symmetry,AAS) - call lopsided(ex,X,Y,Z,gxz,gxz_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ex,X,Y,Z,gyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ex,X,Y,Z,gzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS) - call lopsided(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA) - - call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) - call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) - - call lopsided(ex,X,Y,Z,TZ,TZ_rhs,betax,betay,betaz,Symmetry,SSS) - -! constraint damping terms - TZ_rhs = TZ_rhs - alpn1*(TWO+kappa2)*kappa1*TZ - trK_rhs = trK_rhs + alpn1*kappa1*(ONE-kappa2)*TZ - Gamx_rhs = Gamx_rhs - TWO*alpn1*kappa1*(Gamx-Gamxa) - Gamy_rhs = Gamy_rhs - TWO*alpn1*kappa1*(Gamy-Gamya) - Gamz_rhs = Gamz_rhs - TWO*alpn1*kappa1*(Gamz-Gamza) - -! numerical dissipation part - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxx,gxx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,gyy,gyy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,gzz,gzz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) - call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) - call kodis(ex,X,Y,Z,TZ,TZ_rhs,SSS,Symmetry,eps) - - endif - -#if (ABV == 0) - call ricci_gamma(ex, X, Y, Z, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) -#endif - - call constraint_bssn(ex, X, Y, Z,& - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & - Symmetry) - - gont = 0 - - return - - end function compute_rhs_Z4c -#endif - - -!! using David Z4c-rhs code -#if 0 - function compute_rhs_z4c(ex, T,X, Y, Z, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - TZ_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & -! co is not used here, we always compute constraint - Symmetry,Lev,eps,co) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,co - real*8, intent(in ):: T - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! when out, constraint violation - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chixx,chixy,chixz,chiyy,chiyz,chizz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: dBxx,dBxy,dBxz - real*8, dimension(ex(1),ex(2),ex(3)) :: dByx,dByy,dByz - real*8, dimension(ex(1),ex(2),ex(3)) :: dBzx,dBzy,dBzz - real*8, dimension(ex(1),ex(2),ex(3)) :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,TZx,TZy,TZz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - integer :: i,j,k - -! constraint damping terms stuffs PRD 81, 084003 (2010) - real*8 :: kappa1,kappa2,kappa3,FF,eta - - real*8,parameter :: chiDivfloor=1.d-5 - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & - +sum(TZ) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs.f90: find NaN in gxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs.f90: find NaN in gyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs.f90: find NaN in gzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs.f90: find NaN in betaz" - if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs.f90: find NaN in dtSfx" - if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs.f90: find NaN in dtSfy" - if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs.f90: find NaN in dtSfz" - if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs.f90: find NaN in TZ" - gont = 1 - return - endif - - PI = dacos(-ONE) - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - call fderivs(ex,dtSfx,dBxx,dBxy,dBxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fderivs(ex,dtSfy,dByx,dByy,dByz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fderivs(ex,dtSfz,dBzx,dBzy,dBzz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM,Symmetry,Lev) - call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM,ANTI,Symmetry,Lev) - call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM,ANTI,ANTI,Symmetry,Lev) - call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - - call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z, SYM, SYM,SYM ,Symmetry,Lev) - call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z, SYM, SYM,SYM ,Symmetry,Lev) - call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z, SYM, SYM,SYM ,Symmetry,Lev) - call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) - call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) - call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) - - call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM,Symmetry,Lev) - call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM,Symmetry,Lev) - call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM,ANTI,Symmetry,Lev) - - call fderivs(ex,Lap,Lapx,Lapy,Lapz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - call fderivs(ex,trK,Kx,Ky,Kz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - - call fderivs(ex,TZ,TZx,TZy,TZz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - - call fdderivs(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) - call fdderivs(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) - call fdderivs(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) - - call fdderivs(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - - call fdderivs(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) - - call fderivs(ex,Axx,Axxx,Axxy,Axxz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - call fderivs(ex,Axy,Axyx,Axyy,Axyz,X,Y,Z,ANTI,ANTI,SYM,Symmetry,Lev) - call fderivs(ex,Axz,Axzx,Axzy,Axzz,X,Y,Z,ANTI,SYM,ANTI,Symmetry,Lev) - call fderivs(ex,Ayy,Ayyx,Ayyy,Ayyz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - call fderivs(ex,Ayz,Ayzx,Ayzy,Ayzz,X,Y,Z,SYM,ANTI,ANTI,Symmetry,Lev) - call fderivs(ex,Azz,Azzx,Azzy,Azzz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - call z4c_rhs_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & - alpn1(i,j,k),dtSfx(i,j,k),dtSfy(i,j,k),dtSfz(i,j,k), & - betax(i,j,k),betay(i,j,k),betaz(i,j,k), & - chin1(i,j,k),chiDivfloor, & - Lapx(i,j,k), & - Axxx(i,j,k),Axyx(i,j,k),Axzx(i,j,k),Ayyx(i,j,k),Ayzx(i,j,k),Azzx(i,j,k), & - Lapy(i,j,k), & - Axxy(i,j,k),Axyy(i,j,k),Axzy(i,j,k),Ayyy(i,j,k),Ayzy(i,j,k),Azzy(i,j,k), & - Lapz(i,j,k), & - Axxz(i,j,k),Axyz(i,j,k),Axzz(i,j,k),Ayyz(i,j,k),Ayzz(i,j,k),Azzz(i,j,k), & - betaxx(i,j,k),dBxx(i,j,k),betayx(i,j,k),dByx(i,j,k),betazx(i,j,k),dBzx(i,j,k), & - betaxy(i,j,k),dBxy(i,j,k),betayy(i,j,k),dByy(i,j,k),betazy(i,j,k),dBzy(i,j,k), & - betaxz(i,j,k),dBxz(i,j,k),betayz(i,j,k),dByz(i,j,k),betazz(i,j,k),dBzz(i,j,k), & - chix(i,j,k),chiy(i,j,k),chiz(i,j,k), & - Lapxx(i,j,k),Lapxy(i,j,k),Lapxz(i,j,k),Lapyy(i,j,k),Lapyz(i,j,k),Lapzz(i,j,k), & - sfxxx(i,j,k),sfyxx(i,j,k),sfzxx(i,j,k), & - sfxxy(i,j,k),sfyxy(i,j,k),sfzxy(i,j,k), & - sfxxz(i,j,k),sfyxz(i,j,k),sfzxz(i,j,k), & - sfxyy(i,j,k),sfyyy(i,j,k),sfzyy(i,j,k), & - sfxyz(i,j,k),sfyyz(i,j,k),sfzyz(i,j,k), & - sfxzz(i,j,k),sfyzz(i,j,k),sfzzz(i,j,k), & - chixx(i,j,k),chixy(i,j,k),chixz(i,j,k),chiyy(i,j,k),chiyz(i,j,k),chizz(i,j,k), & - gxxxx(i,j,k),gxyxx(i,j,k),gxzxx(i,j,k),gyyxx(i,j,k),gyzxx(i,j,k),gzzxx(i,j,k), & - gxxxy(i,j,k),gxyxy(i,j,k),gxzxy(i,j,k),gyyxy(i,j,k),gyzxy(i,j,k),gzzxy(i,j,k), & - gxxxz(i,j,k),gxyxz(i,j,k),gxzxz(i,j,k),gyyxz(i,j,k),gyzxz(i,j,k),gzzxz(i,j,k), & - gxxyy(i,j,k),gxyyy(i,j,k),gxzyy(i,j,k),gyyyy(i,j,k),gyzyy(i,j,k),gzzyy(i,j,k), & - gxxyz(i,j,k),gxyyz(i,j,k),gxzyz(i,j,k),gyyyz(i,j,k),gyzyz(i,j,k),gzzyz(i,j,k), & - gxxzz(i,j,k),gxyzz(i,j,k),gxzzz(i,j,k),gyyzz(i,j,k),gyzzz(i,j,k),gzzzz(i,j,k), & - Gamxx(i,j,k),gxxx(i,j,k),gxyx(i,j,k),gxzx(i,j,k), & - Gamyx(i,j,k),gyyx(i,j,k),gyzx(i,j,k), & - Gamzx(i,j,k),gzzx(i,j,k), & - Gamxy(i,j,k),gxxy(i,j,k),gxyy(i,j,k),gxzy(i,j,k), & - Gamyy(i,j,k),gyyy(i,j,k),gyzy(i,j,k), & - Gamzy(i,j,k),gzzy(i,j,k), & - Gamxz(i,j,k),gxxz(i,j,k),gxyz(i,j,k),gxzz(i,j,k), & - Gamyz(i,j,k),gyyz(i,j,k),gyzz(i,j,k), & - Gamzz(i,j,k),gzzz(i,j,k), & - Kx(i,j,k),Ky(i,j,k),Kz(i,j,k), & - TZx(i,j,k),TZy(i,j,k),TZz(i,j,k), & - Gamx(i,j,k),gxx(i,j,k),gxy(i,j,k),gxz(i,j,k), & - Gamy(i,j,k),gyy(i,j,k),gyz(i,j,k), & - Gamz(i,j,k),gzz(i,j,k), & - kappa1,kappa2, & - trK(i,j,k), & - Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & - chi_rhs(i,j,k), & - Gamx_rhs(i,j,k),gxx_rhs(i,j,k),gxy_rhs(i,j,k),gxz_rhs(i,j,k), & - Gamy_rhs(i,j,k),gyy_rhs(i,j,k),gyz_rhs(i,j,k), & - Gamz_rhs(i,j,k),gzz_rhs(i,j,k),trK_rhs(i,j,k),TZ_rhs(i,j,k),TZ(i,j,k)) - enddo - enddo - enddo - -!!!!!gauge variable part - Lap_rhs = -TWO*alpn1*trK -#if (GAUGE == 0) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz -#elif (GAUGE == 1) - betax_rhs = Gamx - eta*betax - betay_rhs = Gamy - eta*betay - betaz_rhs = Gamz - eta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#endif - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI -!!!!!!!!!advection term part - call lopsided(ex,X,Y,Z,gxx,gxx_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,gxy,gxy_rhs,betax,betay,betaz,Symmetry,AAS) - call lopsided(ex,X,Y,Z,gxz,gxz_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ex,X,Y,Z,gyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ex,X,Y,Z,gzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS) - call lopsided(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA) - call lopsided(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA) - call lopsided(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS) - - call lopsided(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA) - - call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) - call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) - -#if (GAUGE == 0) - call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) - call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) - call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) -#endif - - call lopsided(ex,X,Y,Z,TZ,TZ_rhs,betax,betay,betaz,Symmetry,SSS) -! numerical dissipation part - if(eps>0)then -! usual Kreiss-Oliger dissipation - - call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,dxx,gxx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,dyy,gyy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,dzz,gzz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) - call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) - call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) - call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) -#if (GAUGE == 0) - call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) - call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) -#endif - call kodis(ex,X,Y,Z,TZ,TZ_rhs,SSS,Symmetry,eps) - - endif - -#if (ABV == 0) - call ricci_gamma(ex, X, Y, Z, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry) -#endif - - call constraint_bssn(ex, X, Y, Z,& - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & - Symmetry) - - gont = 0 - - return - - end function compute_rhs_Z4c -#endif + + +#include "macrodef.fh" + + function compute_rhs_z4cnot(ex, T,X, Y, Z, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + TZ_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & +! co is not used here, we always compute constraint + Symmetry,Lev,eps,co,chitiny) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,co + real*8, intent(in ):: T,chitiny + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! when out, constraint violation + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont,compute_rhs_z4c + + real*8, dimension(ex(1),ex(2),ex(3)) :: chihere + + chihere = chi + call lowerboundset(ex,chihere,chitiny) + + gont = compute_rhs_z4c(ex, T,X, Y, Z, & + chihere, trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + TZ_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & + Symmetry,Lev,eps,co) + +#if (ABV == 0) + call ricci_gamma(ex, X, Y, Z, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) +#endif + call constraint_bssn(ex, X, Y, Z,& + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & + Symmetry) + + return + + end function compute_rhs_Z4cnot + +#if 1 + function compute_rhs_z4c(ex, T,X, Y, Z, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + TZ_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & +! co is not used here, we always compute constraint + Symmetry,Lev,eps,co) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,co + real*8, intent(in ):: T + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! when out, constraint violation + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: trKd + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + +! constraint damping terms stuffs PRD 81, 084003 (2010) + real*8 :: kappa1,kappa2,kappa3,FF,eta + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & + +sum(TZ) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs.f90: find NaN in gxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs.f90: find NaN in gyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs.f90: find NaN in gzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs.f90: find NaN in betaz" + if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs.f90: find NaN in dtSfx" + if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs.f90: find NaN in dtSfy" + if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs.f90: find NaN in dtSfz" + if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs.f90: find NaN in TZ" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + trKd = trK+TWO*TZ +!this beta^i_,j will be kept till the end of this routine + call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + + div_beta = betaxx + betayy + betazz + + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) + + chi_rhs = F2o3 *chin1*( alpn1 * trKd - div_beta ) !rhs for chi + + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + + gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & + TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) + + gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & + TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) + + gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & + TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) + + gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & + gxx * betaxy + gxz * betazy + & + gyy * betayx + gyz * betazx & + - gxy * betazz + + gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & + gxy * betaxz + gyy * betayz + & + gxz * betaxy + gzz * betazy & + - gyz * betaxx + + gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & + gxx * betaxz + gxy * betayz + & + gyz * betayx + gzz * betazx & + - gxz * betayy !rhs for gij + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz +! gij_,kl will be stored till end of this routine + call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z,SYM ,SYM ,SYM ,symmetry,Lev) + call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z,ANTI,ANTI,SYM ,symmetry,Lev) + call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z,ANTI,SYM ,ANTI,symmetry,Lev) + call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z,SYM ,ANTI,ANTI,symmetry,Lev) +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) +! the so called Gamma_d + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + +!!!!!!!!!!!!because gij_,k will be overwrite later, we calculate TWO*d_k Z^k here +! use Gamma^i as more as possible + Gmxcon = Gamx - Gamxa + Gmycon = Gamy - Gamya + Gmzcon = Gamz - Gamza + +!Maple generated code for g^ki*g^jm*g^ln*g_mn,k*g_ij,l +! Gami_,j are used as maple temp variables + Gamyy = 3*gupxz**2*gupzz*gxzz**2+gupxx*gupxz**2*gxxz**2+2*gxyx*gupxy**3*gxyy+ & + 2*gxyx*gupxy**3*gyyx+gupxx**2*gupzz*gxzx**2+3*gupxx*gupxy**2*gxyx**2+ & + 6*gxyx*gupxy*gupxz*gupyy*gyzy+gupxx**2*gupyy*gxyx**2+ & + 2*gxyz*gupxy*gupyz**2*gyyz+2*gxxz*gupxx**2*gupyz*gxyx+ & + gupxz**2*gupyy*gyzx**2+2*gxxy*gupxx*gupxy*gupxz*gxxz+ & + 2*gyzx*gupxy*gupxz*gupzz*gzzx+3*gupyy*gupyz**2*gyzy**2+ & + 2*gyyy*gupyz**3*gzzz+2*gxxz*gupxz**3*gxzz+ & + 4*gxzy*gupxx*gupxz*gupyy*gxyx+gupyy*gupyz**2*gyyz**2 + Gamxz = Gamyy+2*gxxz*gupxy**2*gupzz*gyzy+4*gxyz*gupxx*gupxy*gupxz*gxxx+ & + 6*gxzz*gupxy*gupyz*gupzz*gyzy+2*gxxy*gupxx*gupxz*gupyz*gxzz+ & + 3*gupxy**2*gupyy*gxyy**2+2*gxyz*gupxx*gupyy*gupzz*gyzx+ & + 4*gxyy*gupxx*gupyy*gupyz*gyzx+6*gxyy*gupxy*gupxz*gupyz*gxzz+ & + 4*gxzz*gupxx*gupyz*gupzz*gyzx+3*gupxx*gupxz**2*gxzx**2+ & + 4*gxyz*gupxx*gupxy*gupyz*gxyx+2*gxxz*gupxx*gupxz*gupyz*gxyz+ & + 2*gxxy*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz*gupyz*gyyz+ & + gupyz**2*gupzz*gzzy**2+gupxz**2*gupzz*gzzx**2+ & + gupyy*gupzz**2*gyzz**2+2*gyzy*gupyz**3*gzzy+gupxx*gupzz**2*gxzz**2 + Gamyy = Gamxz+gupxx*gupyz**2*gxzy**2+2*gxzx*gupxz**3*gzzx+ & + 3*gupyz**2*gupzz*gyzz**2+2*gyzy*gupyz**3*gyzz+gupyy**2*gupzz*gyzy**2+ & + gupxy**2*gupzz*gyzx**2+2*gyyz*gupyz**3*gyzz+gupxy**2*gupyy*gyyx**2+ & + gupxx*gupyz**2*gxyz**2+gupxx*gupyy**2*gxyy**2+ & + gupxy**2*gupzz*gxzy**2+2*gxzx*gupxz**3*gxzz+ & + 2*gyyx*gupxy*gupxz*gupyy*gyzx+gupxx*gupxy**2*gxxy**2+ & + 2*gxxx*gupxz**3*gzzz+2*gxxx*gupxy**3*gyyy+gupxz**2*gupyy*gxyz**2+ & + 2*gxyy*gupxy**3*gxxy + Gamxy = Gamyy+2*gxyy*gupxz*gupyy**2*gyzy+6*gxyy*gupxx*gupxy*gupyz*gxzx+ & + 4*gxyy*gupxy*gupxz*gupyy*gxyz+2*gyzx*gupxz*gupyy*gupzz*gzzy+ & + 2*gxzy*gupxy*gupxz*gupyy*gxyy+4*gxzy*gupxy*gupxz*gupzz*gxzz+ & + 2*gyyx*gupxz*gupyy*gupyz*gyzz+6*gxyx*gupxx*gupxz*gupyz*gxzz+ & + 2*gxyz*gupxy**2*gupzz*gxzy+2*gxyz*gupxy**2*gupyz*gxyy+ & + 2*gxyz*gupxy**2*gupxz*gxxy+2*gupxy*gupxz*gupyz*gxyz**2+ & + 4*gxyy*gupxz*gupyz**2*gzzz+2*gxyy*gupxy*gupyz**2*gzzy+ & + 4*gxyy*gupxy**2*gupyz*gxzy+2*gxyy*gupxy**2*gupxz*gxxz+ & + 4*gxyy*gupxx*gupxy**2*gxxx+2*gxyx*gupxy**2*gupxz*gxzy+ & + 2*gxyx*gupxy**2*gupyz*gyzy + Gamyy = Gamxy+2*gxyx*gupxx*gupxy**2*gxxy+4*gyzz*gupyz*gupzz**2*gzzz+ & + 4*gxzy*gupxx*gupxz*gupyz*gxzx+2*gxzy*gupxx*gupyy*gupzz*gyzx+ & + 4*gxxx*gupxx*gupxy*gupxz*gyzx+2*gxyx*gupxx**2*gupyz*gxzx+ & + 2*gxyx*gupxy**2*gupxz*gxyz+2*gxzy*gupxz*gupyy*gupyz*gyyz+ & + 4*gxzy*gupxy*gupyy*gupyz*gyyy+2*gxzy*gupxx*gupyy*gupyz*gyyx+ & + 2*gyyx*gupxy*gupxz*gupyy*gxzy+2*gyyx*gupxy*gupyy*gupyz*gyyz+ & + 2*gyyx*gupxy*gupyy*gupyz*gyzy+4*gxzy*gupxz*gupyy*gupzz*gyzz+ & + 2*gyyx*gupxy*gupxz*gupyz*gxzz+2*gxyz*gupxx*gupyy*gupzz*gxzy+ & + 2*gxyy*gupxz*gupyy*gupyz*gzzy + Gamxz = Gamyy+2*gxyy*gupxy*gupxz*gupyz*gzzx+2*gxyy*gupxy*gupxz*gupyy*gyzx+ & + 2*gxyy*gupxy*gupyy*gupyz*gyyz+2*gxyy*gupxx*gupyy*gupyz*gxzy+ & + 2*gxxy*gupxy**2*gupxz*gxzy+2*gxxy*gupxy**2*gupyz*gyzy+ & + 2*gxxy*gupxy**2*gupyy*gyyy+2*gxxy*gupxx**2*gupyz*gxzx+ & + 2*gxxy*gupxx**2*gupyy*gxyx+2*gxxx*gupxx*gupxz**2*gzzx+ & + 4*gxxx*gupxy*gupxz**2*gyzz+4*gxxx*gupxy**2*gupxz*gyzy+ & + 2*gxxx*gupxx*gupxy**2*gyyx+4*gxxx*gupxx*gupxz**2*gxzz+ & + 4*gxxx*gupxx**2*gupxz*gxzx+2*gxxx*gupxx**2*gupxz*gxxz+ & + 4*gxyz*gupxz*gupyz**2*gyzz+2*gxyz*gupxy*gupyz**2*gyzy+ & + 2*gxzy*gupxy*gupyy*gupzz*gyzy + Gamyy = Gamxz+2*gxyy*gupxx*gupyy*gupyz*gxyz+6*gxzz*gupxz*gupyz*gupzz*gyzz+ & + 4*gxzy*gupxz*gupyz*gupzz*gzzz+gupyy**3*gyyy**2+ & + 2*gxzy*gupxy*gupyz*gupzz*gzzy+2*gxzy*gupxx*gupyz*gupzz*gzzx+ & + 2*gxyz*gupxx*gupyz*gupzz*gxzz+2*gxzy*gupxx*gupyz*gupzz*gxzz+ & + 2*gyzy*gupxy*gupyz*gupzz*gzzx+2*gyzy*gupxz*gupyy*gupyz*gxzy+ & + 6*gyzy*gupyy*gupyz*gupzz*gyzz+4*gyzx*gupxz*gupyy*gupyz*gyzy+ & + 4*gyzx*gupxy*gupyz*gupzz*gyzz+2*gxxy*gupxx*gupxy*gupyy*gxyy+ & + 4*gyzx*gupxz*gupyz*gupzz*gzzz+2*gyzx*gupxy*gupyy*gupzz*gyzy+ & + 2*gyyz*gupyy*gupyz*gupzz*gzzy+2*gyyz*gupxy*gupyz*gupzz*gzzx + Gamxx = Gamyy+2*gyyz*gupyy*gupyz*gupzz*gyzz+2*gyyz*gupxy*gupyy*gupzz*gyzx+ & + 2*gyyz*gupxy*gupyz*gupzz*gxzz+2*gxxy*gupxx*gupxy*gupyz*gyzx+ & + 4*gyyy*gupxy*gupyy*gupyz*gyzx+2*gyyx*gupxy*gupxz*gupyz*gzzx+ & + 2*gxyz*gupxy*gupyz*gupzz*gyzz+2*gxxz*gupxz**2*gupzz*gzzz+ & + 2*gxxz*gupxz**2*gupyz*gyzz+2*gxxz*gupxy*gupxz**2*gxzy+ & + 2*gxxz*gupxx*gupxz**2*gxzx+2*gxxz*gupxy**2*gupyz*gyyy+ & + 2*gxxz*gupxx**2*gupzz*gxzx+2*gxxy*gupxz**2*gupyz*gzzz+ & + 2*gxxy*gupxz**2*gupyy*gyzz+2*gxxy*gupxy*gupxz**2*gxzz+ & + 2*gzzx*gupxz*gupyz*gupzz*gzzy+2*gyzz*gupxz*gupyz*gupzz*gzzx+ & + 2*gxzx*gupxx*gupxz*gupzz*gzzx+2*gyzx*gupxz*gupyy*gupzz*gyzz + Gamyy = Gamxx+gupzz**3*gzzz**2+2*gxzz*gupxy*gupxz*gupzz*gyzx+ & + 6*gxzx*gupxy*gupxz*gupyz*gyzy+2*gxxy*gupxy*gupxz*gupyz*gzzy+ & + 4*gxzz*gupxy*gupyz**2*gyyy+2*gxzy*gupxz*gupyz**2*gyzz+ & + 2*gxzy*gupxz**2*gupyz*gxzz+2*gxzy*gupxz**2*gupyy*gxyz+ & + 2*gupxy*gupxz*gupyz*gxzy**2+4*gxzx*gupxz**2*gupzz*gzzz+ & + 2*gxzx*gupxz**2*gupyz*gyzz+2*gxyz*gupxy*gupxz*gupzz*gzzx+ & + 2*gxyz*gupxz*gupyy*gupzz*gzzy+2*gxyx*gupxx*gupxz*gupyy*gxyz+ & + 2*gxzz*gupxz*gupyz**2*gyyz+2*gxxy*gupxx*gupxy*gupxz*gxzx+ & + 2*gyyx*gupxy**2*gupxz*gxzx + Gamxz = Gamyy+2*gxyx*gupxy*gupxz*gupyz*gzzy+2*gyzy*gupyy*gupyz*gupzz*gzzy+ & + 2*gxyx*gupxx*gupxz*gupyy*gyzx+2*gyyx*gupxy*gupyz**2*gyzz+ & + 2*gyyx*gupxy**2*gupyz*gyzx+2*gyyx*gupxz*gupyz**2*gzzz+ & + 2*gyyx*gupxy*gupyy**2*gyyy+2*gxyz*gupxy**2*gupzz*gyzx+ & + 2*gxyz*gupxy**2*gupyz*gyyx+2*gxyy*gupxy*gupyz**2*gyzz+ & + 2*gxyy*gupxy**2*gupyz*gyzx+2*gxyy*gupxy**2*gupyy*gyyx+ & + 2*gxyx*gupxy*gupxz**2*gzzx+2*gxyx*gupxy**2*gupyz*gyyz+ & + 4*gxzz*gupxz*gupzz**2*gzzz+2*gxzz*gupxy*gupzz**2*gzzy+ & + 2*gxzz*gupxx*gupzz**2*gzzx+6*gxyx*gupxx*gupxy*gupxz*gxzx+ & + 2*gxyz*gupxy*gupxz*gupyz*gyzx + Gamyy = Gamxz+2*gyyx*gupxz*gupyy**2*gyzy+2*gyyx*gupxz*gupyy*gupyz*gzzy+ & + 2*gxxz*gupxx*gupxy*gupyz*gxyy+2*gyzx*gupxz**2*gupyy*gxzy+ & + 4*gyzx*gupxy*gupxz**2*gxzx+2*gyzx*gupxz*gupyz**2*gyzz+ & + 2*gyzx*gupxz**2*gupyz*gxzz+2*gupxy*gupxz*gupyz*gyzx**2+ & + 2*gyyz*gupyz**2*gupzz*gzzz+2*gyyz*gupyy*gupyz**2*gyzy+ & + 2*gyyz*gupxy*gupyz**2*gyzx+2*gyyz*gupyy**2*gupzz*gyzy+ & + 2*gyyz*gupxy**2*gupzz*gxzx+2*gyyy*gupyy*gupyz**2*gzzy+ & + 2*gyyy*gupxy*gupyz**2*gzzx+4*gyyy*gupyy*gupyz**2*gyzz+ & + 4*gyyy*gupyy**2*gupyz*gyzy+2*gyyy*gupyy**2*gupyz*gyyz + Gamxy = Gamyy+2*gxyz*gupxz*gupyy*gupyz*gyzy+2*gxyz*gupxx*gupyy*gupyz*gyyx+ & + 2*gzzx*gupxz*gupzz**2*gzzz+2*gxzy*gupxy*gupxz*gupyz*gyzx+ & + 2*gyzz*gupyz**2*gupzz*gzzy+2*gyzy*gupxz*gupyz**2*gzzx+ & + 2*gyzx*gupxz*gupyz**2*gzzy+2*gyzx*gupxz**2*gupyz*gzzx+ & + 2*gxzz*gupxz**2*gupzz*gzzx+2*gxzz*gupxy*gupzz**2*gyzz+ & + 2*gxzy*gupxz*gupyz**2*gzzy+2*gxzy*gupxz**2*gupyz*gzzx+ & + 2*gxzx*gupxz**2*gupyz*gzzy+2*gyzz*gupyy*gupzz**2*gzzy+ & + 2*gyzz*gupxy*gupzz**2*gzzx+4*gyzy*gupyz**2*gupzz*gzzz+ & + 2*gyzy*gupxy*gupyz**2*gyzx+2*gyzy*gupxz*gupyz**2*gxzz+ & + 2*gxzy*gupxy*gupyz*gupzz*gyzz+2*gxyx*gupxx*gupxy*gupyz*gxzy + Gamyy = Gamxy+gupxx**3*gxxx**2+2*gzzy*gupyz*gupzz**2*gzzz+ & + 6*gxyx*gupxx*gupxy*gupyy*gxyy+2*gxzz*gupxz*gupyz* gupzz*gzzy+ & + 6*gxyx*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz**2*gxzy+ & + 2*gxyx*gupxx*gupxy*gupyy*gyyx+2*gxyx*gupxx*gupxz*gupyz*gzzx+ & + 2*gxyx*gupxx*gupxy*gupxz*gxxz+4*gxyx*gupxx**2*gupxy*gxxx+ & + 2*gxyx*gupxy*gupxz*gupyy*gyyz+6*gxyy*gupxy*gupyy*gupyz*gyzy+ & + 2*gxyx*gupxx*gupxy*gupyz*gyzx+6*gxyy*gupxz*gupyy*gupyz*gyzz+ & + 4*gxyz*gupxx*gupxy*gupzz*gxzx+2*gxyz*gupxy*gupxz*gupzz*gxzz+ & + 4*gxyx*gupxy**2*gupyy*gyyy+2*gxyz*gupxz*gupyy*gupyz*gyyz + Gamxz = Gamyy+4*gxyz*gupxy*gupyy*gupyz*gyyy+2*gxyx*gupxz**2*gupyy*gyzz+ & + 2*gxyz*gupxz*gupyy*gupzz*gyzz+2*gxyx*gupxy*gupxz**2*gxzz+ & + 4*gxyz*gupxy*gupyy*gupzz*gyzy+2*gxzx*gupxy**2*gupzz*gyzy+ & + 2*gxyz*gupxx*gupxz*gupyz*gxzx+4*gxyx*gupxz**2*gupyz*gzzz+ & + 4*gxzx*gupxy**2*gupyz*gyyy+2*gyyz*gupxy*gupyy*gupzz*gxzy+ & + 2*gxyz*gupxy*gupxz*gupyz*gxzy+2*gxyz*gupxx*gupyz*gupzz*gzzx+ & + 4*gxyy*gupxy*gupyy**2*gyyy+2*gxyy*gupxx*gupyy**2*gyyx+ & + 2*gxyy*gupxx*gupyz**2*gzzx+2*gxyz*gupxy*gupyz*gupzz*gzzy+ & + 2*gxyy*gupxz*gupyy**2*gyyz+4*gxyz*gupxz*gupyz*gupzz*gzzz+ & + 2*gxxy*gupxx*gupxz*gupyy*gxyz + Gamyy = Gamxz+2*gxzx*gupxy*gupxz**2*gxyz+2*gxxy*gupxy*gupxz*gupyy*gyzy+ & + 4*gxxx*gupxx*gupxy*gupxz*gxzy+2*gxxy*gupxy*gupxz*gupyy*gyyz+ & + 2*gxxy*gupxx*gupxz*gupyy*gyzx+2*gxxy*gupxx*gupxz*gupyz*gzzx+ & + 2*gxzx*gupxy**2*gupxz*gxyy+2*gxxy*gupxx*gupxy*gupyz*gxzy+ & + 2*gxyz*gupxy*gupxz**2*gxxz+2*gxxy*gupxx*gupxy*gupyy*gyyx+ & + 2*gxyz*gupxx*gupyz**2*gyzx+4*gxyz*gupxz**2*gupyz*gxzz+ & + 2*gxxz*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxx*gupxz*gupzz*gxzz+ & + 2*gxxx*gupxx**2*gupxy*gxxy+2*gxxz*gupxx*gupxy*gupyz*gyyx+ & + 2*gxxz*gupxy*gupxz*gupzz*gyzz+2*gxxz*gupxx*gupxy*gupzz*gyzx + TZ_rhs = Gamyy+2*gxxz*gupxy*gupxz*gupyz*gyyz+2*gxxz*gupxx*gupxz*gupyz*gyzx+ & + 2*gxxz*gupxx*gupxz*gupzz*gzzx+2*gxxz*gupxy*gupxz*gupyz*gyzy+ & + 2*gxzx*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxy*gupxz*gupzz*gzzy+ & + 6*gxzx*gupxy*gupxz*gupzz*gyzz+2*gxzx*gupxx*gupxy*gupzz*gyzx+ & + 2*gxzx*gupxx*gupxy*gupyz*gyyx+6*gxzx*gupxx*gupxz*gupzz*gxzz+ & + 2*gxxx*gupxy**2*gupxz*gyyz+2*gxzx*gupxy*gupxz*gupzz*gzzy+ & + 2*gxzx*gupxx*gupxz*gupyz*gyzx+2*gxxx*gupxy*gupxz**2*gzzy+ & + 4*gxzy*gupxy*gupyz**2*gyzy+2*gxzy*gupxx*gupyz**2*gyzx+ & + 2*gxzz*gupxx*gupyz**2*gyyx+4*gxyx*gupxy**2*gupxz*gyzx+ & + 2*gxyx*gupxz**2*gupyy*gzzy+2*gxyy*gupxx*gupyz**2*gxzz + +! Gami_,j will be kept till the end of this routine + call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM ,Symmetry,Lev) + call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) + call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM ,ANTI,Symmetry,Lev) + + TZ_rhs = chix*Gmxcon+chiy*Gmycon+chiz*Gmzcon & + +chin1*(Gamxx+Gamyy+Gamzz - & + (TWO*(gupxz*gupyz*gyzxz+gupxx*gupyy*gxyxy+gupxy*gupyz*gxzyy+ & + gupxx*gupxy*gxxxy+gupxx*gupxz*gxxxz+gupxx*gupxy*gxyxx+ & + gupxx*gupyz*gxyxz+gupxx*gupxz*gxzxx+gupxx*gupyz*gxzxy+ & + gupxx*gupzz*gxzxz+gupxy*gupxz*gxxyz+gupxy*gupyy*gxyyy+ & + gupxy*gupyz*gxyyz+gupxy*gupxz*gxzxy+gupxy*gupzz*gxzyz+ & + gupxy*gupxz*gxyxz+gupxz*gupyy*gxyyz+gupxz*gupyz*gxyzz+ & + gupxz*gupyz*gxzyz+gupxz*gupzz*gxzzz+gupxy*gupyy*gyyxy+ & + gupxy*gupyz*gyyxz+gupxy*gupxz*gyzxx+gupxy*gupyz*gyzxy+ & + gupxy*gupzz*gyzxz+gupyy*gupyz*gyyyz+gupxz*gupyy*gyzxy+ & + gupyy*gupyz*gyzyy+gupyy*gupzz*gyzyz+gupyz*gupzz*gyzzz+ & + gupxz*gupyz*gzzxy+gupxz*gupzz*gzzxz+gupyz*gupzz*gzzyz+ & + gupxy*gupxy*gxyxy+gupxz*gupxz*gxzxz+gupyz*gupyz*gyzyz) & + +gupxx*gupxx*gxxxx+gupxy*gupxy*gxxyy+gupxz*gupxz*gxxzz+ & + gupxy*gupxy*gyyxx+gupyy*gupyy*gyyyy+gupyz*gupyz*gyyzz+ & + gupxz*gupxz*gzzxx+gupyz*gupyz*gzzyy+gupzz*gupzz*gzzzz)+& + (gxx*Gamxa*Gamxa+gyy*Gamya*Gamya+gzz*Gamza*Gamza +& + TWO*(gxy*Gamxa*Gamya+gxz*Gamxa*Gamza+gyz*Gamya*Gamza)) + TZ_rhs) + +! Raise indices of \tilde A_{ij} and store in R_ij + + Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & + TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) + + Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & + TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) + + Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & + TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) + + Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & + (gupxx * gupyy + gupxy * gupxy)* Axy + & + (gupxx * gupyz + gupxz * gupxy)* Axz + & + (gupxy * gupyz + gupxz * gupyy)* Ayz + + Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & + (gupxx * gupyz + gupxy * gupxz)* Axy + & + (gupxx * gupzz + gupxz * gupxz)* Axz + & + (gupxy * gupzz + gupxz * gupyz)* Ayz + + Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & + (gupxy * gupyz + gupyy * gupxz)* Axy + & + (gupxy * gupzz + gupyz * gupxz)* Axz + & + (gupyy * gupzz + gupyz * gupyz)* Ayz + +! Right hand side for Gam^i without shift terms... +! Lap_,i will be kept till the end of this routine + call fderivs(ex,Lap,Lapx,Lapy,Lapz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) +! K_,i stored K_,i+TZ_,i/2 indeed, will be kept till the end of this routine + call fderivs(ex,trK,Kx,Ky,Kz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) + call fderivs(ex,TZ,fxx,fxy,fxz,X,Y,Z,SYM,SYM,SYM,symmetry,Lev) + + Kx = Kx + fxx/TWO + Ky = Ky + fxy/TWO + Kz = Kz + fxz/TWO + + Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & + gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & + TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) + + Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & + gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & + TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) + + Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & + gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & + TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) + + call fdderivs(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,& + X,Y,Z,ANTI,SYM, SYM ,Symmetry,Lev) + call fdderivs(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,& + X,Y,Z,SYM ,ANTI,SYM ,Symmetry,Lev) + call fdderivs(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,& + X,Y,Z,SYM ,SYM, ANTI,Symmetry,Lev) + + fxx = gxxx + gxyy + gxzz + fxy = gxyx + gyyy + gyzz + fxz = gxzx + gyzy + gzzz + + Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & + Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & + F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & + gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & + TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) + + Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & + Gamxa * betayx - Gamya * betayy - Gamza * betayz + & + F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & + gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & + TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) + + Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & + Gamxa * betazx - Gamya * betazy - Gamza * betazz + & + F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & + gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & + TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + Rxx = gupxx * gxxxx + gupyy * gxxyy + gupzz * gxxzz + & + ( gupxy * gxxxy + gupxz * gxxxz + gupyz * gxxyz ) * TWO + + Ryy = gupxx * gyyxx + gupyy * gyyyy + gupzz * gyyzz + & + ( gupxy * gyyxy + gupxz * gyyxz + gupyz * gyyyz ) * TWO + + Rzz = gupxx * gzzxx + gupyy * gzzyy + gupzz * gzzzz + & + ( gupxy * gzzxy + gupxz * gzzxz + gupyz * gzzyz ) * TWO + + Rxy = gupxx * gxyxx + gupyy * gxyyy + gupzz * gxyzz + & + ( gupxy * gxyxy + gupxz * gxyxz + gupyz * gxyyz ) * TWO + + Rxz = gupxx * gxzxx + gupyy * gxzyy + gupzz * gxzzz + & + ( gupxy * gxzxy + gupxz * gxzxz + gupyz * gxzyz ) * TWO + + Ryz = gupxx * gyzxx + gupyy * gyzyy + gupzz * gyzzz + & + ( gupxy * gyzxy + gupxz * gyzxz + gupyz * gyzyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + call fdderivs(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z,SYM,SYM,SYM,Symmetry,Lev) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) + +! Add chi part to Ricci tensor: + + fxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + fyy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + fzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + fxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + fxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + fyz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO +! store R/chi in Hcon + Hcon = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + + Rxx = fxx + Ryy = fyy + Rzz = fzz + Rxy = fxy + Rxz = fxz + Ryz = fyz + + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + +! covariant second derivatives of the lapse respect to physical metric + + call fdderivs(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,X,Y,Z, & + SYM,SYM,SYM,symmetry,Lev) + + fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz + fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz + fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz + fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz + fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz + fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz + +! store D^i D_i Lap in trK_rhs upto chi + trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) +! Add lapse and S_ij parts to Ricci tensor: + + fxx = EIGHT * PI * alpn1 * Sxx + fxx + fxy = EIGHT * PI * alpn1 * Sxy + fxy + fxz = EIGHT * PI * alpn1 * Sxz + fxz + fyy = EIGHT * PI * alpn1 * Syy + fyy + fyz = EIGHT * PI * alpn1 * Syz + fyz + fzz = EIGHT * PI * alpn1 * Szz + fzz + +! Compute trace-free part (note: chi^-1 and chi cancel!): + f = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + + f = F1o3 * (Hcon*alpn1 - f) + + fxx = alpn1 * Rxx - fxx + fxy = alpn1 * Rxy - fxy + fxz = alpn1 * Rxz - fxz + fyy = alpn1 * Ryy - fyy + fyz = alpn1 * Ryz - fyz + fzz = alpn1 * Rzz - fzz + + Axx_rhs = fxx - gxx * f + Ayy_rhs = fyy - gyy * f + Azz_rhs = fzz - gzz * f + Axy_rhs = fxy - gxy * f + Axz_rhs = fxz - gxz * f + Ayz_rhs = fyz - gyz * f + +! Now: store A_il A^l_j into fij: + + fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) + fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) + fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) + fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy *(Axx * Ayy + Axy * Axy) + & + gupxz *(Axx * Ayz + Axz * Axy) + & + gupyz *(Axy * Ayz + Axz * Ayy) + fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy *(Axx * Ayz + Axy * Axz) + & + gupxz *(Axx * Azz + Axz * Axz) + & + gupyz *(Axy * Azz + Axz * Ayz) + fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy *(Axy * Ayz + Ayy * Axz) + & + gupxz *(Axy * Azz + Ayz * Axz) + & + gupyz *(Ayy * Azz + Ayz * Ayz) + + f = chin1 +! store D^i D_i Lap in trK_rhs + trK_rhs = f*trK_rhs + + Axx_rhs = f * Axx_rhs+ alpn1 * (trKd * Axx - TWO * fxx) + & + TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx ) - & + F2o3 * Axx * div_beta + + Ayy_rhs = f * Ayy_rhs+ alpn1 * (trKd * Ayy - TWO * fyy) + & + TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy ) - & + F2o3 * Ayy * div_beta + + Azz_rhs = f * Azz_rhs+ alpn1 * (trKd * Azz - TWO * fzz) + & + TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz ) - & + F2o3 * Azz * div_beta + + Axy_rhs = f * Axy_rhs+ alpn1 *( trKd * Axy - TWO * fxy )+ & + Axx * betaxy + Axz * betazy + & + Ayy * betayx + Ayz * betazx + & + F1o3 * Axy * div_beta - Axy * betazz + + Ayz_rhs = f * Ayz_rhs+ alpn1 *( trKd * Ayz - TWO * fyz )+ & + Axy * betaxz + Ayy * betayz + & + Axz * betaxy + Azz * betazy + & + F1o3 * Ayz * div_beta - Ayz * betaxx + + Axz_rhs = f * Axz_rhs+ alpn1 *( trKd * Axz - TWO * fxz )+ & + Axx * betaxz + Axy * betayz + & + Ayz * betayx + Azz * betazx + & + F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij + +! Compute trace of S_ij + + S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & + TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) + + trK_rhs = - trK_rhs + alpn1 *( F1o3 * trKd * trKd + & + gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & + FOUR * PI * ( rho + S )) !rhs for trK + +!!!!!gauge variable part + Lap_rhs = -TWO*alpn1*trK + +#if (GAUGE == 0) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz +#elif (GAUGE == 1) + betax_rhs = Gamx - eta*betax + betay_rhs = Gamy - eta*betay + betaz_rhs = Gamz - eta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#endif +!!!!!Z4 part +! H = trR + 2/3 * trKd^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + + Hcon = chin1*Hcon + F2o3 * trKd * trKd -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho +! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + call fderivs(ex,Axx,gxxx,gxxy,gxxz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,lev) + call fderivs(ex,Axy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,lev) + call fderivs(ex,Axz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,lev) + call fderivs(ex,Ayy,gyyx,gyyy,gyyz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,lev) + call fderivs(ex,Ayz,gyzx,gyzy,gyzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,lev) + call fderivs(ex,Azz,gzzx,gzzy,gzzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,lev) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 + Mxcon = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz + Mycon = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz + Mzcon = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz +! we have already considered TZ_,i in K_,i here, or to say here Micon = +! Micon+TZ_,i indeed + Mxcon = Mxcon - F2o3*Kx - F8*PI*sx + Mycon = Mycon - F2o3*Ky - F8*PI*sy + Mzcon = Mzcon - F2o3*Kz - F8*PI*sz + + f = TZ_rhs + + TZ_rhs = alpn1*Hcon/TWO +! delete TWO*Z^i_,i From Hcon' to get Hcon, this is wrong +! Hcon = Hcon - f + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI +!!!!!!!!!advection term part + call lopsided(ex,X,Y,Z,gxx,gxx_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,gxy,gxy_rhs,betax,betay,betaz,Symmetry,AAS) + call lopsided(ex,X,Y,Z,gxz,gxz_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ex,X,Y,Z,gyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ex,X,Y,Z,gzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS) + call lopsided(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA) + + call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) + call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) + + call lopsided(ex,X,Y,Z,TZ,TZ_rhs,betax,betay,betaz,Symmetry,SSS) + +! constraint damping terms + TZ_rhs = TZ_rhs - alpn1*(TWO+kappa2)*kappa1*TZ + trK_rhs = trK_rhs + alpn1*kappa1*(ONE-kappa2)*TZ + Gamx_rhs = Gamx_rhs - TWO*alpn1*kappa1*(Gamx-Gamxa) + Gamy_rhs = Gamy_rhs - TWO*alpn1*kappa1*(Gamy-Gamya) + Gamz_rhs = Gamz_rhs - TWO*alpn1*kappa1*(Gamz-Gamza) + +! numerical dissipation part + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxx,gxx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,gyy,gyy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,gzz,gzz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) + call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) + call kodis(ex,X,Y,Z,TZ,TZ_rhs,SSS,Symmetry,eps) + + endif + +#if (ABV == 0) + call ricci_gamma(ex, X, Y, Z, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) +#endif + + call constraint_bssn(ex, X, Y, Z,& + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & + Symmetry) + + gont = 0 + + return + + end function compute_rhs_Z4c +#endif + + +!! using David Z4c-rhs code +#if 0 + function compute_rhs_z4c(ex, T,X, Y, Z, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + TZ_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & +! co is not used here, we always compute constraint + Symmetry,Lev,eps,co) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,co + real*8, intent(in ):: T + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! when out, constraint violation + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chixx,chixy,chixz,chiyy,chiyz,chizz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: dBxx,dBxy,dBxz + real*8, dimension(ex(1),ex(2),ex(3)) :: dByx,dByy,dByz + real*8, dimension(ex(1),ex(2),ex(3)) :: dBzx,dBzy,dBzz + real*8, dimension(ex(1),ex(2),ex(3)) :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,TZx,TZy,TZz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + integer :: i,j,k + +! constraint damping terms stuffs PRD 81, 084003 (2010) + real*8 :: kappa1,kappa2,kappa3,FF,eta + + real*8,parameter :: chiDivfloor=1.d-5 + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & + +sum(TZ) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs.f90: find NaN in gxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs.f90: find NaN in gyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs.f90: find NaN in gzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs.f90: find NaN in betaz" + if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs.f90: find NaN in dtSfx" + if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs.f90: find NaN in dtSfy" + if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs.f90: find NaN in dtSfz" + if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs.f90: find NaN in TZ" + gont = 1 + return + endif + + PI = dacos(-ONE) + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs(ex,betax,betaxx,betaxy,betaxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fderivs(ex,betay,betayx,betayy,betayz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fderivs(ex,betaz,betazx,betazy,betazz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + call fderivs(ex,dtSfx,dBxx,dBxy,dBxz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fderivs(ex,dtSfy,dByx,dByy,dByz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fderivs(ex,dtSfz,dBzx,dBzy,dBzz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + call fderivs(ex,chi,chix,chiy,chiz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + call fderivs(ex,dxx,gxxx,gxxy,gxxz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + call fderivs(ex,gxy,gxyx,gxyy,gxyz,X,Y,Z,ANTI,ANTI,SYM,Symmetry,Lev) + call fderivs(ex,gxz,gxzx,gxzy,gxzz,X,Y,Z,ANTI,SYM,ANTI,Symmetry,Lev) + call fderivs(ex,dyy,gyyx,gyyy,gyyz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + call fderivs(ex,gyz,gyzx,gyzy,gyzz,X,Y,Z,SYM,ANTI,ANTI,Symmetry,Lev) + call fderivs(ex,dzz,gzzx,gzzy,gzzz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + + call fdderivs(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,X,Y,Z, SYM, SYM,SYM ,Symmetry,Lev) + call fdderivs(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,X,Y,Z, SYM, SYM,SYM ,Symmetry,Lev) + call fdderivs(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,X,Y,Z, SYM, SYM,SYM ,Symmetry,Lev) + call fdderivs(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,X,Y,Z,ANTI,ANTI,SYM ,Symmetry,Lev) + call fdderivs(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,X,Y,Z,ANTI,SYM ,ANTI,Symmetry,Lev) + call fdderivs(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,X,Y,Z,SYM ,ANTI,ANTI,Symmetry,Lev) + + call fderivs(ex,Gamx,Gamxx,Gamxy,Gamxz,X,Y,Z,ANTI,SYM ,SYM,Symmetry,Lev) + call fderivs(ex,Gamy,Gamyx,Gamyy,Gamyz,X,Y,Z,SYM ,ANTI,SYM,Symmetry,Lev) + call fderivs(ex,Gamz,Gamzx,Gamzy,Gamzz,X,Y,Z,SYM ,SYM,ANTI,Symmetry,Lev) + + call fderivs(ex,Lap,Lapx,Lapy,Lapz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + call fderivs(ex,trK,Kx,Ky,Kz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + + call fderivs(ex,TZ,TZx,TZy,TZz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + + call fdderivs(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,X,Y,Z,ANTI, SYM, SYM,Symmetry,Lev) + call fdderivs(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,X,Y,Z, SYM,ANTI, SYM,Symmetry,Lev) + call fdderivs(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,X,Y,Z, SYM, SYM,ANTI,Symmetry,Lev) + + call fdderivs(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + + call fdderivs(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,X,Y,Z,SYM ,SYM ,SYM ,Symmetry,Lev) + + call fderivs(ex,Axx,Axxx,Axxy,Axxz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + call fderivs(ex,Axy,Axyx,Axyy,Axyz,X,Y,Z,ANTI,ANTI,SYM,Symmetry,Lev) + call fderivs(ex,Axz,Axzx,Axzy,Axzz,X,Y,Z,ANTI,SYM,ANTI,Symmetry,Lev) + call fderivs(ex,Ayy,Ayyx,Ayyy,Ayyz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + call fderivs(ex,Ayz,Ayzx,Ayzy,Ayzz,X,Y,Z,SYM,ANTI,ANTI,Symmetry,Lev) + call fderivs(ex,Azz,Azzx,Azzy,Azzz,X,Y,Z, SYM, SYM,SYM,Symmetry,Lev) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + call z4c_rhs_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & + alpn1(i,j,k),dtSfx(i,j,k),dtSfy(i,j,k),dtSfz(i,j,k), & + betax(i,j,k),betay(i,j,k),betaz(i,j,k), & + chin1(i,j,k),chiDivfloor, & + Lapx(i,j,k), & + Axxx(i,j,k),Axyx(i,j,k),Axzx(i,j,k),Ayyx(i,j,k),Ayzx(i,j,k),Azzx(i,j,k), & + Lapy(i,j,k), & + Axxy(i,j,k),Axyy(i,j,k),Axzy(i,j,k),Ayyy(i,j,k),Ayzy(i,j,k),Azzy(i,j,k), & + Lapz(i,j,k), & + Axxz(i,j,k),Axyz(i,j,k),Axzz(i,j,k),Ayyz(i,j,k),Ayzz(i,j,k),Azzz(i,j,k), & + betaxx(i,j,k),dBxx(i,j,k),betayx(i,j,k),dByx(i,j,k),betazx(i,j,k),dBzx(i,j,k), & + betaxy(i,j,k),dBxy(i,j,k),betayy(i,j,k),dByy(i,j,k),betazy(i,j,k),dBzy(i,j,k), & + betaxz(i,j,k),dBxz(i,j,k),betayz(i,j,k),dByz(i,j,k),betazz(i,j,k),dBzz(i,j,k), & + chix(i,j,k),chiy(i,j,k),chiz(i,j,k), & + Lapxx(i,j,k),Lapxy(i,j,k),Lapxz(i,j,k),Lapyy(i,j,k),Lapyz(i,j,k),Lapzz(i,j,k), & + sfxxx(i,j,k),sfyxx(i,j,k),sfzxx(i,j,k), & + sfxxy(i,j,k),sfyxy(i,j,k),sfzxy(i,j,k), & + sfxxz(i,j,k),sfyxz(i,j,k),sfzxz(i,j,k), & + sfxyy(i,j,k),sfyyy(i,j,k),sfzyy(i,j,k), & + sfxyz(i,j,k),sfyyz(i,j,k),sfzyz(i,j,k), & + sfxzz(i,j,k),sfyzz(i,j,k),sfzzz(i,j,k), & + chixx(i,j,k),chixy(i,j,k),chixz(i,j,k),chiyy(i,j,k),chiyz(i,j,k),chizz(i,j,k), & + gxxxx(i,j,k),gxyxx(i,j,k),gxzxx(i,j,k),gyyxx(i,j,k),gyzxx(i,j,k),gzzxx(i,j,k), & + gxxxy(i,j,k),gxyxy(i,j,k),gxzxy(i,j,k),gyyxy(i,j,k),gyzxy(i,j,k),gzzxy(i,j,k), & + gxxxz(i,j,k),gxyxz(i,j,k),gxzxz(i,j,k),gyyxz(i,j,k),gyzxz(i,j,k),gzzxz(i,j,k), & + gxxyy(i,j,k),gxyyy(i,j,k),gxzyy(i,j,k),gyyyy(i,j,k),gyzyy(i,j,k),gzzyy(i,j,k), & + gxxyz(i,j,k),gxyyz(i,j,k),gxzyz(i,j,k),gyyyz(i,j,k),gyzyz(i,j,k),gzzyz(i,j,k), & + gxxzz(i,j,k),gxyzz(i,j,k),gxzzz(i,j,k),gyyzz(i,j,k),gyzzz(i,j,k),gzzzz(i,j,k), & + Gamxx(i,j,k),gxxx(i,j,k),gxyx(i,j,k),gxzx(i,j,k), & + Gamyx(i,j,k),gyyx(i,j,k),gyzx(i,j,k), & + Gamzx(i,j,k),gzzx(i,j,k), & + Gamxy(i,j,k),gxxy(i,j,k),gxyy(i,j,k),gxzy(i,j,k), & + Gamyy(i,j,k),gyyy(i,j,k),gyzy(i,j,k), & + Gamzy(i,j,k),gzzy(i,j,k), & + Gamxz(i,j,k),gxxz(i,j,k),gxyz(i,j,k),gxzz(i,j,k), & + Gamyz(i,j,k),gyyz(i,j,k),gyzz(i,j,k), & + Gamzz(i,j,k),gzzz(i,j,k), & + Kx(i,j,k),Ky(i,j,k),Kz(i,j,k), & + TZx(i,j,k),TZy(i,j,k),TZz(i,j,k), & + Gamx(i,j,k),gxx(i,j,k),gxy(i,j,k),gxz(i,j,k), & + Gamy(i,j,k),gyy(i,j,k),gyz(i,j,k), & + Gamz(i,j,k),gzz(i,j,k), & + kappa1,kappa2, & + trK(i,j,k), & + Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & + chi_rhs(i,j,k), & + Gamx_rhs(i,j,k),gxx_rhs(i,j,k),gxy_rhs(i,j,k),gxz_rhs(i,j,k), & + Gamy_rhs(i,j,k),gyy_rhs(i,j,k),gyz_rhs(i,j,k), & + Gamz_rhs(i,j,k),gzz_rhs(i,j,k),trK_rhs(i,j,k),TZ_rhs(i,j,k),TZ(i,j,k)) + enddo + enddo + enddo + +!!!!!gauge variable part + Lap_rhs = -TWO*alpn1*trK +#if (GAUGE == 0) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz +#elif (GAUGE == 1) + betax_rhs = Gamx - eta*betax + betay_rhs = Gamy - eta*betay + betaz_rhs = Gamz - eta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#endif + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI +!!!!!!!!!advection term part + call lopsided(ex,X,Y,Z,gxx,gxx_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,gxy,gxy_rhs,betax,betay,betaz,Symmetry,AAS) + call lopsided(ex,X,Y,Z,gxz,gxz_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ex,X,Y,Z,gyy,gyy_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,gyz,gyz_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ex,X,Y,Z,gzz,gzz_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,Axx,Axx_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Axy,Axy_rhs,betax,betay,betaz,Symmetry,AAS) + call lopsided(ex,X,Y,Z,Axz,Axz_rhs,betax,betay,betaz,Symmetry,ASA) + call lopsided(ex,X,Y,Z,Ayy,Ayy_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,Ayz,Ayz_rhs,betax,betay,betaz,Symmetry,SAA) + call lopsided(ex,X,Y,Z,Azz,Azz_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,chi,chi_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,trK,trK_rhs,betax,betay,betaz,Symmetry,SSS) + + call lopsided(ex,X,Y,Z,Gamx,Gamx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,Gamy,Gamy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,Gamz,Gamz_rhs,betax,betay,betaz,Symmetry,SSA) + + call lopsided(ex,X,Y,Z,Lap,Lap_rhs,betax,betay,betaz,Symmetry,SSS) + call lopsided(ex,X,Y,Z,betax,betax_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,betay,betay_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,betaz,betaz_rhs,betax,betay,betaz,Symmetry,SSA) + +#if (GAUGE == 0) + call lopsided(ex,X,Y,Z,dtSfx,dtSfx_rhs,betax,betay,betaz,Symmetry,ASS) + call lopsided(ex,X,Y,Z,dtSfy,dtSfy_rhs,betax,betay,betaz,Symmetry,SAS) + call lopsided(ex,X,Y,Z,dtSfz,dtSfz_rhs,betax,betay,betaz,Symmetry,SSA) +#endif + + call lopsided(ex,X,Y,Z,TZ,TZ_rhs,betax,betay,betaz,Symmetry,SSS) +! numerical dissipation part + if(eps>0)then +! usual Kreiss-Oliger dissipation + + call kodis(ex,X,Y,Z,chi,chi_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,trK,trK_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,dxx,gxx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxy,gxy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,gxz,gxz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,dyy,gyy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,gyz,gyz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,dzz,gzz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axx,Axx_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axy,Axy_rhs,AAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Axz,Axz_rhs,ASA,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayy,Ayy_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Ayz,Ayz_rhs,SAA,Symmetry,eps) + call kodis(ex,X,Y,Z,Azz,Azz_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamx,Gamx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamy,Gamy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,Gamz,Gamz_rhs,SSA,Symmetry,eps) + call kodis(ex,X,Y,Z,Lap,Lap_rhs,SSS,Symmetry,eps) + call kodis(ex,X,Y,Z,betax,betax_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,betay,betay_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,betaz,betaz_rhs,SSA,Symmetry,eps) +#if (GAUGE == 0) + call kodis(ex,X,Y,Z,dtSfx,dtSfx_rhs,ASS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfy,dtSfy_rhs,SAS,Symmetry,eps) + call kodis(ex,X,Y,Z,dtSfz,dtSfz_rhs,SSA,Symmetry,eps) +#endif + call kodis(ex,X,Y,Z,TZ,TZ_rhs,SSS,Symmetry,eps) + + endif + +#if (ABV == 0) + call ricci_gamma(ex, X, Y, Z, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry) +#endif + + call constraint_bssn(ex, X, Y, Z,& + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & + Symmetry) + + gont = 0 + + return + + end function compute_rhs_Z4c +#endif diff --git a/AMSS_NCKU_source/Z4c_rhs_ss.f90 b/AMSS_NCKU_source/Z4C/Z4c_rhs_ss.f90 similarity index 98% rename from AMSS_NCKU_source/Z4c_rhs_ss.f90 rename to AMSS_NCKU_source/Z4C/Z4c_rhs_ss.f90 index 173a1e9..307d7c1 100644 --- a/AMSS_NCKU_source/Z4c_rhs_ss.f90 +++ b/AMSS_NCKU_source/Z4C/Z4c_rhs_ss.f90 @@ -1,2038 +1,2038 @@ - - -#include "macrodef.fh" - -#if 1 - function compute_rhs_z4c_ss(ex, T,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - TZ_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & -! co is not used here, we always compute constraint - Symmetry,Lev,eps,sst,co) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co - real*8, intent(in ):: T - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! when out, constraint violation - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: trKd - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S - real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX, dY, dZ, PI - real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - -! constraint damping terms stuffs PRD 81, 084003 (2010) - real*8 :: kappa1,kappa2,kappa3,FF,eta - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & - +sum(TZ) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs_ss.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs_ss.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs_ss.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs_ss.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs_ss.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs_ss.f90: find NaN in betaz" - if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfx" - if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfy" - if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfz" - if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs_ss.f90: find NaN in TZ" - gont = 1 - return - endif - - PI = dacos(-ONE) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - trKd = trK+TWO*TZ -! advection term will all be replaced by center difference -!this beta^i_,j will be kept till the end of this routine - call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - div_beta = betaxx + betayy + betazz - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - chi_rhs = F2o3 *chin1*( alpn1 * trKd - div_beta ) !rhs for chi - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & - TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) - - gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & - TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) - - gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & - TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) - - gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & - gxx * betaxy + gxz * betazy + & - gyy * betayx + gyz * betazx & - - gxy * betazz - - gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & - gxy * betaxz + gyy * betayz + & - gxz * betaxy + gzz * betazy & - - gyz * betaxx - - gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & - gxx * betaxz + gxy * betayz + & - gyz * betayx + gzz * betazx & - - gxz * betayy !rhs for gij - -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz -! gij_,kl will be stored till end of this routine - call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) -! second kind of connection - Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) - Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) - Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) - - Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) - Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) - Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) - - Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) - Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) - Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) -! the so called Gamma_d - Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & - TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) - Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & - TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) - Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & - TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) - -!!!!!!!!!!!!because gij_,k will be overwrite later, we calculate TWO*d_k Z^k here -! use Gamma^i as more as possible - Gmxcon = Gamx - Gamxa - Gmycon = Gamy - Gamya - Gmzcon = Gamz - Gamza - -!Maple generated code for g^ki*g^jm*g^ln*g_mn,k*g_ij,l -! Gami_,j are used as maple temp variables - Gamyy = 3*gupxz**2*gupzz*gxzz**2+gupxx*gupxz**2*gxxz**2+2*gxyx*gupxy**3*gxyy+ & - 2*gxyx*gupxy**3*gyyx+gupxx**2*gupzz*gxzx**2+3*gupxx*gupxy**2*gxyx**2+ & - 6*gxyx*gupxy*gupxz*gupyy*gyzy+gupxx**2*gupyy*gxyx**2+ & - 2*gxyz*gupxy*gupyz**2*gyyz+2*gxxz*gupxx**2*gupyz*gxyx+ & - gupxz**2*gupyy*gyzx**2+2*gxxy*gupxx*gupxy*gupxz*gxxz+ & - 2*gyzx*gupxy*gupxz*gupzz*gzzx+3*gupyy*gupyz**2*gyzy**2+ & - 2*gyyy*gupyz**3*gzzz+2*gxxz*gupxz**3*gxzz+ & - 4*gxzy*gupxx*gupxz*gupyy*gxyx+gupyy*gupyz**2*gyyz**2 - Gamxz = Gamyy+2*gxxz*gupxy**2*gupzz*gyzy+4*gxyz*gupxx*gupxy*gupxz*gxxx+ & - 6*gxzz*gupxy*gupyz*gupzz*gyzy+2*gxxy*gupxx*gupxz*gupyz*gxzz+ & - 3*gupxy**2*gupyy*gxyy**2+2*gxyz*gupxx*gupyy*gupzz*gyzx+ & - 4*gxyy*gupxx*gupyy*gupyz*gyzx+6*gxyy*gupxy*gupxz*gupyz*gxzz+ & - 4*gxzz*gupxx*gupyz*gupzz*gyzx+3*gupxx*gupxz**2*gxzx**2+ & - 4*gxyz*gupxx*gupxy*gupyz*gxyx+2*gxxz*gupxx*gupxz*gupyz*gxyz+ & - 2*gxxy*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz*gupyz*gyyz+ & - gupyz**2*gupzz*gzzy**2+gupxz**2*gupzz*gzzx**2+ & - gupyy*gupzz**2*gyzz**2+2*gyzy*gupyz**3*gzzy+gupxx*gupzz**2*gxzz**2 - Gamyy = Gamxz+gupxx*gupyz**2*gxzy**2+2*gxzx*gupxz**3*gzzx+ & - 3*gupyz**2*gupzz*gyzz**2+2*gyzy*gupyz**3*gyzz+gupyy**2*gupzz*gyzy**2+ & - gupxy**2*gupzz*gyzx**2+2*gyyz*gupyz**3*gyzz+gupxy**2*gupyy*gyyx**2+ & - gupxx*gupyz**2*gxyz**2+gupxx*gupyy**2*gxyy**2+ & - gupxy**2*gupzz*gxzy**2+2*gxzx*gupxz**3*gxzz+ & - 2*gyyx*gupxy*gupxz*gupyy*gyzx+gupxx*gupxy**2*gxxy**2+ & - 2*gxxx*gupxz**3*gzzz+2*gxxx*gupxy**3*gyyy+gupxz**2*gupyy*gxyz**2+ & - 2*gxyy*gupxy**3*gxxy - Gamxy = Gamyy+2*gxyy*gupxz*gupyy**2*gyzy+6*gxyy*gupxx*gupxy*gupyz*gxzx+ & - 4*gxyy*gupxy*gupxz*gupyy*gxyz+2*gyzx*gupxz*gupyy*gupzz*gzzy+ & - 2*gxzy*gupxy*gupxz*gupyy*gxyy+4*gxzy*gupxy*gupxz*gupzz*gxzz+ & - 2*gyyx*gupxz*gupyy*gupyz*gyzz+6*gxyx*gupxx*gupxz*gupyz*gxzz+ & - 2*gxyz*gupxy**2*gupzz*gxzy+2*gxyz*gupxy**2*gupyz*gxyy+ & - 2*gxyz*gupxy**2*gupxz*gxxy+2*gupxy*gupxz*gupyz*gxyz**2+ & - 4*gxyy*gupxz*gupyz**2*gzzz+2*gxyy*gupxy*gupyz**2*gzzy+ & - 4*gxyy*gupxy**2*gupyz*gxzy+2*gxyy*gupxy**2*gupxz*gxxz+ & - 4*gxyy*gupxx*gupxy**2*gxxx+2*gxyx*gupxy**2*gupxz*gxzy+ & - 2*gxyx*gupxy**2*gupyz*gyzy - Gamyy = Gamxy+2*gxyx*gupxx*gupxy**2*gxxy+4*gyzz*gupyz*gupzz**2*gzzz+ & - 4*gxzy*gupxx*gupxz*gupyz*gxzx+2*gxzy*gupxx*gupyy*gupzz*gyzx+ & - 4*gxxx*gupxx*gupxy*gupxz*gyzx+2*gxyx*gupxx**2*gupyz*gxzx+ & - 2*gxyx*gupxy**2*gupxz*gxyz+2*gxzy*gupxz*gupyy*gupyz*gyyz+ & - 4*gxzy*gupxy*gupyy*gupyz*gyyy+2*gxzy*gupxx*gupyy*gupyz*gyyx+ & - 2*gyyx*gupxy*gupxz*gupyy*gxzy+2*gyyx*gupxy*gupyy*gupyz*gyyz+ & - 2*gyyx*gupxy*gupyy*gupyz*gyzy+4*gxzy*gupxz*gupyy*gupzz*gyzz+ & - 2*gyyx*gupxy*gupxz*gupyz*gxzz+2*gxyz*gupxx*gupyy*gupzz*gxzy+ & - 2*gxyy*gupxz*gupyy*gupyz*gzzy - Gamxz = Gamyy+2*gxyy*gupxy*gupxz*gupyz*gzzx+2*gxyy*gupxy*gupxz*gupyy*gyzx+ & - 2*gxyy*gupxy*gupyy*gupyz*gyyz+2*gxyy*gupxx*gupyy*gupyz*gxzy+ & - 2*gxxy*gupxy**2*gupxz*gxzy+2*gxxy*gupxy**2*gupyz*gyzy+ & - 2*gxxy*gupxy**2*gupyy*gyyy+2*gxxy*gupxx**2*gupyz*gxzx+ & - 2*gxxy*gupxx**2*gupyy*gxyx+2*gxxx*gupxx*gupxz**2*gzzx+ & - 4*gxxx*gupxy*gupxz**2*gyzz+4*gxxx*gupxy**2*gupxz*gyzy+ & - 2*gxxx*gupxx*gupxy**2*gyyx+4*gxxx*gupxx*gupxz**2*gxzz+ & - 4*gxxx*gupxx**2*gupxz*gxzx+2*gxxx*gupxx**2*gupxz*gxxz+ & - 4*gxyz*gupxz*gupyz**2*gyzz+2*gxyz*gupxy*gupyz**2*gyzy+ & - 2*gxzy*gupxy*gupyy*gupzz*gyzy - Gamyy = Gamxz+2*gxyy*gupxx*gupyy*gupyz*gxyz+6*gxzz*gupxz*gupyz*gupzz*gyzz+ & - 4*gxzy*gupxz*gupyz*gupzz*gzzz+gupyy**3*gyyy**2+ & - 2*gxzy*gupxy*gupyz*gupzz*gzzy+2*gxzy*gupxx*gupyz*gupzz*gzzx+ & - 2*gxyz*gupxx*gupyz*gupzz*gxzz+2*gxzy*gupxx*gupyz*gupzz*gxzz+ & - 2*gyzy*gupxy*gupyz*gupzz*gzzx+2*gyzy*gupxz*gupyy*gupyz*gxzy+ & - 6*gyzy*gupyy*gupyz*gupzz*gyzz+4*gyzx*gupxz*gupyy*gupyz*gyzy+ & - 4*gyzx*gupxy*gupyz*gupzz*gyzz+2*gxxy*gupxx*gupxy*gupyy*gxyy+ & - 4*gyzx*gupxz*gupyz*gupzz*gzzz+2*gyzx*gupxy*gupyy*gupzz*gyzy+ & - 2*gyyz*gupyy*gupyz*gupzz*gzzy+2*gyyz*gupxy*gupyz*gupzz*gzzx - Gamxx = Gamyy+2*gyyz*gupyy*gupyz*gupzz*gyzz+2*gyyz*gupxy*gupyy*gupzz*gyzx+ & - 2*gyyz*gupxy*gupyz*gupzz*gxzz+2*gxxy*gupxx*gupxy*gupyz*gyzx+ & - 4*gyyy*gupxy*gupyy*gupyz*gyzx+2*gyyx*gupxy*gupxz*gupyz*gzzx+ & - 2*gxyz*gupxy*gupyz*gupzz*gyzz+2*gxxz*gupxz**2*gupzz*gzzz+ & - 2*gxxz*gupxz**2*gupyz*gyzz+2*gxxz*gupxy*gupxz**2*gxzy+ & - 2*gxxz*gupxx*gupxz**2*gxzx+2*gxxz*gupxy**2*gupyz*gyyy+ & - 2*gxxz*gupxx**2*gupzz*gxzx+2*gxxy*gupxz**2*gupyz*gzzz+ & - 2*gxxy*gupxz**2*gupyy*gyzz+2*gxxy*gupxy*gupxz**2*gxzz+ & - 2*gzzx*gupxz*gupyz*gupzz*gzzy+2*gyzz*gupxz*gupyz*gupzz*gzzx+ & - 2*gxzx*gupxx*gupxz*gupzz*gzzx+2*gyzx*gupxz*gupyy*gupzz*gyzz - Gamyy = Gamxx+gupzz**3*gzzz**2+2*gxzz*gupxy*gupxz*gupzz*gyzx+ & - 6*gxzx*gupxy*gupxz*gupyz*gyzy+2*gxxy*gupxy*gupxz*gupyz*gzzy+ & - 4*gxzz*gupxy*gupyz**2*gyyy+2*gxzy*gupxz*gupyz**2*gyzz+ & - 2*gxzy*gupxz**2*gupyz*gxzz+2*gxzy*gupxz**2*gupyy*gxyz+ & - 2*gupxy*gupxz*gupyz*gxzy**2+4*gxzx*gupxz**2*gupzz*gzzz+ & - 2*gxzx*gupxz**2*gupyz*gyzz+2*gxyz*gupxy*gupxz*gupzz*gzzx+ & - 2*gxyz*gupxz*gupyy*gupzz*gzzy+2*gxyx*gupxx*gupxz*gupyy*gxyz+ & - 2*gxzz*gupxz*gupyz**2*gyyz+2*gxxy*gupxx*gupxy*gupxz*gxzx+ & - 2*gyyx*gupxy**2*gupxz*gxzx - Gamxz = Gamyy+2*gxyx*gupxy*gupxz*gupyz*gzzy+2*gyzy*gupyy*gupyz*gupzz*gzzy+ & - 2*gxyx*gupxx*gupxz*gupyy*gyzx+2*gyyx*gupxy*gupyz**2*gyzz+ & - 2*gyyx*gupxy**2*gupyz*gyzx+2*gyyx*gupxz*gupyz**2*gzzz+ & - 2*gyyx*gupxy*gupyy**2*gyyy+2*gxyz*gupxy**2*gupzz*gyzx+ & - 2*gxyz*gupxy**2*gupyz*gyyx+2*gxyy*gupxy*gupyz**2*gyzz+ & - 2*gxyy*gupxy**2*gupyz*gyzx+2*gxyy*gupxy**2*gupyy*gyyx+ & - 2*gxyx*gupxy*gupxz**2*gzzx+2*gxyx*gupxy**2*gupyz*gyyz+ & - 4*gxzz*gupxz*gupzz**2*gzzz+2*gxzz*gupxy*gupzz**2*gzzy+ & - 2*gxzz*gupxx*gupzz**2*gzzx+6*gxyx*gupxx*gupxy*gupxz*gxzx+ & - 2*gxyz*gupxy*gupxz*gupyz*gyzx - Gamyy = Gamxz+2*gyyx*gupxz*gupyy**2*gyzy+2*gyyx*gupxz*gupyy*gupyz*gzzy+ & - 2*gxxz*gupxx*gupxy*gupyz*gxyy+2*gyzx*gupxz**2*gupyy*gxzy+ & - 4*gyzx*gupxy*gupxz**2*gxzx+2*gyzx*gupxz*gupyz**2*gyzz+ & - 2*gyzx*gupxz**2*gupyz*gxzz+2*gupxy*gupxz*gupyz*gyzx**2+ & - 2*gyyz*gupyz**2*gupzz*gzzz+2*gyyz*gupyy*gupyz**2*gyzy+ & - 2*gyyz*gupxy*gupyz**2*gyzx+2*gyyz*gupyy**2*gupzz*gyzy+ & - 2*gyyz*gupxy**2*gupzz*gxzx+2*gyyy*gupyy*gupyz**2*gzzy+ & - 2*gyyy*gupxy*gupyz**2*gzzx+4*gyyy*gupyy*gupyz**2*gyzz+ & - 4*gyyy*gupyy**2*gupyz*gyzy+2*gyyy*gupyy**2*gupyz*gyyz - Gamxy = Gamyy+2*gxyz*gupxz*gupyy*gupyz*gyzy+2*gxyz*gupxx*gupyy*gupyz*gyyx+ & - 2*gzzx*gupxz*gupzz**2*gzzz+2*gxzy*gupxy*gupxz*gupyz*gyzx+ & - 2*gyzz*gupyz**2*gupzz*gzzy+2*gyzy*gupxz*gupyz**2*gzzx+ & - 2*gyzx*gupxz*gupyz**2*gzzy+2*gyzx*gupxz**2*gupyz*gzzx+ & - 2*gxzz*gupxz**2*gupzz*gzzx+2*gxzz*gupxy*gupzz**2*gyzz+ & - 2*gxzy*gupxz*gupyz**2*gzzy+2*gxzy*gupxz**2*gupyz*gzzx+ & - 2*gxzx*gupxz**2*gupyz*gzzy+2*gyzz*gupyy*gupzz**2*gzzy+ & - 2*gyzz*gupxy*gupzz**2*gzzx+4*gyzy*gupyz**2*gupzz*gzzz+ & - 2*gyzy*gupxy*gupyz**2*gyzx+2*gyzy*gupxz*gupyz**2*gxzz+ & - 2*gxzy*gupxy*gupyz*gupzz*gyzz+2*gxyx*gupxx*gupxy*gupyz*gxzy - Gamyy = Gamxy+gupxx**3*gxxx**2+2*gzzy*gupyz*gupzz**2*gzzz+ & - 6*gxyx*gupxx*gupxy*gupyy*gxyy+2*gxzz*gupxz*gupyz* gupzz*gzzy+ & - 6*gxyx*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz**2*gxzy+ & - 2*gxyx*gupxx*gupxy*gupyy*gyyx+2*gxyx*gupxx*gupxz*gupyz*gzzx+ & - 2*gxyx*gupxx*gupxy*gupxz*gxxz+4*gxyx*gupxx**2*gupxy*gxxx+ & - 2*gxyx*gupxy*gupxz*gupyy*gyyz+6*gxyy*gupxy*gupyy*gupyz*gyzy+ & - 2*gxyx*gupxx*gupxy*gupyz*gyzx+6*gxyy*gupxz*gupyy*gupyz*gyzz+ & - 4*gxyz*gupxx*gupxy*gupzz*gxzx+2*gxyz*gupxy*gupxz*gupzz*gxzz+ & - 4*gxyx*gupxy**2*gupyy*gyyy+2*gxyz*gupxz*gupyy*gupyz*gyyz - Gamxz = Gamyy+4*gxyz*gupxy*gupyy*gupyz*gyyy+2*gxyx*gupxz**2*gupyy*gyzz+ & - 2*gxyz*gupxz*gupyy*gupzz*gyzz+2*gxyx*gupxy*gupxz**2*gxzz+ & - 4*gxyz*gupxy*gupyy*gupzz*gyzy+2*gxzx*gupxy**2*gupzz*gyzy+ & - 2*gxyz*gupxx*gupxz*gupyz*gxzx+4*gxyx*gupxz**2*gupyz*gzzz+ & - 4*gxzx*gupxy**2*gupyz*gyyy+2*gyyz*gupxy*gupyy*gupzz*gxzy+ & - 2*gxyz*gupxy*gupxz*gupyz*gxzy+2*gxyz*gupxx*gupyz*gupzz*gzzx+ & - 4*gxyy*gupxy*gupyy**2*gyyy+2*gxyy*gupxx*gupyy**2*gyyx+ & - 2*gxyy*gupxx*gupyz**2*gzzx+2*gxyz*gupxy*gupyz*gupzz*gzzy+ & - 2*gxyy*gupxz*gupyy**2*gyyz+4*gxyz*gupxz*gupyz*gupzz*gzzz+ & - 2*gxxy*gupxx*gupxz*gupyy*gxyz - Gamyy = Gamxz+2*gxzx*gupxy*gupxz**2*gxyz+2*gxxy*gupxy*gupxz*gupyy*gyzy+ & - 4*gxxx*gupxx*gupxy*gupxz*gxzy+2*gxxy*gupxy*gupxz*gupyy*gyyz+ & - 2*gxxy*gupxx*gupxz*gupyy*gyzx+2*gxxy*gupxx*gupxz*gupyz*gzzx+ & - 2*gxzx*gupxy**2*gupxz*gxyy+2*gxxy*gupxx*gupxy*gupyz*gxzy+ & - 2*gxyz*gupxy*gupxz**2*gxxz+2*gxxy*gupxx*gupxy*gupyy*gyyx+ & - 2*gxyz*gupxx*gupyz**2*gyzx+4*gxyz*gupxz**2*gupyz*gxzz+ & - 2*gxxz*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxx*gupxz*gupzz*gxzz+ & - 2*gxxx*gupxx**2*gupxy*gxxy+2*gxxz*gupxx*gupxy*gupyz*gyyx+ & - 2*gxxz*gupxy*gupxz*gupzz*gyzz+2*gxxz*gupxx*gupxy*gupzz*gyzx - TZ_rhs = Gamyy+2*gxxz*gupxy*gupxz*gupyz*gyyz+2*gxxz*gupxx*gupxz*gupyz*gyzx+ & - 2*gxxz*gupxx*gupxz*gupzz*gzzx+2*gxxz*gupxy*gupxz*gupyz*gyzy+ & - 2*gxzx*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxy*gupxz*gupzz*gzzy+ & - 6*gxzx*gupxy*gupxz*gupzz*gyzz+2*gxzx*gupxx*gupxy*gupzz*gyzx+ & - 2*gxzx*gupxx*gupxy*gupyz*gyyx+6*gxzx*gupxx*gupxz*gupzz*gxzz+ & - 2*gxxx*gupxy**2*gupxz*gyyz+2*gxzx*gupxy*gupxz*gupzz*gzzy+ & - 2*gxzx*gupxx*gupxz*gupyz*gyzx+2*gxxx*gupxy*gupxz**2*gzzy+ & - 4*gxzy*gupxy*gupyz**2*gyzy+2*gxzy*gupxx*gupyz**2*gyzx+ & - 2*gxzz*gupxx*gupyz**2*gyyx+4*gxyx*gupxy**2*gupxz*gyzx+ & - 2*gxyx*gupxz**2*gupyy*gzzy+2*gxyy*gupxx*gupyz**2*gxzz - -! Gami_,j will be kept till the end of this routine - call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - TZ_rhs = chix*Gmxcon+chiy*Gmycon+chiz*Gmzcon & - +chin1*(Gamxx+Gamyy+Gamzz - & - (TWO*(gupxz*gupyz*gyzxz+gupxx*gupyy*gxyxy+gupxy*gupyz*gxzyy+ & - gupxx*gupxy*gxxxy+gupxx*gupxz*gxxxz+gupxx*gupxy*gxyxx+ & - gupxx*gupyz*gxyxz+gupxx*gupxz*gxzxx+gupxx*gupyz*gxzxy+ & - gupxx*gupzz*gxzxz+gupxy*gupxz*gxxyz+gupxy*gupyy*gxyyy+ & - gupxy*gupyz*gxyyz+gupxy*gupxz*gxzxy+gupxy*gupzz*gxzyz+ & - gupxy*gupxz*gxyxz+gupxz*gupyy*gxyyz+gupxz*gupyz*gxyzz+ & - gupxz*gupyz*gxzyz+gupxz*gupzz*gxzzz+gupxy*gupyy*gyyxy+ & - gupxy*gupyz*gyyxz+gupxy*gupxz*gyzxx+gupxy*gupyz*gyzxy+ & - gupxy*gupzz*gyzxz+gupyy*gupyz*gyyyz+gupxz*gupyy*gyzxy+ & - gupyy*gupyz*gyzyy+gupyy*gupzz*gyzyz+gupyz*gupzz*gyzzz+ & - gupxz*gupyz*gzzxy+gupxz*gupzz*gzzxz+gupyz*gupzz*gzzyz+ & - gupxy*gupxy*gxyxy+gupxz*gupxz*gxzxz+gupyz*gupyz*gyzyz) & - +gupxx*gupxx*gxxxx+gupxy*gupxy*gxxyy+gupxz*gupxz*gxxzz+ & - gupxy*gupxy*gyyxx+gupyy*gupyy*gyyyy+gupyz*gupyz*gyyzz+ & - gupxz*gupxz*gzzxx+gupyz*gupyz*gzzyy+gupzz*gupzz*gzzzz)+& - (gxx*Gamxa*Gamxa+gyy*Gamya*Gamya+gzz*Gamza*Gamza +& - TWO*(gxy*Gamxa*Gamya+gxz*Gamxa*Gamza+gyz*Gamya*Gamza)) + TZ_rhs) - -! Raise indices of \tilde A_{ij} and store in R_ij - - Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & - TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) - - Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & - TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) - - Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & - TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) - - Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & - (gupxx * gupyy + gupxy * gupxy)* Axy + & - (gupxx * gupyz + gupxz * gupxy)* Axz + & - (gupxy * gupyz + gupxz * gupyy)* Ayz - - Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & - (gupxx * gupyz + gupxy * gupxz)* Axy + & - (gupxx * gupzz + gupxz * gupxz)* Axz + & - (gupxy * gupzz + gupxz * gupyz)* Ayz - - Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & - (gupxy * gupyz + gupyy * gupxz)* Axy + & - (gupxy * gupzz + gupyz * gupxz)* Axz + & - (gupyy * gupzz + gupyz * gupyz)* Ayz - -! Right hand side for Gam^i without shift terms... -! Lap_,i will be kept till the end of this routine - call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -! K_,i stored K_,i+TZ_,i/2 indeed, will be kept till the end of this routine - call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,TZ,fxx,fxy,fxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - Kx = Kx + fxx/TWO - Ky = Ky + fxy/TWO - Kz = Kz + fxz/TWO - - Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & - gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & - TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) - - Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & - gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & - TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) - - Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & - TWO * alpn1 * ( & - -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & - gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & - gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & - gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & - Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & - TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) - - call fdderivs_shc(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = gxxx + gxyy + gxzz - fxy = gxyx + gyyy + gyzz - fxz = gxzx + gyzy + gzzz - - Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & - Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & - F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & - gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & - TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) - - Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & - Gamxa * betayx - Gamya * betayy - Gamza * betayz + & - F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & - gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & - TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) - - Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & - Gamxa * betazx - Gamya * betazy - Gamza * betazz + & - F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & - gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & - TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i - -!first kind of connection stored in gij,k - gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx - gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy - gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz - gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy - gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz - gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz - - gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx - gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy - gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz - gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy - gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz - gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz - - gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx - gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy - gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz - gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy - gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz - gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz - -!compute Ricci tensor for tilted metric - Rxx = gupxx * gxxxx + gupyy * gxxyy + gupzz * gxxzz + & - ( gupxy * gxxxy + gupxz * gxxxz + gupyz * gxxyz ) * TWO - - Ryy = gupxx * gyyxx + gupyy * gyyyy + gupzz * gyyzz + & - ( gupxy * gyyxy + gupxz * gyyxz + gupyz * gyyyz ) * TWO - - Rzz = gupxx * gzzxx + gupyy * gzzyy + gupzz * gzzzz + & - ( gupxy * gzzxy + gupxz * gzzxz + gupyz * gzzyz ) * TWO - - Rxy = gupxx * gxyxx + gupyy * gxyyy + gupzz * gxyzz + & - ( gupxy * gxyxy + gupxz * gxyxz + gupyz * gxyyz ) * TWO - - Rxz = gupxx * gxzxx + gupyy * gxzyy + gupzz * gxzzz + & - ( gupxy * gxzxy + gupxz * gxzxz + gupyz * gxzyz ) * TWO - - Ryz = gupxx * gyzxx + gupyy * gyzyy + gupzz * gyzzz + & - ( gupxy * gyzxy + gupxz * gyzxz + gupyz * gyzyz ) * TWO - - Rxx = - HALF * Rxx + & - gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & - Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & - gupxx *( & - TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & - Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & - gupxy *( & - TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & - Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxz *( & - TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & - Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupyy *( & - TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupyz *( & - TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupzz *( & - TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) - - Ryy = - HALF * Ryy + & - gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & - Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & - gupxx *( & - TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & - gupxy *( & - TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & - Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupxz *( & - TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & - Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyy *( & - TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & - Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & - gupyz *( & - TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & - Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupzz *( & - TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) - - Rzz = - HALF * Rzz + & - gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & - Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & - gupxx *( & - TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & - gupxy *( & - TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & - gupxz *( & - TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & - Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & - gupyy *( & - TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & - gupyz *( & - TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & - Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & - gupzz *( & - TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & - Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) - - Rxy = HALF*( - Rxy + & - gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & - gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & - Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & - Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & - gupxx *( & - Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & - Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & - Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & - gupxy *( & - Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & - Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & - Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & - Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & - Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & - Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & - gupxz *( & - Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & - Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & - Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupyy *( & - Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & - Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & - Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & - gupyz *( & - Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & - Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & - Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupzz *( & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) - - Rxz = HALF*( - Rxz + & - gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & - gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & - Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & - Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & - gupxx *( & - Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & - Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & - Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & - gupxy *( & - Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & - Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & - Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & - gupxz *( & - Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & - Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & - Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & - Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & - Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & - Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & - gupyy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupyz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & - Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & - Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & - Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupzz *( & - Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & - Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & - Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) - - Ryz = HALF*( - Ryz + & - gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & - gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & - Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & - Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & - gupxx *( & - Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & - Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & - Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & - gupxy *( & - Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & - Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & - Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & - Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & - Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & - Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & - gupxz *( & - Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & - Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & - Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & - Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & - Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & - Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & - gupyy *( & - Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & - Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & - Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & - gupyz *( & - Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & - Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & - Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & - Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & - Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & - Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & - gupzz *( & - Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & - Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & - Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) -!covariant second derivative of chi respect to tilted metric - -! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f - - call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz - fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz - fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz - fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz - fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz - fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz - - f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & - gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & - gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & - TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & - TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & - TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) - -! Add chi part to Ricci tensor: - - fxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO - fyy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO - fzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO - fxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO - fxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO - fyz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO -! store R/chi in Hcon - Hcon = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) - - Rxx = fxx - Ryy = fyy - Rzz = fzz - Rxy = fxy - Rxz = fxz - Ryz = fyz - - gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 - gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 - gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 -! now get physical second kind of connection - Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF - Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF - Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF - Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF - Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF - Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF - Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF - Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF - Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF - Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF - Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF - Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF - Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF - Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF - Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF - Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF - Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF - Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF - -! covariant second derivatives of the lapse respect to physical metric - - call fdderivs_shc(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz - fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz - fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz - fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz - fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz - fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz - -! store D^i D_i Lap in trK_rhs upto chi - trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) -! Add lapse and S_ij parts to Ricci tensor: - - fxx = EIGHT * PI * alpn1 * Sxx + fxx - fxy = EIGHT * PI * alpn1 * Sxy + fxy - fxz = EIGHT * PI * alpn1 * Sxz + fxz - fyy = EIGHT * PI * alpn1 * Syy + fyy - fyz = EIGHT * PI * alpn1 * Syz + fyz - fzz = EIGHT * PI * alpn1 * Szz + fzz - -! Compute trace-free part (note: chi^-1 and chi cancel!): - f = gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) - - f = F1o3 * (Hcon*alpn1 - f) - - fxx = alpn1 * Rxx - fxx - fxy = alpn1 * Rxy - fxy - fxz = alpn1 * Rxz - fxz - fyy = alpn1 * Ryy - fyy - fyz = alpn1 * Ryz - fyz - fzz = alpn1 * Rzz - fzz - - Axx_rhs = fxx - gxx * f - Ayy_rhs = fyy - gyy * f - Azz_rhs = fzz - gzz * f - Axy_rhs = fxy - gxy * f - Axz_rhs = fxz - gxz * f - Ayz_rhs = fyz - gyz * f - -! Now: store A_il A^l_j into fij: - - fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) - fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) - fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) - fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy *(Axx * Ayy + Axy * Axy) + & - gupxz *(Axx * Ayz + Axz * Axy) + & - gupyz *(Axy * Ayz + Axz * Ayy) - fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy *(Axx * Ayz + Axy * Axz) + & - gupxz *(Axx * Azz + Axz * Axz) + & - gupyz *(Axy * Azz + Axz * Ayz) - fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy *(Axy * Ayz + Ayy * Axz) + & - gupxz *(Axy * Azz + Ayz * Axz) + & - gupyz *(Ayy * Azz + Ayz * Ayz) - - f = chin1 -! store D^i D_i Lap in trK_rhs - trK_rhs = f*trK_rhs - - Axx_rhs = f * Axx_rhs+ alpn1 * (trKd * Axx - TWO * fxx) + & - TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx ) - & - F2o3 * Axx * div_beta - - Ayy_rhs = f * Ayy_rhs+ alpn1 * (trKd * Ayy - TWO * fyy) + & - TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy ) - & - F2o3 * Ayy * div_beta - - Azz_rhs = f * Azz_rhs+ alpn1 * (trKd * Azz - TWO * fzz) + & - TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz ) - & - F2o3 * Azz * div_beta - - Axy_rhs = f * Axy_rhs+ alpn1 *( trKd * Axy - TWO * fxy )+ & - Axx * betaxy + Axz * betazy + & - Ayy * betayx + Ayz * betazx + & - F1o3 * Axy * div_beta - Axy * betazz - - Ayz_rhs = f * Ayz_rhs+ alpn1 *( trKd * Ayz - TWO * fyz )+ & - Axy * betaxz + Ayy * betayz + & - Axz * betaxy + Azz * betazy + & - F1o3 * Ayz * div_beta - Ayz * betaxx - - Axz_rhs = f * Axz_rhs+ alpn1 *( trKd * Axz - TWO * fxz )+ & - Axx * betaxz + Axy * betayz + & - Ayz * betayx + Azz * betazx + & - F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij - -! Compute trace of S_ij - - S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & - TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) - - trK_rhs = - trK_rhs + alpn1 *( F1o3 * trKd * trKd + & - gupxx * fxx + gupyy * fyy + gupzz * fzz + & - TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & - FOUR * PI * ( rho + S )) !rhs for trK - -!!!!!gauge variable part - Lap_rhs = -TWO*alpn1*trK -#if (GAUGE == 0) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz -#elif (GAUGE == 1) - betax_rhs = Gamx - eta*betax - betay_rhs = Gamy - eta*betay - betaz_rhs = Gamz - eta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#endif -!!!!!Z4 part -! H = trR + 2/3 * trKd^2 - A_ij * A^ij - 16 * PI * rho -! here trR is respect to physical metric - - Hcon = chin1*Hcon + F2o3 * trKd * trKd -(& - gupxx * ( & - gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & - TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & - gupyy * ( & - gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & - TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & - gupzz * ( & - gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & - TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & - TWO * ( & - gupxy * ( & - gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & - gupxy * (Axx * Ayy + Axy * Axy) + & - gupxz * (Axx * Ayz + Axz * Axy) + & - gupyz * (Axy * Ayz + Axz * Ayy) ) + & - gupxz * ( & - gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & - gupxy * (Axx * Ayz + Axy * Axz) + & - gupxz * (Axx * Azz + Axz * Axz) + & - gupyz * (Axy * Azz + Axz * Ayz) ) + & - gupyz * ( & - gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & - gupxy * (Axy * Ayz + Ayy * Axz) + & - gupxz * (Axy * Azz + Ayz * Axz) + & - gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho -! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric -! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i - - call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & - + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 - gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 - gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 - gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 - gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 - gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 - gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & - + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 - gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & - + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 - gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 - gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & - + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 - gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 - gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 - gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & - + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 - gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & - + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 - gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & - + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 - gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & - + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 - gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & - + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 - gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & - + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 - Mxcon = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & - +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & - +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz - Mycon = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & - +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & - +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz - Mzcon = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & - +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & - +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz -! we have already considered TZ_,i in K_,i here, or to say here Micon = -! Micon+TZ_,i indeed - Mxcon = Mxcon - F2o3*Kx - F8*PI*sx - Mycon = Mycon - F2o3*Ky - F8*PI*sy - Mzcon = Mzcon - F2o3*Kz - F8*PI*sz - - f = TZ_rhs - - TZ_rhs = alpn1*Hcon/TWO -! delete TWO*Z^i_,i From Hcon' to get Hcon, this is wrong -! Hcon = Hcon - f - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI -!!!!!!!!!advection term part -!g_ij - call fderivs_shc(ex,dxx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxx_rhs = gxx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gxy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxy_rhs = gxy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gxz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gxz_rhs = gxz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dyy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gyy_rhs = gyy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,gyz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gyz_rhs = gyz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dzz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - gzz_rhs = gzz_rhs + betax*fxx+betay*fxy+betaz*fxz -!A_ij - call fderivs_shc(ex,Axx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axx_rhs = Axx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Axy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axy_rhs = Axy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Axz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Axz_rhs = Axz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Ayy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Ayy_rhs = Ayy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Ayz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Ayz_rhs = Ayz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Azz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Azz_rhs = Azz_rhs + betax*fxx+betay*fxy+betaz*fxz -!chi and trK - call fderivs_shc(ex,chi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - chi_rhs = chi_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,trK,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - trK_rhs = trK_rhs + betax*fxx+betay*fxy+betaz*fxz -!Gam^i - call fderivs_shc(ex,Gamx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamx_rhs = Gamx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Gamy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamy_rhs = Gamy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,Gamz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Gamz_rhs = Gamz_rhs + betax*fxx+betay*fxy+betaz*fxz -!gauge variables - call fderivs_shc(ex,Lap,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - Lap_rhs = Lap_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betax,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betax_rhs = betax_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betay,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betay_rhs = betay_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,betaz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - betaz_rhs = betaz_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfx_rhs = dtSfx_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfy_rhs = dtSfy_rhs + betax*fxx+betay*fxy+betaz*fxz - call fderivs_shc(ex,dtSfz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - dtSfz_rhs = dtSfz_rhs + betax*fxx+betay*fxy+betaz*fxz -!Z4c variables - call fderivs_shc(ex,TZ,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - TZ_rhs = TZ_rhs + betax*fxx+betay*fxy+betaz*fxz - -! constraint damping terms - TZ_rhs = TZ_rhs - alpn1*(TWO+kappa2)*kappa1*TZ - trK_rhs = trK_rhs + alpn1*kappa1*(ONE-kappa2)*TZ - Gamx_rhs = Gamx_rhs - TWO*alpn1*kappa1*(Gamx-Gamxa) - Gamy_rhs = Gamy_rhs - TWO*alpn1*kappa1*(Gamy-Gamya) - Gamz_rhs = Gamz_rhs - TWO*alpn1*kappa1*(Gamz-Gamza) - -! numerical dissipation part - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) - endif - -#if (ABV == 1) - call ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,Lev,sst) - call constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & - Symmetry,Lev,sst) -#endif - - gont = 0 - - return - - end function compute_rhs_Z4c_ss -#endif - - -!! using David Z4c-rhs code -#if 0 - function compute_rhs_z4c_ss(ex, T,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi , trK , & - dxx , gxy , gxz , dyy , gyz , dzz, & - Axx , Axy , Axz , Ayy , Ayz , Azz, & - Gamx , Gamy , Gamz , & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ , & - chi_rhs, trK_rhs, & - gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & - Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & - Gamx_rhs, Gamy_rhs, Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - TZ_rhs , & - rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & -! co is not used here, we always compute constraint - Symmetry,Lev,eps,sst,co) result(gont) - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co - real*8, intent(in ):: T - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz -! when out, physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz -! when out, physical Ricci tensor - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz -! when out, constraint violation - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon - real*8,intent(in) :: eps -! gont = 0: success; gont = 1: something wrong - integer::gont - -!~~~~~~> Other variables: - - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chixx,chixy,chixz,chiyy,chiyz,chizz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz - real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz - real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz - real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz - real*8, dimension(ex(1),ex(2),ex(3)) :: dtSfxx,dtSfxy,dtSfxz - real*8, dimension(ex(1),ex(2),ex(3)) :: dtSfyx,dtSfyy,dtSfyz - real*8, dimension(ex(1),ex(2),ex(3)) :: dtSfzx,dtSfzy,dtSfzz - real*8, dimension(ex(1),ex(2),ex(3)) :: dBxx,dBxy,dBxz - real*8, dimension(ex(1),ex(2),ex(3)) :: dByx,dByy,dByz - real*8, dimension(ex(1),ex(2),ex(3)) :: dBzx,dBzy,dBzz - real*8, dimension(ex(1),ex(2),ex(3)) :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz - real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,TZx,TZy,TZz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy - real*8, dimension(ex(1),ex(2),ex(3)) :: Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8 :: dX,dY,dZ,PI - real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 - real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 - integer :: i,j,k - -! constraint damping terms stuffs PRD 81, 084003 (2010) - real*8 :: kappa1,kappa2,kappa3,FF,eta - - real*8,parameter :: chiDivfloor=1.d-5 - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - -!!! sanity check - dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & - +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & - +sum(Gamx)+sum(Gamy)+sum(Gamz) & - +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & - +sum(TZ) - if(dX.ne.dX) then - if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs_ss.f90: find NaN in chi" - if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs_ss.f90: find NaN in trk" - if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxx" - if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxy" - if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxz" - if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyy" - if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyz" - if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gzz" - if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axx" - if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axy" - if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axz" - if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayy" - if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayz" - if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Azz" - if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamx" - if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamy" - if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamz" - if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs_ss.f90: find NaN in Lap" - if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs_ss.f90: find NaN in betax" - if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs_ss.f90: find NaN in betay" - if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs_ss.f90: find NaN in betaz" - if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfx" - if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfy" - if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfz" - if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs_ss.f90: find NaN in TZ" - gont = 1 - return - endif - - PI = dacos(-ONE) - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - call fderivs_shc(ex,dtSfx,dBxx,dBxy,dBxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,dtSfy,dByx,dByy,dByz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,dtSfz,dBzx,dBzy,dBzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -#if (GAUGE == 0) - call fderivs_shc(ex,dtSfx,dtSfxx,dtSfxy,dtSfxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,dtSfy,dtSfyx,dtSfyy,dtSfyz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,dtSfz,dtSfzx,dtSfzy,dtSfzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -#endif - - call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -! gij_,kl will be stored till end of this routine - call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - -! Gami_,j will be kept till the end of this routine - call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - -! Right hand side for Gam^i without shift terms... -! Lap_,i will be kept till the end of this routine - call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) -! K_,i stored K_,i+TZ_,i/2 indeed, will be kept till the end of this routine - call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - call fdderivs_shc(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - call fdderivs_shc(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - call fdderivs_shc(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - call fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) - - call fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - call fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz) - - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - call z4c_rhs_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & - alpn1(i,j,k),dtSfx(i,j,k),dtSfy(i,j,k),dtSfz(i,j,k), & - betax(i,j,k),betay(i,j,k),betaz(i,j,k), & - chin1(i,j,k),chiDivfloor, & - Lapx(i,j,k), & - Axxx(i,j,k),Axyx(i,j,k),Axzx(i,j,k),Ayyx(i,j,k),Ayzx(i,j,k),Azzx(i,j,k), & - Lapy(i,j,k), & - Axxy(i,j,k),Axyy(i,j,k),Axzy(i,j,k),Ayyy(i,j,k),Ayzy(i,j,k),Azzy(i,j,k), & - Lapz(i,j,k), & - Axxz(i,j,k),Axyz(i,j,k),Axzz(i,j,k),Ayyz(i,j,k),Ayzz(i,j,k),Azzz(i,j,k), & - betaxx(i,j,k),dBxx(i,j,k),betayx(i,j,k),dByx(i,j,k),betazx(i,j,k),dBzx(i,j,k), & - betaxy(i,j,k),dBxy(i,j,k),betayy(i,j,k),dByy(i,j,k),betazy(i,j,k),dBzy(i,j,k), & - betaxz(i,j,k),dBxz(i,j,k),betayz(i,j,k),dByz(i,j,k),betazz(i,j,k),dBzz(i,j,k), & - chix(i,j,k),chiy(i,j,k),chiz(i,j,k), & - Lapxx(i,j,k),Lapxy(i,j,k),Lapxz(i,j,k),Lapyy(i,j,k),Lapyz(i,j,k),Lapzz(i,j,k), & - sfxxx(i,j,k),sfyxx(i,j,k),sfzxx(i,j,k), & - sfxxy(i,j,k),sfyxy(i,j,k),sfzxy(i,j,k), & - sfxxz(i,j,k),sfyxz(i,j,k),sfzxz(i,j,k), & - sfxyy(i,j,k),sfyyy(i,j,k),sfzyy(i,j,k), & - sfxyz(i,j,k),sfyyz(i,j,k),sfzyz(i,j,k), & - sfxzz(i,j,k),sfyzz(i,j,k),sfzzz(i,j,k), & - chixx(i,j,k),chixy(i,j,k),chixz(i,j,k),chiyy(i,j,k),chiyz(i,j,k),chizz(i,j,k), & - gxxxx(i,j,k),gxyxx(i,j,k),gxzxx(i,j,k),gyyxx(i,j,k),gyzxx(i,j,k),gzzxx(i,j,k), & - gxxxy(i,j,k),gxyxy(i,j,k),gxzxy(i,j,k),gyyxy(i,j,k),gyzxy(i,j,k),gzzxy(i,j,k), & - gxxxz(i,j,k),gxyxz(i,j,k),gxzxz(i,j,k),gyyxz(i,j,k),gyzxz(i,j,k),gzzxz(i,j,k), & - gxxyy(i,j,k),gxyyy(i,j,k),gxzyy(i,j,k),gyyyy(i,j,k),gyzyy(i,j,k),gzzyy(i,j,k), & - gxxyz(i,j,k),gxyyz(i,j,k),gxzyz(i,j,k),gyyyz(i,j,k),gyzyz(i,j,k),gzzyz(i,j,k), & - gxxzz(i,j,k),gxyzz(i,j,k),gxzzz(i,j,k),gyyzz(i,j,k),gyzzz(i,j,k),gzzzz(i,j,k), & - Gamxx(i,j,k),gxxx(i,j,k),gxyx(i,j,k),gxzx(i,j,k), & - Gamyx(i,j,k),gyyx(i,j,k),gyzx(i,j,k), & - Gamzx(i,j,k),gzzx(i,j,k), & - Gamxy(i,j,k),gxxy(i,j,k),gxyy(i,j,k),gxzy(i,j,k), & - Gamyy(i,j,k),gyyy(i,j,k),gyzy(i,j,k), & - Gamzy(i,j,k),gzzy(i,j,k), & - Gamxz(i,j,k),gxxz(i,j,k),gxyz(i,j,k),gxzz(i,j,k), & - Gamyz(i,j,k),gyyz(i,j,k),gyzz(i,j,k), & - Gamzz(i,j,k),gzzz(i,j,k), & - Kx(i,j,k),Ky(i,j,k),Kz(i,j,k), & - TZx(i,j,k),TZy(i,j,k),TZz(i,j,k), & - Gamx(i,j,k),gxx(i,j,k),gxy(i,j,k),gxz(i,j,k), & - Gamy(i,j,k),gyy(i,j,k),gyz(i,j,k), & - Gamz(i,j,k),gzz(i,j,k), & - kappa1,kappa2, & - trK(i,j,k), & - Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & - chi_rhs(i,j,k), & - Gamx_rhs(i,j,k),gxx_rhs(i,j,k),gxy_rhs(i,j,k),gxz_rhs(i,j,k), & - Gamy_rhs(i,j,k),gyy_rhs(i,j,k),gyz_rhs(i,j,k), & - Gamz_rhs(i,j,k),gzz_rhs(i,j,k),trK_rhs(i,j,k),TZ_rhs(i,j,k),TZ(i,j,k)) - enddo - enddo - enddo - -!!!!!gauge variable part - Lap_rhs = -TWO*alpn1*trK -#if (GAUGE == 0) - betax_rhs = FF*dtSfx - betay_rhs = FF*dtSfy - betaz_rhs = FF*dtSfz - - dtSfx_rhs = Gamx_rhs - eta*dtSfx - dtSfy_rhs = Gamy_rhs - eta*dtSfy - dtSfz_rhs = Gamz_rhs - eta*dtSfz -#elif (GAUGE == 1) - betax_rhs = Gamx - eta*betax - betay_rhs = Gamy - eta*betay - betaz_rhs = Gamz - eta*betaz - - dtSfx_rhs = ZEO - dtSfy_rhs = ZEO - dtSfz_rhs = ZEO -#endif - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -!!!!!!!!!advection term part -!g_ij - gxx_rhs = gxx_rhs + (betax*gxxx+betay*gxxy+betaz*gxxz) - gxy_rhs = gxy_rhs + (betax*gxyx+betay*gxyy+betaz*gxyz) - gxz_rhs = gxz_rhs + (betax*gxzx+betay*gxzy+betaz*gxzz) - gyy_rhs = gyy_rhs + (betax*gyyx+betay*gyyy+betaz*gyyz) - gyz_rhs = gyz_rhs + (betax*gyzx+betay*gyzy+betaz*gyzz) - gzz_rhs = gzz_rhs + (betax*gzzx+betay*gzzy+betaz*gzzz) -!A_ij - Axx_rhs = Axx_rhs + (betax*Axxx+betay*Axxy+betaz*Axxz) - Axy_rhs = Axy_rhs + (betax*Axyx+betay*Axyy+betaz*Axyz) - Axz_rhs = Axz_rhs + (betax*Axzx+betay*Axzy+betaz*Axzz) - Ayy_rhs = Ayy_rhs + (betax*Ayyx+betay*Ayyy+betaz*Ayyz) - Ayz_rhs = Ayz_rhs + (betax*Ayzx+betay*Ayzy+betaz*Ayzz) - Azz_rhs = Azz_rhs + (betax*Azzx+betay*Azzy+betaz*Azzz) -!chi and trK - chi_rhs = chi_rhs + (betax*chix+betay*chiy+betaz*chiz) - trK_rhs = trK_rhs + (betax*Kx+betay*Ky+betaz*Kz) -!Gam^i - Gamx_rhs = Gamx_rhs + (betax*Gamxx+betay*Gamxy+betaz*Gamxz) - Gamy_rhs = Gamy_rhs + (betax*Gamyx+betay*Gamyy+betaz*Gamyz) - Gamz_rhs = Gamz_rhs + (betax*Gamzx+betay*Gamzy+betaz*Gamzz) -!Z4c variables - TZ_rhs = TZ_rhs + (betax*TZx+betay*TZy+betaz*TZz) -!!!!!gauge variables - Lap_rhs = Lap_rhs + (betax*Lapx+betay*Lapy+betaz*Lapz) - - betax_rhs = betax_rhs + (betax*betaxx+betay*betaxy+betaz*betaxz) - betay_rhs = betay_rhs + (betax*betayx+betay*betayy+betaz*betayz) - betaz_rhs = betaz_rhs + (betax*betazx+betay*betazy+betaz*betazz) -#if (GAUGE == 0) - dtSfx_rhs = dtSfx_rhs + (betax*dtSfxx+betay*dtSfxy+betaz*dtSfxz) - dtSfy_rhs = dtSfy_rhs + (betax*dtSfyx+betay*dtSfyy+betaz*dtSfyz) - dtSfz_rhs = dtSfz_rhs + (betax*dtSfzx+betay*dtSfzy+betaz*dtSfzz) -#endif - -! numerical dissipation part - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) -#if (GAUGE == 0) - call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) -#endif - - call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) - endif - -#if (ABV == 1) - call ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi, & - dxx , gxy , gxz , dyy , gyz , dzz,& - Gamx , Gamy , Gamz , & - Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& - Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& - Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& - Symmetry,Lev,sst) - call constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz,& - Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& - Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & - Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & - Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & - Symmetry,Lev,sst) -#endif - - gont = 0 - - return - - end function compute_rhs_Z4c_ss -#endif + + +#include "macrodef.fh" + +#if 1 + function compute_rhs_z4c_ss(ex, T,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + TZ_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & +! co is not used here, we always compute constraint + Symmetry,Lev,eps,sst,co) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co + real*8, intent(in ):: T + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! when out, constraint violation + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: trKd + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,div_beta,S + real*8, dimension(ex(1),ex(2),ex(3)) :: f,fxx,fxy,fxz,fyy,fyz,fzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxa,Gamya,Gamza + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX, dY, dZ, PI + real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + +! constraint damping terms stuffs PRD 81, 084003 (2010) + real*8 :: kappa1,kappa2,kappa3,FF,eta + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & + +sum(TZ) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs_ss.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs_ss.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs_ss.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs_ss.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs_ss.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs_ss.f90: find NaN in betaz" + if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfx" + if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfy" + if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfz" + if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs_ss.f90: find NaN in TZ" + gont = 1 + return + endif + + PI = dacos(-ONE) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + trKd = trK+TWO*TZ +! advection term will all be replaced by center difference +!this beta^i_,j will be kept till the end of this routine + call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + div_beta = betaxx + betayy + betazz + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + chi_rhs = F2o3 *chin1*( alpn1 * trKd - div_beta ) !rhs for chi + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + gxx_rhs = - TWO * alpn1 * Axx - F2o3 * gxx * div_beta + & + TWO *( gxx * betaxx + gxy * betayx + gxz * betazx) + + gyy_rhs = - TWO * alpn1 * Ayy - F2o3 * gyy * div_beta + & + TWO *( gxy * betaxy + gyy * betayy + gyz * betazy) + + gzz_rhs = - TWO * alpn1 * Azz - F2o3 * gzz * div_beta + & + TWO *( gxz * betaxz + gyz * betayz + gzz * betazz) + + gxy_rhs = - TWO * alpn1 * Axy + F1o3 * gxy * div_beta + & + gxx * betaxy + gxz * betazy + & + gyy * betayx + gyz * betazx & + - gxy * betazz + + gyz_rhs = - TWO * alpn1 * Ayz + F1o3 * gyz * div_beta + & + gxy * betaxz + gyy * betayz + & + gxz * betaxy + gzz * betazy & + - gyz * betaxx + + gxz_rhs = - TWO * alpn1 * Axz + F1o3 * gxz * div_beta + & + gxx * betaxz + gxy * betayz + & + gyz * betayx + gzz * betazx & + - gxz * betayy !rhs for gij + +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz +! gij_,kl will be stored till end of this routine + call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) +! second kind of connection + Gamxxx =HALF*( gupxx*gxxx + gupxy*(TWO*gxyx - gxxy ) + gupxz*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy*gxxx + gupyy*(TWO*gxyx - gxxy ) + gupyz*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz*gxxx + gupyz*(TWO*gxyx - gxxy ) + gupzz*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx*(TWO*gxyy - gyyx ) + gupxy*gyyy + gupxz*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy*(TWO*gxyy - gyyx ) + gupyy*gyyy + gupyz*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz*(TWO*gxyy - gyyx ) + gupyz*gyyy + gupzz*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx*(TWO*gxzz - gzzx ) + gupxy*(TWO*gyzz - gzzy ) + gupxz*gzzz) + Gamyzz =HALF*( gupxy*(TWO*gxzz - gzzx ) + gupyy*(TWO*gyzz - gzzy ) + gupyz*gzzz) + Gamzzz =HALF*( gupxz*(TWO*gxzz - gzzx ) + gupyz*(TWO*gyzz - gzzy ) + gupzz*gzzz) + + Gamxxy =HALF*( gupxx*gxxy + gupxy*gyyx + gupxz*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy*gxxy + gupyy*gyyx + gupyz*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz*gxxy + gupyz*gyyx + gupzz*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx*gxxz + gupxy*( gxyz + gyzx - gxzy ) + gupxz*gzzx ) + Gamyxz =HALF*( gupxy*gxxz + gupyy*( gxyz + gyzx - gxzy ) + gupyz*gzzx ) + Gamzxz =HALF*( gupxz*gxxz + gupyz*( gxyz + gyzx - gxzy ) + gupzz*gzzx ) + + Gamxyz =HALF*( gupxx*( gxyz + gxzy - gyzx ) + gupxy*gyyz + gupxz*gzzy ) + Gamyyz =HALF*( gupxy*( gxyz + gxzy - gyzx ) + gupyy*gyyz + gupyz*gzzy ) + Gamzyz =HALF*( gupxz*( gxyz + gxzy - gyzx ) + gupyz*gyyz + gupzz*gzzy ) +! the so called Gamma_d + Gamxa = gupxx * Gamxxx + gupyy * Gamxyy + gupzz * Gamxzz + & + TWO*( gupxy * Gamxxy + gupxz * Gamxxz + gupyz * Gamxyz ) + Gamya = gupxx * Gamyxx + gupyy * Gamyyy + gupzz * Gamyzz + & + TWO*( gupxy * Gamyxy + gupxz * Gamyxz + gupyz * Gamyyz ) + Gamza = gupxx * Gamzxx + gupyy * Gamzyy + gupzz * Gamzzz + & + TWO*( gupxy * Gamzxy + gupxz * Gamzxz + gupyz * Gamzyz ) + +!!!!!!!!!!!!because gij_,k will be overwrite later, we calculate TWO*d_k Z^k here +! use Gamma^i as more as possible + Gmxcon = Gamx - Gamxa + Gmycon = Gamy - Gamya + Gmzcon = Gamz - Gamza + +!Maple generated code for g^ki*g^jm*g^ln*g_mn,k*g_ij,l +! Gami_,j are used as maple temp variables + Gamyy = 3*gupxz**2*gupzz*gxzz**2+gupxx*gupxz**2*gxxz**2+2*gxyx*gupxy**3*gxyy+ & + 2*gxyx*gupxy**3*gyyx+gupxx**2*gupzz*gxzx**2+3*gupxx*gupxy**2*gxyx**2+ & + 6*gxyx*gupxy*gupxz*gupyy*gyzy+gupxx**2*gupyy*gxyx**2+ & + 2*gxyz*gupxy*gupyz**2*gyyz+2*gxxz*gupxx**2*gupyz*gxyx+ & + gupxz**2*gupyy*gyzx**2+2*gxxy*gupxx*gupxy*gupxz*gxxz+ & + 2*gyzx*gupxy*gupxz*gupzz*gzzx+3*gupyy*gupyz**2*gyzy**2+ & + 2*gyyy*gupyz**3*gzzz+2*gxxz*gupxz**3*gxzz+ & + 4*gxzy*gupxx*gupxz*gupyy*gxyx+gupyy*gupyz**2*gyyz**2 + Gamxz = Gamyy+2*gxxz*gupxy**2*gupzz*gyzy+4*gxyz*gupxx*gupxy*gupxz*gxxx+ & + 6*gxzz*gupxy*gupyz*gupzz*gyzy+2*gxxy*gupxx*gupxz*gupyz*gxzz+ & + 3*gupxy**2*gupyy*gxyy**2+2*gxyz*gupxx*gupyy*gupzz*gyzx+ & + 4*gxyy*gupxx*gupyy*gupyz*gyzx+6*gxyy*gupxy*gupxz*gupyz*gxzz+ & + 4*gxzz*gupxx*gupyz*gupzz*gyzx+3*gupxx*gupxz**2*gxzx**2+ & + 4*gxyz*gupxx*gupxy*gupyz*gxyx+2*gxxz*gupxx*gupxz*gupyz*gxyz+ & + 2*gxxy*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz*gupyz*gyyz+ & + gupyz**2*gupzz*gzzy**2+gupxz**2*gupzz*gzzx**2+ & + gupyy*gupzz**2*gyzz**2+2*gyzy*gupyz**3*gzzy+gupxx*gupzz**2*gxzz**2 + Gamyy = Gamxz+gupxx*gupyz**2*gxzy**2+2*gxzx*gupxz**3*gzzx+ & + 3*gupyz**2*gupzz*gyzz**2+2*gyzy*gupyz**3*gyzz+gupyy**2*gupzz*gyzy**2+ & + gupxy**2*gupzz*gyzx**2+2*gyyz*gupyz**3*gyzz+gupxy**2*gupyy*gyyx**2+ & + gupxx*gupyz**2*gxyz**2+gupxx*gupyy**2*gxyy**2+ & + gupxy**2*gupzz*gxzy**2+2*gxzx*gupxz**3*gxzz+ & + 2*gyyx*gupxy*gupxz*gupyy*gyzx+gupxx*gupxy**2*gxxy**2+ & + 2*gxxx*gupxz**3*gzzz+2*gxxx*gupxy**3*gyyy+gupxz**2*gupyy*gxyz**2+ & + 2*gxyy*gupxy**3*gxxy + Gamxy = Gamyy+2*gxyy*gupxz*gupyy**2*gyzy+6*gxyy*gupxx*gupxy*gupyz*gxzx+ & + 4*gxyy*gupxy*gupxz*gupyy*gxyz+2*gyzx*gupxz*gupyy*gupzz*gzzy+ & + 2*gxzy*gupxy*gupxz*gupyy*gxyy+4*gxzy*gupxy*gupxz*gupzz*gxzz+ & + 2*gyyx*gupxz*gupyy*gupyz*gyzz+6*gxyx*gupxx*gupxz*gupyz*gxzz+ & + 2*gxyz*gupxy**2*gupzz*gxzy+2*gxyz*gupxy**2*gupyz*gxyy+ & + 2*gxyz*gupxy**2*gupxz*gxxy+2*gupxy*gupxz*gupyz*gxyz**2+ & + 4*gxyy*gupxz*gupyz**2*gzzz+2*gxyy*gupxy*gupyz**2*gzzy+ & + 4*gxyy*gupxy**2*gupyz*gxzy+2*gxyy*gupxy**2*gupxz*gxxz+ & + 4*gxyy*gupxx*gupxy**2*gxxx+2*gxyx*gupxy**2*gupxz*gxzy+ & + 2*gxyx*gupxy**2*gupyz*gyzy + Gamyy = Gamxy+2*gxyx*gupxx*gupxy**2*gxxy+4*gyzz*gupyz*gupzz**2*gzzz+ & + 4*gxzy*gupxx*gupxz*gupyz*gxzx+2*gxzy*gupxx*gupyy*gupzz*gyzx+ & + 4*gxxx*gupxx*gupxy*gupxz*gyzx+2*gxyx*gupxx**2*gupyz*gxzx+ & + 2*gxyx*gupxy**2*gupxz*gxyz+2*gxzy*gupxz*gupyy*gupyz*gyyz+ & + 4*gxzy*gupxy*gupyy*gupyz*gyyy+2*gxzy*gupxx*gupyy*gupyz*gyyx+ & + 2*gyyx*gupxy*gupxz*gupyy*gxzy+2*gyyx*gupxy*gupyy*gupyz*gyyz+ & + 2*gyyx*gupxy*gupyy*gupyz*gyzy+4*gxzy*gupxz*gupyy*gupzz*gyzz+ & + 2*gyyx*gupxy*gupxz*gupyz*gxzz+2*gxyz*gupxx*gupyy*gupzz*gxzy+ & + 2*gxyy*gupxz*gupyy*gupyz*gzzy + Gamxz = Gamyy+2*gxyy*gupxy*gupxz*gupyz*gzzx+2*gxyy*gupxy*gupxz*gupyy*gyzx+ & + 2*gxyy*gupxy*gupyy*gupyz*gyyz+2*gxyy*gupxx*gupyy*gupyz*gxzy+ & + 2*gxxy*gupxy**2*gupxz*gxzy+2*gxxy*gupxy**2*gupyz*gyzy+ & + 2*gxxy*gupxy**2*gupyy*gyyy+2*gxxy*gupxx**2*gupyz*gxzx+ & + 2*gxxy*gupxx**2*gupyy*gxyx+2*gxxx*gupxx*gupxz**2*gzzx+ & + 4*gxxx*gupxy*gupxz**2*gyzz+4*gxxx*gupxy**2*gupxz*gyzy+ & + 2*gxxx*gupxx*gupxy**2*gyyx+4*gxxx*gupxx*gupxz**2*gxzz+ & + 4*gxxx*gupxx**2*gupxz*gxzx+2*gxxx*gupxx**2*gupxz*gxxz+ & + 4*gxyz*gupxz*gupyz**2*gyzz+2*gxyz*gupxy*gupyz**2*gyzy+ & + 2*gxzy*gupxy*gupyy*gupzz*gyzy + Gamyy = Gamxz+2*gxyy*gupxx*gupyy*gupyz*gxyz+6*gxzz*gupxz*gupyz*gupzz*gyzz+ & + 4*gxzy*gupxz*gupyz*gupzz*gzzz+gupyy**3*gyyy**2+ & + 2*gxzy*gupxy*gupyz*gupzz*gzzy+2*gxzy*gupxx*gupyz*gupzz*gzzx+ & + 2*gxyz*gupxx*gupyz*gupzz*gxzz+2*gxzy*gupxx*gupyz*gupzz*gxzz+ & + 2*gyzy*gupxy*gupyz*gupzz*gzzx+2*gyzy*gupxz*gupyy*gupyz*gxzy+ & + 6*gyzy*gupyy*gupyz*gupzz*gyzz+4*gyzx*gupxz*gupyy*gupyz*gyzy+ & + 4*gyzx*gupxy*gupyz*gupzz*gyzz+2*gxxy*gupxx*gupxy*gupyy*gxyy+ & + 4*gyzx*gupxz*gupyz*gupzz*gzzz+2*gyzx*gupxy*gupyy*gupzz*gyzy+ & + 2*gyyz*gupyy*gupyz*gupzz*gzzy+2*gyyz*gupxy*gupyz*gupzz*gzzx + Gamxx = Gamyy+2*gyyz*gupyy*gupyz*gupzz*gyzz+2*gyyz*gupxy*gupyy*gupzz*gyzx+ & + 2*gyyz*gupxy*gupyz*gupzz*gxzz+2*gxxy*gupxx*gupxy*gupyz*gyzx+ & + 4*gyyy*gupxy*gupyy*gupyz*gyzx+2*gyyx*gupxy*gupxz*gupyz*gzzx+ & + 2*gxyz*gupxy*gupyz*gupzz*gyzz+2*gxxz*gupxz**2*gupzz*gzzz+ & + 2*gxxz*gupxz**2*gupyz*gyzz+2*gxxz*gupxy*gupxz**2*gxzy+ & + 2*gxxz*gupxx*gupxz**2*gxzx+2*gxxz*gupxy**2*gupyz*gyyy+ & + 2*gxxz*gupxx**2*gupzz*gxzx+2*gxxy*gupxz**2*gupyz*gzzz+ & + 2*gxxy*gupxz**2*gupyy*gyzz+2*gxxy*gupxy*gupxz**2*gxzz+ & + 2*gzzx*gupxz*gupyz*gupzz*gzzy+2*gyzz*gupxz*gupyz*gupzz*gzzx+ & + 2*gxzx*gupxx*gupxz*gupzz*gzzx+2*gyzx*gupxz*gupyy*gupzz*gyzz + Gamyy = Gamxx+gupzz**3*gzzz**2+2*gxzz*gupxy*gupxz*gupzz*gyzx+ & + 6*gxzx*gupxy*gupxz*gupyz*gyzy+2*gxxy*gupxy*gupxz*gupyz*gzzy+ & + 4*gxzz*gupxy*gupyz**2*gyyy+2*gxzy*gupxz*gupyz**2*gyzz+ & + 2*gxzy*gupxz**2*gupyz*gxzz+2*gxzy*gupxz**2*gupyy*gxyz+ & + 2*gupxy*gupxz*gupyz*gxzy**2+4*gxzx*gupxz**2*gupzz*gzzz+ & + 2*gxzx*gupxz**2*gupyz*gyzz+2*gxyz*gupxy*gupxz*gupzz*gzzx+ & + 2*gxyz*gupxz*gupyy*gupzz*gzzy+2*gxyx*gupxx*gupxz*gupyy*gxyz+ & + 2*gxzz*gupxz*gupyz**2*gyyz+2*gxxy*gupxx*gupxy*gupxz*gxzx+ & + 2*gyyx*gupxy**2*gupxz*gxzx + Gamxz = Gamyy+2*gxyx*gupxy*gupxz*gupyz*gzzy+2*gyzy*gupyy*gupyz*gupzz*gzzy+ & + 2*gxyx*gupxx*gupxz*gupyy*gyzx+2*gyyx*gupxy*gupyz**2*gyzz+ & + 2*gyyx*gupxy**2*gupyz*gyzx+2*gyyx*gupxz*gupyz**2*gzzz+ & + 2*gyyx*gupxy*gupyy**2*gyyy+2*gxyz*gupxy**2*gupzz*gyzx+ & + 2*gxyz*gupxy**2*gupyz*gyyx+2*gxyy*gupxy*gupyz**2*gyzz+ & + 2*gxyy*gupxy**2*gupyz*gyzx+2*gxyy*gupxy**2*gupyy*gyyx+ & + 2*gxyx*gupxy*gupxz**2*gzzx+2*gxyx*gupxy**2*gupyz*gyyz+ & + 4*gxzz*gupxz*gupzz**2*gzzz+2*gxzz*gupxy*gupzz**2*gzzy+ & + 2*gxzz*gupxx*gupzz**2*gzzx+6*gxyx*gupxx*gupxy*gupxz*gxzx+ & + 2*gxyz*gupxy*gupxz*gupyz*gyzx + Gamyy = Gamxz+2*gyyx*gupxz*gupyy**2*gyzy+2*gyyx*gupxz*gupyy*gupyz*gzzy+ & + 2*gxxz*gupxx*gupxy*gupyz*gxyy+2*gyzx*gupxz**2*gupyy*gxzy+ & + 4*gyzx*gupxy*gupxz**2*gxzx+2*gyzx*gupxz*gupyz**2*gyzz+ & + 2*gyzx*gupxz**2*gupyz*gxzz+2*gupxy*gupxz*gupyz*gyzx**2+ & + 2*gyyz*gupyz**2*gupzz*gzzz+2*gyyz*gupyy*gupyz**2*gyzy+ & + 2*gyyz*gupxy*gupyz**2*gyzx+2*gyyz*gupyy**2*gupzz*gyzy+ & + 2*gyyz*gupxy**2*gupzz*gxzx+2*gyyy*gupyy*gupyz**2*gzzy+ & + 2*gyyy*gupxy*gupyz**2*gzzx+4*gyyy*gupyy*gupyz**2*gyzz+ & + 4*gyyy*gupyy**2*gupyz*gyzy+2*gyyy*gupyy**2*gupyz*gyyz + Gamxy = Gamyy+2*gxyz*gupxz*gupyy*gupyz*gyzy+2*gxyz*gupxx*gupyy*gupyz*gyyx+ & + 2*gzzx*gupxz*gupzz**2*gzzz+2*gxzy*gupxy*gupxz*gupyz*gyzx+ & + 2*gyzz*gupyz**2*gupzz*gzzy+2*gyzy*gupxz*gupyz**2*gzzx+ & + 2*gyzx*gupxz*gupyz**2*gzzy+2*gyzx*gupxz**2*gupyz*gzzx+ & + 2*gxzz*gupxz**2*gupzz*gzzx+2*gxzz*gupxy*gupzz**2*gyzz+ & + 2*gxzy*gupxz*gupyz**2*gzzy+2*gxzy*gupxz**2*gupyz*gzzx+ & + 2*gxzx*gupxz**2*gupyz*gzzy+2*gyzz*gupyy*gupzz**2*gzzy+ & + 2*gyzz*gupxy*gupzz**2*gzzx+4*gyzy*gupyz**2*gupzz*gzzz+ & + 2*gyzy*gupxy*gupyz**2*gyzx+2*gyzy*gupxz*gupyz**2*gxzz+ & + 2*gxzy*gupxy*gupyz*gupzz*gyzz+2*gxyx*gupxx*gupxy*gupyz*gxzy + Gamyy = Gamxy+gupxx**3*gxxx**2+2*gzzy*gupyz*gupzz**2*gzzz+ & + 6*gxyx*gupxx*gupxy*gupyy*gxyy+2*gxzz*gupxz*gupyz* gupzz*gzzy+ & + 6*gxyx*gupxy*gupxz*gupyz*gyzz+2*gxzx*gupxy*gupxz**2*gxzy+ & + 2*gxyx*gupxx*gupxy*gupyy*gyyx+2*gxyx*gupxx*gupxz*gupyz*gzzx+ & + 2*gxyx*gupxx*gupxy*gupxz*gxxz+4*gxyx*gupxx**2*gupxy*gxxx+ & + 2*gxyx*gupxy*gupxz*gupyy*gyyz+6*gxyy*gupxy*gupyy*gupyz*gyzy+ & + 2*gxyx*gupxx*gupxy*gupyz*gyzx+6*gxyy*gupxz*gupyy*gupyz*gyzz+ & + 4*gxyz*gupxx*gupxy*gupzz*gxzx+2*gxyz*gupxy*gupxz*gupzz*gxzz+ & + 4*gxyx*gupxy**2*gupyy*gyyy+2*gxyz*gupxz*gupyy*gupyz*gyyz + Gamxz = Gamyy+4*gxyz*gupxy*gupyy*gupyz*gyyy+2*gxyx*gupxz**2*gupyy*gyzz+ & + 2*gxyz*gupxz*gupyy*gupzz*gyzz+2*gxyx*gupxy*gupxz**2*gxzz+ & + 4*gxyz*gupxy*gupyy*gupzz*gyzy+2*gxzx*gupxy**2*gupzz*gyzy+ & + 2*gxyz*gupxx*gupxz*gupyz*gxzx+4*gxyx*gupxz**2*gupyz*gzzz+ & + 4*gxzx*gupxy**2*gupyz*gyyy+2*gyyz*gupxy*gupyy*gupzz*gxzy+ & + 2*gxyz*gupxy*gupxz*gupyz*gxzy+2*gxyz*gupxx*gupyz*gupzz*gzzx+ & + 4*gxyy*gupxy*gupyy**2*gyyy+2*gxyy*gupxx*gupyy**2*gyyx+ & + 2*gxyy*gupxx*gupyz**2*gzzx+2*gxyz*gupxy*gupyz*gupzz*gzzy+ & + 2*gxyy*gupxz*gupyy**2*gyyz+4*gxyz*gupxz*gupyz*gupzz*gzzz+ & + 2*gxxy*gupxx*gupxz*gupyy*gxyz + Gamyy = Gamxz+2*gxzx*gupxy*gupxz**2*gxyz+2*gxxy*gupxy*gupxz*gupyy*gyzy+ & + 4*gxxx*gupxx*gupxy*gupxz*gxzy+2*gxxy*gupxy*gupxz*gupyy*gyyz+ & + 2*gxxy*gupxx*gupxz*gupyy*gyzx+2*gxxy*gupxx*gupxz*gupyz*gzzx+ & + 2*gxzx*gupxy**2*gupxz*gxyy+2*gxxy*gupxx*gupxy*gupyz*gxzy+ & + 2*gxyz*gupxy*gupxz**2*gxxz+2*gxxy*gupxx*gupxy*gupyy*gyyx+ & + 2*gxyz*gupxx*gupyz**2*gyzx+4*gxyz*gupxz**2*gupyz*gxzz+ & + 2*gxxz*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxx*gupxz*gupzz*gxzz+ & + 2*gxxx*gupxx**2*gupxy*gxxy+2*gxxz*gupxx*gupxy*gupyz*gyyx+ & + 2*gxxz*gupxy*gupxz*gupzz*gyzz+2*gxxz*gupxx*gupxy*gupzz*gyzx + TZ_rhs = Gamyy+2*gxxz*gupxy*gupxz*gupyz*gyyz+2*gxxz*gupxx*gupxz*gupyz*gyzx+ & + 2*gxxz*gupxx*gupxz*gupzz*gzzx+2*gxxz*gupxy*gupxz*gupyz*gyzy+ & + 2*gxzx*gupxx*gupxy*gupzz*gxzy+2*gxxz*gupxy*gupxz*gupzz*gzzy+ & + 6*gxzx*gupxy*gupxz*gupzz*gyzz+2*gxzx*gupxx*gupxy*gupzz*gyzx+ & + 2*gxzx*gupxx*gupxy*gupyz*gyyx+6*gxzx*gupxx*gupxz*gupzz*gxzz+ & + 2*gxxx*gupxy**2*gupxz*gyyz+2*gxzx*gupxy*gupxz*gupzz*gzzy+ & + 2*gxzx*gupxx*gupxz*gupyz*gyzx+2*gxxx*gupxy*gupxz**2*gzzy+ & + 4*gxzy*gupxy*gupyz**2*gyzy+2*gxzy*gupxx*gupyz**2*gyzx+ & + 2*gxzz*gupxx*gupyz**2*gyyx+4*gxyx*gupxy**2*gupxz*gyzx+ & + 2*gxyx*gupxz**2*gupyy*gzzy+2*gxyy*gupxx*gupyz**2*gxzz + +! Gami_,j will be kept till the end of this routine + call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + TZ_rhs = chix*Gmxcon+chiy*Gmycon+chiz*Gmzcon & + +chin1*(Gamxx+Gamyy+Gamzz - & + (TWO*(gupxz*gupyz*gyzxz+gupxx*gupyy*gxyxy+gupxy*gupyz*gxzyy+ & + gupxx*gupxy*gxxxy+gupxx*gupxz*gxxxz+gupxx*gupxy*gxyxx+ & + gupxx*gupyz*gxyxz+gupxx*gupxz*gxzxx+gupxx*gupyz*gxzxy+ & + gupxx*gupzz*gxzxz+gupxy*gupxz*gxxyz+gupxy*gupyy*gxyyy+ & + gupxy*gupyz*gxyyz+gupxy*gupxz*gxzxy+gupxy*gupzz*gxzyz+ & + gupxy*gupxz*gxyxz+gupxz*gupyy*gxyyz+gupxz*gupyz*gxyzz+ & + gupxz*gupyz*gxzyz+gupxz*gupzz*gxzzz+gupxy*gupyy*gyyxy+ & + gupxy*gupyz*gyyxz+gupxy*gupxz*gyzxx+gupxy*gupyz*gyzxy+ & + gupxy*gupzz*gyzxz+gupyy*gupyz*gyyyz+gupxz*gupyy*gyzxy+ & + gupyy*gupyz*gyzyy+gupyy*gupzz*gyzyz+gupyz*gupzz*gyzzz+ & + gupxz*gupyz*gzzxy+gupxz*gupzz*gzzxz+gupyz*gupzz*gzzyz+ & + gupxy*gupxy*gxyxy+gupxz*gupxz*gxzxz+gupyz*gupyz*gyzyz) & + +gupxx*gupxx*gxxxx+gupxy*gupxy*gxxyy+gupxz*gupxz*gxxzz+ & + gupxy*gupxy*gyyxx+gupyy*gupyy*gyyyy+gupyz*gupyz*gyyzz+ & + gupxz*gupxz*gzzxx+gupyz*gupyz*gzzyy+gupzz*gupzz*gzzzz)+& + (gxx*Gamxa*Gamxa+gyy*Gamya*Gamya+gzz*Gamza*Gamza +& + TWO*(gxy*Gamxa*Gamya+gxz*Gamxa*Gamza+gyz*Gamya*Gamza)) + TZ_rhs) + +! Raise indices of \tilde A_{ij} and store in R_ij + + Rxx = gupxx * gupxx * Axx + gupxy * gupxy * Ayy + gupxz * gupxz * Azz + & + TWO*(gupxx * gupxy * Axy + gupxx * gupxz * Axz + gupxy * gupxz * Ayz) + + Ryy = gupxy * gupxy * Axx + gupyy * gupyy * Ayy + gupyz * gupyz * Azz + & + TWO*(gupxy * gupyy * Axy + gupxy * gupyz * Axz + gupyy * gupyz * Ayz) + + Rzz = gupxz * gupxz * Axx + gupyz * gupyz * Ayy + gupzz * gupzz * Azz + & + TWO*(gupxz * gupyz * Axy + gupxz * gupzz * Axz + gupyz * gupzz * Ayz) + + Rxy = gupxx * gupxy * Axx + gupxy * gupyy * Ayy + gupxz * gupyz * Azz + & + (gupxx * gupyy + gupxy * gupxy)* Axy + & + (gupxx * gupyz + gupxz * gupxy)* Axz + & + (gupxy * gupyz + gupxz * gupyy)* Ayz + + Rxz = gupxx * gupxz * Axx + gupxy * gupyz * Ayy + gupxz * gupzz * Azz + & + (gupxx * gupyz + gupxy * gupxz)* Axy + & + (gupxx * gupzz + gupxz * gupxz)* Axz + & + (gupxy * gupzz + gupxz * gupyz)* Ayz + + Ryz = gupxy * gupxz * Axx + gupyy * gupyz * Ayy + gupyz * gupzz * Azz + & + (gupxy * gupyz + gupyy * gupxz)* Axy + & + (gupxy * gupzz + gupyz * gupxz)* Axz + & + (gupyy * gupzz + gupyz * gupyz)* Ayz + +! Right hand side for Gam^i without shift terms... +! Lap_,i will be kept till the end of this routine + call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +! K_,i stored K_,i+TZ_,i/2 indeed, will be kept till the end of this routine + call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,TZ,fxx,fxy,fxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + Kx = Kx + fxx/TWO + Ky = Ky + fxy/TWO + Kz = Kz + fxz/TWO + + Gamx_rhs = - TWO * ( Lapx * Rxx + Lapy * Rxy + Lapz * Rxz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxx + chiy * Rxy + chiz * Rxz ) - & + gupxx * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupxy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupxz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamxxx * Rxx + Gamxyy * Ryy + Gamxzz * Rzz + & + TWO * ( Gamxxy * Rxy + Gamxxz * Rxz + Gamxyz * Ryz ) ) + + Gamy_rhs = - TWO * ( Lapx * Rxy + Lapy * Ryy + Lapz * Ryz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxy + chiy * Ryy + chiz * Ryz ) - & + gupxy * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyy * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupyz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamyxx * Rxx + Gamyyy * Ryy + Gamyzz * Rzz + & + TWO * ( Gamyxy * Rxy + Gamyxz * Rxz + Gamyyz * Ryz ) ) + + Gamz_rhs = - TWO * ( Lapx * Rxz + Lapy * Ryz + Lapz * Rzz ) + & + TWO * alpn1 * ( & + -F3o2/chin1 * ( chix * Rxz + chiy * Ryz + chiz * Rzz ) - & + gupxz * ( F2o3 * Kx + EIGHT * PI * Sx ) - & + gupyz * ( F2o3 * Ky + EIGHT * PI * Sy ) - & + gupzz * ( F2o3 * Kz + EIGHT * PI * Sz ) + & + Gamzxx * Rxx + Gamzyy * Ryy + Gamzzz * Rzz + & + TWO * ( Gamzxy * Rxy + Gamzxz * Rxz + Gamzyz * Ryz ) ) + + call fdderivs_shc(ex,betax,gxxx,gxyx,gxzx,gyyx,gyzx,gzzx,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betay,gxxy,gxyy,gxzy,gyyy,gyzy,gzzy,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betaz,gxxz,gxyz,gxzz,gyyz,gyzz,gzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = gxxx + gxyy + gxzz + fxy = gxyx + gyyy + gyzz + fxz = gxzx + gyzy + gzzz + + Gamx_rhs = Gamx_rhs + F2o3 * Gamxa * div_beta - & + Gamxa * betaxx - Gamya * betaxy - Gamza * betaxz + & + F1o3 * (gupxx * fxx + gupxy * fxy + gupxz * fxz ) + & + gupxx * gxxx + gupyy * gyyx + gupzz * gzzx + & + TWO * (gupxy * gxyx + gupxz * gxzx + gupyz * gyzx ) + + Gamy_rhs = Gamy_rhs + F2o3 * Gamya * div_beta - & + Gamxa * betayx - Gamya * betayy - Gamza * betayz + & + F1o3 * (gupxy * fxx + gupyy * fxy + gupyz * fxz ) + & + gupxx * gxxy + gupyy * gyyy + gupzz * gzzy + & + TWO * (gupxy * gxyy + gupxz * gxzy + gupyz * gyzy ) + + Gamz_rhs = Gamz_rhs + F2o3 * Gamza * div_beta - & + Gamxa * betazx - Gamya * betazy - Gamza * betazz + & + F1o3 * (gupxz * fxx + gupyz * fxy + gupzz * fxz ) + & + gupxx * gxxz + gupyy * gyyz + gupzz * gzzz + & + TWO * (gupxy * gxyz + gupxz * gxzz + gupyz * gyzz ) !rhs for Gam^i + +!first kind of connection stored in gij,k + gxxx = gxx * Gamxxx + gxy * Gamyxx + gxz * Gamzxx + gxyx = gxx * Gamxxy + gxy * Gamyxy + gxz * Gamzxy + gxzx = gxx * Gamxxz + gxy * Gamyxz + gxz * Gamzxz + gyyx = gxx * Gamxyy + gxy * Gamyyy + gxz * Gamzyy + gyzx = gxx * Gamxyz + gxy * Gamyyz + gxz * Gamzyz + gzzx = gxx * Gamxzz + gxy * Gamyzz + gxz * Gamzzz + + gxxy = gxy * Gamxxx + gyy * Gamyxx + gyz * Gamzxx + gxyy = gxy * Gamxxy + gyy * Gamyxy + gyz * Gamzxy + gxzy = gxy * Gamxxz + gyy * Gamyxz + gyz * Gamzxz + gyyy = gxy * Gamxyy + gyy * Gamyyy + gyz * Gamzyy + gyzy = gxy * Gamxyz + gyy * Gamyyz + gyz * Gamzyz + gzzy = gxy * Gamxzz + gyy * Gamyzz + gyz * Gamzzz + + gxxz = gxz * Gamxxx + gyz * Gamyxx + gzz * Gamzxx + gxyz = gxz * Gamxxy + gyz * Gamyxy + gzz * Gamzxy + gxzz = gxz * Gamxxz + gyz * Gamyxz + gzz * Gamzxz + gyyz = gxz * Gamxyy + gyz * Gamyyy + gzz * Gamzyy + gyzz = gxz * Gamxyz + gyz * Gamyyz + gzz * Gamzyz + gzzz = gxz * Gamxzz + gyz * Gamyzz + gzz * Gamzzz + +!compute Ricci tensor for tilted metric + Rxx = gupxx * gxxxx + gupyy * gxxyy + gupzz * gxxzz + & + ( gupxy * gxxxy + gupxz * gxxxz + gupyz * gxxyz ) * TWO + + Ryy = gupxx * gyyxx + gupyy * gyyyy + gupzz * gyyzz + & + ( gupxy * gyyxy + gupxz * gyyxz + gupyz * gyyyz ) * TWO + + Rzz = gupxx * gzzxx + gupyy * gzzyy + gupzz * gzzzz + & + ( gupxy * gzzxy + gupxz * gzzxz + gupyz * gzzyz ) * TWO + + Rxy = gupxx * gxyxx + gupyy * gxyyy + gupzz * gxyzz + & + ( gupxy * gxyxy + gupxz * gxyxz + gupyz * gxyyz ) * TWO + + Rxz = gupxx * gxzxx + gupyy * gxzyy + gupzz * gxzzz + & + ( gupxy * gxzxy + gupxz * gxzxz + gupyz * gxzyz ) * TWO + + Ryz = gupxx * gyzxx + gupyy * gyzyy + gupzz * gyzzz + & + ( gupxy * gyzxy + gupxz * gyzxz + gupyz * gyzyz ) * TWO + + Rxx = - HALF * Rxx + & + gxx * Gamxx+ gxy * Gamyx + gxz * Gamzx + & + Gamxa * gxxx + Gamya * gxyx + Gamza * gxzx + & + gupxx *( & + TWO*(Gamxxx * gxxx + Gamyxx * gxyx + Gamzxx * gxzx) + & + Gamxxx * gxxx + Gamyxx * gxxy + Gamzxx * gxxz )+ & + gupxy *( & + TWO*(Gamxxx * gxyx + Gamyxx * gyyx + Gamzxx * gyzx + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx) + & + Gamxxy * gxxx + Gamyxy * gxxy + Gamzxy * gxxz + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxz *( & + TWO*(Gamxxx * gxzx + Gamyxx * gyzx + Gamzxx * gzzx + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx) + & + Gamxxz * gxxx + Gamyxz * gxxy + Gamzxz * gxxz + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupyy *( & + TWO*(Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupyz *( & + TWO*(Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx) + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupzz *( & + TWO*(Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz ) + + Ryy = - HALF * Ryy + & + gxy * Gamxy+ gyy * Gamyy + gyz * Gamzy + & + Gamxa * gxyy + Gamya * gyyy + Gamza * gyzy + & + gupxx *( & + TWO*(Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy) + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz )+ & + gupxy *( & + TWO*(Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxxy + Gamyyy * gxyy + Gamzyy * gxzy) + & + Gamxyy * gxyx + Gamyyy * gxyy + Gamzyy * gxyz + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupxz *( & + TWO*(Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy) + & + Gamxyz * gxyx + Gamyyz * gxyy + Gamzyz * gxyz + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyy *( & + TWO*(Gamxyy * gxyy + Gamyyy * gyyy + Gamzyy * gyzy) + & + Gamxyy * gyyx + Gamyyy * gyyy + Gamzyy * gyyz )+ & + gupyz *( & + TWO*(Gamxyy * gxzy + Gamyyy * gyzy + Gamzyy * gzzy + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy) + & + Gamxyz * gyyx + Gamyyz * gyyy + Gamzyz * gyyz + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupzz *( & + TWO*(Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz ) + + Rzz = - HALF * Rzz + & + gxz * Gamxz+ gyz * Gamyz + gzz * Gamzz + & + Gamxa * gxzz + Gamya * gyzz + Gamza * gzzz + & + gupxx *( & + TWO*(Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz) + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz )+ & + gupxy *( & + TWO*(Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz) + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz )+ & + gupxz *( & + TWO*(Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxxz + Gamyzz * gxyz + Gamzzz * gxzz) + & + Gamxzz * gxzx + Gamyzz * gxzy + Gamzzz * gxzz + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz )+ & + gupyy *( & + TWO*(Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz) + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz )+ & + gupyz *( & + TWO*(Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxyz + Gamyzz * gyyz + Gamzzz * gyzz) + & + Gamxzz * gyzx + Gamyzz * gyzy + Gamzzz * gyzz + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz )+ & + gupzz *( & + TWO*(Gamxzz * gxzz + Gamyzz * gyzz + Gamzzz * gzzz) + & + Gamxzz * gzzx + Gamyzz * gzzy + Gamzzz * gzzz ) + + Rxy = HALF*( - Rxy + & + gxx * Gamxy + gxy * Gamyy + gxz * Gamzy + & + gxy * Gamxx + gyy * Gamyx + gyz * Gamzx + & + Gamxa * gxyx + Gamya * gyyx + Gamza * gyzx + & + Gamxa * gxxy + Gamya * gxyy + Gamza * gxzy )+ & + gupxx *( & + Gamxxx * gxxy + Gamyxx * gxyy + Gamzxx * gxzy + & + Gamxxy * gxxx + Gamyxy * gxyx + Gamzxy * gxzx + & + Gamxxx * gxyx + Gamyxx * gxyy + Gamzxx * gxyz )+ & + gupxy *( & + Gamxxx * gxyy + Gamyxx * gyyy + Gamzxx * gyzy + & + Gamxxy * gxyx + Gamyxy * gyyx + Gamzxy * gyzx + & + Gamxxy * gxyx + Gamyxy * gxyy + Gamzxy * gxyz + & + Gamxxy * gxxy + Gamyxy * gxyy + Gamzxy * gxzy + & + Gamxyy * gxxx + Gamyyy * gxyx + Gamzyy * gxzx + & + Gamxxx * gyyx + Gamyxx * gyyy + Gamzxx * gyyz )+ & + gupxz *( & + Gamxxx * gxzy + Gamyxx * gyzy + Gamzxx * gzzy + & + Gamxxy * gxzx + Gamyxy * gyzx + Gamzxy * gzzx + & + Gamxxz * gxyx + Gamyxz * gxyy + Gamzxz * gxyz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupyy *( & + Gamxxy * gxyy + Gamyxy * gyyy + Gamzxy * gyzy + & + Gamxyy * gxyx + Gamyyy * gyyx + Gamzyy * gyzx + & + Gamxxy * gyyx + Gamyxy * gyyy + Gamzxy * gyyz )+ & + gupyz *( & + Gamxxy * gxzy + Gamyxy * gyzy + Gamzxy * gzzy + & + Gamxyy * gxzx + Gamyyy * gyzx + Gamzyy * gzzx + & + Gamxxz * gyyx + Gamyxz * gyyy + Gamzxz * gyyz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupzz *( & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz ) + + Rxz = HALF*( - Rxz + & + gxx * Gamxz + gxy * Gamyz + gxz * Gamzz + & + gxz * Gamxx + gyz * Gamyx + gzz * Gamzx + & + Gamxa * gxzx + Gamya * gyzx + Gamza * gzzx + & + Gamxa * gxxz + Gamya * gxyz + Gamza * gxzz )+ & + gupxx *( & + Gamxxx * gxxz + Gamyxx * gxyz + Gamzxx * gxzz + & + Gamxxz * gxxx + Gamyxz * gxyx + Gamzxz * gxzx + & + Gamxxx * gxzx + Gamyxx * gxzy + Gamzxx * gxzz )+ & + gupxy *( & + Gamxxx * gxyz + Gamyxx * gyyz + Gamzxx * gyzz + & + Gamxxz * gxyx + Gamyxz * gyyx + Gamzxz * gyzx + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz + & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxyz * gxxx + Gamyyz * gxyx + Gamzyz * gxzx + & + Gamxxx * gyzx + Gamyxx * gyzy + Gamzxx * gyzz )+ & + gupxz *( & + Gamxxx * gxzz + Gamyxx * gyzz + Gamzxx * gzzz + & + Gamxxz * gxzx + Gamyxz * gyzx + Gamzxz * gzzx + & + Gamxxz * gxzx + Gamyxz * gxzy + Gamzxz * gxzz + & + Gamxxz * gxxz + Gamyxz * gxyz + Gamzxz * gxzz + & + Gamxzz * gxxx + Gamyzz * gxyx + Gamzzz * gxzx + & + Gamxxx * gzzx + Gamyxx * gzzy + Gamzxx * gzzz )+ & + gupyy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxyz * gxyx + Gamyyz * gyyx + Gamzyz * gyzx + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupyz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxyz * gxzx + Gamyyz * gyzx + Gamzyz * gzzx + & + Gamxxz * gyzx + Gamyxz * gyzy + Gamzxz * gyzz + & + Gamxxz * gxyz + Gamyxz * gyyz + Gamzxz * gyzz + & + Gamxzz * gxyx + Gamyzz * gyyx + Gamzzz * gyzx + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupzz *( & + Gamxxz * gxzz + Gamyxz * gyzz + Gamzxz * gzzz + & + Gamxzz * gxzx + Gamyzz * gyzx + Gamzzz * gzzx + & + Gamxxz * gzzx + Gamyxz * gzzy + Gamzxz * gzzz ) + + Ryz = HALF*( - Ryz + & + gxy * Gamxz + gyy * Gamyz + gyz * Gamzz + & + gxz * Gamxy + gyz * Gamyy + gzz * Gamzy + & + Gamxa * gxzy + Gamya * gyzy + Gamza * gzzy + & + Gamxa * gxyz + Gamya * gyyz + Gamza * gyzz )+ & + gupxx *( & + Gamxxy * gxxz + Gamyxy * gxyz + Gamzxy * gxzz + & + Gamxxz * gxxy + Gamyxz * gxyy + Gamzxz * gxzy + & + Gamxxy * gxzx + Gamyxy * gxzy + Gamzxy * gxzz )+ & + gupxy *( & + Gamxxy * gxyz + Gamyxy * gyyz + Gamzxy * gyzz + & + Gamxxz * gxyy + Gamyxz * gyyy + Gamzxz * gyzy + & + Gamxyy * gxzx + Gamyyy * gxzy + Gamzyy * gxzz + & + Gamxyy * gxxz + Gamyyy * gxyz + Gamzyy * gxzz + & + Gamxyz * gxxy + Gamyyz * gxyy + Gamzyz * gxzy + & + Gamxxy * gyzx + Gamyxy * gyzy + Gamzxy * gyzz )+ & + gupxz *( & + Gamxxy * gxzz + Gamyxy * gyzz + Gamzxy * gzzz + & + Gamxxz * gxzy + Gamyxz * gyzy + Gamzxz * gzzy + & + Gamxyz * gxzx + Gamyyz * gxzy + Gamzyz * gxzz + & + Gamxyz * gxxz + Gamyyz * gxyz + Gamzyz * gxzz + & + Gamxzz * gxxy + Gamyzz * gxyy + Gamzzz * gxzy + & + Gamxxy * gzzx + Gamyxy * gzzy + Gamzxy * gzzz )+ & + gupyy *( & + Gamxyy * gxyz + Gamyyy * gyyz + Gamzyy * gyzz + & + Gamxyz * gxyy + Gamyyz * gyyy + Gamzyz * gyzy + & + Gamxyy * gyzx + Gamyyy * gyzy + Gamzyy * gyzz )+ & + gupyz *( & + Gamxyy * gxzz + Gamyyy * gyzz + Gamzyy * gzzz + & + Gamxyz * gxzy + Gamyyz * gyzy + Gamzyz * gzzy + & + Gamxyz * gyzx + Gamyyz * gyzy + Gamzyz * gyzz + & + Gamxyz * gxyz + Gamyyz * gyyz + Gamzyz * gyzz + & + Gamxzz * gxyy + Gamyzz * gyyy + Gamzzz * gyzy + & + Gamxyy * gzzx + Gamyyy * gzzy + Gamzyy * gzzz )+ & + gupzz *( & + Gamxyz * gxzz + Gamyyz * gyzz + Gamzyz * gzzz + & + Gamxzz * gxzy + Gamyzz * gyzy + Gamzzz * gzzy + & + Gamxyz * gzzx + Gamyyz * gzzy + Gamzyz * gzzz ) +!covariant second derivative of chi respect to tilted metric + +! Store D^l D_l chi - 3/(2*chi) D^l chi D_l chi in f + + call fdderivs_shc(ex,chi,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = fxx - Gamxxx * chix - Gamyxx * chiy - Gamzxx * chiz + fxy = fxy - Gamxxy * chix - Gamyxy * chiy - Gamzxy * chiz + fxz = fxz - Gamxxz * chix - Gamyxz * chiy - Gamzxz * chiz + fyy = fyy - Gamxyy * chix - Gamyyy * chiy - Gamzyy * chiz + fyz = fyz - Gamxyz * chix - Gamyyz * chiy - Gamzyz * chiz + fzz = fzz - Gamxzz * chix - Gamyzz * chiy - Gamzzz * chiz + + f = gupxx * ( fxx - F3o2/chin1 * chix * chix ) + & + gupyy * ( fyy - F3o2/chin1 * chiy * chiy ) + & + gupzz * ( fzz - F3o2/chin1 * chiz * chiz ) + & + TWO * gupxy * ( fxy - F3o2/chin1 * chix * chiy ) + & + TWO * gupxz * ( fxz - F3o2/chin1 * chix * chiz ) + & + TWO * gupyz * ( fyz - F3o2/chin1 * chiy * chiz ) + +! Add chi part to Ricci tensor: + + fxx = Rxx + (fxx - chix*chix/chin1/TWO + gxx * f)/chin1/TWO + fyy = Ryy + (fyy - chiy*chiy/chin1/TWO + gyy * f)/chin1/TWO + fzz = Rzz + (fzz - chiz*chiz/chin1/TWO + gzz * f)/chin1/TWO + fxy = Rxy + (fxy - chix*chiy/chin1/TWO + gxy * f)/chin1/TWO + fxz = Rxz + (fxz - chix*chiz/chin1/TWO + gxz * f)/chin1/TWO + fyz = Ryz + (fyz - chiy*chiz/chin1/TWO + gyz * f)/chin1/TWO +! store R/chi in Hcon + Hcon = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + + Rxx = fxx + Ryy = fyy + Rzz = fzz + Rxy = fxy + Rxz = fxz + Ryz = fyz + + gxxx = (gupxx * chix + gupxy * chiy + gupxz * chiz)/chin1 + gxxy = (gupxy * chix + gupyy * chiy + gupyz * chiz)/chin1 + gxxz = (gupxz * chix + gupyz * chiy + gupzz * chiz)/chin1 +! now get physical second kind of connection + Gamxxx = Gamxxx - ( (chix + chix)/chin1 - gxx * gxxx )*HALF + Gamyxx = Gamyxx - ( - gxx * gxxy )*HALF + Gamzxx = Gamzxx - ( - gxx * gxxz )*HALF + Gamxyy = Gamxyy - ( - gyy * gxxx )*HALF + Gamyyy = Gamyyy - ( (chiy + chiy)/chin1 - gyy * gxxy )*HALF + Gamzyy = Gamzyy - ( - gyy * gxxz )*HALF + Gamxzz = Gamxzz - ( - gzz * gxxx )*HALF + Gamyzz = Gamyzz - ( - gzz * gxxy )*HALF + Gamzzz = Gamzzz - ( (chiz + chiz)/chin1 - gzz * gxxz )*HALF + Gamxxy = Gamxxy - ( chiy /chin1 - gxy * gxxx )*HALF + Gamyxy = Gamyxy - ( chix /chin1 - gxy * gxxy )*HALF + Gamzxy = Gamzxy - ( - gxy * gxxz )*HALF + Gamxxz = Gamxxz - ( chiz /chin1 - gxz * gxxx )*HALF + Gamyxz = Gamyxz - ( - gxz * gxxy )*HALF + Gamzxz = Gamzxz - ( chix /chin1 - gxz * gxxz )*HALF + Gamxyz = Gamxyz - ( - gyz * gxxx )*HALF + Gamyyz = Gamyyz - ( chiz /chin1 - gyz * gxxy )*HALF + Gamzyz = Gamzyz - ( chiy /chin1 - gyz * gxxz )*HALF + +! covariant second derivatives of the lapse respect to physical metric + + call fdderivs_shc(ex,Lap,fxx,fxy,fxz,fyy,fyz,fzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + fxx = fxx - Gamxxx*Lapx - Gamyxx*Lapy - Gamzxx*Lapz + fyy = fyy - Gamxyy*Lapx - Gamyyy*Lapy - Gamzyy*Lapz + fzz = fzz - Gamxzz*Lapx - Gamyzz*Lapy - Gamzzz*Lapz + fxy = fxy - Gamxxy*Lapx - Gamyxy*Lapy - Gamzxy*Lapz + fxz = fxz - Gamxxz*Lapx - Gamyxz*Lapy - Gamzxz*Lapz + fyz = fyz - Gamxyz*Lapx - Gamyyz*Lapy - Gamzyz*Lapz + +! store D^i D_i Lap in trK_rhs upto chi + trK_rhs = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) +! Add lapse and S_ij parts to Ricci tensor: + + fxx = EIGHT * PI * alpn1 * Sxx + fxx + fxy = EIGHT * PI * alpn1 * Sxy + fxy + fxz = EIGHT * PI * alpn1 * Sxz + fxz + fyy = EIGHT * PI * alpn1 * Syy + fyy + fyz = EIGHT * PI * alpn1 * Syz + fyz + fzz = EIGHT * PI * alpn1 * Szz + fzz + +! Compute trace-free part (note: chi^-1 and chi cancel!): + f = gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO* ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + + f = F1o3 * (Hcon*alpn1 - f) + + fxx = alpn1 * Rxx - fxx + fxy = alpn1 * Rxy - fxy + fxz = alpn1 * Rxz - fxz + fyy = alpn1 * Ryy - fyy + fyz = alpn1 * Ryz - fyz + fzz = alpn1 * Rzz - fzz + + Axx_rhs = fxx - gxx * f + Ayy_rhs = fyy - gyy * f + Azz_rhs = fzz - gzz * f + Axy_rhs = fxy - gxy * f + Axz_rhs = fxz - gxz * f + Ayz_rhs = fyz - gyz * f + +! Now: store A_il A^l_j into fij: + + fxx = gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) + fyy = gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) + fzz = gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) + fxy = gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy *(Axx * Ayy + Axy * Axy) + & + gupxz *(Axx * Ayz + Axz * Axy) + & + gupyz *(Axy * Ayz + Axz * Ayy) + fxz = gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy *(Axx * Ayz + Axy * Axz) + & + gupxz *(Axx * Azz + Axz * Axz) + & + gupyz *(Axy * Azz + Axz * Ayz) + fyz = gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy *(Axy * Ayz + Ayy * Axz) + & + gupxz *(Axy * Azz + Ayz * Axz) + & + gupyz *(Ayy * Azz + Ayz * Ayz) + + f = chin1 +! store D^i D_i Lap in trK_rhs + trK_rhs = f*trK_rhs + + Axx_rhs = f * Axx_rhs+ alpn1 * (trKd * Axx - TWO * fxx) + & + TWO * ( Axx * betaxx + Axy * betayx + Axz * betazx ) - & + F2o3 * Axx * div_beta + + Ayy_rhs = f * Ayy_rhs+ alpn1 * (trKd * Ayy - TWO * fyy) + & + TWO * ( Axy * betaxy + Ayy * betayy + Ayz * betazy ) - & + F2o3 * Ayy * div_beta + + Azz_rhs = f * Azz_rhs+ alpn1 * (trKd * Azz - TWO * fzz) + & + TWO * ( Axz * betaxz + Ayz * betayz + Azz * betazz ) - & + F2o3 * Azz * div_beta + + Axy_rhs = f * Axy_rhs+ alpn1 *( trKd * Axy - TWO * fxy )+ & + Axx * betaxy + Axz * betazy + & + Ayy * betayx + Ayz * betazx + & + F1o3 * Axy * div_beta - Axy * betazz + + Ayz_rhs = f * Ayz_rhs+ alpn1 *( trKd * Ayz - TWO * fyz )+ & + Axy * betaxz + Ayy * betayz + & + Axz * betaxy + Azz * betazy + & + F1o3 * Ayz * div_beta - Ayz * betaxx + + Axz_rhs = f * Axz_rhs+ alpn1 *( trKd * Axz - TWO * fxz )+ & + Axx * betaxz + Axy * betayz + & + Ayz * betayx + Azz * betazx + & + F1o3 * Axz * div_beta - Axz * betayy !rhs for Aij + +! Compute trace of S_ij + + S = f * ( gupxx * Sxx + gupyy * Syy + gupzz * Szz + & + TWO * ( gupxy * Sxy + gupxz * Sxz + gupyz * Syz ) ) + + trK_rhs = - trK_rhs + alpn1 *( F1o3 * trKd * trKd + & + gupxx * fxx + gupyy * fyy + gupzz * fzz + & + TWO * ( gupxy * fxy + gupxz * fxz + gupyz * fyz ) + & + FOUR * PI * ( rho + S )) !rhs for trK + +!!!!!gauge variable part + Lap_rhs = -TWO*alpn1*trK +#if (GAUGE == 0) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz +#elif (GAUGE == 1) + betax_rhs = Gamx - eta*betax + betay_rhs = Gamy - eta*betay + betaz_rhs = Gamz - eta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#endif +!!!!!Z4 part +! H = trR + 2/3 * trKd^2 - A_ij * A^ij - 16 * PI * rho +! here trR is respect to physical metric + + Hcon = chin1*Hcon + F2o3 * trKd * trKd -(& + gupxx * ( & + gupxx * Axx * Axx + gupyy * Axy * Axy + gupzz * Axz * Axz + & + TWO * (gupxy * Axx * Axy + gupxz * Axx * Axz + gupyz * Axy * Axz) ) + & + gupyy * ( & + gupxx * Axy * Axy + gupyy * Ayy * Ayy + gupzz * Ayz * Ayz + & + TWO * (gupxy * Axy * Ayy + gupxz * Axy * Ayz + gupyz * Ayy * Ayz) ) + & + gupzz * ( & + gupxx * Axz * Axz + gupyy * Ayz * Ayz + gupzz * Azz * Azz + & + TWO * (gupxy * Axz * Ayz + gupxz * Axz * Azz + gupyz * Ayz * Azz) ) + & + TWO * ( & + gupxy * ( & + gupxx * Axx * Axy + gupyy * Axy * Ayy + gupzz * Axz * Ayz + & + gupxy * (Axx * Ayy + Axy * Axy) + & + gupxz * (Axx * Ayz + Axz * Axy) + & + gupyz * (Axy * Ayz + Axz * Ayy) ) + & + gupxz * ( & + gupxx * Axx * Axz + gupyy * Axy * Ayz + gupzz * Axz * Azz + & + gupxy * (Axx * Ayz + Axy * Axz) + & + gupxz * (Axx * Azz + Axz * Axz) + & + gupyz * (Axy * Azz + Axz * Ayz) ) + & + gupyz * ( & + gupxx * Axy * Axz + gupyy * Ayy * Ayz + gupzz * Ayz * Azz + & + gupxy * (Axy * Ayz + Ayy * Axz) + & + gupxz * (Axy * Azz + Ayz * Axz) + & + gupyz * (Ayy * Azz + Ayz * Ayz) ) ))- F16 * PI * rho +! M_j = gupki*(-1/chi d_k chi*A_ij + D_k A_ij) - 2/3 d_j trK - 8 PI s_j where D respect to physical metric +! store D_i A_jk - 1/chi d_i chi*A_jk in gjk_i + + call fderivs_shc(ex,Axx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + gxxx = gxxx - ( Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz & + + Gamxxx * Axx + Gamyxx * Axy + Gamzxx * Axz) - chix*Axx/chin1 + gxyx = gxyx - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxx * Axy + Gamyxx * Ayy + Gamzxx * Ayz) - chix*Axy/chin1 + gxzx = gxzx - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxx * Axz + Gamyxx * Ayz + Gamzxx * Azz) - chix*Axz/chin1 + gyyx = gyyx - ( Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chix*Ayy/chin1 + gyzx = gyzx - ( Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chix*Ayz/chin1 + gzzx = gzzx - ( Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chix*Azz/chin1 + gxxy = gxxy - ( Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz & + + Gamxxy * Axx + Gamyxy * Axy + Gamzxy * Axz) - chiy*Axx/chin1 + gxyy = gxyy - ( Gamxyy * Axx + Gamyyy * Axy + Gamzyy * Axz & + + Gamxxy * Axy + Gamyxy * Ayy + Gamzxy * Ayz) - chiy*Axy/chin1 + gxzy = gxzy - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxy * Axz + Gamyxy * Ayz + Gamzxy * Azz) - chiy*Axz/chin1 + gyyy = gyyy - ( Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz & + + Gamxyy * Axy + Gamyyy * Ayy + Gamzyy * Ayz) - chiy*Ayy/chin1 + gyzy = gyzy - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyy * Axz + Gamyyy * Ayz + Gamzyy * Azz) - chiy*Ayz/chin1 + gzzy = gzzy - ( Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiy*Azz/chin1 + gxxz = gxxz - ( Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz & + + Gamxxz * Axx + Gamyxz * Axy + Gamzxz * Axz) - chiz*Axx/chin1 + gxyz = gxyz - ( Gamxyz * Axx + Gamyyz * Axy + Gamzyz * Axz & + + Gamxxz * Axy + Gamyxz * Ayy + Gamzxz * Ayz) - chiz*Axy/chin1 + gxzz = gxzz - ( Gamxzz * Axx + Gamyzz * Axy + Gamzzz * Axz & + + Gamxxz * Axz + Gamyxz * Ayz + Gamzxz * Azz) - chiz*Axz/chin1 + gyyz = gyyz - ( Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz & + + Gamxyz * Axy + Gamyyz * Ayy + Gamzyz * Ayz) - chiz*Ayy/chin1 + gyzz = gyzz - ( Gamxzz * Axy + Gamyzz * Ayy + Gamzzz * Ayz & + + Gamxyz * Axz + Gamyyz * Ayz + Gamzyz * Azz) - chiz*Ayz/chin1 + gzzz = gzzz - ( Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz & + + Gamxzz * Axz + Gamyzz * Ayz + Gamzzz * Azz) - chiz*Azz/chin1 + Mxcon = gupxx*gxxx + gupyy*gxyy + gupzz*gxzz & + +gupxy*gxyx + gupxz*gxzx + gupyz*gxzy & + +gupxy*gxxy + gupxz*gxxz + gupyz*gxyz + Mycon = gupxx*gxyx + gupyy*gyyy + gupzz*gyzz & + +gupxy*gyyx + gupxz*gyzx + gupyz*gyzy & + +gupxy*gxyy + gupxz*gxyz + gupyz*gyyz + Mzcon = gupxx*gxzx + gupyy*gyzy + gupzz*gzzz & + +gupxy*gyzx + gupxz*gzzx + gupyz*gzzy & + +gupxy*gxzy + gupxz*gxzz + gupyz*gyzz +! we have already considered TZ_,i in K_,i here, or to say here Micon = +! Micon+TZ_,i indeed + Mxcon = Mxcon - F2o3*Kx - F8*PI*sx + Mycon = Mycon - F2o3*Ky - F8*PI*sy + Mzcon = Mzcon - F2o3*Kz - F8*PI*sz + + f = TZ_rhs + + TZ_rhs = alpn1*Hcon/TWO +! delete TWO*Z^i_,i From Hcon' to get Hcon, this is wrong +! Hcon = Hcon - f + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI +!!!!!!!!!advection term part +!g_ij + call fderivs_shc(ex,dxx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxx_rhs = gxx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gxy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxy_rhs = gxy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gxz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gxz_rhs = gxz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dyy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gyy_rhs = gyy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,gyz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gyz_rhs = gyz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dzz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + gzz_rhs = gzz_rhs + betax*fxx+betay*fxy+betaz*fxz +!A_ij + call fderivs_shc(ex,Axx,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axx_rhs = Axx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Axy,fxx,fxy,fxz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axy_rhs = Axy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Axz,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Axz_rhs = Axz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Ayy,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Ayy_rhs = Ayy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Ayz,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Ayz_rhs = Ayz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Azz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Azz_rhs = Azz_rhs + betax*fxx+betay*fxy+betaz*fxz +!chi and trK + call fderivs_shc(ex,chi,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + chi_rhs = chi_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,trK,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + trK_rhs = trK_rhs + betax*fxx+betay*fxy+betaz*fxz +!Gam^i + call fderivs_shc(ex,Gamx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamx_rhs = Gamx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Gamy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamy_rhs = Gamy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,Gamz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Gamz_rhs = Gamz_rhs + betax*fxx+betay*fxy+betaz*fxz +!gauge variables + call fderivs_shc(ex,Lap,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + Lap_rhs = Lap_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betax,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betax_rhs = betax_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betay,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betay_rhs = betay_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,betaz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + betaz_rhs = betaz_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfx,fxx,fxy,fxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfx_rhs = dtSfx_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfy,fxx,fxy,fxz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfy_rhs = dtSfy_rhs + betax*fxx+betay*fxy+betaz*fxz + call fderivs_shc(ex,dtSfz,fxx,fxy,fxz,crho,sigma,R,SYM ,SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + dtSfz_rhs = dtSfz_rhs + betax*fxx+betay*fxy+betaz*fxz +!Z4c variables + call fderivs_shc(ex,TZ,fxx,fxy,fxz,crho,sigma,R,SYM,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + TZ_rhs = TZ_rhs + betax*fxx+betay*fxy+betaz*fxz + +! constraint damping terms + TZ_rhs = TZ_rhs - alpn1*(TWO+kappa2)*kappa1*TZ + trK_rhs = trK_rhs + alpn1*kappa1*(ONE-kappa2)*TZ + Gamx_rhs = Gamx_rhs - TWO*alpn1*kappa1*(Gamx-Gamxa) + Gamy_rhs = Gamy_rhs - TWO*alpn1*kappa1*(Gamy-Gamya) + Gamz_rhs = Gamz_rhs - TWO*alpn1*kappa1*(Gamz-Gamza) + +! numerical dissipation part + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) + endif + +#if (ABV == 1) + call ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,Lev,sst) + call constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & + Symmetry,Lev,sst) +#endif + + gont = 0 + + return + + end function compute_rhs_Z4c_ss +#endif + + +!! using David Z4c-rhs code +#if 0 + function compute_rhs_z4c_ss(ex, T,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi , trK , & + dxx , gxy , gxz , dyy , gyz , dzz, & + Axx , Axy , Axz , Ayy , Ayz , Azz, & + Gamx , Gamy , Gamz , & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ , & + chi_rhs, trK_rhs, & + gxx_rhs, gxy_rhs, gxz_rhs, gyy_rhs, gyz_rhs, gzz_rhs, & + Axx_rhs, Axy_rhs, Axz_rhs, Ayy_rhs, Ayz_rhs, Azz_rhs, & + Gamx_rhs, Gamy_rhs, Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + TZ_rhs , & + rho,Sx,Sy,Sz,Sxx,Sxy,Sxz,Syy,Syz,Szz, & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz, & + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz, & + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & +! co is not used here, we always compute constraint + Symmetry,Lev,eps,sst,co) result(gont) + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,Lev,sst,co + real*8, intent(in ):: T + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, intent(in ),dimension(ex(1),ex(2),ex(3)):: X,Y,Z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(out) :: TZ_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: rho,Sx,Sy,Sz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Sxx,Sxy,Sxz,Syy,Syz,Szz +! when out, physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxxx, Gamxxy, Gamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamxyy, Gamxyz, Gamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyxx, Gamyxy, Gamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamyyy, Gamyyz, Gamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzxx, Gamzxy, Gamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamzyy, Gamzyz, Gamzzz +! when out, physical Ricci tensor + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz +! when out, constraint violation + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon + real*8,intent(in) :: eps +! gont = 0: success; gont = 1: something wrong + integer::gont + +!~~~~~~> Other variables: + + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: chix,chiy,chiz,chixx,chixy,chixz,chiyy,chiyz,chizz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxx,gxyx,gxzx,gyyx,gyzx,gzzx + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxy,gxyy,gxzy,gyyy,gyzy,gzzy + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxz,gxyz,gxzz,gyyz,gyzz,gzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz + real*8, dimension(ex(1),ex(2),ex(3)) :: betaxx,betaxy,betaxz + real*8, dimension(ex(1),ex(2),ex(3)) :: betayx,betayy,betayz + real*8, dimension(ex(1),ex(2),ex(3)) :: betazx,betazy,betazz + real*8, dimension(ex(1),ex(2),ex(3)) :: dtSfxx,dtSfxy,dtSfxz + real*8, dimension(ex(1),ex(2),ex(3)) :: dtSfyx,dtSfyy,dtSfyz + real*8, dimension(ex(1),ex(2),ex(3)) :: dtSfzx,dtSfzy,dtSfzz + real*8, dimension(ex(1),ex(2),ex(3)) :: dBxx,dBxy,dBxz + real*8, dimension(ex(1),ex(2),ex(3)) :: dByx,dByy,dByz + real*8, dimension(ex(1),ex(2),ex(3)) :: dBzx,dBzy,dBzz + real*8, dimension(ex(1),ex(2),ex(3)) :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamxx,Gamxy,Gamxz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamyx,Gamyy,Gamyz + real*8, dimension(ex(1),ex(2),ex(3)) :: Gamzx,Gamzy,Gamzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Kx,Ky,Kz,TZx,TZy,TZz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy + real*8, dimension(ex(1),ex(2),ex(3)) :: Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8 :: dX,dY,dZ,PI + real*8, parameter :: ZEO=0.d0,ONE = 1.D0, TWO = 2.D0, FOUR = 4.D0,F16=1.6d1 + real*8, parameter :: EIGHT = 8.D0, HALF = 0.5D0, THR = 3.d0,F8=8.d0 + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: F1o3 = 1.D0/3.D0, F2o3 = 2.D0/3.D0,F3o2=1.5d0, F1o6 = 1.D0/6.D0 + integer :: i,j,k + +! constraint damping terms stuffs PRD 81, 084003 (2010) + real*8 :: kappa1,kappa2,kappa3,FF,eta + + real*8,parameter :: chiDivfloor=1.d-5 + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + +!!! sanity check + dX = sum(chi)+sum(trK)+sum(dxx)+sum(gxy)+sum(gxz)+sum(dyy)+sum(gyz)+sum(dzz) & + +sum(Axx)+sum(Axy)+sum(Axz)+sum(Ayy)+sum(Ayz)+sum(Azz) & + +sum(Gamx)+sum(Gamy)+sum(Gamz) & + +sum(Lap)+sum(betax)+sum(betay)+sum(betaz)+sum(dtSfx)+sum(dtSfy)+sum(dtSfz) & + +sum(TZ) + if(dX.ne.dX) then + if(sum(chi).ne.sum(chi))write(*,*)"Z4c_rhs_ss.f90: find NaN in chi" + if(sum(trK).ne.sum(trK))write(*,*)"Z4c_rhs_ss.f90: find NaN in trk" + if(sum(dxx).ne.sum(dxx))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxx" + if(sum(gxy).ne.sum(gxy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxy" + if(sum(gxz).ne.sum(gxz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gxz" + if(sum(dyy).ne.sum(dyy))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyy" + if(sum(gyz).ne.sum(gyz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gyz" + if(sum(dzz).ne.sum(dzz))write(*,*)"Z4c_rhs_ss.f90: find NaN in gzz" + if(sum(Axx).ne.sum(Axx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axx" + if(sum(Axy).ne.sum(Axy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axy" + if(sum(Axz).ne.sum(Axz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Axz" + if(sum(Ayy).ne.sum(Ayy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayy" + if(sum(Ayz).ne.sum(Ayz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Ayz" + if(sum(Azz).ne.sum(Azz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Azz" + if(sum(Gamx).ne.sum(Gamx))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamx" + if(sum(Gamy).ne.sum(Gamy))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamy" + if(sum(Gamz).ne.sum(Gamz))write(*,*)"Z4c_rhs_ss.f90: find NaN in Gamz" + if(sum(Lap).ne.sum(Lap))write(*,*)"Z4c_rhs_ss.f90: find NaN in Lap" + if(sum(betax).ne.sum(betax))write(*,*)"Z4c_rhs_ss.f90: find NaN in betax" + if(sum(betay).ne.sum(betay))write(*,*)"Z4c_rhs_ss.f90: find NaN in betay" + if(sum(betaz).ne.sum(betaz))write(*,*)"Z4c_rhs_ss.f90: find NaN in betaz" + if(sum(dtSfx).ne.sum(dtSfx))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfx" + if(sum(dtSfy).ne.sum(dtSfy))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfy" + if(sum(dtSfz).ne.sum(dtSfz))write(*,*)"Z4c_rhs_ss.f90: find NaN in dtSfz" + if(sum(TZ).ne.sum(Tz))write(*,*)"Z4c_rhs_ss.f90: find NaN in TZ" + gont = 1 + return + endif + + PI = dacos(-ONE) + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + call fderivs_shc(ex,dtSfx,dBxx,dBxy,dBxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,dtSfy,dByx,dByy,dByz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,dtSfz,dBzx,dBzy,dBzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,betax,betaxx,betaxy,betaxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,betay,betayx,betayy,betayz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,betaz,betazx,betazy,betazz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +#if (GAUGE == 0) + call fderivs_shc(ex,dtSfx,dtSfxx,dtSfxy,dtSfxz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,dtSfy,dtSfyx,dtSfyy,dtSfyz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,dtSfz,dtSfzx,dtSfzy,dtSfzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +#endif + + call fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +! gij_,kl will be stored till end of this routine + call fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R, SYM, SYM,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + +! Gami_,j will be kept till the end of this routine + call fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM ,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM ,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + +! Right hand side for Gam^i without shift terms... +! Lap_,i will be kept till the end of this routine + call fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) +! K_,i stored K_,i+TZ_,i/2 indeed, will be kept till the end of this routine + call fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + call fdderivs_shc(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI, SYM, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R, SYM,ANTI, SYM,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + call fdderivs_shc(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R, SYM, SYM,ANTI,Symmetry,Lev,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + call fdderivs_shc(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + call fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz) + + call fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM ,ANTI,ANTI,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + call fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R, SYM, SYM,SYM,Symmetry,Lev,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz) + + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + call z4c_rhs_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & + alpn1(i,j,k),dtSfx(i,j,k),dtSfy(i,j,k),dtSfz(i,j,k), & + betax(i,j,k),betay(i,j,k),betaz(i,j,k), & + chin1(i,j,k),chiDivfloor, & + Lapx(i,j,k), & + Axxx(i,j,k),Axyx(i,j,k),Axzx(i,j,k),Ayyx(i,j,k),Ayzx(i,j,k),Azzx(i,j,k), & + Lapy(i,j,k), & + Axxy(i,j,k),Axyy(i,j,k),Axzy(i,j,k),Ayyy(i,j,k),Ayzy(i,j,k),Azzy(i,j,k), & + Lapz(i,j,k), & + Axxz(i,j,k),Axyz(i,j,k),Axzz(i,j,k),Ayyz(i,j,k),Ayzz(i,j,k),Azzz(i,j,k), & + betaxx(i,j,k),dBxx(i,j,k),betayx(i,j,k),dByx(i,j,k),betazx(i,j,k),dBzx(i,j,k), & + betaxy(i,j,k),dBxy(i,j,k),betayy(i,j,k),dByy(i,j,k),betazy(i,j,k),dBzy(i,j,k), & + betaxz(i,j,k),dBxz(i,j,k),betayz(i,j,k),dByz(i,j,k),betazz(i,j,k),dBzz(i,j,k), & + chix(i,j,k),chiy(i,j,k),chiz(i,j,k), & + Lapxx(i,j,k),Lapxy(i,j,k),Lapxz(i,j,k),Lapyy(i,j,k),Lapyz(i,j,k),Lapzz(i,j,k), & + sfxxx(i,j,k),sfyxx(i,j,k),sfzxx(i,j,k), & + sfxxy(i,j,k),sfyxy(i,j,k),sfzxy(i,j,k), & + sfxxz(i,j,k),sfyxz(i,j,k),sfzxz(i,j,k), & + sfxyy(i,j,k),sfyyy(i,j,k),sfzyy(i,j,k), & + sfxyz(i,j,k),sfyyz(i,j,k),sfzyz(i,j,k), & + sfxzz(i,j,k),sfyzz(i,j,k),sfzzz(i,j,k), & + chixx(i,j,k),chixy(i,j,k),chixz(i,j,k),chiyy(i,j,k),chiyz(i,j,k),chizz(i,j,k), & + gxxxx(i,j,k),gxyxx(i,j,k),gxzxx(i,j,k),gyyxx(i,j,k),gyzxx(i,j,k),gzzxx(i,j,k), & + gxxxy(i,j,k),gxyxy(i,j,k),gxzxy(i,j,k),gyyxy(i,j,k),gyzxy(i,j,k),gzzxy(i,j,k), & + gxxxz(i,j,k),gxyxz(i,j,k),gxzxz(i,j,k),gyyxz(i,j,k),gyzxz(i,j,k),gzzxz(i,j,k), & + gxxyy(i,j,k),gxyyy(i,j,k),gxzyy(i,j,k),gyyyy(i,j,k),gyzyy(i,j,k),gzzyy(i,j,k), & + gxxyz(i,j,k),gxyyz(i,j,k),gxzyz(i,j,k),gyyyz(i,j,k),gyzyz(i,j,k),gzzyz(i,j,k), & + gxxzz(i,j,k),gxyzz(i,j,k),gxzzz(i,j,k),gyyzz(i,j,k),gyzzz(i,j,k),gzzzz(i,j,k), & + Gamxx(i,j,k),gxxx(i,j,k),gxyx(i,j,k),gxzx(i,j,k), & + Gamyx(i,j,k),gyyx(i,j,k),gyzx(i,j,k), & + Gamzx(i,j,k),gzzx(i,j,k), & + Gamxy(i,j,k),gxxy(i,j,k),gxyy(i,j,k),gxzy(i,j,k), & + Gamyy(i,j,k),gyyy(i,j,k),gyzy(i,j,k), & + Gamzy(i,j,k),gzzy(i,j,k), & + Gamxz(i,j,k),gxxz(i,j,k),gxyz(i,j,k),gxzz(i,j,k), & + Gamyz(i,j,k),gyyz(i,j,k),gyzz(i,j,k), & + Gamzz(i,j,k),gzzz(i,j,k), & + Kx(i,j,k),Ky(i,j,k),Kz(i,j,k), & + TZx(i,j,k),TZy(i,j,k),TZz(i,j,k), & + Gamx(i,j,k),gxx(i,j,k),gxy(i,j,k),gxz(i,j,k), & + Gamy(i,j,k),gyy(i,j,k),gyz(i,j,k), & + Gamz(i,j,k),gzz(i,j,k), & + kappa1,kappa2, & + trK(i,j,k), & + Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & + chi_rhs(i,j,k), & + Gamx_rhs(i,j,k),gxx_rhs(i,j,k),gxy_rhs(i,j,k),gxz_rhs(i,j,k), & + Gamy_rhs(i,j,k),gyy_rhs(i,j,k),gyz_rhs(i,j,k), & + Gamz_rhs(i,j,k),gzz_rhs(i,j,k),trK_rhs(i,j,k),TZ_rhs(i,j,k),TZ(i,j,k)) + enddo + enddo + enddo + +!!!!!gauge variable part + Lap_rhs = -TWO*alpn1*trK +#if (GAUGE == 0) + betax_rhs = FF*dtSfx + betay_rhs = FF*dtSfy + betaz_rhs = FF*dtSfz + + dtSfx_rhs = Gamx_rhs - eta*dtSfx + dtSfy_rhs = Gamy_rhs - eta*dtSfy + dtSfz_rhs = Gamz_rhs - eta*dtSfz +#elif (GAUGE == 1) + betax_rhs = Gamx - eta*betax + betay_rhs = Gamy - eta*betay + betaz_rhs = Gamz - eta*betaz + + dtSfx_rhs = ZEO + dtSfy_rhs = ZEO + dtSfz_rhs = ZEO +#endif + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +!!!!!!!!!advection term part +!g_ij + gxx_rhs = gxx_rhs + (betax*gxxx+betay*gxxy+betaz*gxxz) + gxy_rhs = gxy_rhs + (betax*gxyx+betay*gxyy+betaz*gxyz) + gxz_rhs = gxz_rhs + (betax*gxzx+betay*gxzy+betaz*gxzz) + gyy_rhs = gyy_rhs + (betax*gyyx+betay*gyyy+betaz*gyyz) + gyz_rhs = gyz_rhs + (betax*gyzx+betay*gyzy+betaz*gyzz) + gzz_rhs = gzz_rhs + (betax*gzzx+betay*gzzy+betaz*gzzz) +!A_ij + Axx_rhs = Axx_rhs + (betax*Axxx+betay*Axxy+betaz*Axxz) + Axy_rhs = Axy_rhs + (betax*Axyx+betay*Axyy+betaz*Axyz) + Axz_rhs = Axz_rhs + (betax*Axzx+betay*Axzy+betaz*Axzz) + Ayy_rhs = Ayy_rhs + (betax*Ayyx+betay*Ayyy+betaz*Ayyz) + Ayz_rhs = Ayz_rhs + (betax*Ayzx+betay*Ayzy+betaz*Ayzz) + Azz_rhs = Azz_rhs + (betax*Azzx+betay*Azzy+betaz*Azzz) +!chi and trK + chi_rhs = chi_rhs + (betax*chix+betay*chiy+betaz*chiz) + trK_rhs = trK_rhs + (betax*Kx+betay*Ky+betaz*Kz) +!Gam^i + Gamx_rhs = Gamx_rhs + (betax*Gamxx+betay*Gamxy+betaz*Gamxz) + Gamy_rhs = Gamy_rhs + (betax*Gamyx+betay*Gamyy+betaz*Gamyz) + Gamz_rhs = Gamz_rhs + (betax*Gamzx+betay*Gamzy+betaz*Gamzz) +!Z4c variables + TZ_rhs = TZ_rhs + (betax*TZx+betay*TZy+betaz*TZz) +!!!!!gauge variables + Lap_rhs = Lap_rhs + (betax*Lapx+betay*Lapy+betaz*Lapz) + + betax_rhs = betax_rhs + (betax*betaxx+betay*betaxy+betaz*betaxz) + betay_rhs = betay_rhs + (betax*betayx+betay*betayy+betaz*betayz) + betaz_rhs = betaz_rhs + (betax*betazx+betay*betazy+betaz*betazz) +#if (GAUGE == 0) + dtSfx_rhs = dtSfx_rhs + (betax*dtSfxx+betay*dtSfxy+betaz*dtSfxz) + dtSfy_rhs = dtSfy_rhs + (betax*dtSfyx+betay*dtSfyy+betaz*dtSfyz) + dtSfz_rhs = dtSfz_rhs + (betax*dtSfzx+betay*dtSfzy+betaz*dtSfzz) +#endif + +! numerical dissipation part + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) +#if (GAUGE == 0) + call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) +#endif + + call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) + endif + +#if (ABV == 1) + call ricci_gamma_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi, & + dxx , gxy , gxz , dyy , gyz , dzz,& + Gamx , Gamy , Gamz , & + Gamxxx,Gamxxy,Gamxxz,Gamxyy,Gamxyz,Gamxzz,& + Gamyxx,Gamyxy,Gamyxz,Gamyyy,Gamyyz,Gamyzz,& + Gamzxx,Gamzxy,Gamzxz,Gamzyy,Gamzyz,Gamzzz,& + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz,& + Symmetry,Lev,sst) + call constraint_bssn_ss(ex,crho,sigma,R,X, Y, Z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz,& + Lap,betax,betay,betaz,rho,Sx,Sy,Sz,& + Gamxxx, Gamxxy, Gamxxz,Gamxyy, Gamxyz, Gamxzz, & + Gamyxx, Gamyxy, Gamyxz,Gamyyy, Gamyyz, Gamyzz, & + Gamzxx, Gamzxy, Gamzxz,Gamzyy, Gamzyz, Gamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Hcon,Mxcon,Mycon,Mzcon,Gmxcon,Gmycon,Gmzcon, & + Symmetry,Lev,sst) +#endif + + gont = 0 + + return + + end function compute_rhs_Z4c_ss +#endif diff --git a/AMSS_NCKU_source/cpbc.f90 b/AMSS_NCKU_source/Z4C/cpbc.f90 similarity index 98% rename from AMSS_NCKU_source/cpbc.f90 rename to AMSS_NCKU_source/Z4C/cpbc.f90 index 3b2b667..7f46461 100644 --- a/AMSS_NCKU_source/cpbc.f90 +++ b/AMSS_NCKU_source/Z4C/cpbc.f90 @@ -1,4455 +1,4455 @@ - - -#include "macrodef.fh" - - subroutine get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - - implicit none - - real*8,intent(out) :: kappa1,kappa2,kappa3,FF,eta - - kappa1 = 2.d-2 - kappa2 = 0.d0 - kappa3 = 0.d0 - - FF = 0.75d0 - eta=2.0d0 - - return - - end subroutine get_Z4cparameters -#if 1 -! need CPBC_ghost_width -!PRD 83, 024025 (2011) - subroutine david_milton_cpbc_ss(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax, & - TZ,chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz, & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ_rhs,chi_rhs,trK_rhs, & - gxx_rhs,gxy_rhs,gxz_rhs,gyy_rhs,gyz_rhs,gzz_rhs, & - Axx_rhs,Axy_rhs,Axz_rhs,Ayy_rhs,Ayz_rhs,Azz_rhs, & - Gamx_rhs,Gamy_rhs,Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - pGamxxx,pGamxxy,pGamxxz,pGamxyy,pGamxyz,pGamxzz, & - pGamyxx,pGamyxy,pGamyxz,pGamyyy,pGamyyz,pGamyzz, & - pGamzxx,pGamzxy,pGamzxz,pGamzyy,pGamzyz,pGamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Gmxcon,Gmycon,Gmzcon, & - Symmetry,eps,sst) - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ,chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz,Gmxcon,Gmycon,Gmzcon - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ_rhs,chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8,intent(in) :: eps -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxxx, pGamxxy, pGamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxyy, pGamxyz, pGamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyxx, pGamyxy, pGamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyyy, pGamyyz, pGamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzxx, pGamzxy, pGamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzyy, pGamzyz, pGamzzz - -!~~~~~~~~~~~> local variables - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: qxx,qxy,qxz,qyy,qyz,qzz - real*8, dimension(ex(1),ex(2),ex(3)) :: qupxx,qupxy,qupxz,qupyy,qupyz,qupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: qulxx,qulxy,qulxz,qulyx,qulyy,qulyz,qulzx,qulzy,qulzz - real*8, dimension(ex(1),ex(2),ex(3)) :: slx,sly,slz,ulx,uly,ulz,wlx,wly,wlz - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: fx,fy,fz - logical :: gont - real*8 :: dR - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax -! derivatives - real*8 :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz - real*8 :: sfxx,sfxy,sfxz,sfyx,sfyy,sfyz,sfzx,sfzy,sfzz - real*8 :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz - real*8 :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz - real*8 :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz - real*8 :: TZx,TZy,TZz - real*8 :: chix,chiy,chiz,Kx,Ky,Kz - real*8 :: chixx,chixy,chixz,chiyy,chiyz,chizz - real*8 :: Axxx,Axxy,Axxz - real*8 :: Axyx,Axyy,Axyz - real*8 :: Axzx,Axzy,Axzz - real*8 :: Ayyx,Ayyy,Ayyz - real*8 :: Ayzx,Ayzy,Ayzz - real*8 :: Azzx,Azzy,Azzz - real*8 :: gxxx,gxxy,gxxz - real*8 :: gxyx,gxyy,gxyz - real*8 :: gxzx,gxzy,gxzz - real*8 :: gyyx,gyyy,gyyz - real*8 :: gyzx,gyzy,gyzz - real*8 :: gzzx,gzzy,gzzz - real*8 :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8 :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8 :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8 :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8 :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8 :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8 :: Gamxx,Gamxy,Gamxz - real*8 :: Gamyx,Gamyy,Gamyz - real*8 :: Gamzx,Gamzy,Gamzz - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0,HALF=0.5d0 - real*8,parameter::TINYRR=1.d-14 -! in order to synchronize the following parameters with Z4c_rhs calculation, we -! call a routine - real*8 :: kappa1,kappa2,kappa3,FF,eta - -! real*8,parameter :: ha=0.d0,thbs=0.d0,hu=0.d0,hw=0.d0,Rhpsi0=0.d0,Ihpsi0=0.d0 - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - - dR = R(2) - R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(3,3) = ex(3) - CPBC_ghost_width - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(6,3) = ex(3) - CPBC_ghost_width -endif - -if(dabs(R(1)-zmin) < dR)then - layer(1,6) = 1 - layer(2,6) = 1 - layer(3,6) = 1 - layer(4,6) = ex(1) - layer(5,6) = ex(2) - layer(6,6) = 1 -endif -! fix BD - gp = 6 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -! z direction - TZ_rhs(i,j,k) = ZEO - chi_rhs(i,j,k) = ZEO - trK_rhs(i,j,k) = ZEO - gxx_rhs(i,j,k) = ZEO - gxy_rhs(i,j,k) = ZEO - gxz_rhs(i,j,k) = ZEO - gyy_rhs(i,j,k) = ZEO - gyz_rhs(i,j,k) = ZEO - gzz_rhs(i,j,k) = ZEO - Axx_rhs(i,j,k) = ZEO - Axy_rhs(i,j,k) = ZEO - Axz_rhs(i,j,k) = ZEO - Ayy_rhs(i,j,k) = ZEO - Ayz_rhs(i,j,k) = ZEO - Azz_rhs(i,j,k) = ZEO - Gamx_rhs(i,j,k) = ZEO - Gamy_rhs(i,j,k) = ZEO - Gamz_rhs(i,j,k) = ZEO - Lap_rhs(i,j,k) = ZEO - betax_rhs(i,j,k) = ZEO - betay_rhs(i,j,k) = ZEO - betaz_rhs(i,j,k) = ZEO - dtSfx_rhs(i,j,k) = ZEO - dtSfy_rhs(i,j,k) = ZEO - dtSfz_rhs(i,j,k) = ZEO - enddo - enddo - enddo - endif - -! constraint preserving BD - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - -! cpbc real starts - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -!calculate the involved derivatives -#if 0 - Kx = 0.d0 - Ky = 0.d0 - Kz = 0.d0 - chix = 0.d0 - chiy = 0.d0 - chiz = 0.d0 - Lapx = 0.d0 - Lapy = 0.d0 - Lapz = 0.d0 - TZx = 0.d0 - TZy = 0.d0 - TZz = 0.d0 - Gamxx = 0.d0 - Gamxy = 0.d0 - Gamxz = 0.d0 - Gamyx = 0.d0 - Gamyy = 0.d0 - Gamyz = 0.d0 - Gamzx = 0.d0 - Gamzy = 0.d0 - Gamzz = 0.d0 - sfxx = 0.d0 - sfxy = 0.d0 - sfxz = 0.d0 - sfyx = 0.d0 - sfyy = 0.d0 - sfyz = 0.d0 - sfzx = 0.d0 - sfzy = 0.d0 - sfzz = 0.d0 - Axxx = 0.d0 - Axxy = 0.d0 - Axxz = 0.d0 - Axyx = 0.d0 - Axyy = 0.d0 - Axyz = 0.d0 - Axzx = 0.d0 - Axzy = 0.d0 - Axzz = 0.d0 - Ayyx = 0.d0 - Ayyy = 0.d0 - Ayyz = 0.d0 - Ayzx = 0.d0 - Ayzy = 0.d0 - Ayzz = 0.d0 - Azzx = 0.d0 - Azzy = 0.d0 - Azzz = 0.d0 - gxxx = 0.d0 - gxxy = 0.d0 - gxxz = 0.d0 - gxyx = 0.d0 - gxyy = 0.d0 - gxyz = 0.d0 - gxzx = 0.d0 - gxzy = 0.d0 - gxzz = 0.d0 - gyyx = 0.d0 - gyyy = 0.d0 - gyyz = 0.d0 - gyzx = 0.d0 - gyzy = 0.d0 - gyzz = 0.d0 - gzzx = 0.d0 - gzzy = 0.d0 - gzzz = 0.d0 -#else - call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) -#if 0 - sfxx = 0.d0 - sfxy = 0.d0 - sfxz = 0.d0 - sfyx = 0.d0 - sfyy = 0.d0 - sfyz = 0.d0 - sfzx = 0.d0 - sfzy = 0.d0 - sfzz = 0.d0 -#else - call point_fderivs_shc(ex,betax,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,betay,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,betaz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) -#endif - call point_fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) -#endif - -#if 0 - Lapxx = 0.d0 - Lapxy = 0.d0 - Lapxz = 0.d0 - Lapyy = 0.d0 - Lapyz = 0.d0 - Lapzz = 0.d0 - chixx = 0.d0 - chixy = 0.d0 - chixz = 0.d0 - chiyy = 0.d0 - chiyz = 0.d0 - chizz = 0.d0 - gxxxx = 0.d0 - gxxxy = 0.d0 - gxxxz = 0.d0 - gxxyy = 0.d0 - gxxyz = 0.d0 - gxxzz = 0.d0 - gyyxx = 0.d0 - gyyxy = 0.d0 - gyyxz = 0.d0 - gyyyy = 0.d0 - gyyyz = 0.d0 - gyyzz = 0.d0 - gzzxx = 0.d0 - gzzxy = 0.d0 - gzzxz = 0.d0 - gzzyy = 0.d0 - gzzyz = 0.d0 - gzzzz = 0.d0 - gxyxx = 0.d0 - gxyxy = 0.d0 - gxyxz = 0.d0 - gxyyy = 0.d0 - gxyyz = 0.d0 - gxyzz = 0.d0 - gxzxx = 0.d0 - gxzxy = 0.d0 - gxzxz = 0.d0 - gxzyy = 0.d0 - gxzyz = 0.d0 - gxzzz = 0.d0 - gyzxx = 0.d0 - gyzxy = 0.d0 - gyzxz = 0.d0 - gyzyy = 0.d0 - gyzyz = 0.d0 - gyzzz = 0.d0 - sfxxx = 0.d0 - sfxxy = 0.d0 - sfxxz = 0.d0 - sfxyy = 0.d0 - sfxyz = 0.d0 - sfxzz = 0.d0 - sfyxx = 0.d0 - sfyxy = 0.d0 - sfyxz = 0.d0 - sfyyy = 0.d0 - sfyyz = 0.d0 - sfyzz = 0.d0 - sfzxx = 0.d0 - sfzxy = 0.d0 - sfzxz = 0.d0 - sfzyy = 0.d0 - sfzyz = 0.d0 - sfzzz = 0.d0 -#else - call point_fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM ,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) -#endif - - call cpbc_point(R(k),x(i,j,k),y(i,j,k),z(i,j,k),TZ(i,j,k),chin1(i,j,k),trK(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & - Gamx(i,j,k),Gamy(i,j,k),Gamz(i,j,k), & - alpn1(i,j,k),betax(i,j,k),betay(i,j,k),betaz(i,j,k), & - Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz, & - sfxx,sfxy,sfxz, & - sfyx,sfyy,sfyz, & - sfzx,sfzy,sfzz, & - sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz, & - sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz, & - sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz, & - chix,chiy,chiz,chixx,chixy,chixz,chiyy,chiyz,chizz, & - gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & - gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & - gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & - gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & - gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & - gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & - Kx,Ky,Kz, & - Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx, & - Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy, & - Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz, & - Gamxx,Gamxy,Gamxz, & - Gamyx,Gamyy,Gamyz, & - Gamzx,Gamzy,Gamzz, & - TZx,TZy,TZz, & - trK_rhs(i,j,k),TZ_rhs(i,j,k), & - Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & - Gamx_rhs(i,j,k),Gamy_rhs(i,j,k),Gamz_rhs(i,j,k),kappa1,kappa2,eta) - enddo - enddo - enddo - - endif - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) - -#if 0 - call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) -#endif - - call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) - endif - - return - - end subroutine david_milton_cpbc_ss -#elif 1 -#error "did you change sommerfeld routine for buffer points considering?" -!!! CV == 0: Sommerfeld on everything after decomposing -!!! CV == 1: Sommerfeld on only the CPBC vars after decomposing -!!! CV == 1 and replace Sommerfeld to CPBC one by one -#define CV 1 -! Sommefeld after 2+1 decomposation - subroutine david_milton_cpbc_ss(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax, & - TZ,chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz, & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ_rhs,chi_rhs,trK_rhs, & - gxx_rhs,gxy_rhs,gxz_rhs,gyy_rhs,gyz_rhs,gzz_rhs, & - Axx_rhs,Axy_rhs,Axz_rhs,Ayy_rhs,Ayz_rhs,Azz_rhs, & - Gamx_rhs,Gamy_rhs,Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - pGamxxx,pGamxxy,pGamxxz,pGamxyy,pGamxyz,pGamxzz, & - pGamyxx,pGamyxy,pGamyxz,pGamyyy,pGamyyz,pGamyzz, & - pGamzxx,pGamzxy,pGamzxz,pGamzyy,pGamzyz,pGamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Gmxcon,Gmycon,Gmzcon, & - Symmetry,eps,sst) - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ,chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz,Gmxcon,Gmycon,Gmzcon - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ_rhs,chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8,intent(in) :: eps -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxxx, pGamxxy, pGamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxyy, pGamxyz, pGamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyxx, pGamyxy, pGamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyyy, pGamyyz, pGamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzxx, pGamzxy, pGamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzyy, pGamzyz, pGamzzz - -!~~~~~~~~~~~> local variables - - real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,gxx,gyy,gzz - real*8, dimension(ex(1),ex(2),ex(3)) :: toAqq,toAss,toAsx,toAsy,toAsz - real*8, dimension(ex(1),ex(2),ex(3)) :: toAxx,toAxy,toAxz,toAyy,toAyz,toAzz - real*8, dimension(ex(1),ex(2),ex(3)) :: toAqq_rhs,toAss_rhs,toAsx_rhs,toAsy_rhs,toAsz_rhs - real*8, dimension(ex(1),ex(2),ex(3)) :: toAxx_rhs,toAxy_rhs,toAxz_rhs,toAyy_rhs,toAyz_rhs,toAzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)) :: toGams,toGamx,toGamy,toGamz - real*8, dimension(ex(1),ex(2),ex(3)) :: toGams_rhs,toGamx_rhs,toGamy_rhs,toGamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)) :: tobetas,tobetax,tobetay,tobetaz - real*8, dimension(ex(1),ex(2),ex(3)) :: tobetas_rhs,tobetax_rhs,tobetay_rhs,tobetaz_rhs - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: ZEO = 0.d0 - - logical :: gont - real*8 :: dR - integer :: i, j, k - integer :: layer(1:6,1:6),gp - -! in order to synchronize the following parameters with Z4c_rhs calculation, we -! call a routine - real*8 :: kappa1,kappa2,kappa3,FF,eta - -! real*8,parameter :: ha=0.d0,thbs=0.d0,hu=0.d0,hw=0.d0,Rhpsi0=0.d0,Ihpsi0=0.d0 - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - - dR = R(2) - R(1) - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -#if 1 - chin1 = chi+1.d0 - gxx = dxx+1.d0 - gyy = dyy+1.d0 - gzz = dzz+1.d0 - -! decompose - do k = 1, ex(3) - do j = 1, ex(2) - do i = 1, ex(1) -#if (CV == 0) - call decompose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - betax(i,j,k),betay(i,j,k),betaz(i,j,k), & - tobetas(i,j,k),tobetax(i,j,k),tobetay(i,j,k),tobetaz(i,j,k)) -#endif - call decompose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - Gamx(i,j,k),Gamy(i,j,k),Gamz(i,j,k), & - toGams(i,j,k),toGamx(i,j,k),toGamy(i,j,k),toGamz(i,j,k)) - call decompose2p1_2(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & - toAqq(i,j,k),toAss(i,j,k),toAsx(i,j,k),toAsy(i,j,k),toAsz(i,j,k), & - toAxx(i,j,k),toAxy(i,j,k),toAxz(i,j,k),toAyy(i,j,k),toAyz(i,j,k),toAzz(i,j,k)) - - enddo - enddo - enddo - -! sommerfeld boundary -! cpbc variables -#if 0 - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,trK_rhs,trK,1.d0,SSS,Symmetry) -#else - call cpbcrtrK(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,trK_rhs,& - chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,betax,betay,betaz,TZ,Symmetry,sst,kappa1,kappa2) -#endif -#if 0 - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,TZ_rhs,TZ,1.d0,SSS,Symmetry) -#else - call cpbcrtheta(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,TZ_rhs,& - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,betax,betay,betaz,TZ,Symmetry,sst,kappa1,kappa2) -#endif -#if 1 - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGams_rhs,toGams,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGamx_rhs,toGamx,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGamy_rhs,toGamy,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGamz_rhs,toGamz,1.d0,SSA,Symmetry) -#else - call cpbcrgam(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,toGamx_rhs,toGamy_rhs,toGamz_rhs,toGams_rhs,& - chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,betax,betay,betaz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,eta) -#endif -#if 1 - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAss_rhs,toAss,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAsx_rhs,toAsx,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAsy_rhs,toAsy,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAsz_rhs,toAsz,1.d0,SSA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAxx_rhs,toAxx,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAxy_rhs,toAxy,1.d0,AAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAxz_rhs,toAxz,1.d0,ASA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAyy_rhs,toAyy,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAyz_rhs,toAyz,1.d0,SAA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAzz_rhs,toAzz,1.d0,SSS,Symmetry) -#else - call cpbcra(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax, & - toAxx_rhs,toAxy_rhs,toAxz_rhs,toAyy_rhs,toAyz_rhs,toAzz_rhs,& - toAsx_rhs,toAsy_rhs,toAsz_rhs,toAss_rhs, & - chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Lap,betax,betay,betaz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,kappa1) -#endif -! non-cpbc variables -#if (CV == 0) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAqq_rhs,toAqq,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,chi_rhs,chi,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxx_rhs,dxx,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxy_rhs,gxy,1.d0,AAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxz_rhs,gxz,1.d0,ASA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyy_rhs,dyy,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyz_rhs,gyz,1.d0,SAA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gzz_rhs,dzz,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Lap_rhs,Lap,1.d0,SSS,Symmetry) -#if 1 - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetas_rhs,tobetas,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetax_rhs,tobetax,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetay_rhs,tobetay,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetaz_rhs,tobetaz,1.d0,SSA,Symmetry) -#else - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betax_rhs,betax,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betay_rhs,betay,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betaz_rhs,betaz,1.d0,SSA,Symmetry) -#endif - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfx_rhs,dtSfx,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfy_rhs,dtSfy,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfz_rhs,dtSfz,1.d0,SSA,Symmetry) - -#else - call cpbcrACqq(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,toAqq_rhs,& - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,betax,betay,betaz,Axx,Axy,Axz,Ayy,Ayz,Azz,toAss_rhs,Symmetry,sst) -#endif -! reconstruct -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(3,3) = ex(3) - CPBC_ghost_width - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(6,3) = ex(3) - CPBC_ghost_width -endif - -if(dabs(R(1)-zmin) < dR)then - layer(1,6) = 1 - layer(2,6) = 1 - layer(3,6) = 1 - layer(4,6) = ex(1) - layer(5,6) = ex(2) - layer(6,6) = 1 -endif -! fix BD - gp = 6 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -! z direction - TZ_rhs(i,j,k) = ZEO - chi_rhs(i,j,k) = ZEO - trK_rhs(i,j,k) = ZEO - gxx_rhs(i,j,k) = ZEO - gxy_rhs(i,j,k) = ZEO - gxz_rhs(i,j,k) = ZEO - gyy_rhs(i,j,k) = ZEO - gyz_rhs(i,j,k) = ZEO - gzz_rhs(i,j,k) = ZEO - Axx_rhs(i,j,k) = ZEO - Axy_rhs(i,j,k) = ZEO - Axz_rhs(i,j,k) = ZEO - Ayy_rhs(i,j,k) = ZEO - Ayz_rhs(i,j,k) = ZEO - Azz_rhs(i,j,k) = ZEO - Gamx_rhs(i,j,k) = ZEO - Gamy_rhs(i,j,k) = ZEO - Gamz_rhs(i,j,k) = ZEO - Lap_rhs(i,j,k) = ZEO - betax_rhs(i,j,k) = ZEO - betay_rhs(i,j,k) = ZEO - betaz_rhs(i,j,k) = ZEO - dtSfx_rhs(i,j,k) = ZEO - dtSfy_rhs(i,j,k) = ZEO - dtSfz_rhs(i,j,k) = ZEO - enddo - enddo - enddo - endif - -! constraint preserving BD - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -#if (CV == 0) - call compose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - betax_rhs(i,j,k),betay_rhs(i,j,k),betaz_rhs(i,j,k), & - tobetas_rhs(i,j,k),tobetax_rhs(i,j,k),tobetay_rhs(i,j,k),tobetaz_rhs(i,j,k)) -#endif - call compose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - Gamx_rhs(i,j,k),Gamy_rhs(i,j,k),Gamz_rhs(i,j,k), & - toGams_rhs(i,j,k),toGamx_rhs(i,j,k),toGamy_rhs(i,j,k),toGamz_rhs(i,j,k)) - call compose2p1_2(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & - gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & - Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & - toAqq_rhs(i,j,k),toAss_rhs(i,j,k),toAsx_rhs(i,j,k),toAsy_rhs(i,j,k),toAsz_rhs(i,j,k), & - toAxx_rhs(i,j,k),toAxy_rhs(i,j,k),toAxz_rhs(i,j,k),toAyy_rhs(i,j,k),toAyz_rhs(i,j,k),toAzz_rhs(i,j,k)) - - enddo - enddo - enddo - - endif - -! check direct Sommerfeld BD -#else - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,trK_rhs,trK,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,TZ_rhs,TZ,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Gamx_rhs,Gamx,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Gamy_rhs,Gamy,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Gamz_rhs,Gamz,1.d0,SSA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Axx_rhs,Axx,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Axy_rhs,Axy,1.d0,AAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Axz_rhs,Axz,1.d0,ASA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Ayy_rhs,Ayy,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Ayz_rhs,Ayz,1.d0,SAA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Azz_rhs,Azz,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,chi_rhs,chi,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxx_rhs,dxx,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxy_rhs,gxy,1.d0,AAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxz_rhs,gxz,1.d0,ASA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyy_rhs,dyy,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyz_rhs,gyz,1.d0,SAA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gzz_rhs,dzz,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Lap_rhs,Lap,1.d0,SSS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betax_rhs,betax,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betay_rhs,betay,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betaz_rhs,betaz,1.d0,SSA,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfx_rhs,dtSfx,1.d0,ASS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfy_rhs,dtSfy,1.d0,SAS,Symmetry) - call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfz_rhs,dtSfz,1.d0,SSA,Symmetry) -#endif - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) - endif - - return - - end subroutine david_milton_cpbc_ss -#undef CV -#else -!out of time code, never debuged -! need CPBC_ghost_width -!PRD 83, 024025 (2011) - subroutine david_milton_cpbc_ss(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax, & - TZ,chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gamx,Gamy,Gamz, & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz , & - TZ_rhs,chi_rhs,trK_rhs, & - gxx_rhs,gxy_rhs,gxz_rhs,gyy_rhs,gyz_rhs,gzz_rhs, & - Axx_rhs,Axy_rhs,Axz_rhs,Ayy_rhs,Ayz_rhs,Azz_rhs, & - Gamx_rhs,Gamy_rhs,Gamz_rhs, & - Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & - dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & - pGamxxx,pGamxxy,pGamxxz,pGamxyy,pGamxyz,pGamxzz, & - pGamyxx,pGamyxy,pGamyxz,pGamyyy,pGamyyz,pGamyzz, & - pGamzxx,pGamzxy,pGamzxz,pGamzyy,pGamzyz,pGamzzz, & - Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & - Gmxcon,Gmycon,Gmzcon, & - Symmetry,eps,sst) - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3), Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ,chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz,Gmxcon,Gmycon,Gmzcon - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ_rhs,chi_rhs,trK_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxx_rhs,gxy_rhs,gxz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gyy_rhs,gyz_rhs,gzz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx_rhs,Axy_rhs,Axz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Ayy_rhs,Ayz_rhs,Azz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamx_rhs,Gamy_rhs,Gamz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8,intent(in) :: eps -! physical second kind of connection - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxxx, pGamxxy, pGamxxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxyy, pGamxyz, pGamxzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyxx, pGamyxy, pGamyxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyyy, pGamyyz, pGamyzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzxx, pGamzxy, pGamzxz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzyy, pGamzyz, pGamzzz - -!~~~~~~~~~~~> local variables - real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 - real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz - real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: qxx,qxy,qxz,qyy,qyz,qzz - real*8, dimension(ex(1),ex(2),ex(3)) :: qupxx,qupxy,qupxz,qupyy,qupyz,qupzz - real*8, dimension(ex(1),ex(2),ex(3)) :: qulxx,qulxy,qulxz,qulyx,qulyy,qulyz,qulzx,qulzy,qulzz - real*8, dimension(ex(1),ex(2),ex(3)) :: slx,sly,slz,ulx,uly,ulz,wlx,wly,wlz - real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz - real*8, dimension(ex(1),ex(2),ex(3)) :: fx,fy,fz - logical :: gont - real*8 :: dR - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8 :: toAss_rhs,toAqq_rhs,toAs1_rhs,toAs2_rhs,toA11_rhs,toA12_rhs,toA22_rhs - real*8 :: toGams_rhs,toGam1_rhs,toGam2_rhs - real*8 :: totrK_rhs,toTZ_rhs -! derivatives - real*8 :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz - real*8 :: sfxx,sfxy,sfxz,sfyx,sfyy,sfyz,sfzx,sfzy,sfzz - real*8 :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz - real*8 :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz - real*8 :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz - real*8 :: TZx,TZy,TZz - real*8 :: chix,chiy,chiz,Kx,Ky,Kz - real*8 :: Axxx,Axxy,Axxz - real*8 :: Axyx,Axyy,Axyz - real*8 :: Axzx,Axzy,Axzz - real*8 :: Ayyx,Ayyy,Ayyz - real*8 :: Ayzx,Ayzy,Ayzz - real*8 :: Azzx,Azzy,Azzz - real*8 :: gxxx,gxxy,gxxz - real*8 :: gxyx,gxyy,gxyz - real*8 :: gxzx,gxzy,gxzz - real*8 :: gyyx,gyyy,gyyz - real*8 :: gyzx,gyzy,gyzz - real*8 :: gzzx,gzzy,gzzz - real*8 :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8 :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8 :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8 :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8 :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8 :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - real*8 :: Gamxx,Gamxy,Gamxz - real*8 :: Gamyx,Gamyy,Gamyz - real*8 :: Gamzx,Gamzy,Gamzz - real*8 :: Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz - real*8 :: Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz - real*8 :: Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz - real*8 :: Gamxa,Gamya,Gamza - real*8 :: CAZxx,CAZxy,CAZxz - real*8 :: CAZyx,CAZyy,CAZyz - real*8 :: CAZzx,CAZzy,CAZzz -! tilted A^k_iA_kj - real*8 :: AAxx,AAxy,AAxz,AAyy,AAyz,AAzz - real*8 :: Ainvxx,Ainvxy,Ainvxz,Ainvyy,Ainvyz,Ainvzz - real*8 :: liegxx,liegxy,liegxz,liegyy,liegyz,liegzz - real*8 :: fxx,fxy,fxz,fyy,fyz,fzz - real*8 :: TFxx,TFxy,TFxz,TFyy,TFyz,TFzz - - real*8 :: MapleGenVar1,MapleGenVar2,MapleGenVar3,MapleGenVar4 - real*8 :: f,betas - - real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0,HALF=0.5d0 - real*8,parameter::TINYRR=1.d-14 -! in order to synchronize the following parameters with Z4c_rhs calculation, we -! call a routine - real*8 :: muL,tmuSL,tmuST - real*8 :: kappa1,kappa2,kappa3,FF,eta - - real*8,parameter :: ha=0.d0,thbs=0.d0,hu=0.d0,hw=0.d0,Rhpsi0=0.d0,Ihpsi0=0.d0 - - call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) - - dR = R(2) - R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(3,3) = ex(3) - CPBC_ghost_width - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(6,3) = ex(3) - CPBC_ghost_width -endif - -if(dabs(R(1)-zmin) < dR)then - layer(1,6) = 1 - layer(2,6) = 1 - layer(3,6) = 1 - layer(4,6) = ex(1) - layer(5,6) = ex(2) - layer(6,6) = 1 -endif -! fix BD - gp = 6 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -! z direction - TZ_rhs(i,j,k) = ZEO - chi_rhs(i,j,k) = ZEO - trK_rhs(i,j,k) = ZEO - gxx_rhs(i,j,k) = ZEO - gxy_rhs(i,j,k) = ZEO - gxz_rhs(i,j,k) = ZEO - gyy_rhs(i,j,k) = ZEO - gyz_rhs(i,j,k) = ZEO - gzz_rhs(i,j,k) = ZEO - Axx_rhs(i,j,k) = ZEO - Axy_rhs(i,j,k) = ZEO - Axz_rhs(i,j,k) = ZEO - Ayy_rhs(i,j,k) = ZEO - Ayz_rhs(i,j,k) = ZEO - Azz_rhs(i,j,k) = ZEO - Gamx_rhs(i,j,k) = ZEO - Gamy_rhs(i,j,k) = ZEO - Gamz_rhs(i,j,k) = ZEO - Lap_rhs(i,j,k) = ZEO - betax_rhs(i,j,k) = ZEO - betay_rhs(i,j,k) = ZEO - betaz_rhs(i,j,k) = ZEO - dtSfx_rhs(i,j,k) = ZEO - dtSfy_rhs(i,j,k) = ZEO - dtSfz_rhs(i,j,k) = ZEO - enddo - enddo - enddo - endif - -! constraint preserving BD - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - -! cpbc real starts - - alpn1 = Lap + ONE - chin1 = chi + ONE - gxx = dxx + ONE - gyy = dyy + ONE - gzz = dzz + ONE -! invert tilted metric - gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & - gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz - gupxx = ( gyy * gzz - gyz * gyz ) / gupzz - gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz - gupxz = ( gxy * gyz - gyy * gxz ) / gupzz - gupyy = ( gxx * gzz - gxz * gxz ) / gupzz - gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz - gupzz = ( gxx * gyy - gxy * gxy ) / gupzz -! tetrad for 2+1 decomposation - do i=1,ex(1) - do j=1,ex(2) - do k=1,ex(3) - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then - vx(i,j,k) = TINYRR - vy(i,j,k) = TINYRR - vz(i,j,k) = TINYRR - else - vx(i,j,k) = X(i,j,k) - vy(i,j,k) = Y(i,j,k) - vz(i,j,k) = Z(i,j,k) - endif - if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then - ux(i,j,k) = - TINYRR - uy(i,j,k) = TINYRR - uz(i,j,k) = ZEO - wx(i,j,k) = TINYRR*Z(i,j,k) - wy(i,j,k) = TINYRR*Z(i,j,k) - wz(i,j,k) = -2*TINYRR*TINYRR - else - ux(i,j,k) = - Y(i,j,k) - uy(i,j,k) = X(i,j,k) - uz(i,j,k) = ZEO - wx(i,j,k) = X(i,j,k)*Z(i,j,k) - wy(i,j,k) = Y(i,j,k)*Z(i,j,k) - wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) - endif - enddo - enddo - enddo - -! v^i corresponds to s^i - fx = vx - fy = vy - fz = vz - slx = vx - sly = vy - slz = vz - vx = gupxx*fx + gupxy*fy + gupxz*fz - vy = gupxy*fx + gupyy*fy + gupyz*fz - vz = gupxz*fx + gupyz*fy + gupzz*fz - - fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & - +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO - fx = dsqrt(fx*chin1) - vx = vx/fx - vy = vy/fx - vz = vz/fx - slx = slx/fx - sly = sly/fx - slz = slz/fx -! 2+1: 1->u, 2->w - fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & - gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & - gxz*vz*ux + gyz*vz*uy + gzz*vz*uz - fx = fx/chin1 - ux = ux - fx*vx - uy = uy - fx*vy - uz = uz - fx*vz - fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & - +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO - fx = dsqrt(fx/chin1) - ux = ux/fx - uy = uy/fx - uz = uz/fx - ulx = (gxx*ux+gxy*uy+gxz*uz)/chin1 - uly = (gxy*ux+gyy*uy+gyz*uz)/chin1 - ulz = (gxz*ux+gyz*uy+gzz*uz)/chin1 - - fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & - gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & - gxz*vz*wx + gyz*vz*wy + gzz*vz*wz - fx = fx/chin1 - wx = wx - fx*vx - wy = wy - fx*vy - wz = wz - fx*vz - fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & - gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & - gxz*uz*wx + gyz*uz*wy + gzz*uz*wz - fx = fx/chin1 - wx = wx - fx*ux - wy = wy - fx*uy - wz = wz - fx*uz - fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & - +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO - fx = dsqrt(fx/chin1) - wx = wx/fx - wy = wy/fx - wz = wz/fx - wlx = (gxx*wx+gxy*wy+gxz*wz)/chin1 - wly = (gxy*wx+gyy*wy+gyz*wz)/chin1 - wlz = (gxz*wx+gyz*wy+gzz*wz)/chin1 -!~ end tetrad - - qupxx = gupxx*chin1 - vx*vx - qupxy = gupxy*chin1 - vx*vy - qupxz = gupxz*chin1 - vx*vz - qupyy = gupyy*chin1 - vy*vy - qupyz = gupyz*chin1 - vy*vz - qupzz = gupzz*chin1 - vz*vz - - qxx = gxx/chin1 - slx*slx - qxy = gxy/chin1 - slx*sly - qxz = gxz/chin1 - slx*slz - qyy = gyy/chin1 - sly*sly - qyz = gyz/chin1 - sly*slz - qzz = gzz/chin1 - slz*slz - - qulxx = ONE - vx*slx - qulyy = ONE - vy*sly - qulzz = ONE - vz*slz - qulxy = - vx*sly - qulyx = - vy*slx - qulxz = - vx*slz - qulzx = - vz*slx - qulyz = - vy*slz - qulzy = - vz*sly - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) -!calculate the involved derivatives - call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,betax,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,betay,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,betaz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - - liegxx = betax(i,j,k)*gxxx+gxx(i,j,k)*sfxx+betay(i,j,k)*gxxy-gxx(i,j,k)*sfyy+2.0*sfyx*gxy(i,j,k)+betaz(i,j,k)*gxxz-gxx(i,j,k)*sfzz+2.0*sfzx*gxz(i,j,k) - liegxy = betax(i,j,k)*gxyx+sfxy*gxx(i,j,k)+betay(i,j,k)*gxyy+sfyx*gyy(i,j,k)+betaz(i,j,k)*gxyz-gxy(i,j,k)*sfzz+sfzx*gyz(i,j,k)+sfzy*gxz(i,j,k) - liegxz = betax(i,j,k)*gxzx+sfxz*gxx(i,j,k)+betay(i,j,k)*gxzy-gxz(i,j,k)*sfyy+sfyx*gyz(i,j,k)+sfyz*gxy(i,j,k)+betaz(i,j,k)*gxzz+sfzx*gzz(i,j,k) - liegyy = betax(i,j,k)*gyyx-gyy(i,j,k)*sfxx+2.0*sfxy*gxy(i,j,k)+betay(i,j,k)*gyyy+gyy(i,j,k)*sfyy+betaz(i,j,k)*gyyz-gyy(i,j,k)*sfzz+2.0*sfzy*gyz(i,j,k) - liegyz = betax(i,j,k)*gyzx-gyz(i,j,k)*sfxx+sfxy*gxz(i,j,k)+sfxz*gxy(i,j,k)+betay(i,j,k)*gyzy+sfyz*gyy(i,j,k)+betaz(i,j,k)*gyzz+sfzy*gzz(i,j,k) - liegzz = betax(i,j,k)*gzzx-gzz(i,j,k)*sfxx+2.0*sfxz*gxz(i,j,k)+betay(i,j,k)*gzzy-gzz(i,j,k)*sfyy+2.0*sfyz*gyz(i,j,k)+betaz(i,j,k)*gzzz+gzz(i,j,k)*sfzz - - call point_fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - - MapleGenVar3 = gupxy(i,j,k)*gupxy(i,j,k)*gxxyy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz+gupxy(i,j,k)*& -gupxy(i,j,k)*gxyxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gxyy+gupxx(i,j,k)*gupyz(i,j,k)*gxyxz+gupxz(i,j,k)*gupxz(i,j,k)*gxxzz& --2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxxz*gxxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzz*gxzz-2.0*gupxx(i,j,k)*& -gupxx(i,j,k)*gupyy(i,j,k)*gxxy*gxxy+gupxx(i,j,k)*gupyy(i,j,k)*gxyxy+gupxz(i,j,k)*gupzz(i,j,k)*gxzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)& -*gxzx*gxzx+2.0*gupxx(i,j,k)*gupxz(i,j,k)*gxxxz+gupxz(i,j,k)*gupyy(i,j,k)*gxyyz+gupxx(i,j,k)*gupyz(i,j,k)*gxzxy+gupxy(i,j,k)*& -gupzz(i,j,k)*gxzyz+2.0*gupxy(i,j,k)*gupxz(i,j,k)*gxxyz+2.0*gupxx(i,j,k)*gupxy(i,j,k)*gxxxy+gupxz(i,j,k)*gupxy(i,j,k)*gxyxz+gupxz(i,j,k)& -*gupyz(i,j,k)*gxyzz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxyx-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy+& -gupxx(i,j,k)*gupxx(i,j,k)*gxxxx+gupxx(i,j,k)*gupxz(i,j,k)*gxzxx-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxzy*gxzy+gupxx(i,j,k)*gupzz(i,j,k)& -*gxzxz - MapleGenVar4 = gupxz(i,j,k)*gupyz(i,j,k)*gxzyz+gupxy(i,j,k)*gupyz(i,j,k)*gxyyz+gupxy(i,j,k)*gupyz(i,j,k)*gxzyy+& -gupxx(i,j,k)*gupxy(i,j,k)*gxyxx+gupxy(i,j,k)*gupxz(i,j,k)*gxzxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gxyz+gupxy(i,j,k)*gupyy(i,j,k)& -*gxyyy+gupxz(i,j,k)*gupxz(i,j,k)*gxzxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxxz-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*& -gxxx*gxxx-6.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxxz*gxyz-6.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyx-6.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxzx - MapleGenVar2 = MapleGenVar4-gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)& --4.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxxy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*gxyy-4.0*gupxx(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-gupxx(i,j,k)& -*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-4.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gxzy+gxzx*gxxy)-& -gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)& --4.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxxx*gxzz+MapleGenVar3 - MapleGenVar4 = -4.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupxx(i,j,k)*gupxz(i,j,k)*& -gupyy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-4.0*gupxx(i,j,k)*& -gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gxzz+gxzx*gxxz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-gupxx(i,j,k)& -*gupxz(i,j,k)*gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-gupxx(i,j,k)*gupxy(i,j,k)*& -gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)& -*gupyz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxx(i,j,k)*& -gupyy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy) - MapleGenVar3 = MapleGenVar4-gupxx(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-4.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxxy*gxxz-4.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupxx(i,j,k)*& -gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-4.0*& -gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gxzz+gxzy*gxxz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz)& --gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-gupxx(i,j,k)*& -gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxx(i,j,k)& -*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-& -gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz) - MapleGenVar4 = -gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)& -*(gxxz*gyzy+gxyy*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*& -gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*& -gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*& -gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)& --gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+gxyx*gxyy& -)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyx*gyyy-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyx*gyzy - MapleGenVar1 = MapleGenVar4-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)& --gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz& -)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxyz-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxzy-2.0*gupxx(i,j,k)*& -gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxyz-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxxy-6.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*& -gxxy*gxyy-6.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxxy*gxzy-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxxy*gxyz+& -MapleGenVar3+MapleGenVar2 - MapleGenVar4 = MapleGenVar1-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxxy*gxzz-2.0*gupxx(i,j,k)*& -gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxxz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxxz-6.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*& -gxxz*gxzz-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-4.0*& -gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyx*gyyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*& -gupyz(i,j,k)*gxyx*gyzz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gxzz+gxzx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(& -gxyx*gyzz+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzx*gyzz) - MapleGenVar3 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyx-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzx-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)& -*(gxyy*gzzx+gxzy*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& -gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(& -gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*& -(gxxy*gyyz+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxyy*gxzz) - MapleGenVar4 = MapleGenVar3-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gxyz-2.0*gupxy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*& -gupyz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupxy(i,j,k)*gupxy(i,j,k)& -*gupxz(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxy(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupyz(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy) - MapleGenVar2 = MapleGenVar4-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupzz(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-& -gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)& --gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx& -)-gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxzx*& -gxyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzx& -*gyyy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxzy-& -gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyzz+gxzx*gxyz) - MapleGenVar4 = MapleGenVar2-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxz(i,j,k)& -*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzx*gyzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzx*gzzz-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(& -gxxy*gyzx+gxyx*gxzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*& -(gxyy*gyzx+gxzy*gyyx)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)& -*(gxxy*gzzy+gxzy*gxzy)-gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxz(i,j,k)*gupyy(i,j,k)*& -gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy) - MapleGenVar3 = MapleGenVar4-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-gupxz(i,j,k)& -*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-& -gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxzz-2.0*& -gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)& -*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupxz(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-4.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyy*gyyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*& -gxyz*gyyx - MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyz*gyzx-2.0*gupxy(i,j,k)*& -gupyz(i,j,k)*gupyy(i,j,k)*gxyz*gyyy-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*& -gxyz*gyzz-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*& -gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzx*gyzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*& -gupzz(i,j,k)*gxzx*gzzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxzy*gzzx& --2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy - CAZxx = Gamxx - (MapleGenVar4-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzy*gzzz-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzx-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzz*gzzx-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*& -gyzy+gxyy*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz& -*gyzy+gxzz*gyyy)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*& -gxzz*gyzy-gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz+& -gxzz*gyyz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*& -gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gzzy-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz) - MapleGenVar3 = -2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz+gupxy(i,j,k)*gupyz(i,j,k)*gxzxy+2.0*& -gupxy(i,j,k)*gupyy(i,j,k)*gxyxy+gupxy(i,j,k)*gupxz(i,j,k)*gxzxx+gupxy(i,j,k)*gupxy(i,j,k)*gxyxx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*& -gxxx*gxxx+2.0*gupxy(i,j,k)*gupyz(i,j,k)*gxyxz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy+gupyz(i,j,k)*gupxz(i,j,k)*& -gxxzz+gupxy(i,j,k)*gupxy(i,j,k)*gxxxy+gupxy(i,j,k)*gupxx(i,j,k)*gxxxx+gupyy(i,j,k)*gupxx(i,j,k)*gxxxy+gupxy(i,j,k)*gupxz(i,j,k)*gxxxz+& -gupxy(i,j,k)*gupzz(i,j,k)*gxzxz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzz*gyzy+gupyy(i,j,k)*gupxy(i,j,k)*gxxyy+gupyz(i,j,k)*gupxz(i,j,k)& -*gxzxz+2.0*gupyy(i,j,k)*gupyz(i,j,k)*gxyyz+gupyz(i,j,k)*gupzz(i,j,k)*gxzzz+gupyy(i,j,k)*gupzz(i,j,k)*gxzyz-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*gxyy+gupyy(i,j,k)*gupxz(i,j,k)*gxxyz+gupyz(i,j,k)*& -gupyz(i,j,k)*gxzyz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxyy - MapleGenVar4 = gupyz(i,j,k)*gupxx(i,j,k)*gxxxz+gupyz(i,j,k)*gupxy(i,j,k)*gxxyz+gupyy(i,j,k)*gupxz(i,j,k)*gxzxy+& -gupyz(i,j,k)*gupyz(i,j,k)*gxyzz+gupyy(i,j,k)*gupyz(i,j,k)*gxzyy+gupyy(i,j,k)*gupyy(i,j,k)*gxyyy-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*& -gzzx+gxzy*gyzx)-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxxx*gxxz-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*gxyx& --2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-3.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+& -gxyx*gxzx)-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*& -gxxy - MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxzy-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gxzy+gxzx*& -gxxy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+& -gxzx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxxx*gxzz-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxx*gyyz+gxyx*& -gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gxzz+& -gxzx*gxxz)+MapleGenVar3 - MapleGenVar4 = -2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*& -gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*& -gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-2.0*& -gupxy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxxy-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxxy*gxyy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& -gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-3.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxy(i,j,k)*& -gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxxy*gxyz - MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gxyz+gxyy*gxxz)& --2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*& -gxzz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gxzz+gxzy*gxxz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*& -gyzz+gxzy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*& -gxyx*gxxz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx& -*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx& -+gxyx*gxzz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*& -gxxz - MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*& -gxzz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxxz& --4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxxz*gxyz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)& --3.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*& -gxzz)-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx-gupyy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)& --2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx - MapleGenVar1 = MapleGenVar4-4.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxzx-4.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gupxz(i,j,k)*gxxy*gxzy-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxxz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*& -gxxy*gxzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxxz-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxxz*gxzz-2.0*& -gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxyx*gyyx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-gupyy(i,j,k)*& -gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-& -gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-4.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*& -gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyx*gyyy+MapleGenVar2 - MapleGenVar4 = -2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-2.0*gupyy(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*& -gupyy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)& --2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyx*gyyz-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gxzz+gxzx*gxyz)& --2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzx*& -gyzz)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyyx& --2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzy*gyyx) - MapleGenVar3 = MapleGenVar4-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-2.0*& -gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxyy-gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupyy(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(& -gxyy*gyzy+gxzy*gyyy)-gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*& -gupxx(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*gupyy(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyyz-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(& -gxyy*gxzz+gxzy*gxyz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzy*gyyz) - MapleGenVar4 = MapleGenVar3-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupyy(i,j,k)& -*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyz*gyyx-2.0*gupyy(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupyy(i,j,k)& -*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyz*gyyy-2.0*gupyy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-gupyy(i,j,k)*gupyz(i,j,k)*& -gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupyy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*gupyy(i,j,k)*& -gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz - MapleGenVar2 = MapleGenVar4-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxyz*gyyz-2.0*gupyy(i,j,k)*& -gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*& -gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxzx-gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupyz(i,j,k)*gupyz(i,j,k)& -*gupxx(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxzx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*& -gupxx(i,j,k)*gxzx*gyzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gxzy+gxzx*gxxy)-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(& -gxxx*gzzy+gxzx*gxzy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-gupyz(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxzx*gyzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& -gupxx(i,j,k)*(gxxx*gxzz+gxzx*gxxz) - MapleGenVar4 = MapleGenVar2-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*& -gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gxzz+gxzx*gxyz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)& --4.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzx*gyzz-gupyz(i,j,k)*gupxy(i,j,k)*& -gupxz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*& -gupxz(i,j,k)*gxyx*gxzx-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyx*gyzy-4.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxyz& --2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyx*gyzz-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzx - MapleGenVar3 = MapleGenVar4-4.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz-2.0*gupyy(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*gxyz*gyzx-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxyz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*& -gxyz*gyzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxzx-2.0*& -gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy-2.0*gupyz(i,j,k)*gupxy(i,j,k)*& -gupzz(i,j,k)*gxzx*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzx*gzzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxzy*gyzx& --gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gzzy+gxzy*gyzy& -) - MapleGenVar4 = MapleGenVar3-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gxzy-2.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupyy(i,j,k)*gxzy*gyzy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gxzz+gxzy*gxxz)-gupyz(i,j,k)*gupyz(i,j,k)*& -gupxz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-gupyz(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupzz(i,j,k)*gxzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)& -*(gxyz*gzzx+gxzz*gyzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzz*gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*& -gzzy+gxzy*gxzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+gxzz*gyzy) - CAZyx = Gamyx - (MapleGenVar4-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gzzy-gupyz(i,j,k)*gupzz(i,j,k)*& -gupxz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupyz(i,j,k)*& -gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gyzz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*& -gxzz*gzzz-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxzy*gzzx-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxzy-2.0*& -gupyz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxzy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& -gupzz(i,j,k)*gxzz*gzzx-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxzz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxzz& -+MapleGenVar1) - MapleGenVar3 = gupzz(i,j,k)*gupxz(i,j,k)*gxxzz+gupyz(i,j,k)*gupxz(i,j,k)*gxxyz+gupyz(i,j,k)*gupyz(i,j,k)*gxyyz+2.0*& -gupyz(i,j,k)*gupzz(i,j,k)*gxzyz+gupyz(i,j,k)*gupxx(i,j,k)*gxxxy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz-2.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy+gupzz(i,j,k)*gupxy(i,j,k)*gxyxz+gupyz(i,j,k)*gupxy(i,j,k)*gxxyy+gupzz(i,j,k)*gupyz(i,j,k)*gxyzz+& -gupxz(i,j,k)*gupxz(i,j,k)*gxxxz+2.0*gupxz(i,j,k)*gupzz(i,j,k)*gxzxz-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxxx+gupzz(i,j,k)*& -gupxy(i,j,k)*gxxyz+gupxz(i,j,k)*gupyz(i,j,k)*gxyxz+gupxz(i,j,k)*gupxy(i,j,k)*gxxxy+gupzz(i,j,k)*gupzz(i,j,k)*gxzzz+gupyz(i,j,k)*gupyy(i,j,k)*& -gxyyy+gupxz(i,j,k)*gupyy(i,j,k)*gxyxy+gupyz(i,j,k)*gupyz(i,j,k)*gxzyy+gupxz(i,j,k)*gupxz(i,j,k)*gxzxx+gupzz(i,j,k)*gupxx(i,j,k)*gxxxz+& -2.0*gupxz(i,j,k)*gupyz(i,j,k)*gxzxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*& -gxyy*gyzz - MapleGenVar4 = MapleGenVar3+gupzz(i,j,k)*gupyy(i,j,k)*gxyyz+gupxz(i,j,k)*gupxy(i,j,k)*gxyxx-2.0*gupzz(i,j,k)& -*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*gzzz+gupxz(i,j,k)*gupxx(i,j,k)*gxxxx+gupyz(i,j,k)*gupxy(i,j,k)*gxyxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*& -gupxz(i,j,k)*gxxx*gxzz-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxyy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxxx*gxzx& --gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-3.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*& -gxzx)-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*& -gxyy - MapleGenVar2 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxzy-2.0*gupxz(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-2.0*& -gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gxzy+gxzx*& -gxxy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+& -gxzx*gxzy)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxxx*gxxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxyz-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gxzz+& -gxzx*gxxz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz) - MapleGenVar4 = MapleGenVar2-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)& --2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxxy-gupxz(i,j,k)*gupxy(i,j,k)*& -gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-gupxz(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)& --2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxxy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxxy*gxzy-gupxz(i,j,k)*gupyy(i,j,k)*& -gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-3.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*& -gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy) - MapleGenVar3 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxxy*gxzz-2.0*gupxz(i,j,k)*& -gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-2.0*& -gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gxzz+gxzy*& -gxxz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+& -gxzy*gxzz)-4.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyx-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*gxxy-4.0*& -gupxz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxxy*gxyy-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxxz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*gxxy*gxyz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxxz - MapleGenVar4 = MapleGenVar3-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxxz-& -gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*& -gxyz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+& -gxzy*gxzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxxz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxxz*gxzz-& -gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz) - MapleGenVar1 = MapleGenVar4-3.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)& --2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx-& -gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxyx*gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupyz(i,j,k)*& -gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-& -gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyx*gyzy-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-gupyz(i,j,k)*& -gupyz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxzx*gyyy) - MapleGenVar4 = MapleGenVar1-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)& --2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyyz+gxyx*& -gxyz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyx*gyzz-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gxzz+gxzx*& -gxyz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+& -gxzx*gyzz)-gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*& -gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+& -gxzy*gyzx) - MapleGenVar3 = MapleGenVar4-gupyz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*& -gupyz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxyy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*& -gupyy(i,j,k)*gxyy*gyzy-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(& -gxyy*gzzy+gxzy*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupyz(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*& -gupyy(i,j,k)*gxyy*gyyz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(& -gxyy*gyzz+gxzy*gyyz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz) - MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyz*gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupyz(i,j,k)*& -gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyz*gyyy-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-2.0*& -gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxyz*gyzz-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(& -gxyz*gyzz+gxzz*gyyz) - MapleGenVar2 = MapleGenVar4-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)& --2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxxz-4.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxxz*gxyz-2.0*gupyz(i,j,k)*& -gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*& -gxyx*gyyy-4.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxyz-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyx*gyyz-2.0*& -gupyz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyx-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& -gupyy(i,j,k)*gxyz*gyyx-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxyz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz& --2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz - MapleGenVar4 = MapleGenVar2-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxzx-gupzz(i,j,k)*gupxx(i,j,k)*& -gupxy(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupzz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupzz(i,j,k)*& -gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxzx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxzx*gzzx-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(& -gxxx*gxzy+gxzx*gxxy)-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-2.0*gupzz(i,j,k)*gupxy(i,j,k)*& -gupxy(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-gupzz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-2.0*gupzz(i,j,k)*& -gupzz(i,j,k)*gupxy(i,j,k)*gxzx*gzzy-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gxzz+gxzx*gxxz)-gupzz(i,j,k)*gupxz(i,j,k)*& -gupxy(i,j,k)*(gxxx*gyzz+gxzx*gxyz) - MapleGenVar3 = MapleGenVar4-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gxzz+gxzx*gxyz)-& -gupzz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-4.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*& -gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzx*gzzz-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupzz(i,j,k)*gupxy(i,j,k)& -*gupyy(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxzy*gzzx-gupzz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*& -(gxxy*gyzy+gxyy*gxzy)-gupzz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupzz(i,j,k)*gupyy(i,j,k)*& -gupxz(i,j,k)*gxzy*gxzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxzy*gzzy-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*& -gxzz+gxzy*gxxz)-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxzy*gxyz) - MapleGenVar4 = MapleGenVar3-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-& -gupzz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz-2.0*& -gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzy*gzzz-gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupzz(i,j,k)*gupxz(i,j,k)& -*gupyy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gzzx-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*& -(gxxz*gyzy+gxyy*gxzz)-gupzz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*& -gupyz(i,j,k)*gxzz*gyzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gzzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxzz& --gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzz+gxyz*gxzz) - CAZzx = Gamzx -(MapleGenVar4-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxzz-gupzz(i,j,k)*gupzz(i,j,k)*& -gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz-2.0*gupzz(i,j,k)*gupxx(i,j,k)*& -gupxy(i,j,k)*gxyx*gxzx-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-4.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy& --2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzx*gyzy-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzx*gyzz-2.0*gupzz(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gyzx-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxzy-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*& -gxyy*gxzy-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-4.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*& -gupzz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzx) - MapleGenVar3 = gupxz(i,j,k)*gupxz(i,j,k)*gyzxz+2.0*gupxy(i,j,k)*gupxz(i,j,k)*gxyyz+gupxx(i,j,k)*gupyz(i,j,k)*gyzxy& --2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyyy+gupxx(i,j,k)*gupxx(i,j,k)*gxyxx+gupxy(i,j,k)*gupyz(i,j,k)*gyzyy-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gyzz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gyyy+gupxy(i,j,k)*gupyy(i,j,k)*gyyyy+gupxz(i,j,k)*& -gupyz(i,j,k)*gyyzz+gupxy(i,j,k)*gupzz(i,j,k)*gyzyz+gupxx(i,j,k)*gupyz(i,j,k)*gyyxz+gupxy(i,j,k)*gupyz(i,j,k)*gyyyz-2.0*gupxx(i,j,k)*& -gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx+gupxy(i,j,k)*gupxy(i,j,k)*gxyyy+gupxz(i,j,k)*gupyy(i,j,k)*gyyyz+gupxz(i,j,k)*gupxy(i,j,k)*gyyxz+& -gupxx(i,j,k)*gupxz(i,j,k)*gyzxx+gupxz(i,j,k)*gupxz(i,j,k)*gxyzz+2.0*gupxx(i,j,k)*gupxy(i,j,k)*gxyxy+2.0*gupxx(i,j,k)*gupxz(i,j,k)*gxyxz& -+gupxz(i,j,k)*gupzz(i,j,k)*gyzzz-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx+gupxy(i,j,k)*gupxy(i,j,k)*gyyxy+gupxz(i,j,k)*& -gupyz(i,j,k)*gyzyz - MapleGenVar4 = MapleGenVar3-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*gyzx-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyyx+gupxx(i,j,k)*gupzz(i,j,k)*gyzxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxyz*& -gyzx)+gupxx(i,j,k)*gupxy(i,j,k)*gyyxx-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-4.0*gupxy(i,j,k)*& -gupxz(i,j,k)*gupyy(i,j,k)*gyyx*gyyz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)+gupxx(i,j,k)*gupyy(i,j,k)*& -gyyxy-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)+gupxy(i,j,k)*gupxz(i,j,k)*gyzxy-4.0*gupxx(i,j,k)*gupxz(i,j,k)& -*gupxy(i,j,k)*gxyx*gxyz - MapleGenVar2 = MapleGenVar4-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupxx(i,j,k)*& -gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-gupxx(i,j,k)*gupxx(i,j,k)*& -gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupxx(i,j,k)*& -gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-4.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(& -gxxy*gyyx+gxyx*gxyy)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)-gupxx(i,j,k)*gupxy(i,j,k)*& -gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-2.0*& -gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxyy*gyzx) - MapleGenVar4 = MapleGenVar2-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*& -gupxy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)-gupxx(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzy-gupxx(i,j,k)*gupxz(i,j,k)*& -gupzz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*& -gupxy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxx(i,j,k)*& -gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxzx*gxyy) - MapleGenVar3 = MapleGenVar4-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxxy*gxyy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxyy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*& -gupxy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(& -gxyy*gyzy+gxzy*gyyy)-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*& -gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyy*gxxz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-gupxx(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxyy*gxzz) - MapleGenVar4 = MapleGenVar3-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxyz*gyzy)-& -gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxyz-2.0*& -gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxx(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-& -gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxxy*gxyz-2.0*& -gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)& --2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxzy*gxyz) - MapleGenVar1 = MapleGenVar4-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxxz*gxyz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*& -gupxy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxx(i,j,k)*& -gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-4.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gyyx-3.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*& -gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyyx-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-4.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyyx*gyyy - MapleGenVar4 = MapleGenVar1-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyyx*gyzy-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gyzy+gyzx*gyyy)-& -gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyyz+gxyz*& -gyyx)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyz*gyyx& --2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gyzz+& -gyzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx& -+gxzx*gyyy) - MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyyy-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-4.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-3.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*& -gupyy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-& -gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyz*gyyy-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*& -gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxyy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy - MapleGenVar4 = MapleGenVar3-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-4.0*gupxx(i,j,k)*& -gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyy*gxzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*& -gxzy*gxyz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz-2.0*& -gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxyz*gyzz-4.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyyx*gyzx-2.0*gupxy(i,j,k)*gupxz(i,j,k)*& -gupyz(i,j,k)*gyyx*gyzz-4.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzy-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyyz& --gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzx*gyyz) - MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gyyz-2.0*gupxy(i,j,k)*& -gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupxy(i,j,k)& -*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyyz-2.0*gupxy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-gupxy(i,j,k)*gupyz(i,j,k)*& -gupzz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gyyz-3.0*gupxy(i,j,k)*gupzz(i,j,k)*& -gupxz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyyz-gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(& -gyyz*gzzz+gyzz*gyzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*& -(gyyx*gzzx+gyzx*gyzx) - MapleGenVar4 = MapleGenVar2-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gyzx-2.0*gupxz(i,j,k)*& -gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*& -gupxy(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gyyx*gyzy+gyzx*gyyy)-gupxz(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzy*gyzx-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzz+gxyz*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyx*gyzz+gyzx*gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)& --4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyzz - MapleGenVar3 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzx*gzzz-gupxz(i,j,k)*gupxz(i,j,k)*& -gupxy(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gyzy-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*& -gupyy(i,j,k)*gyyy*gyzy-gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*& -gxzy*gyzy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyzz+gxyz& -*gyzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gyzz& -+gyzy*gyyz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz) - MapleGenVar4 = MapleGenVar3-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzy-4.0*gupxz(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)& -*(gyyz*gzzx+gyzx*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzz*gzzx-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*& -gzzy+gxzy*gyzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*& -gxzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzz+& -gyzz*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzz*gyzz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz-2.0*& -gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyyz - CAZxy = Gamxy - (MapleGenVar4-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyyz*gyzz-2.0*gupxz(i,j,k)*& -gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyzx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyzx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& -gyzx*gzzx-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzx*gzzy-2.0*& -gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzy*gzzx-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyzy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*& -gupzz(i,j,k)*gyzy*gzzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzy*gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzy& --2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyzz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyzz-2.0*gupxz(i,j,k)*& -gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz) - MapleGenVar3 = gupxy(i,j,k)*gupxy(i,j,k)*gxyxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gxyy+gupxx(i,j,k)*& -gupyz(i,j,k)*gxyxz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gyyx*gyyx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gyzz+& -gupxx(i,j,k)*gupyy(i,j,k)*gxyxy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gyzy+gupxy(i,j,k)*gupyz(i,j,k)*gyzxy+gupxz(i,j,k)*gupyy(i,j,k)& -*gxyyz+gupyz(i,j,k)*gupyz(i,j,k)*gyzyz+2.0*gupyy(i,j,k)*gupyz(i,j,k)*gyyyz+gupyy(i,j,k)*gupzz(i,j,k)*gyzyz+2.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gyyxy+gupxz(i,j,k)*gupxy(i,j,k)*gxyxz+gupxz(i,j,k)*gupyz(i,j,k)*gxyzz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxyx& -+gupxy(i,j,k)*gupxz(i,j,k)*gyzxx+gupyy(i,j,k)*gupxz(i,j,k)*gyzxy-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy+gupyz(i,j,k)*& -gupxz(i,j,k)*gyzxz+gupyy(i,j,k)*gupyz(i,j,k)*gyzyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gyzx*gyzx+gupyz(i,j,k)*gupyz(i,j,k)*gyyzz& --4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz+gupyz(i,j,k)*gupzz(i,j,k)*gyzzz+gupxy(i,j,k)*gupyz(i,j,k)*gxyyz - MapleGenVar4 = MapleGenVar3+gupxy(i,j,k)*gupzz(i,j,k)*gyzxz+gupxx(i,j,k)*gupxy(i,j,k)*gxyxx-2.0*gupxy(i,j,k)& -*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gxyz+gupxy(i,j,k)*gupyy(i,j,k)*gxyyy-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyyy+gupxy(i,j,k)*& -gupxy(i,j,k)*gyyxx+gupyy(i,j,k)*gupyy(i,j,k)*gyyyy+2.0*gupxy(i,j,k)*gupyz(i,j,k)*gyyxz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyyz*& -gyyz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxxz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxxz*gxyz-2.0*gupxx(i,j,k)*& -gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyx - MapleGenVar2 = MapleGenVar4-gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-gupxx(i,j,k)& -*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*gxyy-gupxx(i,j,k)*gupxy(i,j,k)*& -gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-gupxx(i,j,k)*gupxz(i,j,k)& -*gupyy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-2.0*gupxx(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)& -*(gxxy*gyzx+gxyx*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-gupxx(i,j,k)*gupyy(i,j,k)*& -gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)& -*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz) - MapleGenVar4 = MapleGenVar2-gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxx(i,j,k)& -*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-& -gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)& --gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyyx+gxyx*gxyx& -)-gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx& -*gyyx)-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+& -gxyx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyx*gyyy - MapleGenVar3 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxyz-2.0*gupxx(i,j,k)*& -gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxyz-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxxy*gxyy-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*& -gxxy*gxyz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxxz-6.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-4.0*& -gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupxy(i,j,k)*gupxz(i,j,k)*& -gupyy(i,j,k)*gxyx*gyyz-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy& -*gyyx+gxyx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyx - MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-6.0*& -gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*& -gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-4.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gxyz-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-gupxy(i,j,k)*gupxy(i,j,k)& -*gupxz(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupxy(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy) - MapleGenVar1 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-gupxy(i,j,k)& -*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-& -gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*& -gyyx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxzx& -*gxyy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyzz+& -gxzx*gxyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzx*& -gyzz-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzx+gxzy*& -gyyx)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy) - MapleGenVar4 = MapleGenVar1-gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxz(i,j,k)& -*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-2.0*& -gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)& -*gupyy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-4.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& -gupxz(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyy*gyyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyz*gyyx& --2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyz*gyyy-6.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz - MapleGenVar3 = MapleGenVar4-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxyz*gyzz-2.0*gupxy(i,j,k)*& -gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*& -gxzx*gyzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gyzx-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzx-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)& -*gupyy(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzz*gyzy-2.0*gupxz(i,j,k)*gupzz(i,j,k)*& -gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxz(i,j,k)*& -gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz - MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzy-4.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-4.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)& --2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)-& -gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxyz*& -gyzx)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxyy-& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzx*gyzy) - - MapleGenVar2 = MapleGenVar4-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxyz*& -gyzy)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz-& -gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)& --gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzy*gyzz& -)-gupyy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzy*& -gyyx)-4.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gyyx*gyyy-4.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gyzy+gyzx*& -gyyy)-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy) - MapleGenVar4 = MapleGenVar2-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-4.0*& -gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gyyx*gyyz-4.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gyzz+gyzx*gyyz)-gupyy(i,j,k)*& -gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyy*gxzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxyz-6.0*gupyy(i,j,k)*gupxx(i,j,k)*& -gupyz(i,j,k)*gyyx*gyzx-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyyx*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyyx*gyzz& --gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-6.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzy - MapleGenVar3 = MapleGenVar4-gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyy(i,j,k)& -*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-4.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyyz-2.0*gupyy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz-4.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-gupyy(i,j,k)*gupyz(i,j,k)*& -gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-gupyy(i,j,k)*gupxz(i,j,k)& -*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupyy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)& -*(gyyz*gzzz+gyzz*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupyz(i,j,k)*gupxy(i,j,k)*& -gupxz(i,j,k)*(gxyx*gzzy+gxzy*gyzx) - MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-4.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gyzy-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-gupyz(i,j,k)*gupyz(i,j,k)& -*gupxz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gyzz-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*& -(gxyy*gzzx+gxzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)& -*(gyyy*gzzy+gyzy*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*& -gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(& -gxyz*gzzx+gxzx*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyyz*gzzx+gyzx*gyzz) - CAZyy = Gamyy - (MapleGenVar4-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyyy-2.0*gupyy(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyyz-6.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyyz*gyzz-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& -gyzx*gzzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzx*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzx*gzzz-2.0*& -gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzy*gzzx-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& -gupzz(i,j,k)*gyzz*gzzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz& -*gzzy+gyzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzy-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+& -gyzz*gyzz)-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz) - MapleGenVar3 = gupyz(i,j,k)*gupxx(i,j,k)*gxyxy+gupxz(i,j,k)*gupyy(i,j,k)*gyyxy+gupzz(i,j,k)*gupxy(i,j,k)*gyyxz+2.0*& -gupxz(i,j,k)*gupzz(i,j,k)*gyzxz+gupzz(i,j,k)*gupxy(i,j,k)*gxyyz+gupyz(i,j,k)*gupxy(i,j,k)*gxyyy+gupyz(i,j,k)*gupxy(i,j,k)*gyyxy+gupyz(i,j,k)*& -gupyy(i,j,k)*gyyyy+gupxz(i,j,k)*gupxz(i,j,k)*gyzxx+gupxz(i,j,k)*gupyz(i,j,k)*gyyxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz& --2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz+gupxz(i,j,k)*gupxy(i,j,k)*gxyxy+gupzz(i,j,k)*gupyy(i,j,k)*gyyyz+gupxz(i,j,k)*& -gupxy(i,j,k)*gyyxx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz+gupyz(i,j,k)*gupyz(i,j,k)*gyzyy+2.0*gupyz(i,j,k)*gupzz(i,j,k)*& -gyzyz+gupzz(i,j,k)*gupxx(i,j,k)*gxyxz+gupyz(i,j,k)*gupxz(i,j,k)*gxyyz+gupxz(i,j,k)*gupxx(i,j,k)*gxyxx+2.0*gupxz(i,j,k)*gupyz(i,j,k)*& -gyzxy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz+gupzz(i,j,k)*& -gupzz(i,j,k)*gyzzz - MapleGenVar4 = MapleGenVar3+gupzz(i,j,k)*gupxz(i,j,k)*gxyzz-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzy*& -gyzx+gupyz(i,j,k)*gupyz(i,j,k)*gyyyz+gupxz(i,j,k)*gupxz(i,j,k)*gxyxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-2.0*& -gupzz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz+gupzz(i,j,k)*gupyz(i,j,k)*gyyzz-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyz*gyyx& --2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupxx(i,j,k)*gxyx*gxzx-gupxz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyyx+gxyx*gxyx) - MapleGenVar2 = MapleGenVar4-3.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-& -gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*& -gyzx)-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxzy-gupxz(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)& --2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxyx*& -gxzy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*& -gzzy+gxzy*gyzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxyx*gxxz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxyz& --gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyx+gxyx*gxyz) - MapleGenVar4 = MapleGenVar2-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxyx*& -gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxyz*gyzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*& -gzzz+gxzz*gyzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxyy-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+& -gxyx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*& -gyzy+gxzx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*& -gupxy(i,j,k)*gxyy*gxyy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyy*gxzy - MapleGenVar3 = MapleGenVar4-gupxz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*& -gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-3.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxz(i,j,k)*& -gupxz(i,j,k)*gupyy(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyy*gxzz-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*& -gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*& -gyyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+& -gxyz*gyzy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*& -gxxx*gxyz - MapleGenVar4 = MapleGenVar3-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxyz-& -gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*& -gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+& -gxzy*gyzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxyz*gxzz-& -gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyz+gxyz*gxyz) - MapleGenVar1 = MapleGenVar4-3.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-& -gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*& -gyzz)-gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyyx& --4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gyyx*gyzx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-2.0*gupxz(i,j,k)*& -gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxxy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*& -gxxx*gxyy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxyy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*& -gupxz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxyy*gxxz-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz - MapleGenVar4 = MapleGenVar1-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxyz-2.0*gupxz(i,j,k)*& -gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxyz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*& -gxyz*gyzz-4.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyyx-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx& -*gyzx)-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyyy& -+gxyy*gyyx)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyyx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyyx*gyzy-& -gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzy*gyyx) - MapleGenVar3 = MapleGenVar4-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyyx*gyzy+gyzx*gyyy)& --2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gyyx+gxyx*& -gxyz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyyx*& -gyzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyyx*gyzz+& -gyzx*gyyz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*& -gyyy+gxyx*gxyy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gyyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gyyy& --gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+gyzx*& -gyzy) - MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-4.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyzy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyz(i,j,k)*& -gupyz(i,j,k)*gupxx(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)& --2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyz*gyyy-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyyz-gupyz(i,j,k)*gupyz(i,j,k)*& -gupxz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gyyz+gxyx*gxyz)& --2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gyyz - MapleGenVar2 = MapleGenVar4-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-2.0*& -gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gyyz+gxyy*gxyz)& --2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gyyz-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-gupyz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*(gxxz*gyyz+gxyz*gxyz)& --2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyyz-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyyz*gyzz-2.0*gupyz(i,j,k)*& -gupzz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-gupzz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupzz(i,j,k)& -*gupxx(i,j,k)*gupxy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-2.0*gupzz(i,j,k)*& -gupzz(i,j,k)*gupxx(i,j,k)*gyzx*gzzx - MapleGenVar4 = MapleGenVar2-gupzz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-2.0*& -gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyy*gyzx+gxzy*gyyx)& --2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gyyx*gyzy+gyzx*gyyy)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gyzx*gzzy-& -gupzz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzz+gxyz*& -gyzx)-gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyx*gyzz+& -gyzx*gyyz)-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*gyzx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gyzx*gzzz-& -gupzz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyzy+gxzx*gxyy) - MapleGenVar3 = MapleGenVar4-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-4.0*& -gupyz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyyx*gyyy-4.0*gupyz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gyyx*gyyz-4.0*gupyz(i,j,k)*gupyy(i,j,k)*& -gupxy(i,j,k)*gxyy*gyyy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gyyz-4.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyyz& --2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyzx-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyzx-2.0*gupzz(i,j,k)*& -gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gyzx-4.0*gupzz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-4.0*gupzz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*& -gyzx*gyzz-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gyzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gyzy*gzzx - MapleGenVar4 = MapleGenVar3-gupzz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupzz(i,j,k)& -*gupyy(i,j,k)*gupxy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyzy-2.0*gupzz(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyzy*gzzy-gupzz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxz*& -gyzy+gxyy*gxzz)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyzz+gxyz*gyzy)-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(& -gxyz*gyzy+gxzz*gyyy)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-4.0*gupzz(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzy*gzzz-gupzz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*& -gyzz+gxzx*gxyz)-gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzz+gxzx*gyyz) - CAZzy = Gamzy -(MapleGenVar4-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gyzz-2.0*gupzz(i,j,k)*& -gupzz(i,j,k)*gupxz(i,j,k)*gyzz*gzzx-gupzz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)& -*(gxyy*gyzz+gxzy*gyyz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gzzy-gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*(gxxz*& -gyzz+gxyz*gxzz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyzz-gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxyz*gyzz+& -gxzz*gyyz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyzz-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gyzz-2.0*& -gupzz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyzy-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gyzy-2.0*gupzz(i,j,k)*gupyz(i,j,k)*& -gupxz(i,j,k)*gxzz*gyzy-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gyzz) - MapleGenVar3 = gupxx(i,j,k)*gupyy(i,j,k)*gyzxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gzzz+gupxz(i,j,k)*& -gupzz(i,j,k)*gzzzz+gupxy(i,j,k)*gupxy(i,j,k)*gxzyy+2.0*gupxx(i,j,k)*gupxy(i,j,k)*gxzxy+2.0*gupxy(i,j,k)*gupxz(i,j,k)*gxzyz-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxzx+gupxz(i,j,k)*gupxy(i,j,k)*gyzxz+gupxx(i,j,k)*gupyz(i,j,k)*gzzxy+gupxy(i,j,k)*gupxy(i,j,k)*& -gyzxy+gupxz(i,j,k)*gupyz(i,j,k)*gzzyz+gupxy(i,j,k)*gupyy(i,j,k)*gyzyy+gupxz(i,j,k)*gupyy(i,j,k)*gyzyz+gupxz(i,j,k)*gupxz(i,j,k)*gzzxz& --2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyzx+2.0*gupxx(i,j,k)*gupxz(i,j,k)*gxzxz+gupxx(i,j,k)*gupxx(i,j,k)*gxzxx-2.0*& -gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gzzz*gzzz+gupxx(i,j,k)*gupyz(i,j,k)*gyzxz+gupxz(i,j,k)*gupxz(i,j,k)*gxzzz-2.0*gupxx(i,j,k)*gupxx(i,j,k)& -*gupxx(i,j,k)*gxxx*gxzx+gupxy(i,j,k)*gupxz(i,j,k)*gzzxy+gupxx(i,j,k)*gupxy(i,j,k)*gyzxx+gupxy(i,j,k)*gupyz(i,j,k)*gyzyz-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gyzy - MapleGenVar4 = MapleGenVar3+gupxx(i,j,k)*gupxz(i,j,k)*gzzxx+gupxx(i,j,k)*gupzz(i,j,k)*gzzxz+gupxy(i,j,k)*& -gupyz(i,j,k)*gzzyy+gupxy(i,j,k)*gupzz(i,j,k)*gzzyz+gupxz(i,j,k)*gupyz(i,j,k)*gyzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*gzzx& --2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxzx-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-& -gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*& -gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx) - - MapleGenVar2 = MapleGenVar4-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*gupxx(i,j,k)*& -gupxx(i,j,k)*gupxy(i,j,k)*gxzx*gxxy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxzx*gxyy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(& -gxxy*gyzx+gxzx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*& -gupyz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxx(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)& --2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-4.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*gupxx(i,j,k)*& -gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-2.0*& -gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzx*gyzz+gxzz*gyzx) - MapleGenVar4 = MapleGenVar2-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-& -gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxzx*gzzz+gxzz*& -gzzx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxzy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxzy-2.0*gupxx(i,j,k)& -*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-2.0*& -gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)& --2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxxy*gxzy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gxzy-2.0*gupxx(i,j,k)*& -gupyy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzy+gxyy*gxzy) - MapleGenVar3 = MapleGenVar4-gupxx(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*& -gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)& --2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzy*gxxz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-& -gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxzy*gyzz+gxzz*& -gyzy)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+& -gxzy*gyzz)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxzy*gzzz+gxzz*gzzy)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*& -gxxx*gxzz-4.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxyz - MapleGenVar4 = MapleGenVar3-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxzy-2.0*gupxx(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*& -gxzy*gxyz-4.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxzz-2.0*& -gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzz*gyyx)& --2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzz*& -gyzx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxxy*gxzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxyy*& -gxzz) - MapleGenVar1 = MapleGenVar4-gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*& -gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)& --2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxxz*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz-2.0*gupxx(i,j,k)*& -gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*& -gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)& --2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*gzzz-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-3.0*gupxy(i,j,k)*gupxx(i,j,k)*& -gupxz(i,j,k)*(gxyx*gzzx+gxzx*gyzx) - MapleGenVar4 = MapleGenVar1-gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupxy(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)& --2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyzx*gyyy-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyzx*gzzy+gyzy*gzzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)& --2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gyzz+gxzz*gyzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyz*gyzx - MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-& -gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyzx*gzzz+gyzz*& -gzzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyyx*gyzy& --2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gzzy+gyzx*& -gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyzy& --2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy-3.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzy+gyzy*gyzy) - MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-4.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupxy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)-& -gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gyzz-2.0*& -gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)& --gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy) - MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-2.0*gupxy(i,j,k)*& -gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupzz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gyzz-2.0*gupxy(i,j,k)*& -gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz-3.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-gupxy(i,j,k)*gupzz(i,j,k)*& -gupyz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*gxyy*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz& --2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyzx - MapleGenVar4 = MapleGenVar2-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gyzx*gzzx-2.0*gupxy(i,j,k)*& -gupxz(i,j,k)*gupyy(i,j,k)*gyzx*gyyz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyzz-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*& -gxzy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gyyz-2.0*& -gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gyyx*gyzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*& -gupxz(i,j,k)*gxzz*gyzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyzz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gzzx& --gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gyyx*gzzx+gyzx*gyzx) - MapleGenVar3 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gzzx*gzzx-gupxz(i,j,k)*gupxy(i,j,k)*& -gupxy(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxzx*gzzy+gxzy*gzzx)-gupxz(i,j,k)*& -gupxy(i,j,k)*gupyy(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyzx*gzzy+gyzy*gzzx)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzy*gzzx-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gzzz+gxzz*gzzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyz*gzzx+gyzx*gyzz)& --2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyzx*gzzz+gyzz*gzzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzz*gzzx& --4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gzzx*gzzz-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gzzy+gxzy*gyzx) - MapleGenVar4 = MapleGenVar3-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-2.0*& -gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gzzy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxzy*gzzy-gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(& -gyyy*gzzy+gyzy*gyzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gzzy*gzzy-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyz*& -gzzy+gxzy*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzy*gzzz+gxzz*gzzy)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(& -gyyz*gzzy+gyzy*gyzz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gzzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzz*gzzy-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*& -gzzz+gxzz*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyx*gzzz+gyzx*gyzz) - CAZxz = Gamxz - (MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gzzz-gupxz(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-2.0*gupxz(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gzzz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*& -gxzz*gzzz-gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-4.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*& -gzzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzy*gzzx-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gzzx*gzzy-2.0*gupxz(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gzzy-4.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gzzy-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*& -gzzy*gzzz-4.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gzzz) - MapleGenVar3 = gupyz(i,j,k)*gupyz(i,j,k)*gzzyz+gupyy(i,j,k)*gupyy(i,j,k)*gyzyy+gupyz(i,j,k)*gupzz(i,j,k)*gzzzz-2.0*& -gupyy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyzy+2.0*gupyy(i,j,k)*gupyz(i,j,k)*gyzyz+gupxy(i,j,k)*gupyz(i,j,k)*gzzxy-2.0*gupyy(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy+gupyy(i,j,k)*gupxx(i,j,k)*gxzxy+gupyz(i,j,k)*gupyz(i,j,k)*gyzzz+gupxy(i,j,k)*gupxz(i,j,k)*gxzxz+2.0& -*gupxy(i,j,k)*gupyz(i,j,k)*gyzxz+gupxy(i,j,k)*gupxx(i,j,k)*gxzxx+gupyy(i,j,k)*gupxz(i,j,k)*gzzxy+gupyy(i,j,k)*gupxz(i,j,k)*gxzyz+gupxy(i,j,k)*& -gupzz(i,j,k)*gzzxz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxzx*gxyy+gupyz(i,j,k)*gupxy(i,j,k)*gxzyz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*& -gupzz(i,j,k)*gzzz*gzzz+gupxy(i,j,k)*gupxz(i,j,k)*gzzxx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gzzz-2.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyzz*gzzy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*gxzy+2.0*gupxy(i,j,k)*gupyy(i,j,k)*gyzxy+& -gupyz(i,j,k)*gupxz(i,j,k)*gxzzz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxzx*gzzz+gxzz*gzzx) - MapleGenVar4 = MapleGenVar3+gupxy(i,j,k)*gupxy(i,j,k)*gyzxx+gupxy(i,j,k)*gupxy(i,j,k)*gxzxy+gupyy(i,j,k)*& -gupyz(i,j,k)*gzzyy+gupyz(i,j,k)*gupxz(i,j,k)*gzzxz+gupyz(i,j,k)*gupxx(i,j,k)*gxzxz+gupyy(i,j,k)*gupzz(i,j,k)*gzzyz-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxzy-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gyzz+gupyy(i,j,k)*gupxy(i,j,k)*gxzyy-2.0*& -gupxy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxzx-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*& -gupxz(i,j,k)*gxzx*gxzx - MapleGenVar2 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*& -gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)& --3.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxzx*gxxy& --4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxzx*gyzy+gxzy*& -gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+& -gxzx*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*& -gxzx*gxyz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz - MapleGenVar4 = MapleGenVar2-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*& -gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzx*gyzz+gxzz*& -gyzx)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+& -gxzx*gyzz)-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*& -gupxy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gxxz-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzy*gyzx) - MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gxzy-gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& -gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-3.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gxyz-gupxy(i,j,k)*gupxy(i,j,k)*& -gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)& --2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxzy*gzzz+& -gxzz*gzzy) - MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-gupxy(i,j,k)*gupxy(i,j,k)*& -gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupxy(i,j,k)*& -gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)& --2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gxzz-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)& --2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gxzz& --2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz - MapleGenVar1 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*& -gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)& --3.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*gzzz-& -gupyy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gyyx*gyzx-2.0*& -gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-gupyy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyy(i,j,k)*& -gupxx(i,j,k)*gupyz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupyy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*& -gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyzx-2.0*& -gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gyzx*gyyy - MapleGenVar4 = MapleGenVar1-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-2.0*& -gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyzx*gzzy+gyzy*& -gzzx)-gupyy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gyzz+& -gxzz*gyzx)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gyzx*gyyz-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzz*& -gyzx)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyzx*& -gzzz+gyzz*gzzx)-gupyy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*& -gxyx*gyzy - MapleGenVar3 = MapleGenVar4-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gyyx*gyzy-gupyy(i,j,k)*gupxy(i,j,k)*& -gupxz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-gupyy(i,j,k)*& -gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gyzy-2.0*gupyy(i,j,k)*& -gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyzy-gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*& -gupyz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-gupyy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(& -gxxz*gyzy+gxzy*gxyz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-2.0*gupyy(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-4.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz - MapleGenVar4 = MapleGenVar3-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-2.0*& -gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyzy*gzzz+gyzz*& -gzzy)-gupyy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxzy& --2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupxy(i,j,k)*& -gupyz(i,j,k)*gupxx(i,j,k)*gxzy*gxxz-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*& -gxxx*gxzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxzz - MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz-2.0*gupyy(i,j,k)*& -gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gyzx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyzx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& -gyzx*gzzx-4.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyz*gyzx-4.0*& -gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyzz-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyz*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*& -gupxy(i,j,k)*gxyx*gyzz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gyyx*gyzz-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+& -gxzx*gyzz)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupyy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*& -gyzz+gxyy*gxzz)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzz - MapleGenVar4 = MapleGenVar2-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-2.0*& -gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*(gxxz*gyzz+gxyz*gxzz)& --2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyyz*gyzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz-gupyy(i,j,k)*gupzz(i,j,k)*& -gupxz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-2.0*& -gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-4.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupxx(i,j,k)*gyzx*gzzx-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gzzx*gzzx-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*& -gzzx+gxzx*gxzy) - MapleGenVar3 = MapleGenVar4-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)-& -gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyzx*gzzy+gyzy*& -gzzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzy*gzzx-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gzzx+gxzx*gxzz)& --2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gzzz+gxzz*gzzx)-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyz*gzzx+gxzz*& -gyzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyzx*gzzz+gyzz*gzzx)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*& -gzzx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzz*gzzx-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-& -gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gzzy - MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-4.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gzzy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gzzy*gzzy-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(& -gxxz*gzzy+gxzy*gxzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxzy*gzzz+gxzz*gzzy)-gupyz(i,j,k)*gupyz(i,j,k)*& -gupxy(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)-2.0*& -gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzz*gzzy-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gzzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(& -gxxx*gzzz+gxzx*gxzz)-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& -gupxz(i,j,k)*gxzx*gzzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gzzz - CAZyz = Gamyz - (MapleGenVar4-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupyz(i,j,k)*& -gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gzzz-gupyz(i,j,k)*gupzz(i,j,k)*& -gupxx(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*& -gupxz(i,j,k)*gxzz*gyzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyzz-4.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gzzx& --2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzy*gzzx-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gzzx*gzzy-4.0*gupyz(i,j,k)*& -gupxz(i,j,k)*gupzz(i,j,k)*gzzx*gzzz-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gzzy-4.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*& -gxzy*gzzy-4.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gzzz) - MapleGenVar3 = -4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*& -gxzz*gxzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gyzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gyzy+gupxz(i,j,k)& -*gupzz(i,j,k)*gxzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gxzx+gupxy(i,j,k)*gupyz(i,j,k)*gyzxy+gupyz(i,j,k)*gupyz(i,j,k)*& -gyzyz+gupxx(i,j,k)*gupyz(i,j,k)*gxzxy+gupxy(i,j,k)*gupzz(i,j,k)*gxzyz+gupyy(i,j,k)*gupzz(i,j,k)*gyzyz+2.0*gupxz(i,j,k)*gupzz(i,j,k)*& -gzzxz+gupxy(i,j,k)*gupxz(i,j,k)*gyzxx+gupyy(i,j,k)*gupxz(i,j,k)*gyzxy+gupyz(i,j,k)*gupxz(i,j,k)*gyzxz+gupyy(i,j,k)*gupyz(i,j,k)*gyzyy& --2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gyzx*gyzx+gupxx(i,j,k)*gupxz(i,j,k)*gxzxx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gzzx*& -gzzx-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxzy*gxzy-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz+gupxx(i,j,k)*& -gupzz(i,j,k)*gxzxz+gupxz(i,j,k)*gupyz(i,j,k)*gxzyz+gupyz(i,j,k)*gupzz(i,j,k)*gyzzz+gupxz(i,j,k)*gupxz(i,j,k)*gzzxx+gupxy(i,j,k)*gupyz(i,j,k)*& -gxzyy - MapleGenVar4 = MapleGenVar3+gupzz(i,j,k)*gupzz(i,j,k)*gzzzz+gupxy(i,j,k)*gupzz(i,j,k)*gyzxz+2.0*gupyz(i,j,k)& -*gupzz(i,j,k)*gzzyz+gupyz(i,j,k)*gupyz(i,j,k)*gzzyy+gupxy(i,j,k)*gupxz(i,j,k)*gxzxy+gupxz(i,j,k)*gupxz(i,j,k)*gxzxz-2.0*gupzz(i,j,k)*& -gupzz(i,j,k)*gupyy(i,j,k)*gzzy*gzzy+2.0*gupxz(i,j,k)*gupyz(i,j,k)*gzzxy-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxzx-& -gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)& --gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy) - MapleGenVar2 = MapleGenVar4-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-2.0*& -gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxxx*gxzz-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)& -*gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-gupxx(i,j,k)*& -gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxx(i,j,k)& -*gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-& -gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-gupxx(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupxx(i,j,k)& -*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz) - MapleGenVar4 = MapleGenVar2-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxx(i,j,k)& -*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-& -gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)& --2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxyx*& -gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyx*gyzy-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-& -gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxzy-2.0*& -gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxxy - MapleGenVar3 = MapleGenVar4-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxxy*gxzy-2.0*gupxx(i,j,k)*& -gupyz(i,j,k)*gupxz(i,j,k)*gxxy*gxzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxxz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*& -gxxz*gxzz-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*& -gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyx*gyzz-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-gupxy(i,j,k)*gupxy(i,j,k)& -*gupxz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzx-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*& -(gxyy*gzzx+gxzy*gyzx)-gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)& -*(gxyy*gyzy+gxzy*gyyy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy) - MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupxy(i,j,k)*gupxz(i,j,k)& -*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupxy(i,j,k)*& -gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-gupxy(i,j,k)*gupyz(i,j,k)*& -gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxy(i,j,k)*gupzz(i,j,k)& -*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-gupxz(i,j,k)*& -gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx) - MapleGenVar1 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-& -gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)& --4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxzy-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxz(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzx*gzzz-gupxz(i,j,k)*gupxz(i,j,k)*& -gupxy(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)& -*gupyy(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupxz(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupxz(i,j,k)& -*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzy*gyzz) - MapleGenVar4 = MapleGenVar1-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxzz-gupxz(i,j,k)*gupxz(i,j,k)*& -gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-2.0*gupxy(i,j,k)*& -gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*& -gxyz*gyzx-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxyz*gyzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-4.0*& -gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-6.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*& -gupzz(i,j,k)*gxzx*gzzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxzy*gzzx - MapleGenVar3 = MapleGenVar4-4.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-6.0*gupxz(i,j,k)*& -gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzy*gzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*& -gxzz*gzzx-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+& -gxzz*gyzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz& -+gxzz*gyyz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-6.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*& -gxzz*gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gzzy-4.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz-2.0*& -gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzy - MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupxy(i,j,k)& -*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-gupxy(i,j,k)*gupxz(i,j,k)*& -gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*gupxy(i,j,k)*& -gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxyy-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)& -*(gxyy*gzzx+gxzx*gyzy)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-gupxy(i,j,k)*gupyz(i,j,k)*& -gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(& -gxyz*gyzx+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz) - MapleGenVar2 = MapleGenVar4-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-gupxy(i,j,k)& -*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-gupyy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-& -gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)& --gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz& -)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyy*gxzz-2.0*& -gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxyz-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyyx*gyzx-2.0*gupyy(i,j,k)*gupxy(i,j,k)*& -gupyz(i,j,k)*gyyx*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyyx*gyzz-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+& -gyzx*gyzy) - MapleGenVar4 = MapleGenVar2-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzy-gupyy(i,j,k)*gupyy(i,j,k)*& -gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*gupyy(i,j,k)*& -gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)& -*(gxyz*gyzx+gxzx*gyyz)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupyy(i,j,k)*gupyz(i,j,k)*& -gupxz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(& -gyyz*gzzy+gyzy*gyzz)-gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*& -(gyyx*gzzx+gyzx*gyzx) - MapleGenVar3 = MapleGenVar4-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-gupyz(i,j,k)& -*gupyz(i,j,k)*gupxy(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gyzy-gupyz(i,j,k)*gupxz(i,j,k)*& -gupxz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-4.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gyzz-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)& -*(gyyy*gzzx+gyzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*& -gupxz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-2.0*gupyz(i,j,k)*& -gupyz(i,j,k)*gupzz(i,j,k)*gyzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)& -*(gyyz*gzzx+gyzx*gyzz) - MapleGenVar4 = MapleGenVar3-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyyy-2.0*gupyy(i,j,k)*& -gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyyz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyyz*gyzz-6.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& -gyzx*gzzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzx*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzx*gzzz-2.0*& -gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzy*gzzx-6.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& -gupzz(i,j,k)*gyzz*gzzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz& -*gzzy+gyzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzy-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+& -gyzz*gyzz) - CAZzz = Gamzz - (MapleGenVar4-6.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-4.0*gupxz(i,j,k)*& -gupxy(i,j,k)*gupyz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)& --4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzx*gyzz+gxzz*gyzx)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxzx*gzzz+& -gxzz*gzzx)-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(& -gxzy*gzzz+gxzz*gzzy)-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyzx*gzzy+gyzy*gzzx)-4.0*gupyz(i,j,k)*& -gupxz(i,j,k)*gupzz(i,j,k)*(gyzx*gzzz+gyzz*gzzx)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)& --4.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gzzx*gzzy-4.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gzzx*gzzz-4.0*gupzz(i,j,k)*& -gupzz(i,j,k)*gupyz(i,j,k)*gzzy*gzzz-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gzzz*gzzz) - -! second kind of connection - Gamxxx =HALF*( gupxx(i,j,k)*gxxx + gupxy(i,j,k)*(TWO*gxyx - gxxy ) + gupxz(i,j,k)*(TWO*gxzx - gxxz )) - Gamyxx =HALF*( gupxy(i,j,k)*gxxx + gupyy(i,j,k)*(TWO*gxyx - gxxy ) + gupyz(i,j,k)*(TWO*gxzx - gxxz )) - Gamzxx =HALF*( gupxz(i,j,k)*gxxx + gupyz(i,j,k)*(TWO*gxyx - gxxy ) + gupzz(i,j,k)*(TWO*gxzx - gxxz )) - - Gamxyy =HALF*( gupxx(i,j,k)*(TWO*gxyy - gyyx ) + gupxy(i,j,k)*gyyy + gupxz(i,j,k)*(TWO*gyzy - gyyz )) - Gamyyy =HALF*( gupxy(i,j,k)*(TWO*gxyy - gyyx ) + gupyy(i,j,k)*gyyy + gupyz(i,j,k)*(TWO*gyzy - gyyz )) - Gamzyy =HALF*( gupxz(i,j,k)*(TWO*gxyy - gyyx ) + gupyz(i,j,k)*gyyy + gupzz(i,j,k)*(TWO*gyzy - gyyz )) - - Gamxzz =HALF*( gupxx(i,j,k)*(TWO*gxzz - gzzx ) + gupxy(i,j,k)*(TWO*gyzz - gzzy ) + gupxz(i,j,k)*gzzz) - Gamyzz =HALF*( gupxy(i,j,k)*(TWO*gxzz - gzzx ) + gupyy(i,j,k)*(TWO*gyzz - gzzy ) + gupyz(i,j,k)*gzzz) - Gamzzz =HALF*( gupxz(i,j,k)*(TWO*gxzz - gzzx ) + gupyz(i,j,k)*(TWO*gyzz - gzzy ) + gupzz(i,j,k)*gzzz) - - Gamxxy =HALF*( gupxx(i,j,k)*gxxy + gupxy(i,j,k)*gyyx + gupxz(i,j,k)*( gxzy + gyzx - gxyz ) ) - Gamyxy =HALF*( gupxy(i,j,k)*gxxy + gupyy(i,j,k)*gyyx + gupyz(i,j,k)*( gxzy + gyzx - gxyz ) ) - Gamzxy =HALF*( gupxz(i,j,k)*gxxy + gupyz(i,j,k)*gyyx + gupzz(i,j,k)*( gxzy + gyzx - gxyz ) ) - - Gamxxz =HALF*( gupxx(i,j,k)*gxxz + gupxy(i,j,k)*( gxyz + gyzx - gxzy ) + gupxz(i,j,k)*gzzx ) - Gamyxz =HALF*( gupxy(i,j,k)*gxxz + gupyy(i,j,k)*( gxyz + gyzx - gxzy ) + gupyz(i,j,k)*gzzx ) - Gamzxz =HALF*( gupxz(i,j,k)*gxxz + gupyz(i,j,k)*( gxyz + gyzx - gxzy ) + gupzz(i,j,k)*gzzx ) - - Gamxyz =HALF*( gupxx(i,j,k)*( gxyz + gxzy - gyzx ) + gupxy(i,j,k)*gyyz + gupxz(i,j,k)*gzzy ) - Gamyyz =HALF*( gupxy(i,j,k)*( gxyz + gxzy - gyzx ) + gupyy(i,j,k)*gyyz + gupyz(i,j,k)*gzzy ) - Gamzyz =HALF*( gupxz(i,j,k)*( gxyz + gxzy - gyzx ) + gupyz(i,j,k)*gyyz + gupzz(i,j,k)*gzzy ) - - Gamxa = gupxx(i,j,k) * Gamxxx + gupyy(i,j,k) * Gamxyy + gupzz(i,j,k) * Gamxzz + & - TWO*( gupxy(i,j,k) * Gamxxy + gupxz(i,j,k) * Gamxxz + gupyz(i,j,k) * Gamxyz ) - Gamya = gupxx(i,j,k) * Gamyxx + gupyy(i,j,k) * Gamyyy + gupzz(i,j,k) * Gamyzz + & - TWO*( gupxy(i,j,k) * Gamyxy + gupxz(i,j,k) * Gamyxz + gupyz(i,j,k) * Gamyyz ) - Gamza = gupxx(i,j,k) * Gamzxx + gupyy(i,j,k) * Gamzyy + gupzz(i,j,k) * Gamzzz + & - TWO*( gupxy(i,j,k) * Gamzxy + gupxz(i,j,k) * Gamzxz + gupyz(i,j,k) * Gamzyz ) - - call point_fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst,& - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - - AAxx = gupxx(i,j,k) * Axx(i,j,k) * Axx(i,j,k) + gupyy(i,j,k) * Axy(i,j,k) * Axy(i,j,k) + gupzz(i,j,k) * Axz(i,j,k) * Axz(i,j,k) + & - TWO * (gupxy(i,j,k) * Axx(i,j,k) * Axy(i,j,k) + gupxz(i,j,k) * Axx(i,j,k) * Axz(i,j,k) + gupyz(i,j,k) * Axy(i,j,k) * Axz(i,j,k)) - AAyy = gupxx(i,j,k) * Axy(i,j,k) * Axy(i,j,k) + gupyy(i,j,k) * Ayy(i,j,k) * Ayy(i,j,k) + gupzz(i,j,k) * Ayz(i,j,k) * Ayz(i,j,k) + & - TWO * (gupxy(i,j,k) * Axy(i,j,k) * Ayy(i,j,k) + gupxz(i,j,k) * Axy(i,j,k) * Ayz(i,j,k) + gupyz(i,j,k) * Ayy(i,j,k) * Ayz(i,j,k)) - AAzz = gupxx(i,j,k) * Axz(i,j,k) * Axz(i,j,k) + gupyy(i,j,k) * Ayz(i,j,k) * Ayz(i,j,k) + gupzz(i,j,k) * Azz(i,j,k) * Azz(i,j,k) + & - TWO * (gupxy(i,j,k) * Axz(i,j,k) * Ayz(i,j,k) + gupxz(i,j,k) * Axz(i,j,k) * Azz(i,j,k) + gupyz(i,j,k) * Ayz(i,j,k) * Azz(i,j,k)) - AAxy = gupxx(i,j,k) * Axx(i,j,k) * Axy(i,j,k) + gupyy(i,j,k) * Axy(i,j,k) * Ayy(i,j,k) + gupzz(i,j,k) * Axz(i,j,k) * Ayz(i,j,k) + & - gupxy(i,j,k) *(Axx(i,j,k) * Ayy(i,j,k) + Axy(i,j,k) * Axy(i,j,k)) + & - gupxz(i,j,k) *(Axx(i,j,k) * Ayz(i,j,k) + Axz(i,j,k) * Axy(i,j,k)) + & - gupyz(i,j,k) *(Axy(i,j,k) * Ayz(i,j,k) + Axz(i,j,k) * Ayy(i,j,k)) - AAxz = gupxx(i,j,k) * Axx(i,j,k) * Axz(i,j,k) + gupyy(i,j,k) * Axy(i,j,k) * Ayz(i,j,k) + gupzz(i,j,k) * Axz(i,j,k) * Azz(i,j,k) + & - gupxy(i,j,k) *(Axx(i,j,k) * Ayz(i,j,k) + Axy(i,j,k) * Axz(i,j,k)) + & - gupxz(i,j,k) *(Axx(i,j,k) * Azz(i,j,k) + Axz(i,j,k) * Axz(i,j,k)) + & - gupyz(i,j,k) *(Axy(i,j,k) * Azz(i,j,k) + Axz(i,j,k) * Ayz(i,j,k)) - AAyz = gupxx(i,j,k) * Axy(i,j,k) * Axz(i,j,k) + gupyy(i,j,k) * Ayy(i,j,k) * Ayz(i,j,k) + gupzz(i,j,k) * Ayz(i,j,k) * Azz(i,j,k) + & - gupxy(i,j,k) *(Axy(i,j,k) * Ayz(i,j,k) + Ayy(i,j,k) * Axz(i,j,k)) + & - gupxz(i,j,k) *(Axy(i,j,k) * Azz(i,j,k) + Ayz(i,j,k) * Axz(i,j,k)) + & - gupyz(i,j,k) *(Ayy(i,j,k) * Azz(i,j,k) + Ayz(i,j,k) * Ayz(i,j,k)) - - betas = betax(i,j,k)*slx(i,j,k)+betay(i,j,k)*sly(i,j,k)+betaz(i,j,k)*slz(i,j,k) - fxx = trK(i,j,k)+TWO*TZ(i,j,k) - fxy = fxx*Axy(i,j,k)-TWO*AAxy - fxz = fxx*Axz(i,j,k)-TWO*AAxz - fyy = fxx*Ayy(i,j,k)-TWO*AAyy - fyz = fxx*Ayz(i,j,k)-TWO*AAyz - fzz = fxx*Azz(i,j,k)-TWO*AAzz - fxx = fxx*Axx(i,j,k)-TWO*AAxx - - muL = 2.d0/alpn1(i,j,k) - tmuSL = chin1(i,j,k)*2.d0/dsqrt(3.d0)/alpn1(i,j,k)**2 - tmuST = chin1(i,j,k)/alpn1(i,j,k)**2 -! Eq.(17) - totrK_rhs = (betax(i,j,k)*Kx+betay(i,j,k)*Ky+betaz(i,j,k)*Kz) & - -dsqrt(muL)*alpn1(i,j,k)*(vx(i,j,k)*Kx+vy(i,j,k)*Ky+vz(i,j,k)*Kz+trK(i,j,k)/R(k)) -#if 0 - -0.5d0*(qupxx(i,j,k)*Lapxx+qupyy(i,j,k)*Lapyy+qupzz(i,j,k)*Lapzz+ & - TWO*(qupxy(i,j,k)*Lapxy+qupxz(i,j,k)*Lapxz+qupyz(i,j,k)*Lapyz)) & - -trK(i,j,k)/R(k)*betas & - -0.5d0*alpn1(i,j,k)*(gupxx(i,j,k)*AAxx+gupyy(i,j,k)*AAyy+gupzz(i,j,k)*AAzz+ & - TWO*(gupxy(i,j,k)*AAxy+gupxz(i,j,k)*AAxz+gupyz(i,j,k)*AAyz)+(trK(i,j,k)+TWO*TZ(i,j,k))**2/3.d0 & - +kappa1*(ONE-kappa2)*TZ(i,j,k))+(ONE+betas/dsqrt(muL)/alpn1(i,j,k))/R(k)*(vx(i,j,k)*Lapx+vy(i,j,k)*Lapy+vz(i,j,k)*Lapz) & - +ha/R(k)**4-kappa3*alpn1(i,j,k)*trK(i,j,k) -#endif - -! Eq.(18) - toGams_rhs = -alpn1(i,j,k)*dsqrt(tmuSL)*(Gamxx+Gamyy+Gamzz) + ( & - slx(i,j,k)*(qupxx(i,j,k)*sfxxx+qupyy(i,j,k)*sfxyy+qupzz(i,j,k)*sfxzz+TWO*(qupxy(i,j,k)*sfxxy+qupxz(i,j,k)*sfxxz+qupyz(i,j,k)*sfxyz)) & - +sly(i,j,k)*(qupxx(i,j,k)*sfyxx+qupyy(i,j,k)*sfyyy+qupzz(i,j,k)*sfyzz+TWO*(qupxy(i,j,k)*sfyxy+qupxz(i,j,k)*sfyxz+qupyz(i,j,k)*sfyyz)) & - +slz(i,j,k)*(qupxx(i,j,k)*sfzxx+qupyy(i,j,k)*sfzyy+qupzz(i,j,k)*sfzzz+TWO*(qupxy(i,j,k)*sfzxy+qupxz(i,j,k)*sfzxz+qupyz(i,j,k)*sfzyz)) ) & - /chin1(i,j,k) - ( & - vx(i,j,k)*(qulxx(i,j,k)*sfxxx+qulxy(i,j,k)*sfxxy+qulxz(i,j,k)*sfxxz+ & - qulxy(i,j,k)*sfyxx+qulyy(i,j,k)*sfyxy+qulyz(i,j,k)*sfyxz+ & - qulxz(i,j,k)*sfzxx+qulyz(i,j,k)*sfzxy+qulzz(i,j,k)*sfzxz) & - +vy(i,j,k)*(qulxx(i,j,k)*sfxxy+qulxy(i,j,k)*sfxyy+qulxz(i,j,k)*sfxyz+ & - qulxy(i,j,k)*sfyxy+qulyy(i,j,k)*sfyyy+qulyz(i,j,k)*sfyyz+ & - qulxz(i,j,k)*sfzxy+qulyz(i,j,k)*sfzyy+qulzz(i,j,k)*sfzyz) & - +vz(i,j,k)*(qulxx(i,j,k)*sfxxz+qulxy(i,j,k)*sfxyz+qulxz(i,j,k)*sfxzz+ & - qulxy(i,j,k)*sfyxz+qulyy(i,j,k)*sfyyz+qulyz(i,j,k)*sfyzz+ & - qulxz(i,j,k)*sfzxz+qulyz(i,j,k)*sfzyz+qulzz(i,j,k)*sfzzz) )/chin1(i,j,k) & - -4.d0*alpn1(i,j,k)*dsqrt(muL)/3.d0/(dsqrt(tmuSL)+dsqrt(muL))/chin1(i,j,k)*(vx(i,j,k)*Kx+vy(i,j,k)*Ky+vz(i,j,k)*Kz) & - -2.d0*alpn1(i,j,k)/3.d0/(dsqrt(tmuSL)+ONE)/chin1(i,j,k)*(vx(i,j,k)*TZx+vy(i,j,k)*TZy+vz(i,j,k)*TZz) & - +thbs-kappa3*alpn1(i,j,k)*(slx(i,j,k)*Gamx(i,j,k)+sly(i,j,k)*Gamy(i,j,k)+slz(i,j,k)*Gamz(i,j,k)) & - +(slx(i,j,k)*(betax(i,j,k)*Gamxx+betay(i,j,k)*Gamxy+betaz(i,j,k)*Gamxz) & - +sly(i,j,k)*(betax(i,j,k)*Gamyx+betay(i,j,k)*Gamyy+betaz(i,j,k)*Gamyz) & - +slz(i,j,k)*(betax(i,j,k)*Gamzx+betay(i,j,k)*Gamzy+betaz(i,j,k)*Gamzz)) - - toTZ_rhs = -alpn1(i,j,k)*(vx(i,j,k)*TZx+vy(i,j,k)*TZy+vz(i,j,k)*TZz)+(betax(i,j,k)*TZx+betay(i,j,k)*TZy+betaz(i,j,k)*TZz) - - toAss_rhs = -alpn1(i,j,k)*chin1(i,j,k)*( & - TWO*((gupxx(i,j,k)*(Axxx-(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axxy-(Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axxz-(Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axxy-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & - + gupyy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axxz-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Axyz-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & - - (Gamxa*Axx(i,j,k)+Gamya*Axy(i,j,k)+Gamza*Axz(i,j,k)) )*vx(i,j,k) & - + (gupxx(i,j,k)*(Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k))) & - + gupyy(i,j,k)*(Ayyy-(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Ayyz-(Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Ayyz-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & - - (Gamxa*Axy(i,j,k)+Gamya*Ayy(i,j,k)+Gamza*Ayz(i,j,k)) )*vy(i,j,k) & - + (gupxx(i,j,k)*(Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axzy-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & - + gupyy(i,j,k)*(Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Azzz-(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k))) & - - (Gamxa*Axz(i,j,k)+Gamya*Ayz(i,j,k)+Gamza*Azz(i,j,k)) )*vz(i,j,k) ) & - -2.d0/3.d0*chin1(i,j,k)*(vx(i,j,k)*(TWO*Kx+TZx)+vy(i,j,k)*(TWO*Ky+TZy)+vz(i,j,k)*(TWO*Kz+TZz)) & - -2.d0/3.d0*(Rxx(i,j,k)*vx(i,j,k)*vx(i,j,k)+Ryy(i,j,k)*vy(i,j,k)*vy(i,j,k)+Rzz(i,j,k)*vz(i,j,k)*vz(i,j,k) & - +TWO*(Rxy(i,j,k)*vx(i,j,k)*vy(i,j,k)+Rxz(i,j,k)*vx(i,j,k)*vz(i,j,k)+Ryz(i,j,k)*vy(i,j,k)*vz(i,j,k))) & - + ONE/3.d0*(Rxx(i,j,k)*qupxx(i,j,k)+Ryy(i,j,k)*qupyy(i,j,k)+Rzz(i,j,k)*qupzz(i,j,k) & - +TWO*(Rxy(i,j,k)*qupxy(i,j,k)+Rxz(i,j,k)*qupxz(i,j,k)+Ryz(i,j,k)*qupyz(i,j,k))) & - +2.d0/3.d0*chin1(i,j,k)*(slx(i,j,k)*vx(i,j,k)*CAZxx+slx(i,j,k)*vy(i,j,k)*CAZxy+slx(i,j,k)*vz(i,j,k)*CAZxz & - +sly(i,j,k)*vx(i,j,k)*CAZyx+sly(i,j,k)*vy(i,j,k)*CAZyy+sly(i,j,k)*vz(i,j,k)*CAZyz & - +slz(i,j,k)*vx(i,j,k)*CAZzx+slz(i,j,k)*vy(i,j,k)*CAZzy+slz(i,j,k)*vz(i,j,k)*CAZzz) & - -ONE/3.d0*chin1(i,j,k)*(qulxx(i,j,k)*CAZxx+qulyx(i,j,k)*CAZxy+qulzx(i,j,k)*CAZxz & - +qulxy(i,j,k)*CAZyx+qulyy(i,j,k)*CAZyy+qulzy(i,j,k)*CAZyz & - +qulxz(i,j,k)*CAZzx+qulyz(i,j,k)*CAZzy+qulzz(i,j,k)*CAZzz) & - -3.d0/chin1(i,j,k)*(vx(i,j,k)*(gupxx(i,j,k)*chix*Axx(i,j,k)+gupxy(i,j,k)*chix*Axy(i,j,k)+gupxz(i,j,k)*chix*Axz(i,j,k) & - +gupxy(i,j,k)*chiy*Axx(i,j,k)+gupyy(i,j,k)*chiy*Axy(i,j,k)+gupyz(i,j,k)*chiy*Axz(i,j,k) & - +gupxz(i,j,k)*chiz*Axx(i,j,k)+gupyz(i,j,k)*chiz*Axy(i,j,k)+gupzz(i,j,k)*chiz*Axz(i,j,k)) & - +vy(i,j,k)*(gupxx(i,j,k)*chix*Axy(i,j,k)+gupxy(i,j,k)*chix*Ayy(i,j,k)+gupxz(i,j,k)*chix*Ayz(i,j,k) & - +gupxy(i,j,k)*chiy*Axy(i,j,k)+gupyy(i,j,k)*chiy*Ayy(i,j,k)+gupyz(i,j,k)*chiy*Ayz(i,j,k) & - +gupxz(i,j,k)*chiz*Axy(i,j,k)+gupyz(i,j,k)*chiz*Ayy(i,j,k)+gupzz(i,j,k)*chiz*Ayz(i,j,k)) & - +vz(i,j,k)*(gupxx(i,j,k)*chix*Axz(i,j,k)+gupxy(i,j,k)*chix*Ayz(i,j,k)+gupxz(i,j,k)*chix*Azz(i,j,k) & - +gupxy(i,j,k)*chiy*Axz(i,j,k)+gupyy(i,j,k)*chiy*Ayz(i,j,k)+gupyz(i,j,k)*chiy*Azz(i,j,k) & - +gupxz(i,j,k)*chiz*Axz(i,j,k)+gupyz(i,j,k)*chiz*Ayz(i,j,k)+gupzz(i,j,k)*chiz*Azz(i,j,k)) ) & - -kappa1*(vx(i,j,k)*Gmxcon(i,j,k)+vy(i,j,k)*Gmycon(i,j,k)+vz(i,j,k)*Gmzcon(i,j,k)) ) & - +alpn1(i,j,k)*(fxx*vx(i,j,k)*vx(i,j,k)+fyy*vy(i,j,k)*vy(i,j,k)+fzz*vz(i,j,k)*vz(i,j,k) & - +TWO*(fxy*vx(i,j,k)*vy(i,j,k)+fxz*vx(i,j,k)*vz(i,j,k)+fyz*vy(i,j,k)*vz(i,j,k))) - -! Eq.(22) - toAs1_rhs = alpn1(i,j,k)*(fxx*vx(i,j,k)*ux(i,j,k)+fxy*vy(i,j,k)*ux(i,j,k)+fxz*vz(i,j,k)*ux(i,j,k) & - +fxy*vx(i,j,k)*uy(i,j,k)+fyy*vy(i,j,k)*uy(i,j,k)+fyz*vz(i,j,k)*uy(i,j,k) & - +fxz*vx(i,j,k)*uz(i,j,k)+fyz*vy(i,j,k)*uz(i,j,k)+fzz*vz(i,j,k)*uz(i,j,k)) - - toAs2_rhs = alpn1(i,j,k)*(fxx*vx(i,j,k)*wx(i,j,k)+fxy*vy(i,j,k)*wx(i,j,k)+fxz*vz(i,j,k)*wx(i,j,k) & - +fxy*vx(i,j,k)*wy(i,j,k)+fyy*vy(i,j,k)*wy(i,j,k)+fyz*vz(i,j,k)*wy(i,j,k) & - +fxz*vx(i,j,k)*wz(i,j,k)+fyz*vy(i,j,k)*wz(i,j,k)+fzz*vz(i,j,k)*wz(i,j,k)) - - fxx = Lapxx - (Gamxxx-((chix+chix)/chin1(i,j,k)-gxx(i,j,k)*gxxx)*HALF)*Lapx - (Gamyxx+gxx(i,j,k)*gxxy*HALF)*Lapy - (Gamzxx+gxx(i,j,k)*gxxz*HALF)*Lapz - fyy = Lapyy - (Gamxyy+gyy(i,j,k)*gxxx*HALF)*Lapx - (Gamyyy-((chiy+chiy)/chin1(i,j,k)-gyy(i,j,k)*gxxy)*HALF)*Lapy - (Gamzyy+gyy(i,j,k)*gxxz*HALF)*Lapz - fzz = Lapzz - (Gamxzz+gzz(i,j,k)*gxxx*HALF)*Lapx - (Gamyzz+gzz(i,j,k)*gxxy*HALF)*Lapy - (Gamzzz-((chiz+chiz)/chin1(i,j,k)-gzz(i,j,k)*gxxz)*HALF)*Lapz - fxy = Lapxy - (Gamxxy-(chiy/chin1(i,j,k)-gxy(i,j,k)*gxxx)*HALF)*Lapx - (Gamyxy-(chix/chin1(i,j,k)-gxy(i,j,k)*gxxy)*HALF)*Lapy& - - (Gamzxy+gxy(i,j,k)*gxxz*HALF)*Lapz - fxz = Lapxz - (Gamxxz-(chiz/chin1(i,j,k)-gxz(i,j,k)*gxxx)*HALF)*Lapx - (Gamyxz+gxz(i,j,k)*gxxy*HALF)*Lapy& - - (Gamzxz-(chix/chin1(i,j,k)-gxz(i,j,k)*gxxz)*HALF)*Lapz - fyz = Lapyz - (Gamxyz+gyz(i,j,k)*gxxx*HALF)*Lapx - (Gamyyz-(chiz/chin1(i,j,k)-gyz(i,j,k)*gxxy)*HALF)*Lapy& - - (Gamzyz-(chiy/chin1(i,j,k)-gyz(i,j,k)*gxxz)*HALF)*Lapz - - TFxx = -chin1(i,j,k)*fxx - TFxy = -chin1(i,j,k)*fxy - TFxz = -chin1(i,j,k)*fxz - TFyy = -chin1(i,j,k)*fyy - TFyz = -chin1(i,j,k)*fyz - TFzz = -chin1(i,j,k)*fzz - toAss_rhs = toAss_rhs -2.d0/3.d0*chin1(i,j,k)*(fxx*vx(i,j,k)*vx(i,j,k)+fyy*vy(i,j,k)*vy(i,j,k)+fzz*vz(i,j,k)*vz(i,j,k) & - +TWO*(fxy*vx(i,j,k)*vy(i,j,k)+fxz*vx(i,j,k)*vz(i,j,k)+fyz*vy(i,j,k)*vz(i,j,k))) & - +ONE/3.d0*chin1(i,j,k)*(fxx*qupxx(i,j,k)+fyy*qupyy(i,j,k)+fzz*qupzz(i,j,k) & - +TWO*(fxy*qupxy(i,j,k)+fxz*qupxz(i,j,k)+fyz*qupyz(i,j,k))) - toAs1_rhs = toAs1_rhs -chin1(i,j,k)*(fxx*vx(i,j,k)*ux(i,j,k)+fxy*vy(i,j,k)*ux(i,j,k)+fxz*vz(i,j,k)*ux(i,j,k) & - +fxy*vx(i,j,k)*uy(i,j,k)+fyy*vy(i,j,k)*uy(i,j,k)+fyz*vz(i,j,k)*uy(i,j,k) & - +fxz*vx(i,j,k)*uz(i,j,k)+fyz*vy(i,j,k)*uz(i,j,k)+fzz*vz(i,j,k)*uz(i,j,k)) - toAs2_rhs = toAs2_rhs -chin1(i,j,k)*(fxx*vx(i,j,k)*wx(i,j,k)+fxy*vy(i,j,k)*wx(i,j,k)+fxz*vz(i,j,k)*wx(i,j,k) & - +fxy*vx(i,j,k)*wy(i,j,k)+fyy*vy(i,j,k)*wy(i,j,k)+fyz*vz(i,j,k)*wy(i,j,k) & - +fxz*vx(i,j,k)*wz(i,j,k)+fyz*vy(i,j,k)*wz(i,j,k)+fzz*vz(i,j,k)*wz(i,j,k)) - - fxx = (betax(i,j,k)*Axxx+betay(i,j,k)*Axxy+betaz(i,j,k)*Axxz)-TWO*(Axx(i,j,k)*sfxx+Axy(i,j,k)*sfyx+Axz(i,j,k)*sfzx) - fxy = (betax(i,j,k)*Axyx+betay(i,j,k)*Axyy+betaz(i,j,k)*Axyz)- & - (Axx(i,j,k)*sfxy+Axy(i,j,k)*sfyy+Axz(i,j,k)*sfzy)-(Axy(i,j,k)*sfxx+Ayy(i,j,k)*sfyx+Ayz(i,j,k)*sfzx) - fxz = (betax(i,j,k)*Axzx+betay(i,j,k)*Axzy+betaz(i,j,k)*Axzz)- & - (Axx(i,j,k)*sfxz+Axy(i,j,k)*sfyz+Axz(i,j,k)*sfzz)-(Axz(i,j,k)*sfxx+Ayz(i,j,k)*sfyx+Azz(i,j,k)*sfzx) - fyy = (betax(i,j,k)*Ayyx+betay(i,j,k)*Ayyy+betaz(i,j,k)*Ayyz)-TWO*(Axy(i,j,k)*sfxy+Ayy(i,j,k)*sfyy+Ayz(i,j,k)*sfzy) - fyz = (betax(i,j,k)*Ayzx+betay(i,j,k)*Ayzy+betaz(i,j,k)*Ayzz)- & - (Axy(i,j,k)*sfxz+Ayy(i,j,k)*sfyz+Ayz(i,j,k)*sfzz)-(Axz(i,j,k)*sfxy+Ayz(i,j,k)*sfyy+Azz(i,j,k)*sfzy) - fzz = (betax(i,j,k)*Azzx+betay(i,j,k)*Azzy+betaz(i,j,k)*Azzz)-TWO*(Axz(i,j,k)*sfxz+Ayz(i,j,k)*sfyz+Azz(i,j,k)*sfzz) - TFxx = TFxx+fxx - TFxy = TFxy+fxy - TFxz = TFxz+fxz - TFyy = TFyy+fyy - TFyz = TFyz+fyz - TFzz = TFzz+fzz - - toAss_rhs = toAss_rhs + (fxx*vx(i,j,k)*vx(i,j,k)+fyy*vy(i,j,k)*vy(i,j,k)+fzz*vz(i,j,k)*vz(i,j,k) & - +TWO*(fxy*vx(i,j,k)*vy(i,j,k)+fxz*vx(i,j,k)*vz(i,j,k)+fyz*vy(i,j,k)*vz(i,j,k))) - toAs1_rhs = toAs1_rhs +(fxx*vx(i,j,k)*ux(i,j,k)+fxy*vy(i,j,k)*ux(i,j,k)+fxz*vz(i,j,k)*ux(i,j,k) & - + fxy*vx(i,j,k)*uy(i,j,k)+fyy*vy(i,j,k)*uy(i,j,k)+fyz*vz(i,j,k)*uy(i,j,k) & - + fxz*vx(i,j,k)*uz(i,j,k)+fyz*vy(i,j,k)*uz(i,j,k)+fzz*vz(i,j,k)*uz(i,j,k)) - toAs2_rhs = toAs2_rhs +(fxx*vx(i,j,k)*wx(i,j,k)+fxy*vy(i,j,k)*wx(i,j,k)+fxz*vz(i,j,k)*wx(i,j,k) & - + fxy*vx(i,j,k)*wy(i,j,k)+fyy*vy(i,j,k)*wy(i,j,k)+fyz*vz(i,j,k)*wy(i,j,k) & - + fxz*vx(i,j,k)*wz(i,j,k)+fyz*vy(i,j,k)*wz(i,j,k)+fzz*vz(i,j,k)*wz(i,j,k)) - toAs1_rhs = toAs1_rhs-alpn1(i,j,k)*chin1(i,j,k)*( & - (gupxx(i,j,k)*(Axxx-(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axxy-(Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axxz-(Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axxy-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & - + gupyy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axxz-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Axyz-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & - - (Gamxa*Axx(i,j,k)+Gamya*Axy(i,j,k)+Gamza*Axz(i,j,k)) )*ux(i,j,k) & - + (gupxx(i,j,k)*(Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k))) & - + gupyy(i,j,k)*(Ayyy-(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Ayyz-(Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Ayyz-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & - - (Gamxa*Axy(i,j,k)+Gamya*Ayy(i,j,k)+Gamza*Ayz(i,j,k)) )*uy(i,j,k) & - + (gupxx(i,j,k)*(Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axzy-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & - + gupyy(i,j,k)*(Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Azzz-(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k))) & - - (Gamxa*Axz(i,j,k)+Gamya*Ayz(i,j,k)+Gamza*Azz(i,j,k)) )*uz(i,j,k) & - -2.d0/3.d0*(Kx*ux(i,j,k)+Ky*uy(i,j,k)+Kz*uz(i,j,k)) & - -ONE/3.d0* (TZx*ux(i,j,k)+TZy*uy(i,j,k)+TZz*uz(i,j,k)) & - -1.5d0/chin1(i,j,k)* & - (ux(i,j,k)*(gupxx(i,j,k)*chix*Axx(i,j,k)+gupxy(i,j,k)*chix*Axy(i,j,k)+gupxz(i,j,k)*chix*Axz(i,j,k) & - +gupxy(i,j,k)*chiy*Axx(i,j,k)+gupyy(i,j,k)*chiy*Axy(i,j,k)+gupyz(i,j,k)*chiy*Axz(i,j,k) & - +gupxz(i,j,k)*chiz*Axx(i,j,k)+gupyz(i,j,k)*chiz*Axy(i,j,k)+gupzz(i,j,k)*chiz*Axz(i,j,k)) & - +uy(i,j,k)*(gupxx(i,j,k)*chix*Axy(i,j,k)+gupxy(i,j,k)*chix*Ayy(i,j,k)+gupxz(i,j,k)*chix*Ayz(i,j,k) & - +gupxy(i,j,k)*chiy*Axy(i,j,k)+gupyy(i,j,k)*chiy*Ayy(i,j,k)+gupyz(i,j,k)*chiy*Ayz(i,j,k) & - +gupxz(i,j,k)*chiz*Axy(i,j,k)+gupyz(i,j,k)*chiz*Ayy(i,j,k)+gupzz(i,j,k)*chiz*Ayz(i,j,k)) & - +uz(i,j,k)*(gupxx(i,j,k)*chix*Axz(i,j,k)+gupxy(i,j,k)*chix*Ayz(i,j,k)+gupxz(i,j,k)*chix*Azz(i,j,k) & - +gupxy(i,j,k)*chiy*Axz(i,j,k)+gupyy(i,j,k)*chiy*Ayz(i,j,k)+gupyz(i,j,k)*chiy*Azz(i,j,k) & - +gupxz(i,j,k)*chiz*Axz(i,j,k)+gupyz(i,j,k)*chiz*Ayz(i,j,k)+gupzz(i,j,k)*chiz*Azz(i,j,k)) ) & - -0.5d0*kappa1*(Gmxcon(i,j,k)*ulx(i,j,k)+Gmycon(i,j,k)*uly(i,j,k)+Gmzcon(i,j,k)*ulz(i,j,k)) & - -(Rxx(i,j,k)*vx(i,j,k)*ux(i,j,k)+Rxy(i,j,k)*vy(i,j,k)*ux(i,j,k)+Rxz(i,j,k)*vz(i,j,k)*ux(i,j,k) & - +Rxy(i,j,k)*vx(i,j,k)*uy(i,j,k)+Ryy(i,j,k)*vy(i,j,k)*uy(i,j,k)+Ryz(i,j,k)*vz(i,j,k)*uy(i,j,k) & - +Rxz(i,j,k)*vx(i,j,k)*uz(i,j,k)+Ryz(i,j,k)*vy(i,j,k)*uz(i,j,k)+Rzz(i,j,k)*vz(i,j,k)*uz(i,j,k)) & - +0.5d0*chin1(i,j,k)*(ulx(i,j,k)*vx(i,j,k)*CAZxx+ulx(i,j,k)*vy(i,j,k)*CAZxy+ulx(i,j,k)*vz(i,j,k)*CAZxz & - +uly(i,j,k)*vx(i,j,k)*CAZyx+uly(i,j,k)*vy(i,j,k)*CAZyy+uly(i,j,k)*vz(i,j,k)*CAZyz & - +ulz(i,j,k)*vx(i,j,k)*CAZzx+ulz(i,j,k)*vy(i,j,k)*CAZzy+ulz(i,j,k)*vz(i,j,k)*CAZzz)) - toAs2_rhs = toAs2_rhs-alpn1(i,j,k)*chin1(i,j,k)*( & - (gupxx(i,j,k)*(Axxx-(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axxy-(Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axxz-(Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axxy-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & - + gupyy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axxz-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Axyz-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & - - (Gamxa*Axx(i,j,k)+Gamya*Axy(i,j,k)+Gamza*Axz(i,j,k)) )*wx(i,j,k) & - + (gupxx(i,j,k)*(Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k))) & - + gupyy(i,j,k)*(Ayyy-(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Ayyz-(Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Ayyz-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & - - (Gamxa*Axy(i,j,k)+Gamya*Ayy(i,j,k)+Gamza*Ayz(i,j,k)) )*wy(i,j,k) & - + (gupxx(i,j,k)*(Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & - + gupxy(i,j,k)*(Axzy-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & - + gupxz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & - + gupxy(i,j,k)*(Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & - + gupyy(i,j,k)*(Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & - + gupyz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & - + gupxz(i,j,k)*(Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k))) & - + gupyz(i,j,k)*(Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k))) & - + gupzz(i,j,k)*(Azzz-(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k))) & - - (Gamxa*Axz(i,j,k)+Gamya*Ayz(i,j,k)+Gamza*Azz(i,j,k)) )*wz(i,j,k) & - -2.d0/3.d0*(Kx*wx(i,j,k)+ky*wy(i,j,k)+Kz*wz(i,j,k)) & - -ONE/3.d0* (TZx*wx(i,j,k)+TZy*wy(i,j,k)+TZz*wz(i,j,k)) & - -1.5d0/chin1(i,j,k)* & - (wx(i,j,k)*(gupxx(i,j,k)*chix*Axx(i,j,k)+gupxy(i,j,k)*chix*Axy(i,j,k)+gupxz(i,j,k)*chix*Axz(i,j,k) & - +gupxy(i,j,k)*chiy*Axx(i,j,k)+gupyy(i,j,k)*chiy*Axy(i,j,k)+gupyz(i,j,k)*chiy*Axz(i,j,k) & - +gupxz(i,j,k)*chiz*Axx(i,j,k)+gupyz(i,j,k)*chiz*Axy(i,j,k)+gupzz(i,j,k)*chiz*Axz(i,j,k)) & - +wy(i,j,k)*(gupxx(i,j,k)*chix*Axy(i,j,k)+gupxy(i,j,k)*chix*Ayy(i,j,k)+gupxz(i,j,k)*chix*Ayz(i,j,k) & - +gupxy(i,j,k)*chiy*Axy(i,j,k)+gupyy(i,j,k)*chiy*Ayy(i,j,k)+gupyz(i,j,k)*chiy*Ayz(i,j,k) & - +gupxz(i,j,k)*chiz*Axy(i,j,k)+gupyz(i,j,k)*chiz*Ayy(i,j,k)+gupzz(i,j,k)*chiz*Ayz(i,j,k)) & - +wz(i,j,k)*(gupxx(i,j,k)*chix*Axz(i,j,k)+gupxy(i,j,k)*chix*Ayz(i,j,k)+gupxz(i,j,k)*chix*Azz(i,j,k) & - +gupxy(i,j,k)*chiy*Axz(i,j,k)+gupyy(i,j,k)*chiy*Ayz(i,j,k)+gupyz(i,j,k)*chiy*Azz(i,j,k) & - +gupxz(i,j,k)*chiz*Axz(i,j,k)+gupyz(i,j,k)*chiz*Ayz(i,j,k)+gupzz(i,j,k)*chiz*Azz(i,j,k)) ) & - -0.5d0*kappa1*(Gmxcon(i,j,k)*wlx(i,j,k)+Gmycon(i,j,k)*wly(i,j,k)+Gmzcon(i,j,k)*wlz(i,j,k)) & - -(Rxx(i,j,k)*vx(i,j,k)*wx(i,j,k)+Rxy(i,j,k)*vy(i,j,k)*wx(i,j,k)+Rxz(i,j,k)*vz(i,j,k)*wx(i,j,k) & - +Rxy(i,j,k)*vx(i,j,k)*wy(i,j,k)+Ryy(i,j,k)*vy(i,j,k)*wy(i,j,k)+Ryz(i,j,k)*vz(i,j,k)*wy(i,j,k) & - +Rxz(i,j,k)*vx(i,j,k)*wz(i,j,k)+Ryz(i,j,k)*vy(i,j,k)*wz(i,j,k)+Rzz(i,j,k)*vz(i,j,k)*wz(i,j,k)) & - +0.5d0*chin1(i,j,k)*(wlx(i,j,k)*vx(i,j,k)*CAZxx+wlx(i,j,k)*vy(i,j,k)*CAZxy+wlx(i,j,k)*vz(i,j,k)*CAZxz & - +wly(i,j,k)*vx(i,j,k)*CAZyx+wly(i,j,k)*vy(i,j,k)*CAZyy+wly(i,j,k)*vz(i,j,k)*CAZyz & - +wlz(i,j,k)*vx(i,j,k)*CAZzx+wlz(i,j,k)*vy(i,j,k)*CAZzy+wlz(i,j,k)*vz(i,j,k)*CAZzz)) - - toGam1_rhs = -alpn1(i,j,k)*dsqrt(tmuST)*((Gamxx*vx(i,j,k)*ulx(i,j,k)+Gamxy*vy(i,j,k)*ulx(i,j,k)+Gamxz*vz(i,j,k)*ulx(i,j,k) & - +Gamyx*vx(i,j,k)*uly(i,j,k)+Gamyy*vy(i,j,k)*uly(i,j,k)+Gamyz*vz(i,j,k)*uly(i,j,k) & - +Gamzx*vx(i,j,k)*ulz(i,j,k)+Gamzy*vy(i,j,k)*ulz(i,j,k)+Gamzz*vz(i,j,k)*ulz(i,j,k)) & - -(Gamxx*ux(i,j,k)*slx(i,j,k)+Gamxy*uy(i,j,k)*slx(i,j,k)+Gamxz*uz(i,j,k)*slx(i,j,k) & - +Gamyx*ux(i,j,k)*sly(i,j,k)+Gamyy*uy(i,j,k)*sly(i,j,k)+Gamyz*uz(i,j,k)*sly(i,j,k) & - +Gamzx*ux(i,j,k)*slz(i,j,k)+Gamzy*uy(i,j,k)*slz(i,j,k)+Gamzz*uz(i,j,k)*slz(i,j,k))/chin1(i,j,k) ) & - +((qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx & - +TWO*(qupxy(i,j,k)*sfxxy+qupxz(i,j,k)*sfxxz+qupyz(i,j,k)*sfxyz))*ulx(i,j,k) & - +(qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx & - +TWO*(qupxy(i,j,k)*sfyxy+qupxz(i,j,k)*sfyxz+qupyz(i,j,k)*sfyyz))*uly(i,j,k) & - +(qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx & - +TWO*(qupxy(i,j,k)*sfzxy+qupxz(i,j,k)*sfzxz+qupyz(i,j,k)*sfzyz))*ulz(i,j,k) & - )/chin1(i,j,k) & - +4.d0/3.d0/chin1(i,j,k)*(ux(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxx+vx(i,j,k)*sly(i,j,k)*sfyxx+vx(i,j,k)*slz(i,j,k)*sfzxx & - +vy(i,j,k)*slx(i,j,k)*sfxxy+vy(i,j,k)*sly(i,j,k)*sfyxy+vy(i,j,k)*slz(i,j,k)*sfzxy & - +vz(i,j,k)*slx(i,j,k)*sfxxz+vz(i,j,k)*sly(i,j,k)*sfyxz+vz(i,j,k)*slz(i,j,k)*sfzxz) & - +uy(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxy+vx(i,j,k)*sly(i,j,k)*sfyxy+vx(i,j,k)*slz(i,j,k)*sfzxy & - +vy(i,j,k)*slx(i,j,k)*sfxyy+vy(i,j,k)*sly(i,j,k)*sfyyy+vy(i,j,k)*slz(i,j,k)*sfzyy & - +vz(i,j,k)*slx(i,j,k)*sfxyz+vz(i,j,k)*sly(i,j,k)*sfyyz+vz(i,j,k)*slz(i,j,k)*sfzyz) & - +uz(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxz+vx(i,j,k)*sly(i,j,k)*sfyxz+vx(i,j,k)*slz(i,j,k)*sfzxz & - +vy(i,j,k)*slx(i,j,k)*sfxyz+vy(i,j,k)*sly(i,j,k)*sfyyz+vy(i,j,k)*slz(i,j,k)*sfzyz & - +vz(i,j,k)*slx(i,j,k)*sfxzz+vz(i,j,k)*sly(i,j,k)*sfyzz+vz(i,j,k)*slz(i,j,k)*sfzzz)) & - +ONE/3.d0/chin1(i,j,k)* (ux(i,j,k)*(qulxx(i,j,k)*sfxxx+qulxy(i,j,k)*sfyxx+qulxz(i,j,k)*sfzxx & - +qulyx(i,j,k)*sfxxy+qulyy(i,j,k)*sfyxy+qulyz(i,j,k)*sfzxy & - +qulzx(i,j,k)*sfxxz+qulzy(i,j,k)*sfyxz+qulzz(i,j,k)*sfzxz) & - +uy(i,j,k)*(qulxx(i,j,k)*sfxxy+qulxy(i,j,k)*sfyxy+qulxz(i,j,k)*sfzxy & - +qulyx(i,j,k)*sfxyy+qulyy(i,j,k)*sfyyy+qulyz(i,j,k)*sfzyy & - +qulzx(i,j,k)*sfxyz+qulzy(i,j,k)*sfyyz+qulzz(i,j,k)*sfzyz) & - +uz(i,j,k)*(qulxx(i,j,k)*sfxxz+qulxy(i,j,k)*sfyxz+qulxz(i,j,k)*sfzxz & - +qulyx(i,j,k)*sfxyz+qulyy(i,j,k)*sfyyz+qulyz(i,j,k)*sfzyz & - +qulzx(i,j,k)*sfxzz+qulzy(i,j,k)*sfyzz+qulzz(i,j,k)*sfzzz)) & - -2.d0/3.d0*alpn1(i,j,k)/chin1(i,j,k)*(ux(i,j,k)*(TWO*Kx+TZx)+uy(i,j,k)*(TWO*Ky+TZy)+uz(i,j,k)*(TWO*Kz+TZz)) & - +hu-kappa3*alpn1(i,j,k)*(Gamx(i,j,k)*ulx(i,j,k)+Gamx(i,j,k)*uly(i,j,k)+Gamz(i,j,k)*ulz(i,j,k)) & - +(betax(i,j,k)*Gamxx+betay(i,j,k)*Gamxy+betaz(i,j,k)*Gamxz)*ulx(i,j,k) & - +(betax(i,j,k)*Gamyx+betay(i,j,k)*Gamyy+betaz(i,j,k)*Gamyz)*uly(i,j,k) & - +(betax(i,j,k)*Gamzx+betay(i,j,k)*Gamzy+betaz(i,j,k)*Gamzz)*ulz(i,j,k) - - toGam2_rhs = -alpn1(i,j,k)*dsqrt(tmuST)*((Gamxx*vx(i,j,k)*wlx(i,j,k)+Gamxy*vy(i,j,k)*wlx(i,j,k)+Gamxz*vz(i,j,k)*wlx(i,j,k) & - +Gamyx*vx(i,j,k)*wly(i,j,k)+Gamyy*vy(i,j,k)*wly(i,j,k)+Gamyz*vz(i,j,k)*wly(i,j,k) & - +Gamzx*vx(i,j,k)*wlz(i,j,k)+Gamzy*vy(i,j,k)*wlz(i,j,k)+Gamzz*vz(i,j,k)*wlz(i,j,k)) & - -(Gamxx*wx(i,j,k)*slx(i,j,k)+Gamxy*wy(i,j,k)*slx(i,j,k)+Gamxz*wz(i,j,k)*slx(i,j,k) & - +Gamyx*wx(i,j,k)*sly(i,j,k)+Gamyy*wy(i,j,k)*sly(i,j,k)+Gamyz*wz(i,j,k)*sly(i,j,k) & - +Gamzx*wx(i,j,k)*slz(i,j,k)+Gamzy*wy(i,j,k)*slz(i,j,k)+Gamzz*wz(i,j,k)*slz(i,j,k))/chin1(i,j,k) ) & - +((qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx & - +TWO*(qupxy(i,j,k)*sfxxy+qupxz(i,j,k)*sfxxz+qupyz(i,j,k)*sfxyz))*wlx(i,j,k) & - +(qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx & - +TWO*(qupxy(i,j,k)*sfyxy+qupxz(i,j,k)*sfyxz+qupyz(i,j,k)*sfyyz))*wly(i,j,k) & - +(qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx & - +TWO*(qupxy(i,j,k)*sfzxy+qupxz(i,j,k)*sfzxz+qupyz(i,j,k)*sfzyz))*wlz(i,j,k) & - )/chin1(i,j,k) & - +4.d0/3.d0/chin1(i,j,k)*(wx(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxx+vx(i,j,k)*sly(i,j,k)*sfyxx+vx(i,j,k)*slz(i,j,k)*sfzxx & - +vy(i,j,k)*slx(i,j,k)*sfxxy+vy(i,j,k)*sly(i,j,k)*sfyxy+vy(i,j,k)*slz(i,j,k)*sfzxy & - +vz(i,j,k)*slx(i,j,k)*sfxxz+vz(i,j,k)*sly(i,j,k)*sfyxz+vz(i,j,k)*slz(i,j,k)*sfzxz) & - +wy(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxy+vx(i,j,k)*sly(i,j,k)*sfyxy+vx(i,j,k)*slz(i,j,k)*sfzxy & - +vy(i,j,k)*slx(i,j,k)*sfxyy+vy(i,j,k)*sly(i,j,k)*sfyyy+vy(i,j,k)*slz(i,j,k)*sfzyy & - +vz(i,j,k)*slx(i,j,k)*sfxyz+vz(i,j,k)*sly(i,j,k)*sfyyz+vz(i,j,k)*slz(i,j,k)*sfzyz) & - +wz(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxz+vx(i,j,k)*sly(i,j,k)*sfyxz+vx(i,j,k)*slz(i,j,k)*sfzxz & - +vy(i,j,k)*slx(i,j,k)*sfxyz+vy(i,j,k)*sly(i,j,k)*sfyyz+vy(i,j,k)*slz(i,j,k)*sfzyz & - +vz(i,j,k)*slx(i,j,k)*sfxzz+vz(i,j,k)*sly(i,j,k)*sfyzz+vz(i,j,k)*slz(i,j,k)*sfzzz)) & - +ONE/3.d0/chin1(i,j,k)* (wx(i,j,k)*(qulxx(i,j,k)*sfxxx+qulxy(i,j,k)*sfyxx+qulxz(i,j,k)*sfzxx & - +qulyx(i,j,k)*sfxxy+qulyy(i,j,k)*sfyxy+qulyz(i,j,k)*sfzxy & - +qulzx(i,j,k)*sfxxz+qulzy(i,j,k)*sfyxz+qulzz(i,j,k)*sfzxz) & - +wy(i,j,k)*(qulxx(i,j,k)*sfxxy+qulxy(i,j,k)*sfyxy+qulxz(i,j,k)*sfzxy & - +qulyx(i,j,k)*sfxyy+qulyy(i,j,k)*sfyyy+qulyz(i,j,k)*sfzyy & - +qulzx(i,j,k)*sfxyz+qulzy(i,j,k)*sfyyz+qulzz(i,j,k)*sfzyz) & - +wz(i,j,k)*(qulxx(i,j,k)*sfxxz+qulxy(i,j,k)*sfyxz+qulxz(i,j,k)*sfzxz & - +qulyx(i,j,k)*sfxyz+qulyy(i,j,k)*sfyyz+qulyz(i,j,k)*sfzyz & - +qulzx(i,j,k)*sfxzz+qulzy(i,j,k)*sfyzz+qulzz(i,j,k)*sfzzz)) & - -2.d0/3.d0*alpn1(i,j,k)/chin1(i,j,k)*(wx(i,j,k)*(TWO*Kx+TZx)+wy(i,j,k)*(TWO*Ky+TZy)+wz(i,j,k)*(TWO*Kz+TZz)) & - +hw-kappa3*alpn1(i,j,k)*(Gamx(i,j,k)*wlx(i,j,k)+Gamx(i,j,k)*wly(i,j,k)+Gamz(i,j,k)*wlz(i,j,k)) & - +(betax(i,j,k)*Gamxx+betay(i,j,k)*Gamxy+betaz(i,j,k)*Gamxz)*wlx(i,j,k) & - +(betax(i,j,k)*Gamyx+betay(i,j,k)*Gamyy+betaz(i,j,k)*Gamyz)*wly(i,j,k) & - +(betax(i,j,k)*Gamzx+betay(i,j,k)*Gamzy+betaz(i,j,k)*Gamzz)*wlz(i,j,k) - -! \tilde{D} A_ij - gxxx = Axxx-TWO*(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k)) - gxxy = Axxy-TWO*(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k)) - gxxz = Axxz-TWO*(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k)) - gyyx = Ayyx-TWO*(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k)) - gyyy = Ayyy-TWO*(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k)) - gyyz = Ayyz-TWO*(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k)) - gzzx = Azzx-TWO*(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k)) - gzzy = Azzy-TWO*(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k)) - gzzz = Azzz-TWO*(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k)) - gxyx = Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k)+Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k)) - gxyy = Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k)+Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k)) - gxyz = Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k)+Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k)) - gxzx = Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k)+Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k)) - gxzy = Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k)+Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k)) - gxzz = Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k)+Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k)) - gyzx = Ayzx-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k)+Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k)) - gyzy = Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k)+Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k)) - gyzz = Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k)+Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k)) - - f = (trK(i,j,k)+TWO*TZ(i,j,k))*TWO/3.d0 - fxx = (vx(i,j,k)*gxxx + vy(i,j,k)*gxxy + vz(i,j,k)*gxxz & - -(vx(i,j,k)*gxxx + vy(i,j,k)*gxyx + vz(i,j,k)*gxzx)) & - +AAxx-f*Axx(i,j,k) - fyy = (vx(i,j,k)*gyyx + vy(i,j,k)*gyyy + vz(i,j,k)*gyyz & - -(vx(i,j,k)*gxyy + vy(i,j,k)*gyyy + vz(i,j,k)*gyzy)) & - +AAyy-f*Ayy(i,j,k) - fzz = (vx(i,j,k)*gzzx + vy(i,j,k)*gzzy + vz(i,j,k)*gzzz & - -(vx(i,j,k)*gxzz + vy(i,j,k)*gyzz + vz(i,j,k)*gzzz)) & - +AAzz-f*Azz(i,j,k) - fxy = (vx(i,j,k)*gxyx + vy(i,j,k)*gxyy + vz(i,j,k)*gxyz & - -(vx(i,j,k)*gxxy + vy(i,j,k)*gxyy + vz(i,j,k)*gxzy + vx(i,j,k)*gxyx + vy(i,j,k)*gyyx + vz(i,j,k)*gyzx)/TWO) & - +AAxy-f*Axy(i,j,k) - fxz = (vx(i,j,k)*gxzx + vy(i,j,k)*gxzy + vz(i,j,k)*gxzz & - -(vx(i,j,k)*gxxz + vy(i,j,k)*gxyz + vz(i,j,k)*gxzz + vx(i,j,k)*gyzx + vy(i,j,k)*gyzx + vz(i,j,k)*gzzx)/TWO) & - +AAxz-f*Axz(i,j,k) - fyz = (vx(i,j,k)*gyzx + vy(i,j,k)*gyzy + vz(i,j,k)*gyzz & - -(vx(i,j,k)*gxyz + vy(i,j,k)*gyyz + vz(i,j,k)*gyzz + vx(i,j,k)*gyzy + vy(i,j,k)*gyzy + vz(i,j,k)*gzzy)/TWO) & - +AAyz-f*Ayz(i,j,k) - -! 1/2 A_ij D_k(ln chi) - gxxx = Axx(i,j,k)*chix/TWO/chin1(i,j,k) - gxxy = Axx(i,j,k)*chiy/TWO/chin1(i,j,k) - gxxz = Axx(i,j,k)*chiz/TWO/chin1(i,j,k) - gxyx = Axy(i,j,k)*chix/TWO/chin1(i,j,k) - gxyy = Axy(i,j,k)*chiy/TWO/chin1(i,j,k) - gxyz = Axy(i,j,k)*chiz/TWO/chin1(i,j,k) - gxzx = Axz(i,j,k)*chix/TWO/chin1(i,j,k) - gxzy = Axz(i,j,k)*chiy/TWO/chin1(i,j,k) - gxzz = Axz(i,j,k)*chiz/TWO/chin1(i,j,k) - gyyx = Ayy(i,j,k)*chix/TWO/chin1(i,j,k) - gyyy = Ayy(i,j,k)*chiy/TWO/chin1(i,j,k) - gyyz = Ayy(i,j,k)*chiz/TWO/chin1(i,j,k) - gyzx = Ayz(i,j,k)*chix/TWO/chin1(i,j,k) - gyzy = Ayz(i,j,k)*chiy/TWO/chin1(i,j,k) - gyzz = Ayz(i,j,k)*chiz/TWO/chin1(i,j,k) - gzzx = Azz(i,j,k)*chix/TWO/chin1(i,j,k) - gzzy = Azz(i,j,k)*chiy/TWO/chin1(i,j,k) - gzzz = Azz(i,j,k)*chiz/TWO/chin1(i,j,k) - - fxx = fxx - (vx(i,j,k)*gxxx + vy(i,j,k)*gxxy + vz(i,j,k)*gxxz & - -(vx(i,j,k)*gxxx + vy(i,j,k)*gxyx + vz(i,j,k)*gxzx)) - fyy = fyy - (vx(i,j,k)*gyyx + vy(i,j,k)*gyyy + vz(i,j,k)*gyyz & - -(vx(i,j,k)*gxyy + vy(i,j,k)*gyyy + vz(i,j,k)*gyzy)) - fzz = fzz - (vx(i,j,k)*gzzx + vy(i,j,k)*gzzy + vz(i,j,k)*gzzz & - -(vx(i,j,k)*gxzz + vy(i,j,k)*gyzz + vz(i,j,k)*gzzz)) - fxy = fxy - (vx(i,j,k)*gxyx + vy(i,j,k)*gxyy + vz(i,j,k)*gxyz & - -(vx(i,j,k)*gxxy + vy(i,j,k)*gxyy + vz(i,j,k)*gxzy + vx(i,j,k)*gxyx + vy(i,j,k)*gyyx + vz(i,j,k)*gyzx)/TWO) - fxz = fxz - (vx(i,j,k)*gxzx + vy(i,j,k)*gxzy + vz(i,j,k)*gxzz & - -(vx(i,j,k)*gxxz + vy(i,j,k)*gxyz + vz(i,j,k)*gxzz + vx(i,j,k)*gyzx + vy(i,j,k)*gyzx + vz(i,j,k)*gzzx)/TWO) - fyz = fyz - (vx(i,j,k)*gyzx + vy(i,j,k)*gyzy + vz(i,j,k)*gyzz & - -(vx(i,j,k)*gxyz + vy(i,j,k)*gyyz + vz(i,j,k)*gyzz + vx(i,j,k)*gyzy + vy(i,j,k)*gyzy + vz(i,j,k)*gzzy)/TWO) - - TFxx = TFxx-alpn1(i,j,k)*fxx - TFxy = TFxy-alpn1(i,j,k)*fxy - TFxz = TFxz-alpn1(i,j,k)*fxz - TFyy = TFyy-alpn1(i,j,k)*fyy - TFyz = TFyz-alpn1(i,j,k)*fyz - TFzz = TFzz-alpn1(i,j,k)*fzz - - f = 0.5d0*(qupxx(i,j,k)*TFxx+qupyy(i,j,k)*TFyy+qupzz(i,j,k)*TFzz & - +TWO*(qupxy(i,j,k)*TFxy+qupxz(i,j,k)*TFxz+qupyz(i,j,k)*TFyz)) - - toA11_rhs = ux(i,j,k)*ux(i,j,k)*TFxx+uy(i,j,k)*uy(i,j,k)*TFyy+uz(i,j,k)*uz(i,j,k)*TFzz+ & - TWO*(ux(i,j,k)*uy(i,j,k)*TFxy+ux(i,j,k)*uz(i,j,k)*TFxz+uy(i,j,k)*uz(i,j,k)*TFyz)-f - toA22_rhs = wx(i,j,k)*wx(i,j,k)*TFxx+wy(i,j,k)*wy(i,j,k)*TFyy+wz(i,j,k)*wz(i,j,k)*TFzz+ & - TWO*(wx(i,j,k)*wy(i,j,k)*TFxy+wx(i,j,k)*wz(i,j,k)*TFxz+wy(i,j,k)*wz(i,j,k)*TFyz)-f - toA12_rhs = ux(i,j,k)*wx(i,j,k)*TFxx+ux(i,j,k)*wy(i,j,k)*TFxy+ux(i,j,k)*wz(i,j,k)*TFxz & - +uy(i,j,k)*wx(i,j,k)*TFxy+uy(i,j,k)*wy(i,j,k)*TFyy+uy(i,j,k)*wz(i,j,k)*TFyz & - +uz(i,j,k)*wx(i,j,k)*TFxz+uz(i,j,k)*wy(i,j,k)*TFyz+uz(i,j,k)*wz(i,j,k)*TFzz - - toA11_rhs = toA11_rhs +alpn1(i,j,k)*chin1(i,j,k)*Rhpsi0 - toA22_rhs = toA22_rhs -alpn1(i,j,k)*chin1(i,j,k)*Rhpsi0 - toA12_rhs = toA12_rhs +alpn1(i,j,k)*chin1(i,j,k)*Ihpsi0 - -#if 0 - toAqq_rhs = qupxx(i,j,k)*Axx_rhs(i,j,k)+qupyy(i,j,k)*Ayy_rhs(i,j,k)+qupzz(i,j,k)*Azz_rhs(i,j,k) & - +TWO*(qupxy(i,j,k)*Axy_rhs(i,j,k)+qupxz(i,j,k)*Axz_rhs(i,j,k)+qupyz(i,j,k)*Ayz_rhs(i,j,k)) -#else - Ainvxx = gupxx(i,j,k)*gupxx(i,j,k)*Axx(i,j,k)+2.0*gupxx(i,j,k)*gupxy(i,j,k)*Axy(i,j,k)+ & - 2.0*gupxx(i,j,k)*gupxz(i,j,k)*Axz(i,j,k)+gupxy(i,j,k)*gupxy(i,j,k)*Ayy(i,j,k)+ & - 2.0*gupxy(i,j,k)*gupxz(i,j,k)*Ayz(i,j,k)+gupxz(i,j,k)*gupxz(i,j,k)*Azz(i,j,k) - - Ainvxy = gupxx(i,j,k)*gupxy(i,j,k)*Axx(i,j,k)+gupxx(i,j,k)*gupyy(i,j,k)*Axy(i,j,k)+ & - gupxx(i,j,k)*gupyz(i,j,k)*Axz(i,j,k)+gupxy(i,j,k)*gupxy(i,j,k)*Axy(i,j,k)+ & - gupxy(i,j,k)*gupyy(i,j,k)*Ayy(i,j,k)+gupxy(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+ & - gupxz(i,j,k)*gupxy(i,j,k)*Axz(i,j,k)+gupxz(i,j,k)*gupyy(i,j,k)*Ayz(i,j,k)+gupxz(i,j,k)*gupyz(i,j,k)*Azz(i,j,k) - - Ainvxz = gupxx(i,j,k)*gupxz(i,j,k)*Axx(i,j,k)+gupxx(i,j,k)*gupyz(i,j,k)*Axy(i,j,k)+ & - gupxx(i,j,k)*gupzz(i,j,k)*Axz(i,j,k)+gupxy(i,j,k)*gupxz(i,j,k)*Axy(i,j,k)+ & - gupxy(i,j,k)*gupyz(i,j,k)*Ayy(i,j,k)+gupxy(i,j,k)*gupzz(i,j,k)*Ayz(i,j,k)+ & - gupxz(i,j,k)*gupxz(i,j,k)*Axz(i,j,k)+gupxz(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+gupxz(i,j,k)*gupzz(i,j,k)*Azz(i,j,k) - Ainvyy = gupxy(i,j,k)*gupxy(i,j,k)*Axx(i,j,k)+2.0*gupxy(i,j,k)*gupyy(i,j,k)*Axy(i,j,k)+ & - 2.0*gupxy(i,j,k)*gupyz(i,j,k)*Axz(i,j,k)+gupyy(i,j,k)*gupyy(i,j,k)*Ayy(i,j,k)+ & - 2.0*gupyy(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+gupyz(i,j,k)*gupyz(i,j,k)*Azz(i,j,k) - - Ainvyz = gupxy(i,j,k)*gupxz(i,j,k)*Axx(i,j,k)+gupxy(i,j,k)*gupyz(i,j,k)*Axy(i,j,k)+ & - gupxy(i,j,k)*gupzz(i,j,k)*Axz(i,j,k)+gupyy(i,j,k)*gupxz(i,j,k)*Axy(i,j,k)+ & - gupyy(i,j,k)*gupyz(i,j,k)*Ayy(i,j,k)+gupyy(i,j,k)*gupzz(i,j,k)*Ayz(i,j,k)+ & - gupyz(i,j,k)*gupxz(i,j,k)*Axz(i,j,k)+gupyz(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+gupyz(i,j,k)*gupzz(i,j,k)*Azz(i,j,k) - Ainvzz = gupxz(i,j,k)*gupxz(i,j,k)*Axx(i,j,k)+2.0*gupxz(i,j,k)*gupyz(i,j,k)*Axy(i,j,k)+ & - 2.0*gupxz(i,j,k)*gupzz(i,j,k)*Axz(i,j,k)+gupyz(i,j,k)*gupyz(i,j,k)*Ayy(i,j,k)+ & - 2.0*gupyz(i,j,k)*gupzz(i,j,k)*Ayz(i,j,k)+gupzz(i,j,k)*gupzz(i,j,k)*Azz(i,j,k) - - toAqq_rhs = -TWO*alpn1(i,j,k)*chin1(i,j,k)*(gupxx(i,j,k)*AAxx+gupyy(i,j,k)*AAyy+gupzz(i,j,k)*AAzz & - +TWO*(gupxy(i,j,k)*AAxy+gupxz(i,j,k)*AAxz+gupyz(i,j,k)*AAyz))+chin1(i,j,k)*(Ainvxx+liegxx+Ainvyy*liegyy+Ainvzz*liegzz & - +TWO*(Ainvxy*liegxy+Ainvxz*liegxz+Ainvyz*liegyz))-toAss_rhs -#endif -! reconstruct rhs for dynamical variables - trK_rhs(i,j,k) = totrK_rhs - TZ_rhs(i,j,k) = toTZ_rhs - Gamx_rhs(i,j,k) = toGams_rhs*vx(i,j,k)+toGam1_rhs*ux(i,j,k)+toGam2_rhs*wx(i,j,k) - Gamy_rhs(i,j,k) = toGams_rhs*vy(i,j,k)+toGam1_rhs*uy(i,j,k)+toGam2_rhs*wy(i,j,k) - Gamz_rhs(i,j,k) = toGams_rhs*vz(i,j,k)+toGam1_rhs*uz(i,j,k)+toGam2_rhs*wz(i,j,k) - Axx_rhs(i,j,k) = (ulx(i,j,k)*ulx(i,j,k)-0.5d0*qxx(i,j,k))*toA11_rhs+(wlx(i,j,k)*wlx(i,j,k)-0.5d0*qxx(i,j,k))*toA22_rhs+ulx(i,j,k)*wlx(i,j,k)*toA12_rhs & - + ulx(i,j,k)*slx(i,j,k)*toAs1_rhs+wlx(i,j,k)*slx(i,j,k)*toAs2_rhs+slx(i,j,k)*slx(i,j,k)*toAss_rhs & - + 0.5d0*qxx(i,j,k)*toAqq_rhs - Ayy_rhs(i,j,k) = (uly(i,j,k)*uly(i,j,k)-0.5d0*qyy(i,j,k))*toA11_rhs+(wly(i,j,k)*wly(i,j,k)-0.5d0*qyy(i,j,k))*toA22_rhs+uly(i,j,k)*wly(i,j,k)*toA12_rhs & - + uly(i,j,k)*sly(i,j,k)*toAs1_rhs+wly(i,j,k)*sly(i,j,k)*toAs2_rhs+sly(i,j,k)*sly(i,j,k)*toAss_rhs & - + 0.5d0*qyy(i,j,k)*toAqq_rhs - Azz_rhs(i,j,k) = (ulz(i,j,k)*ulz(i,j,k)-0.5d0*qzz(i,j,k))*toA11_rhs+(wlz(i,j,k)*wlz(i,j,k)-0.5d0*qzz(i,j,k))*toA22_rhs+ulz(i,j,k)*wlz(i,j,k)*toA12_rhs & - + ulz(i,j,k)*slz(i,j,k)*toAs1_rhs+wlz(i,j,k)*slz(i,j,k)*toAs2_rhs+slz(i,j,k)*slz(i,j,k)*toAss_rhs & - + 0.5d0*qzz(i,j,k)*toAqq_rhs - Axy_rhs(i,j,k) = (ulx(i,j,k)*uly(i,j,k)-0.5d0*qxy(i,j,k))*toA11_rhs+(wlx(i,j,k)*wly(i,j,k)-0.5d0*qxy(i,j,k))*toA22_rhs+ & - (ulx(i,j,k)*wly(i,j,k)+uly(i,j,k)*wlx(i,j,k))/TWO*toA12_rhs & - +(ulx(i,j,k)*sly(i,j,k)+uly(i,j,k)*slx(i,j,k))/TWO*toAs1_rhs & - +(wlx(i,j,k)*sly(i,j,k)+wly(i,j,k)*slx(i,j,k))/TWO*toAs2_rhs & - +(slx(i,j,k)*sly(i,j,k)+sly(i,j,k)*slx(i,j,k))/TWO*toAss_rhs & - + 0.5d0*qxy(i,j,k)*toAqq_rhs - Axz_rhs(i,j,k) = (ulx(i,j,k)*ulz(i,j,k)-0.5d0*qxz(i,j,k))*toA11_rhs+(wlx(i,j,k)*wlz(i,j,k)-0.5d0*qxz(i,j,k))*toA22_rhs+ & - (ulx(i,j,k)*wlz(i,j,k)+ulz(i,j,k)*wlx(i,j,k))/TWO*toA12_rhs & - +(ulx(i,j,k)*slz(i,j,k)+ulz(i,j,k)*slx(i,j,k))/TWO*toAs1_rhs & - +(wlx(i,j,k)*slz(i,j,k)+wlz(i,j,k)*slx(i,j,k))/TWO*toAs2_rhs & - +(slx(i,j,k)*slz(i,j,k)+slz(i,j,k)*slx(i,j,k))/TWO*toAss_rhs & - + 0.5d0*qxz(i,j,k)*toAqq_rhs - Ayz_rhs(i,j,k) = (uly(i,j,k)*ulz(i,j,k)-0.5d0*qyz(i,j,k))*toA11_rhs+(wlz(i,j,k)*wlz(i,j,k)-0.5d0*qyz(i,j,k))*toA22_rhs+ & - (uly(i,j,k)*wlz(i,j,k)+ulz(i,j,k)*wly(i,j,k))/TWO*toA12_rhs & - +(uly(i,j,k)*slz(i,j,k)+ulz(i,j,k)*sly(i,j,k))/TWO*toAs1_rhs & - +(wly(i,j,k)*slz(i,j,k)+wlz(i,j,k)*sly(i,j,k))/TWO*toAs2_rhs & - +(sly(i,j,k)*slz(i,j,k)+slz(i,j,k)*sly(i,j,k))/TWO*toAss_rhs & - + 0.5d0*qyz(i,j,k)*toAqq_rhs - enddo - enddo - enddo - - endif - - SSS(1)=SYM - SSS(2)=SYM - SSS(3)=SYM - - AAS(1)=ANTI - AAS(2)=ANTI - AAS(3)=SYM - - ASA(1)=ANTI - ASA(2)=SYM - ASA(3)=ANTI - - SAA(1)=SYM - SAA(2)=ANTI - SAA(3)=ANTI - - ASS(1)=ANTI - ASS(2)=SYM - ASS(3)=SYM - - SAS(1)=SYM - SAS(2)=ANTI - SAS(3)=SYM - - SSA(1)=SYM - SSA(2)=SYM - SSA(3)=ANTI - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - if(eps>0)then -! usual Kreiss-Oliger dissipation - call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) - call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) - - call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) - endif - - return - - end subroutine david_milton_cpbc_ss -#endif -! repopulate the buffer points of outer boundary through extroplation -! need CPBC_ghost_width - subroutine repo_extro_ss(ex,x,y,z,f,zmin,zmax,tpp) - implicit none - integer,intent(in ):: ex(1:3) - double precision,intent(in),dimension(ex(1))::x - double precision,intent(in),dimension(ex(2))::y - double precision,intent(in),dimension(ex(3))::z - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: f - real*8, intent(in):: zmin,zmax -! extraplate type -! 0: Lagange polynomial; 1: D+^n f = 0 - integer,intent(in) :: tpp -!~~~~~~~~~~~> local variables - logical :: gont - real*8 :: dZ - integer :: i, j, k - integer :: layer(1:6,1:6),gp - real*8 :: extroplate_lag,extroplate_cg - - integer :: NP - -!sanity check - if(ex(3) .le. CPBC_ghost_width +(ghost_width*2+1))then - write(*,*) "repo_extro_ss has assumed ex(3) > CPBC_ghost_width +(ghost_width*2+1) but ex(3) = ",ex(3),"CPBC_ghost_width = ",CPBC_ghost_width - stop - endif - - dZ = Z(2) - Z(1) - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(Z(ex(3))-zmax) < dZ)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(3,3) = ex(3) - CPBC_ghost_width - layer(4,3) = ex(1) - layer(5,3) = ex(2) - layer(6,3) = ex(3) - CPBC_ghost_width -endif -! extroplate point by point - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - -!!! fixme: note the assumption points requirement is enough or not - select case (tpp) - case (0) - NP = ghost_width*2+1 -! NP = ghost_width*2-1 - - do k = layer(3,gp) + 1,ex(3) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - f(i,j,k) = extroplate_lag(NP,f(i,j,k-NP:k-1)) - enddo - enddo - enddo - - case (1) -! NP = (ghost_width-1)*2 - NP = ghost_width*2 - - do k = layer(3,gp) + 1,ex(3) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - f(i,j,k) = extroplate_cg(NP,f(i,j,k-NP:k-1)) - enddo - enddo - enddo - - case (2) - NP = ghost_width*2+1 -! NP = ghost_width*2-1 - - NP = NP + CPBC_ghost_width - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - call extroplate_lag2(NP,f(i,j,ex(3)-NP+1:ex(3))) - enddo - enddo - - case default - write(*,*) "repo_extro_ss: not recognized extraplation type = ",tpp - return - end select - - - endif - - return - - end subroutine repo_extro_ss -! extroplate for unigrid with Lagange polynomial - function extroplate_lag(N,f) result(gont) - implicit none - integer,intent(in ) :: N - real*8,dimension(N),intent(in) :: f - - real*8 :: gont - - real*8,parameter :: THR=3.d0 - real*8,parameter :: FIV=5.d0,TEN=1.d1,NIN=9.d0 - real*8,parameter :: SEV=7.d0,TYO=2.1d1,F35=3.5d1 - real*8,parameter :: F36=3.6d1,F84=8.4d1,F126=1.26d2 - real*8,parameter :: F11=1.1d1,F55=5.5d1,F165=1.65d2,F330=3.3d2,F462=4.62d2 - -! Lagange polynomial - select case (N) -! for 2nd order code - case (3) - gont = THR*f(3)-THR*f(2)+f(1) -! for 2nd order code - case (5) - gont = FIV*f(5)-TEN*f(4)+TEN*f(3)-FIV*f(2)+f(1) -! for 4th order code - case (7) - gont = SEV*f(7)-TYO*f(6)+F35*f(5)-F35*f(4)+TYO*f(3)-SEV*f(2)+f(1) -! for 6th order code - case (9) - gont = NIN*f(9)-F36*f(8)+F84*f(7)-F126*f(6)+F126*f(5)-F84*f(4)+F36*f(3)-NIN*f(2)+f(1) -! for 8th order code - case (11) - gont = F11*f(11)-F55*f(10)+F165*f(9)-F330*f(8)+F462*f(7)-F462*f(6)+F330*f(5)-F165*f(4)+F55*f(3)-F11*f(2)+f(1) - end select - - return - - end function extroplate_lag -! extroplate for unigrid with Lagange polynomial -! but using inner N-ghost_width points for all of the outer ghost_width points - subroutine extroplate_lag2(N,f) - implicit none - integer,intent(in ) :: N - real*8,dimension(N),intent(inout) :: f - - integer :: NI,i - real*8 :: s1,s2 - - NI = N - CPBC_ghost_width - - do i=1,CPBC_ghost_width - -! Lagange polynomial - select case (NI) -! for 2nd order code - case (3) - f(NI+i) = i**2*f(1)/2+i*f(1)/2-i**2*f(2)-2*i*f(2)+f(3)*i**2/2+3.D0/2.D0*f(3)*i+f(3) -! for 2nd order code - case (5) - f(NI+i) = i**4*f(1)/24+i**3*f(1)/4+11.D0/24.D0*i**2*f(1)+i*f(1)/4-i**4*f(2)/6 & - -7.D0/6.D0*i**3*f(2)-7.D0/3.D0*i**2*f(2)-4.D0/3.D0*i*f(2)+f(3)*i**4/4 & - +2*f(3)*i**3+19.D0/4.D0*f(3)*i**2+3*f(3)*i-i**4*f(4)/6 & - -3.D0/2.D0*i**3*f(4)-13.D0/3.D0*i**2*f(4)-4*i*f(4) & - +f(5)*i**4/24+5.D0/12.D0*f(5)*i**3+35.D0/24.D0*f(5)*i**2 & - +25.D0/12.D0*f(5)*i+f(5) -! for 4th order code - case (7) - s1 = 33.D0/4.D0*f(3)*i**2+15.D0/2.D0*f(5)*i+117.D0/8.D0*f(5)*i**2 & - -121.D0/36.D0*i**4*f(4)+i**5*f(1)/48-i**6*f(2)/120-20.D0/3.D0*i*f(4) & - +35.D0/144.D0*f(7)*i**4+137.D0/48.D0*f(5)*i**4+107.D0/48.D0*f(3)*i**4 & - +203.D0/90.D0*f(7)*i**2-31.D0/3.D0*i**3*f(4)-27.D0/10.D0*i**2*f(2) & - +f(5)*i**6/48+15.D0/4.D0*f(3)*i+17.D0/144.D0*i**4*f(1)-i**5*f(4)/2 & - -i**5*f(6)/6-13.D0/6.D0*i**3*f(2)+137.D0/360.D0*i**2*f(1) & - +49.D0/48.D0*f(7)*i**3 - f(NI+i) = s1-19.D0/24.D0*i**4*f(2)+7.D0/240.D0*f(7)*i**5+f(7)*i**6/720 & - +461.D0/48.D0*f(5)*i**3-6*i*f(6)-87.D0/10.D0*i**2*f(6) & - +i**6*f(1)/720-127.D0/9.D0*i**2*f(4)+19.D0/48.D0*f(5)*i**5 & - +5.D0/16.D0*i**3*f(1)-i**6*f(6)/120+49.D0/20.D0*f(7)*i & - -29.D0/6.D0*i**3*f(6)-31.D0/24.D0*i**4*f(6)-6.D0/5.D0*i*f(2) & - +i*f(1)/6-2.D0/15.D0*i**5*f(2)-i**6*f(4)/36 & - +307.D0/48.D0*f(3)*i**3+17.D0/48.D0*f(3)*i**5+f(3)*i**6/48+f(7) -! for 6th order code - case (9) - s1 = -8*i*f(8)-527.D0/180.D0*i**3*f(2)+2803.D0/480.D0*f(3)*i**4 & - -i**8*f(8)/5040+18353.D0/720.D0*f(7)*i**3-391.D0/720.D0*i**6*f(4) & - +1457.D0/36.D0*f(5)*i**3+9.D0/80.D0*f(9)*i**5+23.D0/2880.D0*i**6*f(1) & - +17.D0/720.D0*f(7)*i**7-56.D0/3.D0*i*f(6)+761.D0/280.D0*f(9)*i & - -67.D0/45.D0*i**4*f(2)+14*f(7)*i+f(3)*i**7/48-268.D0/15.D0*i**4*f(6) & - -2003.D0/45.D0*i**2*f(6)+13.D0/960.D0*f(9)*i**6-73.D0/720.D0*i**6*f(8) & - +f(7)*i**8/1440+363.D0/1120.D0*i**2*f(1)-797.D0/20.D0*i**3*f(6) & - -11.D0/240.D0*i**7*f(6)-329.D0/90.D0*i**4*f(8)+179.D0/36.D0*f(5)*i**5 & - +967.D0/5760.D0*i**4*f(1)-103.D0/35.D0*i**2*f(2)-481.D0/35.D0*i**2*f(8) & - +179.D0/72.D0*f(7)*i**5-349.D0/36.D0*i**3*f(8)+61.D0/240.D0*f(3)*i**6 & - -115.D0/144.D0*i**5*f(8)+f(5)*i**8/576-56.D0/5.D0*i*f(4) & - +187.D0/16.D0*f(3)*i**3-149.D0/240.D0*i**6*f(6) - f(NI+i) = s1+i**8*f(1)/40320+2143.D0/180.D0*f(3)*i**2+469.D0/1440.D0*i**3*f(1) & - +f(5)*i**7/18+621.D0/20.D0*f(7)*i**2+f(9)+267.D0/160.D0*f(9)*i**3 & - +7.D0/144.D0*i**5*f(1)-i**7*f(8)/144+1069.D0/1920.D0*f(9)*i**4 & - -141.D0/5.D0*i**2*f(4)-29.D0/5040.D0*i**7*f(2)-i**8*f(4)/720 & - +691.D0/16.D0*f(5)*i**2+f(9)*i**7/1120-2581.D0/720.D0*i**5*f(4) & - -i**8*f(2)/5040+10993.D0/576.D0*f(5)*i**4+14.D0/3.D0*f(3)*i & - -i**8*f(6)/720-4891.D0/180.D0*i**3*f(4)+13.D0/8.D0*f(3)*i**5 & - +239.D0/720.D0*f(7)*i**6+15289.D0/1440.D0*f(7)*i**4+f(3)*i**8/1440 & - -49.D0/720.D0*i**6*f(2)+35.D0/2.D0*f(5)*i-71.D0/16.D0*i**5*f(6) & - +f(9)*i**8/40320+29531.D0/10080.D0*f(9)*i**2+209.D0/288.D0*f(5)*i**6 & - -1193.D0/90.D0*i**4*f(4)+i*f(1)/8-61.D0/144.D0*i**5*f(2)+i**7*f(1)/1440 & - -31.D0/720.D0*i**7*f(4)-8.D0/7.D0*i*f(2) -! for 8th order code - case (11) - s2 = -433739.D0/7560.D0*i**4*f(8)+7129.D0/25200.D0*i**2*f(1) & - -6947.D0/8640.D0*i**5*f(2)+3013.D0/172800.D0*i**6*f(1) & - -107.D0/1440.D0*i**8*f(6)-119.D0/4320.D0*i**7*f(2)+i*f(1)/10 & - +f(7)*i**10/17280+i**10*f(1)/3628800+59.D0/5040.D0*f(3)*i**8 & - -67.D0/1440.D0*i**7*f(10)+105.D0/2.D0*f(7)*i & - +84095.D0/36288.D0*f(11)*i**3-62549.D0/720.D0*i**4*f(6) & - -263.D0/84.D0*i**2*f(2)-5419.D0/1440.D0*i**6*f(8) & - +11.D0/30240.D0*f(11)*i**8+757.D0/5760.D0*f(3)*i**7 & - +39867.D0/2240.D0*f(3)*i**3-i**10*f(8)/30240-8.D0/9.D0*i**7*f(6) & - -10*i*f(10)+6961.D0/72.D0*f(5)*i**2-i**10*f(10)/362880 & - +i**9*f(1)/80640+728587.D0/8640.D0*f(7)*i**4-41.D0/1260.D0*i**8*f(4) - s1 = s2-6709.D0/17280.D0*i**6*f(10)+47.D0/80640.D0*f(3)*i**9 & - +49.D0/17280.D0*f(5)*i**9-1253.D0/480.D0*i**6*f(4) & - +6751.D0/48.D0*f(7)*i**2+10427.D0/11520.D0*f(3)*i**6-10.D0/9.D0*i*f(2) & - -23.D0/181440.D0*i**9*f(2)-i**9*f(10)/6720+45449.D0/11520.D0*f(3)*i**5 & - +2281.D0/2880.D0*f(7)*i**7-252.D0/5.D0*i*f(6)+f(9)*i**10/80640 & - +29.D0/120960.D0*i**8*f(1)-6541.D0/63.D0*i**2*f(8) & - +461789.D0/4320.D0*f(5)*i**3-161353.D0/45360.D0*i**3*f(2) & - +435893.D0/40320.D0*f(3)*i**4-97.D0/2520.D0*i**8*f(8) & - +1123.D0/5760.D0*f(9)*i**7-i**10*f(4)/30240-1003.D0/21.D0*i**2*f(4) & - -4861.D0/252.D0*i**2*f(10)-40*i*f(8)-i**9*f(6)/288-i**10*f(6)/14400 & - -13.D0/7560.D0*i**9*f(8)+1303.D0/4032.D0*i**3*f(1) - s2 = s1-151.D0/60480.D0*i**8*f(2)+19.D0/256.D0*i**5*f(1) & - +71689.D0/480.D0*f(7)*i**3-6877.D0/50.D0*i**2*f(6)+34343.D0/5760.D0*f(7)*i**6 & - -211.D0/60480.D0*i**8*f(10)+129067.D0/5760.D0*f(5)*i**5+35*f(5)*i & - -8321.D0/720.D0*i**5*f(4)+i**7*f(1)/384-1197.D0/8.D0*i**3*f(6) & - +3533.D0/224.D0*f(3)*i**2+18047.D0/11520.D0*f(9)*i**6 & - +163313.D0/5760.D0*f(7)*i**5+f(5)*i**10/17280+f(11)*i**10/3628800 & - +11.D0/725760.D0*f(11)*i**9-120.D0/7.D0*i*f(4)-i**9*f(4)/630 & - +177133.D0/50400.D0*f(11)*i**2-93773.D0/14400.D0*i**6*f(6) & - +121.D0/24192.D0*f(11)*i**7+28603.D0/5760.D0*f(5)*i**6 & - -197741.D0/90720.D0*i**4*f(2)+f(3)*i**10/80640+7381.D0/2520.D0*f(11)*i-3229.D0/17280.D0*i**6*f(2) - f(NI+i) = s2+17.D0/5760.D0*f(7)*i**9-22439.D0/420.D0*i**3*f(4) & - -1877.D0/5040.D0*i**7*f(4)-i**10*f(2)/362880-43319.D0/1440.D0*i**5*f(6) & - +31.D0/480.D0*f(7)*i**8+1999.D0/2880.D0*f(5)*i**7+45.D0/8.D0*f(3)*i & - +19.D0/320.D0*f(5)*i**8-349.D0/720.D0*i**7*f(8) & - +273431.D0/4320.D0*f(5)*i**4-242639.D0/7560.D0*i**4*f(4) & - +4523.D0/22680.D0*i**4*f(1)+607.D0/40320.D0*f(9)*i**8 & - +92771.D0/11520.D0*f(9)*i**5+264767.D0/10080.D0*f(9)*i**4 & - +115923.D0/2240.D0*f(9)*i**3+6121.D0/112.D0*f(9)*i**2+45.D0/2.D0*f(9)*i & - +53.D0/80640.D0*f(9)*i**9-6041.D0/2880.D0*i**5*f(10) & - -663941.D0/90720.D0*i**4*f(10)-79913.D0/5040.D0*i**3*f(10) & - +7513.D0/172800.D0*f(11)*i**6+8591.D0/34560.D0*f(11)*i**5 & - +341693.D0/362880.D0*f(11)*i**4-13349.D0/720.D0*i**5*f(8) & - -400579.D0/3780.D0*i**3*f(8)+f(11) - - end select - - enddo - - return - - end subroutine extroplate_lag2 -! extroplate for unigrid with Calabrese Gundlach type, Eq.(16) of CQG 23 S343 (2006) - function extroplate_cg(N,f) result(gont) - implicit none - integer,intent(in ) :: N - real*8,dimension(N),intent(in) :: f - - real*8 :: gont - -! Eq.(16) of CQG 23 S343 (2006) - select case (N) -! for 2nd order code - case (2) - gont = 2.d0*f(2)-f(1) -! for 4th order code - case (4) - gont = 4.d0*f(4)-6.d0*f(3)+4.d0*f(2)-f(1) -! for 6th order code - case (6) -! Eq.(C7) of PRD 83, 024025 - gont = 6.d0*f(6)-1.5d1*f(5)+2.d1*f(4)-1.5d1*f(3)+6.d0*f(2)-f(1) -! for 8th order code - case (8) - gont = 8.d0*f(8)-2.8d1*f(7)+5.6d1*f(6)-7.d1*f(5)+5.6d1*f(4)-2.8d1*f(3)+8.d0*f(2)-f(1) - end select - - return - - end function extroplate_cg -! need CPBC_ghost_width - subroutine david_milton_extroplate_ss(ex,crho,sigma,R, & - TZ,chi,trK, & - dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Gmx,Gmy,Gmz, & - Lap , betax , betay , betaz , & - dtSfx , dtSfy , dtSfz,zmin,zmax) - -! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine - implicit none - -!~~~~~~> Input parameters: - - integer,intent(in ):: ex(1:3) - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ,chi,dxx,dyy,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: trK - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxy,gxz,gyz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gmx,Gmy,Gmz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx, dtSfy, dtSfz - real*8, intent(in):: zmin,zmax - -#define tptype 1 -#if (tptype == 0) -! default we always use hp (tpp=0) - - call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,0) -#elif (tptype == 1) -! all D+ f = 0 (tpp=1) - - call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,1) -#elif (tptype == 2) -! Lagange polynomial but all used inner points (tpp=2) - - call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,2) - call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,2) - -#elif (tptype == 3) -! thumb of rule: D+ f = 0 (tpp=1) for outgoing ones; hp (tpp=0) for ingoing ones - - call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,0) - call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,1) - call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,1) - -#else -#error "not recognized tptype" -#endif - -#undef tptype - - return - - end subroutine david_milton_extroplate_ss -!construct rACqq rhs - subroutine cpbcrACqq(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,rACqq,& - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,Sfx,Sfy,Sfz,Axx,Axy,Axz,Ayy,Ayz,Azz,rACss,Symmetry,sst) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,Axx,Axy,Axz,Ayy,Ayz,Azz,rACss - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rACqq -!~~~~~~> Other variables: - real*8 :: chin1,alpha,gxx,gyy,gzz - real*8 :: sfxx,sfxy,sfxz,sfyx,sfyy,sfyz,sfzx,sfzy,sfzz - real*8 :: gxxx,gxxy,gxxz - real*8 :: gxyx,gxyy,gxyz - real*8 :: gxzx,gxzy,gxzz - real*8 :: gyyx,gyyy,gyyz - real*8 :: gyzx,gyzy,gyzz - real*8 :: gzzx,gzzy,gzzz - logical :: gont - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - real*8 :: dR - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - dR = R(2)-R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) -! consider buffer points near boundary - layer(3,3) = ex(3) - CPBC_ghost_width - layer(6,3) = ex(3) - CPBC_ghost_width -endif - - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - alpha = Lap(i,j,k)+1.d0 - chin1 = chi(i,j,k)+1.d0 - gxx = dxx(i,j,k)+1.d0 - gyy = dyy(i,j,k)+1.d0 - gzz = dzz(i,j,k)+1.d0 - call point_fderivs_shc(ex,Sfx,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfy,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call racqq_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & - alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & - sfxx,sfyx,sfzx,sfxy,sfyy,sfzy,sfxz,sfyz,sfzz, & - gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & - gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & - gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & - gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz, & - rACqq(i,j,k),rACss(i,j,k)) - enddo - enddo - enddo - endif - - return - - end subroutine cpbcrACqq -!construct rtrK rhs - subroutine cpbcrtrK(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,rtrK,& - chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,Sfx,Sfy,Sfz,TZ,Symmetry,sst,kappa1,kappa2) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,kappa1,kappa2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rtrK -!~~~~~~> Other variables: - real*8 :: chin1,alpha,gxx,gyy,gzz - real*8 :: Kx,Ky,Kz,TZx,TZy,TZz - logical :: gont - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - real*8 :: dR - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - dR = R(2)-R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) -! consider buffer points near boundary - layer(3,3) = ex(3) - CPBC_ghost_width - layer(6,3) = ex(3) - CPBC_ghost_width -endif - - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - alpha = Lap(i,j,k)+1.d0 - chin1 = chi(i,j,k)+1.d0 - gxx = dxx(i,j,k)+1.d0 - gyy = dyy(i,j,k)+1.d0 - gzz = dzz(i,j,k)+1.d0 - call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call rkhat_point(alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & - Kx,Ky,Kz,TZx,TZy,TZz, & - gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz,kappa1,kappa2, & - trK(i,j,k),R(k),rtrK(i,j,k),TZ(i,j,k),x(i,j,k),y(i,j,k),z(i,j,k)) - enddo - enddo - enddo - endif - - return - - end subroutine cpbcrtrK -!construct rTZ rhs - subroutine cpbcrtheta(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,rTheta,& - chi,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,Sfx,Sfy,Sfz,TZ,Symmetry,sst,kappa1,kappa2) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,kappa1,kappa2 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rTheta -!~~~~~~> Other variables: - real*8 :: alpha,chin1,gxx,gyy,gzz - real*8 :: TZx,TZy,TZz - logical :: gont - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - real*8 :: dR - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - dR = R(2)-R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) -! consider buffer points near boundary - layer(3,3) = ex(3) - CPBC_ghost_width - layer(6,3) = ex(3) - CPBC_ghost_width -endif - - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - alpha = Lap(i,j,k)+1.d0 - chin1 = chi(i,j,k)+1.d0 - gxx = dxx(i,j,k)+1.d0 - gyy = dyy(i,j,k)+1.d0 - gzz = dzz(i,j,k)+1.d0 - call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call rtheta_point(alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & - TZx,TZy,TZz, & - gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz,kappa1,kappa2, & - R(k),rTheta(i,j,k),TZ(i,j,k),x(i,j,k),y(i,j,k),z(i,j,k)) - enddo - enddo - enddo - endif - - return - - end subroutine cpbcrtheta -!construct rGam rhs - subroutine cpbcrgam(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax,rGamAx,rGamAy,rGamAz,rGams,& - chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & - Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,eta) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK,chi,dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,eta - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rGamAx,rGamAy,rGamAz,rGams -!~~~~~~> Other variables: - real*8 :: alpha,chin1,gxx,gyy,gzz - real*8 :: sfxx,sfyx,sfzx - real*8 :: sfxy,sfyy,sfzy - real*8 :: sfxz,sfyz,sfzz - real*8 :: sfxxx,sfyxx,sfzxx - real*8 :: sfxxy,sfyxy,sfzxy - real*8 :: sfxxz,sfyxz,sfzxz - real*8 :: sfxyy,sfyyy,sfzyy - real*8 :: sfxyz,sfyyz,sfzyz - real*8 :: sfxzz,sfyzz,sfzzz - real*8 :: Gamxx,Gamyx,Gamzx - real*8 :: Gamxy,Gamyy,Gamzy - real*8 :: Gamxz,Gamyz,Gamzz - real*8 :: Kx,Ky,Kz,TZx,TZy,TZz - logical :: gont - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - real*8 :: dR - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - dR = R(2)-R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) -! consider buffer points near boundary - layer(3,3) = ex(3) - CPBC_ghost_width - layer(6,3) = ex(3) - CPBC_ghost_width -endif - - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - alpha = Lap(i,j,k)+1.d0 - chin1 = chi(i,j,k)+1.d0 - gxx = dxx(i,j,k)+1.d0 - gyy = dyy(i,j,k)+1.d0 - gzz = dzz(i,j,k)+1.d0 - call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfx,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfy,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fdderivs_shc(ex,Sfx,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,Sfy,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM ,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,Sfz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call rgam_point(alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & - sfxx,sfyx,sfzx, & - sfxy,sfyy,sfzy, & - sfxz,sfyz,sfzz, & - sfxxx,sfyxx,sfzxx, & - sfxxy,sfyxy,sfzxy, & - sfxxz,sfyxz,sfzxz, & - sfxyy,sfyyy,sfzyy, & - sfxyz,sfyyz,sfzyz, & - sfxzz,sfyzz,sfzzz, & - Gamxx,Gamyx,Gamzx, & - Gamxy,Gamyy,Gamzy, & - Gamxz,Gamyz,Gamzz, & - Kx,Ky,Kz,TZx,TZy,TZz, & - gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz,& - R(k),rGamAx(i,j,k),rGamAy(i,j,k),rGamAz(i,j,k),rGams(i,j,k), & - eta,x(i,j,k),y(i,j,k),z(i,j,k)) - enddo - enddo - enddo - endif - - return - - end subroutine cpbcrgam -!construct rA rhs - subroutine cpbcra(ex,crho,sigma,R,x,y,z, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & - xmin,ymin,zmin,xmax,ymax,zmax, & - rACABTFxx,rACABTFxy,rACABTFxz,rACABTFyy,rACABTFyz,rACABTFzz,& - rACsAx,rACsAy,rACsAz,rACss, & - chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & - Axx,Axy,Axz,Ayy,Ayz,Azz, & - Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,kappa1) - - implicit none - -!~~~~~~> Input parameters: - integer, intent(in):: ex(1:3),Symmetry,sst - double precision,intent(in),dimension(ex(1))::crho - double precision,intent(in),dimension(ex(2))::sigma - double precision,intent(in),dimension(ex(3))::R - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK,chi,dxx,gxy,gxz,dyy,gyz,dzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz,Axx,Axy,Axz,Ayy,Ayz,Azz - real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,kappa1 - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rACABTFxx,rACABTFxy,rACABTFxz,rACABTFyy,rACABTFyz,rACABTFzz - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rACsAx,rACsAy,rACsAz,rACss -!~~~~~~> Other variables: - real*8 :: alpha,chin1,gxx,gyy,gzz - real*8 :: sfxx,sfyx,sfzx - real*8 :: sfxy,sfyy,sfzy - real*8 :: sfxz,sfyz,sfzz - real*8 :: sfxxx,sfyxx,sfzxx - real*8 :: sfxxy,sfyxy,sfzxy - real*8 :: sfxxz,sfyxz,sfzxz - real*8 :: sfxyy,sfyyy,sfzyy - real*8 :: sfxyz,sfyyz,sfzyz - real*8 :: sfxzz,sfyzz,sfzzz - real*8 :: Gamxx,Gamyx,Gamzx - real*8 :: Gamxy,Gamyy,Gamzy - real*8 :: Gamxz,Gamyz,Gamzz - real*8 :: Kx,Ky,Kz,TZx,TZy,TZz - real*8 :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz - real*8 :: chix,chiy,chiz - real*8 :: chixx,chixy,chixz,chiyy,chiyz,chizz - real*8 :: Axxx,Axxy,Axxz - real*8 :: Axyx,Axyy,Axyz - real*8 :: Axzx,Axzy,Axzz - real*8 :: Ayyx,Ayyy,Ayyz - real*8 :: Ayzx,Ayzy,Ayzz - real*8 :: Azzx,Azzy,Azzz - real*8 :: gxxx,gxxy,gxxz - real*8 :: gxyx,gxyy,gxyz - real*8 :: gxzx,gxzy,gxzz - real*8 :: gyyx,gyyy,gyyz - real*8 :: gyzx,gyzy,gyzz - real*8 :: gzzx,gzzy,gzzz - real*8 :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz - real*8 :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz - real*8 :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz - real*8 :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz - real*8 :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz - real*8 :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz - logical :: gont - integer :: i, j, k - integer :: layer(1:6,1:6),gp -! index of layer, first one: i,j,k; second one: front back etc. boundary - integer :: kmin,kmax - real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 - real*8 :: dR - real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 - - dR = R(2)-R(1) - - kmax = ex(3) - - kmin = 1 - -layer(1:3,:) = 1 -layer(4:6,:) =-1 - -if(dabs(R(ex(3))-zmax) < dR)then - layer(1,3) = 1 - layer(2,3) = 1 - layer(4,3) = ex(1) - layer(5,3) = ex(2) -! consider buffer points near boundary - layer(3,3) = ex(3) - CPBC_ghost_width - layer(6,3) = ex(3) - CPBC_ghost_width -endif - - gp = 3 - - gont = any( layer(:,gp) == - 1 ) - - if( .not. gont ) then - - do k = layer(3,gp), layer(6,gp) - do j = layer(2,gp), layer(5,gp) - do i = layer(1,gp), layer(4,gp) - alpha = Lap(i,j,k)+1.d0 - chin1 = chi(i,j,k)+1.d0 - gxx = dxx(i,j,k)+1.d0 - gyy = dyy(i,j,k)+1.d0 - gzz = dzz(i,j,k)+1.d0 - call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfx,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfy,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Sfz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fdderivs_shc(ex,Sfx,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,Sfy,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM ,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,Sfz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - - call point_fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz,i,j,k) - call point_fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call point_fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI ,Symmetry,0,sst, & - drhodx, drhody, drhodz, & - dsigmadx,dsigmady,dsigmadz, & - dRdx,dRdy,dRdz, & - drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & - dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & - dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) - call ra_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & - alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & - Lapx,Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx, & - Lapy,Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy, & - Lapz,Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz, & - sfxx,sfyx,sfzx, & - sfxy,sfyy,sfzy, & - sfxz,sfyz,sfzz, & - chix,chiy,chiz, & - Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz, & - sfxxx,sfyxx,sfzxx, & - sfxxy,sfyxy,sfzxy, & - sfxxz,sfyxz,sfzxz, & - sfxyy,sfyyy,sfzyy, & - sfxyz,sfyyz,sfzyz, & - sfxzz,sfyzz,sfzzz, & - chixx,chixy,chixz,chiyy,chiyz,chizz, & - gxxxx,gxyxx,gxzxx,gyyxx,gyzxx,gzzxx, & - gxxxy,gxyxy,gxzxy,gyyxy,gyzxy,gzzxy, & - gxxxz,gxyxz,gxzxz,gyyxz,gyzxz,gzzxz, & - gxxyy,gxyyy,gxzyy,gyyyy,gyzyy,gzzyy, & - gxxyz,gxyyz,gxzyz,gyyyz,gyzyz,gzzyz, & - gxxzz,gxyzz,gxzzz,gyyzz,gyzzz,gzzzz, & - Gamxx,gxxx,gxyx,gxzx, & - Gamyx,gyyx,gyzx, & - Gamzx,gzzx, & - Gamxy,gxxy,gxyy,gxzy, & - Gamyy,gyyy,gyzy, & - Gamzy,gzzy, & - Gamxz,gxxz,gxyz,gxzz, & - Gamyz,gyyz,gyzz, & - Gamzz,gzzz, & - Kx,Ky,Kz,TZx,TZy,TZz, & - Gamx(i,j,k),gxx,gxy(i,j,k),gxz(i,j,k), & - Gamy(i,j,k),gyy,gyz(i,j,k), & - Gamz(i,j,k),gzz, & - kappa1,trK(i,j,k), & - R(k),rACABTFxx(i,j,k),rACABTFxy(i,j,k),rACABTFxz(i,j,k), & - rACABTFyy(i,j,k),rACABTFyz(i,j,k),rACABTFzz(i,j,k), & - rACsAx(i,j,k),rACsAy(i,j,k),rACsAz(i,j,k), & - rACss(i,j,k),TZ(i,j,k), & - x(i,j,k),y(i,j,k),z(i,j,k)) - enddo - enddo - enddo - endif - - return - - end subroutine cpbcra + + +#include "macrodef.fh" + + subroutine get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + + implicit none + + real*8,intent(out) :: kappa1,kappa2,kappa3,FF,eta + + kappa1 = 2.d-2 + kappa2 = 0.d0 + kappa3 = 0.d0 + + FF = 0.75d0 + eta=2.0d0 + + return + + end subroutine get_Z4cparameters +#if 1 +! need CPBC_ghost_width +!PRD 83, 024025 (2011) + subroutine david_milton_cpbc_ss(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax, & + TZ,chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz, & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ_rhs,chi_rhs,trK_rhs, & + gxx_rhs,gxy_rhs,gxz_rhs,gyy_rhs,gyz_rhs,gzz_rhs, & + Axx_rhs,Axy_rhs,Axz_rhs,Ayy_rhs,Ayz_rhs,Azz_rhs, & + Gamx_rhs,Gamy_rhs,Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + pGamxxx,pGamxxy,pGamxxz,pGamxyy,pGamxyz,pGamxzz, & + pGamyxx,pGamyxy,pGamyxz,pGamyyy,pGamyyz,pGamyzz, & + pGamzxx,pGamzxy,pGamzxz,pGamzyy,pGamzyz,pGamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Gmxcon,Gmycon,Gmzcon, & + Symmetry,eps,sst) + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ,chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz,Gmxcon,Gmycon,Gmzcon + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ_rhs,chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8,intent(in) :: eps +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxxx, pGamxxy, pGamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxyy, pGamxyz, pGamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyxx, pGamyxy, pGamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyyy, pGamyyz, pGamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzxx, pGamzxy, pGamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzyy, pGamzyz, pGamzzz + +!~~~~~~~~~~~> local variables + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: qxx,qxy,qxz,qyy,qyz,qzz + real*8, dimension(ex(1),ex(2),ex(3)) :: qupxx,qupxy,qupxz,qupyy,qupyz,qupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: qulxx,qulxy,qulxz,qulyx,qulyy,qulyz,qulzx,qulzy,qulzz + real*8, dimension(ex(1),ex(2),ex(3)) :: slx,sly,slz,ulx,uly,ulz,wlx,wly,wlz + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: fx,fy,fz + logical :: gont + real*8 :: dR + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax +! derivatives + real*8 :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz + real*8 :: sfxx,sfxy,sfxz,sfyx,sfyy,sfyz,sfzx,sfzy,sfzz + real*8 :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz + real*8 :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz + real*8 :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz + real*8 :: TZx,TZy,TZz + real*8 :: chix,chiy,chiz,Kx,Ky,Kz + real*8 :: chixx,chixy,chixz,chiyy,chiyz,chizz + real*8 :: Axxx,Axxy,Axxz + real*8 :: Axyx,Axyy,Axyz + real*8 :: Axzx,Axzy,Axzz + real*8 :: Ayyx,Ayyy,Ayyz + real*8 :: Ayzx,Ayzy,Ayzz + real*8 :: Azzx,Azzy,Azzz + real*8 :: gxxx,gxxy,gxxz + real*8 :: gxyx,gxyy,gxyz + real*8 :: gxzx,gxzy,gxzz + real*8 :: gyyx,gyyy,gyyz + real*8 :: gyzx,gyzy,gyzz + real*8 :: gzzx,gzzy,gzzz + real*8 :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8 :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8 :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8 :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8 :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8 :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8 :: Gamxx,Gamxy,Gamxz + real*8 :: Gamyx,Gamyy,Gamyz + real*8 :: Gamzx,Gamzy,Gamzz + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0,HALF=0.5d0 + real*8,parameter::TINYRR=1.d-14 +! in order to synchronize the following parameters with Z4c_rhs calculation, we +! call a routine + real*8 :: kappa1,kappa2,kappa3,FF,eta + +! real*8,parameter :: ha=0.d0,thbs=0.d0,hu=0.d0,hw=0.d0,Rhpsi0=0.d0,Ihpsi0=0.d0 + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + + dR = R(2) - R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(3,3) = ex(3) - CPBC_ghost_width + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(6,3) = ex(3) - CPBC_ghost_width +endif + +if(dabs(R(1)-zmin) < dR)then + layer(1,6) = 1 + layer(2,6) = 1 + layer(3,6) = 1 + layer(4,6) = ex(1) + layer(5,6) = ex(2) + layer(6,6) = 1 +endif +! fix BD + gp = 6 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +! z direction + TZ_rhs(i,j,k) = ZEO + chi_rhs(i,j,k) = ZEO + trK_rhs(i,j,k) = ZEO + gxx_rhs(i,j,k) = ZEO + gxy_rhs(i,j,k) = ZEO + gxz_rhs(i,j,k) = ZEO + gyy_rhs(i,j,k) = ZEO + gyz_rhs(i,j,k) = ZEO + gzz_rhs(i,j,k) = ZEO + Axx_rhs(i,j,k) = ZEO + Axy_rhs(i,j,k) = ZEO + Axz_rhs(i,j,k) = ZEO + Ayy_rhs(i,j,k) = ZEO + Ayz_rhs(i,j,k) = ZEO + Azz_rhs(i,j,k) = ZEO + Gamx_rhs(i,j,k) = ZEO + Gamy_rhs(i,j,k) = ZEO + Gamz_rhs(i,j,k) = ZEO + Lap_rhs(i,j,k) = ZEO + betax_rhs(i,j,k) = ZEO + betay_rhs(i,j,k) = ZEO + betaz_rhs(i,j,k) = ZEO + dtSfx_rhs(i,j,k) = ZEO + dtSfy_rhs(i,j,k) = ZEO + dtSfz_rhs(i,j,k) = ZEO + enddo + enddo + enddo + endif + +! constraint preserving BD + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + +! cpbc real starts + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +!calculate the involved derivatives +#if 0 + Kx = 0.d0 + Ky = 0.d0 + Kz = 0.d0 + chix = 0.d0 + chiy = 0.d0 + chiz = 0.d0 + Lapx = 0.d0 + Lapy = 0.d0 + Lapz = 0.d0 + TZx = 0.d0 + TZy = 0.d0 + TZz = 0.d0 + Gamxx = 0.d0 + Gamxy = 0.d0 + Gamxz = 0.d0 + Gamyx = 0.d0 + Gamyy = 0.d0 + Gamyz = 0.d0 + Gamzx = 0.d0 + Gamzy = 0.d0 + Gamzz = 0.d0 + sfxx = 0.d0 + sfxy = 0.d0 + sfxz = 0.d0 + sfyx = 0.d0 + sfyy = 0.d0 + sfyz = 0.d0 + sfzx = 0.d0 + sfzy = 0.d0 + sfzz = 0.d0 + Axxx = 0.d0 + Axxy = 0.d0 + Axxz = 0.d0 + Axyx = 0.d0 + Axyy = 0.d0 + Axyz = 0.d0 + Axzx = 0.d0 + Axzy = 0.d0 + Axzz = 0.d0 + Ayyx = 0.d0 + Ayyy = 0.d0 + Ayyz = 0.d0 + Ayzx = 0.d0 + Ayzy = 0.d0 + Ayzz = 0.d0 + Azzx = 0.d0 + Azzy = 0.d0 + Azzz = 0.d0 + gxxx = 0.d0 + gxxy = 0.d0 + gxxz = 0.d0 + gxyx = 0.d0 + gxyy = 0.d0 + gxyz = 0.d0 + gxzx = 0.d0 + gxzy = 0.d0 + gxzz = 0.d0 + gyyx = 0.d0 + gyyy = 0.d0 + gyyz = 0.d0 + gyzx = 0.d0 + gyzy = 0.d0 + gyzz = 0.d0 + gzzx = 0.d0 + gzzy = 0.d0 + gzzz = 0.d0 +#else + call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) +#if 0 + sfxx = 0.d0 + sfxy = 0.d0 + sfxz = 0.d0 + sfyx = 0.d0 + sfyy = 0.d0 + sfyz = 0.d0 + sfzx = 0.d0 + sfzy = 0.d0 + sfzz = 0.d0 +#else + call point_fderivs_shc(ex,betax,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,betay,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,betaz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) +#endif + call point_fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) +#endif + +#if 0 + Lapxx = 0.d0 + Lapxy = 0.d0 + Lapxz = 0.d0 + Lapyy = 0.d0 + Lapyz = 0.d0 + Lapzz = 0.d0 + chixx = 0.d0 + chixy = 0.d0 + chixz = 0.d0 + chiyy = 0.d0 + chiyz = 0.d0 + chizz = 0.d0 + gxxxx = 0.d0 + gxxxy = 0.d0 + gxxxz = 0.d0 + gxxyy = 0.d0 + gxxyz = 0.d0 + gxxzz = 0.d0 + gyyxx = 0.d0 + gyyxy = 0.d0 + gyyxz = 0.d0 + gyyyy = 0.d0 + gyyyz = 0.d0 + gyyzz = 0.d0 + gzzxx = 0.d0 + gzzxy = 0.d0 + gzzxz = 0.d0 + gzzyy = 0.d0 + gzzyz = 0.d0 + gzzzz = 0.d0 + gxyxx = 0.d0 + gxyxy = 0.d0 + gxyxz = 0.d0 + gxyyy = 0.d0 + gxyyz = 0.d0 + gxyzz = 0.d0 + gxzxx = 0.d0 + gxzxy = 0.d0 + gxzxz = 0.d0 + gxzyy = 0.d0 + gxzyz = 0.d0 + gxzzz = 0.d0 + gyzxx = 0.d0 + gyzxy = 0.d0 + gyzxz = 0.d0 + gyzyy = 0.d0 + gyzyz = 0.d0 + gyzzz = 0.d0 + sfxxx = 0.d0 + sfxxy = 0.d0 + sfxxz = 0.d0 + sfxyy = 0.d0 + sfxyz = 0.d0 + sfxzz = 0.d0 + sfyxx = 0.d0 + sfyxy = 0.d0 + sfyxz = 0.d0 + sfyyy = 0.d0 + sfyyz = 0.d0 + sfyzz = 0.d0 + sfzxx = 0.d0 + sfzxy = 0.d0 + sfzxz = 0.d0 + sfzyy = 0.d0 + sfzyz = 0.d0 + sfzzz = 0.d0 +#else + call point_fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM ,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) +#endif + + call cpbc_point(R(k),x(i,j,k),y(i,j,k),z(i,j,k),TZ(i,j,k),chin1(i,j,k),trK(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & + Gamx(i,j,k),Gamy(i,j,k),Gamz(i,j,k), & + alpn1(i,j,k),betax(i,j,k),betay(i,j,k),betaz(i,j,k), & + Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz, & + sfxx,sfxy,sfxz, & + sfyx,sfyy,sfyz, & + sfzx,sfzy,sfzz, & + sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz, & + sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz, & + sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz, & + chix,chiy,chiz,chixx,chixy,chixz,chiyy,chiyz,chizz, & + gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz, & + gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz, & + gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz, & + gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz, & + gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz, & + gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz, & + Kx,Ky,Kz, & + Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx, & + Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy, & + Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz, & + Gamxx,Gamxy,Gamxz, & + Gamyx,Gamyy,Gamyz, & + Gamzx,Gamzy,Gamzz, & + TZx,TZy,TZz, & + trK_rhs(i,j,k),TZ_rhs(i,j,k), & + Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & + Gamx_rhs(i,j,k),Gamy_rhs(i,j,k),Gamz_rhs(i,j,k),kappa1,kappa2,eta) + enddo + enddo + enddo + + endif + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) + +#if 0 + call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) +#endif + + call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) + endif + + return + + end subroutine david_milton_cpbc_ss +#elif 1 +#error "did you change sommerfeld routine for buffer points considering?" +!!! CV == 0: Sommerfeld on everything after decomposing +!!! CV == 1: Sommerfeld on only the CPBC vars after decomposing +!!! CV == 1 and replace Sommerfeld to CPBC one by one +#define CV 1 +! Sommefeld after 2+1 decomposation + subroutine david_milton_cpbc_ss(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax, & + TZ,chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz, & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ_rhs,chi_rhs,trK_rhs, & + gxx_rhs,gxy_rhs,gxz_rhs,gyy_rhs,gyz_rhs,gzz_rhs, & + Axx_rhs,Axy_rhs,Axz_rhs,Ayy_rhs,Ayz_rhs,Azz_rhs, & + Gamx_rhs,Gamy_rhs,Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + pGamxxx,pGamxxy,pGamxxz,pGamxyy,pGamxyz,pGamxzz, & + pGamyxx,pGamyxy,pGamyxz,pGamyyy,pGamyyz,pGamyzz, & + pGamzxx,pGamzxy,pGamzxz,pGamzyy,pGamzyz,pGamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Gmxcon,Gmycon,Gmzcon, & + Symmetry,eps,sst) + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ,chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz,Gmxcon,Gmycon,Gmzcon + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ_rhs,chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8,intent(in) :: eps +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxxx, pGamxxy, pGamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxyy, pGamxyz, pGamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyxx, pGamyxy, pGamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyyy, pGamyyz, pGamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzxx, pGamzxy, pGamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzyy, pGamzyz, pGamzzz + +!~~~~~~~~~~~> local variables + + real*8, dimension(ex(1),ex(2),ex(3)) :: chin1,gxx,gyy,gzz + real*8, dimension(ex(1),ex(2),ex(3)) :: toAqq,toAss,toAsx,toAsy,toAsz + real*8, dimension(ex(1),ex(2),ex(3)) :: toAxx,toAxy,toAxz,toAyy,toAyz,toAzz + real*8, dimension(ex(1),ex(2),ex(3)) :: toAqq_rhs,toAss_rhs,toAsx_rhs,toAsy_rhs,toAsz_rhs + real*8, dimension(ex(1),ex(2),ex(3)) :: toAxx_rhs,toAxy_rhs,toAxz_rhs,toAyy_rhs,toAyz_rhs,toAzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)) :: toGams,toGamx,toGamy,toGamz + real*8, dimension(ex(1),ex(2),ex(3)) :: toGams_rhs,toGamx_rhs,toGamy_rhs,toGamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)) :: tobetas,tobetax,tobetay,tobetaz + real*8, dimension(ex(1),ex(2),ex(3)) :: tobetas_rhs,tobetax_rhs,tobetay_rhs,tobetaz_rhs + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: ZEO = 0.d0 + + logical :: gont + real*8 :: dR + integer :: i, j, k + integer :: layer(1:6,1:6),gp + +! in order to synchronize the following parameters with Z4c_rhs calculation, we +! call a routine + real*8 :: kappa1,kappa2,kappa3,FF,eta + +! real*8,parameter :: ha=0.d0,thbs=0.d0,hu=0.d0,hw=0.d0,Rhpsi0=0.d0,Ihpsi0=0.d0 + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + + dR = R(2) - R(1) + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +#if 1 + chin1 = chi+1.d0 + gxx = dxx+1.d0 + gyy = dyy+1.d0 + gzz = dzz+1.d0 + +! decompose + do k = 1, ex(3) + do j = 1, ex(2) + do i = 1, ex(1) +#if (CV == 0) + call decompose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + betax(i,j,k),betay(i,j,k),betaz(i,j,k), & + tobetas(i,j,k),tobetax(i,j,k),tobetay(i,j,k),tobetaz(i,j,k)) +#endif + call decompose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + Gamx(i,j,k),Gamy(i,j,k),Gamz(i,j,k), & + toGams(i,j,k),toGamx(i,j,k),toGamy(i,j,k),toGamz(i,j,k)) + call decompose2p1_2(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & + toAqq(i,j,k),toAss(i,j,k),toAsx(i,j,k),toAsy(i,j,k),toAsz(i,j,k), & + toAxx(i,j,k),toAxy(i,j,k),toAxz(i,j,k),toAyy(i,j,k),toAyz(i,j,k),toAzz(i,j,k)) + + enddo + enddo + enddo + +! sommerfeld boundary +! cpbc variables +#if 0 + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,trK_rhs,trK,1.d0,SSS,Symmetry) +#else + call cpbcrtrK(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,trK_rhs,& + chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,betax,betay,betaz,TZ,Symmetry,sst,kappa1,kappa2) +#endif +#if 0 + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,TZ_rhs,TZ,1.d0,SSS,Symmetry) +#else + call cpbcrtheta(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,TZ_rhs,& + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,betax,betay,betaz,TZ,Symmetry,sst,kappa1,kappa2) +#endif +#if 1 + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGams_rhs,toGams,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGamx_rhs,toGamx,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGamy_rhs,toGamy,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toGamz_rhs,toGamz,1.d0,SSA,Symmetry) +#else + call cpbcrgam(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,toGamx_rhs,toGamy_rhs,toGamz_rhs,toGams_rhs,& + chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,betax,betay,betaz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,eta) +#endif +#if 1 + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAss_rhs,toAss,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAsx_rhs,toAsx,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAsy_rhs,toAsy,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAsz_rhs,toAsz,1.d0,SSA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAxx_rhs,toAxx,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAxy_rhs,toAxy,1.d0,AAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAxz_rhs,toAxz,1.d0,ASA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAyy_rhs,toAyy,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAyz_rhs,toAyz,1.d0,SAA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAzz_rhs,toAzz,1.d0,SSS,Symmetry) +#else + call cpbcra(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax, & + toAxx_rhs,toAxy_rhs,toAxz_rhs,toAyy_rhs,toAyz_rhs,toAzz_rhs,& + toAsx_rhs,toAsy_rhs,toAsz_rhs,toAss_rhs, & + chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Lap,betax,betay,betaz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,kappa1) +#endif +! non-cpbc variables +#if (CV == 0) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,toAqq_rhs,toAqq,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,chi_rhs,chi,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxx_rhs,dxx,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxy_rhs,gxy,1.d0,AAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxz_rhs,gxz,1.d0,ASA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyy_rhs,dyy,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyz_rhs,gyz,1.d0,SAA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gzz_rhs,dzz,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Lap_rhs,Lap,1.d0,SSS,Symmetry) +#if 1 + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetas_rhs,tobetas,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetax_rhs,tobetax,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetay_rhs,tobetay,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,tobetaz_rhs,tobetaz,1.d0,SSA,Symmetry) +#else + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betax_rhs,betax,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betay_rhs,betay,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betaz_rhs,betaz,1.d0,SSA,Symmetry) +#endif + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfx_rhs,dtSfx,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfy_rhs,dtSfy,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfz_rhs,dtSfz,1.d0,SSA,Symmetry) + +#else + call cpbcrACqq(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,toAqq_rhs,& + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,betax,betay,betaz,Axx,Axy,Axz,Ayy,Ayz,Azz,toAss_rhs,Symmetry,sst) +#endif +! reconstruct +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(3,3) = ex(3) - CPBC_ghost_width + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(6,3) = ex(3) - CPBC_ghost_width +endif + +if(dabs(R(1)-zmin) < dR)then + layer(1,6) = 1 + layer(2,6) = 1 + layer(3,6) = 1 + layer(4,6) = ex(1) + layer(5,6) = ex(2) + layer(6,6) = 1 +endif +! fix BD + gp = 6 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +! z direction + TZ_rhs(i,j,k) = ZEO + chi_rhs(i,j,k) = ZEO + trK_rhs(i,j,k) = ZEO + gxx_rhs(i,j,k) = ZEO + gxy_rhs(i,j,k) = ZEO + gxz_rhs(i,j,k) = ZEO + gyy_rhs(i,j,k) = ZEO + gyz_rhs(i,j,k) = ZEO + gzz_rhs(i,j,k) = ZEO + Axx_rhs(i,j,k) = ZEO + Axy_rhs(i,j,k) = ZEO + Axz_rhs(i,j,k) = ZEO + Ayy_rhs(i,j,k) = ZEO + Ayz_rhs(i,j,k) = ZEO + Azz_rhs(i,j,k) = ZEO + Gamx_rhs(i,j,k) = ZEO + Gamy_rhs(i,j,k) = ZEO + Gamz_rhs(i,j,k) = ZEO + Lap_rhs(i,j,k) = ZEO + betax_rhs(i,j,k) = ZEO + betay_rhs(i,j,k) = ZEO + betaz_rhs(i,j,k) = ZEO + dtSfx_rhs(i,j,k) = ZEO + dtSfy_rhs(i,j,k) = ZEO + dtSfz_rhs(i,j,k) = ZEO + enddo + enddo + enddo + endif + +! constraint preserving BD + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +#if (CV == 0) + call compose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + betax_rhs(i,j,k),betay_rhs(i,j,k),betaz_rhs(i,j,k), & + tobetas_rhs(i,j,k),tobetax_rhs(i,j,k),tobetay_rhs(i,j,k),tobetaz_rhs(i,j,k)) +#endif + call compose2p1_1(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + Gamx_rhs(i,j,k),Gamy_rhs(i,j,k),Gamz_rhs(i,j,k), & + toGams_rhs(i,j,k),toGamx_rhs(i,j,k),toGamy_rhs(i,j,k),toGamz_rhs(i,j,k)) + call compose2p1_2(R(k),x(i,j,k),y(i,j,k),z(i,j,k), chin1(i,j,k), & + gxx(i,j,k),gxy(i,j,k),gxz(i,j,k),gyy(i,j,k),gyz(i,j,k),gzz(i,j,k), & + Axx_rhs(i,j,k),Axy_rhs(i,j,k),Axz_rhs(i,j,k),Ayy_rhs(i,j,k),Ayz_rhs(i,j,k),Azz_rhs(i,j,k), & + toAqq_rhs(i,j,k),toAss_rhs(i,j,k),toAsx_rhs(i,j,k),toAsy_rhs(i,j,k),toAsz_rhs(i,j,k), & + toAxx_rhs(i,j,k),toAxy_rhs(i,j,k),toAxz_rhs(i,j,k),toAyy_rhs(i,j,k),toAyz_rhs(i,j,k),toAzz_rhs(i,j,k)) + + enddo + enddo + enddo + + endif + +! check direct Sommerfeld BD +#else + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,trK_rhs,trK,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,TZ_rhs,TZ,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Gamx_rhs,Gamx,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Gamy_rhs,Gamy,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Gamz_rhs,Gamz,1.d0,SSA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Axx_rhs,Axx,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Axy_rhs,Axy,1.d0,AAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Axz_rhs,Axz,1.d0,ASA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Ayy_rhs,Ayy,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Ayz_rhs,Ayz,1.d0,SAA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Azz_rhs,Azz,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,chi_rhs,chi,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxx_rhs,dxx,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxy_rhs,gxy,1.d0,AAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gxz_rhs,gxz,1.d0,ASA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyy_rhs,dyy,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gyz_rhs,gyz,1.d0,SAA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,gzz_rhs,dzz,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,Lap_rhs,Lap,1.d0,SSS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betax_rhs,betax,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betay_rhs,betay,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,betaz_rhs,betaz,1.d0,SSA,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfx_rhs,dtSfx,1.d0,ASS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfy_rhs,dtSfy,1.d0,SAS,Symmetry) + call sommerfeld_routbam_ss(ex,crho,sigma,R,xmin,ymin,zmin,xmax,ymax,zmax,dtSfz_rhs,dtSfz,1.d0,SSA,Symmetry) +#endif + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) + endif + + return + + end subroutine david_milton_cpbc_ss +#undef CV +#else +!out of time code, never debuged +! need CPBC_ghost_width +!PRD 83, 024025 (2011) + subroutine david_milton_cpbc_ss(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax, & + TZ,chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gamx,Gamy,Gamz, & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz , & + TZ_rhs,chi_rhs,trK_rhs, & + gxx_rhs,gxy_rhs,gxz_rhs,gyy_rhs,gyz_rhs,gzz_rhs, & + Axx_rhs,Axy_rhs,Axz_rhs,Ayy_rhs,Ayz_rhs,Azz_rhs, & + Gamx_rhs,Gamy_rhs,Gamz_rhs, & + Lap_rhs, betax_rhs, betay_rhs, betaz_rhs, & + dtSfx_rhs, dtSfy_rhs, dtSfz_rhs, & + pGamxxx,pGamxxy,pGamxxz,pGamxyy,pGamxyz,pGamxzz, & + pGamyxx,pGamyxy,pGamyxz,pGamyyy,pGamyyz,pGamyzz, & + pGamzxx,pGamzxy,pGamzxz,pGamzyy,pGamzyz,pGamzzz, & + Rxx,Rxy,Rxz,Ryy,Ryz,Rzz, & + Gmxcon,Gmycon,Gmzcon, & + Symmetry,eps,sst) + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3), Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: TZ,chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Gamx,Gamy,Gamz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: dtSfx, dtSfy, dtSfz,Gmxcon,Gmycon,Gmzcon + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ_rhs,chi_rhs,trK_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxx_rhs,gxy_rhs,gxz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gyy_rhs,gyz_rhs,gzz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx_rhs,Axy_rhs,Axz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Ayy_rhs,Ayz_rhs,Azz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gamx_rhs,Gamy_rhs,Gamz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap_rhs, betax_rhs, betay_rhs, betaz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx_rhs,dtSfy_rhs,dtSfz_rhs + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Rxx,Rxy,Rxz,Ryy,Ryz,Rzz + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8,intent(in) :: eps +! physical second kind of connection + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxxx, pGamxxy, pGamxxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamxyy, pGamxyz, pGamxzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyxx, pGamyxy, pGamyxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamyyy, pGamyyz, pGamyzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzxx, pGamzxy, pGamzxz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: pGamzyy, pGamzyz, pGamzzz + +!~~~~~~~~~~~> local variables + real*8, dimension(ex(1),ex(2),ex(3)) :: gxx,gyy,gzz,alpn1,chin1 + real*8, dimension(ex(1),ex(2),ex(3)) :: gupxx,gupxy,gupxz + real*8, dimension(ex(1),ex(2),ex(3)) :: gupyy,gupyz,gupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: qxx,qxy,qxz,qyy,qyz,qzz + real*8, dimension(ex(1),ex(2),ex(3)) :: qupxx,qupxy,qupxz,qupyy,qupyz,qupzz + real*8, dimension(ex(1),ex(2),ex(3)) :: qulxx,qulxy,qulxz,qulyx,qulyy,qulyz,qulzx,qulzy,qulzz + real*8, dimension(ex(1),ex(2),ex(3)) :: slx,sly,slz,ulx,uly,ulz,wlx,wly,wlz + real*8, dimension(ex(1),ex(2),ex(3)) :: vx,vy,vz,ux,uy,uz,wx,wy,wz + real*8, dimension(ex(1),ex(2),ex(3)) :: fx,fy,fz + logical :: gont + real*8 :: dR + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8 :: toAss_rhs,toAqq_rhs,toAs1_rhs,toAs2_rhs,toA11_rhs,toA12_rhs,toA22_rhs + real*8 :: toGams_rhs,toGam1_rhs,toGam2_rhs + real*8 :: totrK_rhs,toTZ_rhs +! derivatives + real*8 :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz + real*8 :: sfxx,sfxy,sfxz,sfyx,sfyy,sfyz,sfzx,sfzy,sfzz + real*8 :: sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz + real*8 :: sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz + real*8 :: sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz + real*8 :: TZx,TZy,TZz + real*8 :: chix,chiy,chiz,Kx,Ky,Kz + real*8 :: Axxx,Axxy,Axxz + real*8 :: Axyx,Axyy,Axyz + real*8 :: Axzx,Axzy,Axzz + real*8 :: Ayyx,Ayyy,Ayyz + real*8 :: Ayzx,Ayzy,Ayzz + real*8 :: Azzx,Azzy,Azzz + real*8 :: gxxx,gxxy,gxxz + real*8 :: gxyx,gxyy,gxyz + real*8 :: gxzx,gxzy,gxzz + real*8 :: gyyx,gyyy,gyyz + real*8 :: gyzx,gyzy,gyzz + real*8 :: gzzx,gzzy,gzzz + real*8 :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8 :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8 :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8 :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8 :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8 :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + real*8 :: Gamxx,Gamxy,Gamxz + real*8 :: Gamyx,Gamyy,Gamyz + real*8 :: Gamzx,Gamzy,Gamzz + real*8 :: Gamxxx, Gamxxy, Gamxxz, Gamxyy, Gamxyz, Gamxzz + real*8 :: Gamyxx, Gamyxy, Gamyxz, Gamyyy, Gamyyz, Gamyzz + real*8 :: Gamzxx, Gamzxy, Gamzxz, Gamzyy, Gamzyz, Gamzzz + real*8 :: Gamxa,Gamya,Gamza + real*8 :: CAZxx,CAZxy,CAZxz + real*8 :: CAZyx,CAZyy,CAZyz + real*8 :: CAZzx,CAZzy,CAZzz +! tilted A^k_iA_kj + real*8 :: AAxx,AAxy,AAxz,AAyy,AAyz,AAzz + real*8 :: Ainvxx,Ainvxy,Ainvxz,Ainvyy,Ainvyz,Ainvzz + real*8 :: liegxx,liegxy,liegxz,liegyy,liegyz,liegzz + real*8 :: fxx,fxy,fxz,fyy,fyz,fzz + real*8 :: TFxx,TFxy,TFxz,TFyy,TFyz,TFzz + + real*8 :: MapleGenVar1,MapleGenVar2,MapleGenVar3,MapleGenVar4 + real*8 :: f,betas + + real*8,dimension(3) ::SSS,AAS,ASA,SAA,ASS,SAS,SSA + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0,HALF=0.5d0 + real*8,parameter::TINYRR=1.d-14 +! in order to synchronize the following parameters with Z4c_rhs calculation, we +! call a routine + real*8 :: muL,tmuSL,tmuST + real*8 :: kappa1,kappa2,kappa3,FF,eta + + real*8,parameter :: ha=0.d0,thbs=0.d0,hu=0.d0,hw=0.d0,Rhpsi0=0.d0,Ihpsi0=0.d0 + + call get_Z4cparameters(kappa1,kappa2,kappa3,FF,eta) + + dR = R(2) - R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(3,3) = ex(3) - CPBC_ghost_width + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(6,3) = ex(3) - CPBC_ghost_width +endif + +if(dabs(R(1)-zmin) < dR)then + layer(1,6) = 1 + layer(2,6) = 1 + layer(3,6) = 1 + layer(4,6) = ex(1) + layer(5,6) = ex(2) + layer(6,6) = 1 +endif +! fix BD + gp = 6 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +! z direction + TZ_rhs(i,j,k) = ZEO + chi_rhs(i,j,k) = ZEO + trK_rhs(i,j,k) = ZEO + gxx_rhs(i,j,k) = ZEO + gxy_rhs(i,j,k) = ZEO + gxz_rhs(i,j,k) = ZEO + gyy_rhs(i,j,k) = ZEO + gyz_rhs(i,j,k) = ZEO + gzz_rhs(i,j,k) = ZEO + Axx_rhs(i,j,k) = ZEO + Axy_rhs(i,j,k) = ZEO + Axz_rhs(i,j,k) = ZEO + Ayy_rhs(i,j,k) = ZEO + Ayz_rhs(i,j,k) = ZEO + Azz_rhs(i,j,k) = ZEO + Gamx_rhs(i,j,k) = ZEO + Gamy_rhs(i,j,k) = ZEO + Gamz_rhs(i,j,k) = ZEO + Lap_rhs(i,j,k) = ZEO + betax_rhs(i,j,k) = ZEO + betay_rhs(i,j,k) = ZEO + betaz_rhs(i,j,k) = ZEO + dtSfx_rhs(i,j,k) = ZEO + dtSfy_rhs(i,j,k) = ZEO + dtSfz_rhs(i,j,k) = ZEO + enddo + enddo + enddo + endif + +! constraint preserving BD + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + +! cpbc real starts + + alpn1 = Lap + ONE + chin1 = chi + ONE + gxx = dxx + ONE + gyy = dyy + ONE + gzz = dzz + ONE +! invert tilted metric + gupzz = gxx * gyy * gzz + gxy * gyz * gxz + gxz * gxy * gyz - & + gxz * gyy * gxz - gxy * gxy * gzz - gxx * gyz * gyz + gupxx = ( gyy * gzz - gyz * gyz ) / gupzz + gupxy = - ( gxy * gzz - gyz * gxz ) / gupzz + gupxz = ( gxy * gyz - gyy * gxz ) / gupzz + gupyy = ( gxx * gzz - gxz * gxz ) / gupzz + gupyz = - ( gxx * gyz - gxy * gxz ) / gupzz + gupzz = ( gxx * gyy - gxy * gxy ) / gupzz +! tetrad for 2+1 decomposation + do i=1,ex(1) + do j=1,ex(2) + do k=1,ex(3) + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR .and. abs(Z(i,j,k)) < TINYRR)then + vx(i,j,k) = TINYRR + vy(i,j,k) = TINYRR + vz(i,j,k) = TINYRR + else + vx(i,j,k) = X(i,j,k) + vy(i,j,k) = Y(i,j,k) + vz(i,j,k) = Z(i,j,k) + endif + if(abs(X(i,j,k)) < TINYRR .and. abs(Y(i,j,k)) < TINYRR)then + ux(i,j,k) = - TINYRR + uy(i,j,k) = TINYRR + uz(i,j,k) = ZEO + wx(i,j,k) = TINYRR*Z(i,j,k) + wy(i,j,k) = TINYRR*Z(i,j,k) + wz(i,j,k) = -2*TINYRR*TINYRR + else + ux(i,j,k) = - Y(i,j,k) + uy(i,j,k) = X(i,j,k) + uz(i,j,k) = ZEO + wx(i,j,k) = X(i,j,k)*Z(i,j,k) + wy(i,j,k) = Y(i,j,k)*Z(i,j,k) + wz(i,j,k) = -(X(i,j,k)*X(i,j,k) + Y(i,j,k)*Y(i,j,k)) + endif + enddo + enddo + enddo + +! v^i corresponds to s^i + fx = vx + fy = vy + fz = vz + slx = vx + sly = vy + slz = vz + vx = gupxx*fx + gupxy*fy + gupxz*fz + vy = gupxy*fx + gupyy*fy + gupyz*fz + vz = gupxz*fx + gupyz*fy + gupzz*fz + + fx = gxx*vx*vx + gyy*vy*vy + gzz*vz*vz & + +(gxy*vx*vy + gxz*vx*vz + gyz*vy*vz)*TWO + fx = dsqrt(fx*chin1) + vx = vx/fx + vy = vy/fx + vz = vz/fx + slx = slx/fx + sly = sly/fx + slz = slz/fx +! 2+1: 1->u, 2->w + fx = gxx*vx*ux + gxy*vx*uy + gxz*vx*uz + & + gxy*vy*ux + gyy*vy*uy + gyz*vy*uz + & + gxz*vz*ux + gyz*vz*uy + gzz*vz*uz + fx = fx/chin1 + ux = ux - fx*vx + uy = uy - fx*vy + uz = uz - fx*vz + fx = gxx*ux*ux + gyy*uy*uy + gzz*uz*uz & + +(gxy*ux*uy + gxz*ux*uz + gyz*uy*uz)*TWO + fx = dsqrt(fx/chin1) + ux = ux/fx + uy = uy/fx + uz = uz/fx + ulx = (gxx*ux+gxy*uy+gxz*uz)/chin1 + uly = (gxy*ux+gyy*uy+gyz*uz)/chin1 + ulz = (gxz*ux+gyz*uy+gzz*uz)/chin1 + + fx = gxx*vx*wx + gxy*vx*wy + gxz*vx*wz + & + gxy*vy*wx + gyy*vy*wy + gyz*vy*wz + & + gxz*vz*wx + gyz*vz*wy + gzz*vz*wz + fx = fx/chin1 + wx = wx - fx*vx + wy = wy - fx*vy + wz = wz - fx*vz + fx = gxx*ux*wx + gxy*ux*wy + gxz*ux*wz + & + gxy*uy*wx + gyy*uy*wy + gyz*uy*wz + & + gxz*uz*wx + gyz*uz*wy + gzz*uz*wz + fx = fx/chin1 + wx = wx - fx*ux + wy = wy - fx*uy + wz = wz - fx*uz + fx = gxx*wx*wx + gyy*wy*wy + gzz*wz*wz & + +(gxy*wx*wy + gxz*wx*wz + gyz*wy*wz)*TWO + fx = dsqrt(fx/chin1) + wx = wx/fx + wy = wy/fx + wz = wz/fx + wlx = (gxx*wx+gxy*wy+gxz*wz)/chin1 + wly = (gxy*wx+gyy*wy+gyz*wz)/chin1 + wlz = (gxz*wx+gyz*wy+gzz*wz)/chin1 +!~ end tetrad + + qupxx = gupxx*chin1 - vx*vx + qupxy = gupxy*chin1 - vx*vy + qupxz = gupxz*chin1 - vx*vz + qupyy = gupyy*chin1 - vy*vy + qupyz = gupyz*chin1 - vy*vz + qupzz = gupzz*chin1 - vz*vz + + qxx = gxx/chin1 - slx*slx + qxy = gxy/chin1 - slx*sly + qxz = gxz/chin1 - slx*slz + qyy = gyy/chin1 - sly*sly + qyz = gyz/chin1 - sly*slz + qzz = gzz/chin1 - slz*slz + + qulxx = ONE - vx*slx + qulyy = ONE - vy*sly + qulzz = ONE - vz*slz + qulxy = - vx*sly + qulyx = - vy*slx + qulxz = - vx*slz + qulzx = - vz*slx + qulyz = - vy*slz + qulzy = - vz*sly + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) +!calculate the involved derivatives + call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,betax,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,betay,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,betaz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + + liegxx = betax(i,j,k)*gxxx+gxx(i,j,k)*sfxx+betay(i,j,k)*gxxy-gxx(i,j,k)*sfyy+2.0*sfyx*gxy(i,j,k)+betaz(i,j,k)*gxxz-gxx(i,j,k)*sfzz+2.0*sfzx*gxz(i,j,k) + liegxy = betax(i,j,k)*gxyx+sfxy*gxx(i,j,k)+betay(i,j,k)*gxyy+sfyx*gyy(i,j,k)+betaz(i,j,k)*gxyz-gxy(i,j,k)*sfzz+sfzx*gyz(i,j,k)+sfzy*gxz(i,j,k) + liegxz = betax(i,j,k)*gxzx+sfxz*gxx(i,j,k)+betay(i,j,k)*gxzy-gxz(i,j,k)*sfyy+sfyx*gyz(i,j,k)+sfyz*gxy(i,j,k)+betaz(i,j,k)*gxzz+sfzx*gzz(i,j,k) + liegyy = betax(i,j,k)*gyyx-gyy(i,j,k)*sfxx+2.0*sfxy*gxy(i,j,k)+betay(i,j,k)*gyyy+gyy(i,j,k)*sfyy+betaz(i,j,k)*gyyz-gyy(i,j,k)*sfzz+2.0*sfzy*gyz(i,j,k) + liegyz = betax(i,j,k)*gyzx-gyz(i,j,k)*sfxx+sfxy*gxz(i,j,k)+sfxz*gxy(i,j,k)+betay(i,j,k)*gyzy+sfyz*gyy(i,j,k)+betaz(i,j,k)*gyzz+sfzy*gzz(i,j,k) + liegzz = betax(i,j,k)*gzzx-gzz(i,j,k)*sfxx+2.0*sfxz*gxz(i,j,k)+betay(i,j,k)*gzzy-gzz(i,j,k)*sfyy+2.0*sfyz*gyz(i,j,k)+betaz(i,j,k)*gzzz+gzz(i,j,k)*sfzz + + call point_fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + + MapleGenVar3 = gupxy(i,j,k)*gupxy(i,j,k)*gxxyy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz+gupxy(i,j,k)*& +gupxy(i,j,k)*gxyxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gxyy+gupxx(i,j,k)*gupyz(i,j,k)*gxyxz+gupxz(i,j,k)*gupxz(i,j,k)*gxxzz& +-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxxz*gxxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzz*gxzz-2.0*gupxx(i,j,k)*& +gupxx(i,j,k)*gupyy(i,j,k)*gxxy*gxxy+gupxx(i,j,k)*gupyy(i,j,k)*gxyxy+gupxz(i,j,k)*gupzz(i,j,k)*gxzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)& +*gxzx*gxzx+2.0*gupxx(i,j,k)*gupxz(i,j,k)*gxxxz+gupxz(i,j,k)*gupyy(i,j,k)*gxyyz+gupxx(i,j,k)*gupyz(i,j,k)*gxzxy+gupxy(i,j,k)*& +gupzz(i,j,k)*gxzyz+2.0*gupxy(i,j,k)*gupxz(i,j,k)*gxxyz+2.0*gupxx(i,j,k)*gupxy(i,j,k)*gxxxy+gupxz(i,j,k)*gupxy(i,j,k)*gxyxz+gupxz(i,j,k)& +*gupyz(i,j,k)*gxyzz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxyx-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy+& +gupxx(i,j,k)*gupxx(i,j,k)*gxxxx+gupxx(i,j,k)*gupxz(i,j,k)*gxzxx-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxzy*gxzy+gupxx(i,j,k)*gupzz(i,j,k)& +*gxzxz + MapleGenVar4 = gupxz(i,j,k)*gupyz(i,j,k)*gxzyz+gupxy(i,j,k)*gupyz(i,j,k)*gxyyz+gupxy(i,j,k)*gupyz(i,j,k)*gxzyy+& +gupxx(i,j,k)*gupxy(i,j,k)*gxyxx+gupxy(i,j,k)*gupxz(i,j,k)*gxzxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gxyz+gupxy(i,j,k)*gupyy(i,j,k)& +*gxyyy+gupxz(i,j,k)*gupxz(i,j,k)*gxzxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxxz-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*& +gxxx*gxxx-6.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxxz*gxyz-6.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyx-6.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxzx + MapleGenVar2 = MapleGenVar4-gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)& +-4.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxxy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*gxyy-4.0*gupxx(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-gupxx(i,j,k)& +*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-4.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gxzy+gxzx*gxxy)-& +gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)& +-4.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxxx*gxzz+MapleGenVar3 + MapleGenVar4 = -4.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupxx(i,j,k)*gupxz(i,j,k)*& +gupyy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-4.0*gupxx(i,j,k)*& +gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gxzz+gxzx*gxxz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-gupxx(i,j,k)& +*gupxz(i,j,k)*gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-gupxx(i,j,k)*gupxy(i,j,k)*& +gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)& +*gupyz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxx(i,j,k)*& +gupyy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy) + MapleGenVar3 = MapleGenVar4-gupxx(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-4.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxxy*gxxz-4.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupxx(i,j,k)*& +gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-4.0*& +gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gxzz+gxzy*gxxz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz)& +-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-gupxx(i,j,k)*& +gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxx(i,j,k)& +*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-& +gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz) + MapleGenVar4 = -gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)& +*(gxxz*gyzy+gxyy*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*& +gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*& +gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*& +gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)& +-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+gxyx*gxyy& +)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyx*gyyy-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyx*gyzy + MapleGenVar1 = MapleGenVar4-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)& +-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz& +)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxyz-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxzy-2.0*gupxx(i,j,k)*& +gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxyz-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxxy-6.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*& +gxxy*gxyy-6.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxxy*gxzy-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxxy*gxyz+& +MapleGenVar3+MapleGenVar2 + MapleGenVar4 = MapleGenVar1-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxxy*gxzz-2.0*gupxx(i,j,k)*& +gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxxz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxxz-6.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*& +gxxz*gxzz-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-4.0*& +gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyx*gyyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*& +gupyz(i,j,k)*gxyx*gyzz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gxzz+gxzx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(& +gxyx*gyzz+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzx*gyzz) + MapleGenVar3 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyx-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzx-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)& +*(gxyy*gzzx+gxzy*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& +gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(& +gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*& +(gxxy*gyyz+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxyy*gxzz) + MapleGenVar4 = MapleGenVar3-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gxyz-2.0*gupxy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*& +gupyz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupxy(i,j,k)*gupxy(i,j,k)& +*gupxz(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxy(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupyz(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy) + MapleGenVar2 = MapleGenVar4-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupzz(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-& +gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)& +-gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx& +)-gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxzx*& +gxyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzx& +*gyyy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxzy-& +gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyzz+gxzx*gxyz) + MapleGenVar4 = MapleGenVar2-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxz(i,j,k)& +*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzx*gyzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzx*gzzz-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(& +gxxy*gyzx+gxyx*gxzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*& +(gxyy*gyzx+gxzy*gyyx)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)& +*(gxxy*gzzy+gxzy*gxzy)-gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxz(i,j,k)*gupyy(i,j,k)*& +gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy) + MapleGenVar3 = MapleGenVar4-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-gupxz(i,j,k)& +*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-& +gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxzz-2.0*& +gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)& +*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupxz(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-4.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyy*gyyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*& +gxyz*gyyx + MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyz*gyzx-2.0*gupxy(i,j,k)*& +gupyz(i,j,k)*gupyy(i,j,k)*gxyz*gyyy-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*& +gxyz*gyzz-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*& +gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzx*gyzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*& +gupzz(i,j,k)*gxzx*gzzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxzy*gzzx& +-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy + CAZxx = Gamxx - (MapleGenVar4-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzy*gzzz-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzx-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzz*gzzx-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*& +gyzy+gxyy*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz& +*gyzy+gxzz*gyyy)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*& +gxzz*gyzy-gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz+& +gxzz*gyyz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*& +gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gzzy-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz) + MapleGenVar3 = -2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz+gupxy(i,j,k)*gupyz(i,j,k)*gxzxy+2.0*& +gupxy(i,j,k)*gupyy(i,j,k)*gxyxy+gupxy(i,j,k)*gupxz(i,j,k)*gxzxx+gupxy(i,j,k)*gupxy(i,j,k)*gxyxx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*& +gxxx*gxxx+2.0*gupxy(i,j,k)*gupyz(i,j,k)*gxyxz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy+gupyz(i,j,k)*gupxz(i,j,k)*& +gxxzz+gupxy(i,j,k)*gupxy(i,j,k)*gxxxy+gupxy(i,j,k)*gupxx(i,j,k)*gxxxx+gupyy(i,j,k)*gupxx(i,j,k)*gxxxy+gupxy(i,j,k)*gupxz(i,j,k)*gxxxz+& +gupxy(i,j,k)*gupzz(i,j,k)*gxzxz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzz*gyzy+gupyy(i,j,k)*gupxy(i,j,k)*gxxyy+gupyz(i,j,k)*gupxz(i,j,k)& +*gxzxz+2.0*gupyy(i,j,k)*gupyz(i,j,k)*gxyyz+gupyz(i,j,k)*gupzz(i,j,k)*gxzzz+gupyy(i,j,k)*gupzz(i,j,k)*gxzyz-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*gxyy+gupyy(i,j,k)*gupxz(i,j,k)*gxxyz+gupyz(i,j,k)*& +gupyz(i,j,k)*gxzyz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxyy + MapleGenVar4 = gupyz(i,j,k)*gupxx(i,j,k)*gxxxz+gupyz(i,j,k)*gupxy(i,j,k)*gxxyz+gupyy(i,j,k)*gupxz(i,j,k)*gxzxy+& +gupyz(i,j,k)*gupyz(i,j,k)*gxyzz+gupyy(i,j,k)*gupyz(i,j,k)*gxzyy+gupyy(i,j,k)*gupyy(i,j,k)*gxyyy-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*& +gzzx+gxzy*gyzx)-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxxx*gxxz-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*gxyx& +-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-3.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+& +gxyx*gxzx)-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*& +gxxy + MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxzy-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gxzy+gxzx*& +gxxy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+& +gxzx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxxx*gxzz-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxx*gyyz+gxyx*& +gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gxzz+& +gxzx*gxxz)+MapleGenVar3 + MapleGenVar4 = -2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*& +gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*& +gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-2.0*& +gupxy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxxy-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxxy*gxyy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& +gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-3.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxy(i,j,k)*& +gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxxy*gxyz + MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gxyz+gxyy*gxxz)& +-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*& +gxzz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gxzz+gxzy*gxxz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*& +gyzz+gxzy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*& +gxyx*gxxz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx& +*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx& ++gxyx*gxzz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*& +gxxz + MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*& +gxzz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxxz& +-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxxz*gxyz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)& +-3.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*& +gxzz)-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx-gupyy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)& +-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx + MapleGenVar1 = MapleGenVar4-4.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxzx-4.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gupxz(i,j,k)*gxxy*gxzy-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxxz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*& +gxxy*gxzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxxz-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxxz*gxzz-2.0*& +gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxyx*gyyx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-gupyy(i,j,k)*& +gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-& +gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-4.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*& +gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyx*gyyy+MapleGenVar2 + MapleGenVar4 = -2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-2.0*gupyy(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*& +gupyy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)& +-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyx*gyyz-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gxzz+gxzx*gxyz)& +-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzx*& +gyzz)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyyx& +-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzy*gyyx) + MapleGenVar3 = MapleGenVar4-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-2.0*& +gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxyy-gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupyy(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(& +gxyy*gyzy+gxzy*gyyy)-gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*& +gupxx(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*gupyy(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyyz-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(& +gxyy*gxzz+gxzy*gxyz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzy*gyyz) + MapleGenVar4 = MapleGenVar3-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupyy(i,j,k)& +*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyz*gyyx-2.0*gupyy(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupyy(i,j,k)& +*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyz*gyyy-2.0*gupyy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-gupyy(i,j,k)*gupyz(i,j,k)*& +gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupyy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*gupyy(i,j,k)*& +gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz + MapleGenVar2 = MapleGenVar4-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxyz*gyyz-2.0*gupyy(i,j,k)*& +gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*& +gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxzx-gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupyz(i,j,k)*gupyz(i,j,k)& +*gupxx(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxzx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*& +gupxx(i,j,k)*gxzx*gyzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gxzy+gxzx*gxxy)-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(& +gxxx*gzzy+gxzx*gxzy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-gupyz(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxzx*gyzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& +gupxx(i,j,k)*(gxxx*gxzz+gxzx*gxxz) + MapleGenVar4 = MapleGenVar2-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*& +gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gxzz+gxzx*gxyz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)& +-4.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzx*gyzz-gupyz(i,j,k)*gupxy(i,j,k)*& +gupxz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*& +gupxz(i,j,k)*gxyx*gxzx-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyx*gyzy-4.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxyz& +-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyx*gyzz-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzx + MapleGenVar3 = MapleGenVar4-4.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz-2.0*gupyy(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*gxyz*gyzx-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxyz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*& +gxyz*gyzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxzx-2.0*& +gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy-2.0*gupyz(i,j,k)*gupxy(i,j,k)*& +gupzz(i,j,k)*gxzx*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzx*gzzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxzy*gyzx& +-gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gzzy+gxzy*gyzy& +) + MapleGenVar4 = MapleGenVar3-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gxzy-2.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupyy(i,j,k)*gxzy*gyzy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gxzz+gxzy*gxxz)-gupyz(i,j,k)*gupyz(i,j,k)*& +gupxz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-gupyz(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupzz(i,j,k)*gxzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)& +*(gxyz*gzzx+gxzz*gyzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzz*gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*& +gzzy+gxzy*gxzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+gxzz*gyzy) + CAZyx = Gamyx - (MapleGenVar4-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gzzy-gupyz(i,j,k)*gupzz(i,j,k)*& +gupxz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupyz(i,j,k)*& +gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gyzz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*& +gxzz*gzzz-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxzy*gzzx-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxzy-2.0*& +gupyz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxzy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& +gupzz(i,j,k)*gxzz*gzzx-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxzz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxzz& ++MapleGenVar1) + MapleGenVar3 = gupzz(i,j,k)*gupxz(i,j,k)*gxxzz+gupyz(i,j,k)*gupxz(i,j,k)*gxxyz+gupyz(i,j,k)*gupyz(i,j,k)*gxyyz+2.0*& +gupyz(i,j,k)*gupzz(i,j,k)*gxzyz+gupyz(i,j,k)*gupxx(i,j,k)*gxxxy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz-2.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy+gupzz(i,j,k)*gupxy(i,j,k)*gxyxz+gupyz(i,j,k)*gupxy(i,j,k)*gxxyy+gupzz(i,j,k)*gupyz(i,j,k)*gxyzz+& +gupxz(i,j,k)*gupxz(i,j,k)*gxxxz+2.0*gupxz(i,j,k)*gupzz(i,j,k)*gxzxz-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxxx+gupzz(i,j,k)*& +gupxy(i,j,k)*gxxyz+gupxz(i,j,k)*gupyz(i,j,k)*gxyxz+gupxz(i,j,k)*gupxy(i,j,k)*gxxxy+gupzz(i,j,k)*gupzz(i,j,k)*gxzzz+gupyz(i,j,k)*gupyy(i,j,k)*& +gxyyy+gupxz(i,j,k)*gupyy(i,j,k)*gxyxy+gupyz(i,j,k)*gupyz(i,j,k)*gxzyy+gupxz(i,j,k)*gupxz(i,j,k)*gxzxx+gupzz(i,j,k)*gupxx(i,j,k)*gxxxz+& +2.0*gupxz(i,j,k)*gupyz(i,j,k)*gxzxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*& +gxyy*gyzz + MapleGenVar4 = MapleGenVar3+gupzz(i,j,k)*gupyy(i,j,k)*gxyyz+gupxz(i,j,k)*gupxy(i,j,k)*gxyxx-2.0*gupzz(i,j,k)& +*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*gzzz+gupxz(i,j,k)*gupxx(i,j,k)*gxxxx+gupyz(i,j,k)*gupxy(i,j,k)*gxyxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*& +gupxz(i,j,k)*gxxx*gxzz-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxyy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxxx*gxzx& +-gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-3.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*& +gxzx)-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*& +gxyy + MapleGenVar2 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxzy-2.0*gupxz(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-2.0*& +gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gxzy+gxzx*& +gxxy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+& +gxzx*gxzy)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxxx*gxxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxyz-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gxzz+& +gxzx*gxxz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz) + MapleGenVar4 = MapleGenVar2-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)& +-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxxy-gupxz(i,j,k)*gupxy(i,j,k)*& +gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-gupxz(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)& +-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxxy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxxy*gxzy-gupxz(i,j,k)*gupyy(i,j,k)*& +gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-3.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*& +gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy) + MapleGenVar3 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxxy*gxzz-2.0*gupxz(i,j,k)*& +gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-2.0*& +gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gxzz+gxzy*& +gxxz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+& +gxzy*gxzz)-4.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyx-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*gxxy-4.0*& +gupxz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxxy*gxyy-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxxz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*gxxy*gxyz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxxz + MapleGenVar4 = MapleGenVar3-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxxz-& +gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*& +gxyz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+& +gxzy*gxzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxxz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxxz*gxzz-& +gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz) + MapleGenVar1 = MapleGenVar4-3.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)& +-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx-& +gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxyx*gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupyz(i,j,k)*& +gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gxyy+gxyx*gxxy)-& +gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyx*gyzy-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-gupyz(i,j,k)*& +gupyz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxzx*gyyy) + MapleGenVar4 = MapleGenVar1-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)& +-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gxyz+gxyx*gxxz)-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyyz+gxyx*& +gxyz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyx*gyzz-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gxzz+gxzx*& +gxyz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+& +gxzx*gyzz)-gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*& +gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+& +gxzy*gyzx) + MapleGenVar3 = MapleGenVar4-gupyz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*& +gupyz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxyy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*& +gupyy(i,j,k)*gxyy*gyzy-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(& +gxyy*gzzy+gxzy*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gxyz+gxyy*gxxz)-gupyz(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*& +gupyy(i,j,k)*gxyy*gyyz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(& +gxyy*gyzz+gxzy*gyyz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz) + MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyz*gyzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupyz(i,j,k)*& +gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyz*gyyy-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-2.0*& +gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxyz*gyzz-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(& +gxyz*gyzz+gxzz*gyyz) + MapleGenVar2 = MapleGenVar4-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)& +-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxxz-4.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxxz*gxyz-2.0*gupyz(i,j,k)*& +gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*& +gxyx*gyyy-4.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxyz-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyx*gyyz-2.0*& +gupyz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyx-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& +gupyy(i,j,k)*gxyz*gyyx-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxyz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz& +-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz + MapleGenVar4 = MapleGenVar2-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxzx-gupzz(i,j,k)*gupxx(i,j,k)*& +gupxy(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupzz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupzz(i,j,k)*& +gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxzx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxzx*gzzx-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(& +gxxx*gxzy+gxzx*gxxy)-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-2.0*gupzz(i,j,k)*gupxy(i,j,k)*& +gupxy(i,j,k)*(gxyx*gxzy+gxzx*gxyy)-gupzz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-2.0*gupzz(i,j,k)*& +gupzz(i,j,k)*gupxy(i,j,k)*gxzx*gzzy-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gxzz+gxzx*gxxz)-gupzz(i,j,k)*gupxz(i,j,k)*& +gupxy(i,j,k)*(gxxx*gyzz+gxzx*gxyz) + MapleGenVar3 = MapleGenVar4-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gxzz+gxzx*gxyz)-& +gupzz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-4.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*& +gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzx*gzzz-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupzz(i,j,k)*gupxy(i,j,k)& +*gupyy(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxzy*gzzx-gupzz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*& +(gxxy*gyzy+gxyy*gxzy)-gupzz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupzz(i,j,k)*gupyy(i,j,k)*& +gupxz(i,j,k)*gxzy*gxzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxzy*gzzy-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*& +gxzz+gxzy*gxxz)-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxzy*gxyz) + MapleGenVar4 = MapleGenVar3-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gxzz+gxzy*gxyz)-& +gupzz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz-2.0*& +gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzy*gzzz-gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupzz(i,j,k)*gupxz(i,j,k)& +*gupyy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gzzx-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*& +(gxxz*gyzy+gxyy*gxzz)-gupzz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*& +gupyz(i,j,k)*gxzz*gyzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gzzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxzz& +-gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzz+gxyz*gxzz) + CAZzx = Gamzx -(MapleGenVar4-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxzz-gupzz(i,j,k)*gupzz(i,j,k)*& +gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz-2.0*gupzz(i,j,k)*gupxx(i,j,k)*& +gupxy(i,j,k)*gxyx*gxzx-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-4.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy& +-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzx*gyzy-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzx*gyzz-2.0*gupzz(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gyzx-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxzy-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*& +gxyy*gxzy-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-4.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*& +gupzz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzx) + MapleGenVar3 = gupxz(i,j,k)*gupxz(i,j,k)*gyzxz+2.0*gupxy(i,j,k)*gupxz(i,j,k)*gxyyz+gupxx(i,j,k)*gupyz(i,j,k)*gyzxy& +-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyyy+gupxx(i,j,k)*gupxx(i,j,k)*gxyxx+gupxy(i,j,k)*gupyz(i,j,k)*gyzyy-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gyzz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gyyy+gupxy(i,j,k)*gupyy(i,j,k)*gyyyy+gupxz(i,j,k)*& +gupyz(i,j,k)*gyyzz+gupxy(i,j,k)*gupzz(i,j,k)*gyzyz+gupxx(i,j,k)*gupyz(i,j,k)*gyyxz+gupxy(i,j,k)*gupyz(i,j,k)*gyyyz-2.0*gupxx(i,j,k)*& +gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx+gupxy(i,j,k)*gupxy(i,j,k)*gxyyy+gupxz(i,j,k)*gupyy(i,j,k)*gyyyz+gupxz(i,j,k)*gupxy(i,j,k)*gyyxz+& +gupxx(i,j,k)*gupxz(i,j,k)*gyzxx+gupxz(i,j,k)*gupxz(i,j,k)*gxyzz+2.0*gupxx(i,j,k)*gupxy(i,j,k)*gxyxy+2.0*gupxx(i,j,k)*gupxz(i,j,k)*gxyxz& ++gupxz(i,j,k)*gupzz(i,j,k)*gyzzz-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx+gupxy(i,j,k)*gupxy(i,j,k)*gyyxy+gupxz(i,j,k)*& +gupyz(i,j,k)*gyzyz + MapleGenVar4 = MapleGenVar3-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*gyzx-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyyx+gupxx(i,j,k)*gupzz(i,j,k)*gyzxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxyz*& +gyzx)+gupxx(i,j,k)*gupxy(i,j,k)*gyyxx-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-4.0*gupxy(i,j,k)*& +gupxz(i,j,k)*gupyy(i,j,k)*gyyx*gyyz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)+gupxx(i,j,k)*gupyy(i,j,k)*& +gyyxy-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)+gupxy(i,j,k)*gupxz(i,j,k)*gyzxy-4.0*gupxx(i,j,k)*gupxz(i,j,k)& +*gupxy(i,j,k)*gxyx*gxyz + MapleGenVar2 = MapleGenVar4-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupxx(i,j,k)*& +gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-gupxx(i,j,k)*gupxx(i,j,k)*& +gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupxx(i,j,k)*& +gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-4.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(& +gxxy*gyyx+gxyx*gxyy)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)-gupxx(i,j,k)*gupxy(i,j,k)*& +gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-2.0*& +gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxyy*gyzx) + MapleGenVar4 = MapleGenVar2-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxxz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*& +gupxy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)-gupxx(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzy-gupxx(i,j,k)*gupxz(i,j,k)*& +gupzz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*& +gupxy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxx(i,j,k)*& +gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxzx*gxyy) + MapleGenVar3 = MapleGenVar4-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxxy*gxyy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxyy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*& +gupxy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(& +gxyy*gyzy+gxzy*gyyy)-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*& +gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyy*gxxz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-gupxx(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxyy*gxzz) + MapleGenVar4 = MapleGenVar3-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxyz*gyzy)-& +gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxyz-2.0*& +gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxx(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-& +gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxxy*gxyz-2.0*& +gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)& +-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxzy*gxyz) + MapleGenVar1 = MapleGenVar4-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxxz*gxyz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*& +gupxy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxx(i,j,k)*& +gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-4.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gyyx-3.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*& +gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyyx-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-4.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyyx*gyyy + MapleGenVar4 = MapleGenVar1-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyyx*gyzy-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gyzy+gyzx*gyyy)-& +gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyyz+gxyz*& +gyyx)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyz*gyyx& +-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gyzz+& +gyzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx& ++gxzx*gyyy) + MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyyy-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-4.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-3.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*& +gupyy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-& +gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyz*gyyy-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*& +gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxyy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy + MapleGenVar4 = MapleGenVar3-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-4.0*gupxx(i,j,k)*& +gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyy*gxzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*& +gxzy*gxyz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz-2.0*& +gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxyz*gyzz-4.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyyx*gyzx-2.0*gupxy(i,j,k)*gupxz(i,j,k)*& +gupyz(i,j,k)*gyyx*gyzz-4.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzy-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyyz& +-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzx*gyyz) + MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gyyz-2.0*gupxy(i,j,k)*& +gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupxy(i,j,k)& +*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyyz-2.0*gupxy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-gupxy(i,j,k)*gupyz(i,j,k)*& +gupzz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gyyz-3.0*gupxy(i,j,k)*gupzz(i,j,k)*& +gupxz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyyz-gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(& +gyyz*gzzz+gyzz*gyzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*& +(gyyx*gzzx+gyzx*gyzx) + MapleGenVar4 = MapleGenVar2-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gyzx-2.0*gupxz(i,j,k)*& +gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*& +gupxy(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gyyx*gyzy+gyzx*gyyy)-gupxz(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzy*gyzx-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzz+gxyz*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyx*gyzz+gyzx*gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)& +-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyzz + MapleGenVar3 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzx*gzzz-gupxz(i,j,k)*gupxz(i,j,k)*& +gupxy(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gyzy-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*& +gupyy(i,j,k)*gyyy*gyzy-gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*& +gxzy*gyzy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyzz+gxyz& +*gyzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gyzz& ++gyzy*gyyz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz) + MapleGenVar4 = MapleGenVar3-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzy-4.0*gupxz(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)& +*(gyyz*gzzx+gyzx*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzz*gzzx-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*& +gzzy+gxzy*gyzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*& +gxzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzz+& +gyzz*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzz*gyzz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz-2.0*& +gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyyz + CAZxy = Gamxy - (MapleGenVar4-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyyz*gyzz-2.0*gupxz(i,j,k)*& +gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyzx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyzx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& +gyzx*gzzx-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzx*gzzy-2.0*& +gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzy*gzzx-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyzy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*& +gupzz(i,j,k)*gyzy*gzzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzy*gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzy& +-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyzz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyzz-2.0*gupxz(i,j,k)*& +gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz) + MapleGenVar3 = gupxy(i,j,k)*gupxy(i,j,k)*gxyxy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gxyy+gupxx(i,j,k)*& +gupyz(i,j,k)*gxyxz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gyyx*gyyx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gyzz+& +gupxx(i,j,k)*gupyy(i,j,k)*gxyxy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gyzy+gupxy(i,j,k)*gupyz(i,j,k)*gyzxy+gupxz(i,j,k)*gupyy(i,j,k)& +*gxyyz+gupyz(i,j,k)*gupyz(i,j,k)*gyzyz+2.0*gupyy(i,j,k)*gupyz(i,j,k)*gyyyz+gupyy(i,j,k)*gupzz(i,j,k)*gyzyz+2.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gyyxy+gupxz(i,j,k)*gupxy(i,j,k)*gxyxz+gupxz(i,j,k)*gupyz(i,j,k)*gxyzz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxyx& ++gupxy(i,j,k)*gupxz(i,j,k)*gyzxx+gupyy(i,j,k)*gupxz(i,j,k)*gyzxy-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy+gupyz(i,j,k)*& +gupxz(i,j,k)*gyzxz+gupyy(i,j,k)*gupyz(i,j,k)*gyzyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gyzx*gyzx+gupyz(i,j,k)*gupyz(i,j,k)*gyyzz& +-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz+gupyz(i,j,k)*gupzz(i,j,k)*gyzzz+gupxy(i,j,k)*gupyz(i,j,k)*gxyyz + MapleGenVar4 = MapleGenVar3+gupxy(i,j,k)*gupzz(i,j,k)*gyzxz+gupxx(i,j,k)*gupxy(i,j,k)*gxyxx-2.0*gupxy(i,j,k)& +*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gxyz+gupxy(i,j,k)*gupyy(i,j,k)*gxyyy-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyyy+gupxy(i,j,k)*& +gupxy(i,j,k)*gyyxx+gupyy(i,j,k)*gupyy(i,j,k)*gyyyy+2.0*gupxy(i,j,k)*gupyz(i,j,k)*gyyxz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyyz*& +gyyz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxxz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxxz*gxyz-2.0*gupxx(i,j,k)*& +gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxyx + MapleGenVar2 = MapleGenVar4-gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-gupxx(i,j,k)& +*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxxx*gxyy-gupxx(i,j,k)*gupxy(i,j,k)*& +gupyy(i,j,k)*(gxxx*gyyy+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxzx*gxyy)-gupxx(i,j,k)*gupxz(i,j,k)& +*gupyy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)-2.0*gupxx(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxxy-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)& +*(gxxy*gyzx+gxyx*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-gupxx(i,j,k)*gupyy(i,j,k)*& +gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-gupxx(i,j,k)*gupyz(i,j,k)& +*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz) + MapleGenVar4 = MapleGenVar2-gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxx(i,j,k)& +*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-& +gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxxz*gyyz+gxyz*gxyz)& +-gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyyx+gxyx*gxyx& +)-gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx& +*gyyx)-gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+& +gxyx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyx*gyyy + MapleGenVar3 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxyz-2.0*gupxx(i,j,k)*& +gupxz(i,j,k)*gupxy(i,j,k)*gxxx*gxyz-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxxy*gxyy-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*& +gxxy*gxyz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxxz-6.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-4.0*& +gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*gupxy(i,j,k)*gupxz(i,j,k)*& +gupyy(i,j,k)*gxyx*gyyz-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy& +*gyyx+gxyx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyyx + MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzy*gyyx)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-6.0*& +gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*& +gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-4.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gxyz-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-gupxy(i,j,k)*gupxy(i,j,k)& +*gupxz(i,j,k)*(gxxz*gyyx+gxyx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-gupxy(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzz*gyyy) + MapleGenVar1 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxz*gyyz+gxyz*gxyz)-gupxy(i,j,k)& +*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-& +gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*& +gyyx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxzx& +*gxyy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyzz+& +gxzx*gxyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzx*& +gyzz-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzx+gxzy*& +gyyx)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy) + MapleGenVar4 = MapleGenVar1-gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxz(i,j,k)& +*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-2.0*& +gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzy*gyzz-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)& +*gupyy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-4.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& +gupxz(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyy*gyyz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyz*gyyx& +-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gxyz*gyyy-6.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz + MapleGenVar3 = MapleGenVar4-4.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxyz*gyzz-2.0*gupxy(i,j,k)*& +gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*& +gxzx*gyzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gyzx-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gyzx-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)& +*gupyy(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxzz*gyzy-2.0*gupxz(i,j,k)*gupzz(i,j,k)*& +gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxz(i,j,k)*& +gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz + MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzy-4.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-4.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)& +-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)-& +gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxyz*& +gyzx)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxyy-& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzx*gyzy) + + MapleGenVar2 = MapleGenVar4-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxyz*& +gyzy)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz-& +gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)& +-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzy*gyzz& +)-gupyy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzy*& +gyyx)-4.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gyyx*gyyy-4.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gyzy+gyzx*& +gyyy)-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy) + MapleGenVar4 = MapleGenVar2-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-4.0*& +gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gyyx*gyyz-4.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gyzz+gyzx*gyyz)-gupyy(i,j,k)*& +gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyy*gxzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxyz-6.0*gupyy(i,j,k)*gupxx(i,j,k)*& +gupyz(i,j,k)*gyyx*gyzx-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyyx*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyyx*gyzz& +-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-6.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzy + MapleGenVar3 = MapleGenVar4-gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyy(i,j,k)& +*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-4.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyyz-2.0*gupyy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz-4.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-gupyy(i,j,k)*gupyz(i,j,k)*& +gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-gupyy(i,j,k)*gupxz(i,j,k)& +*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupyy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)& +*(gyyz*gzzz+gyzz*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupyz(i,j,k)*gupxy(i,j,k)*& +gupxz(i,j,k)*(gxyx*gzzy+gxzy*gyzx) + MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-4.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gyzy-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-gupyz(i,j,k)*gupyz(i,j,k)& +*gupxz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gyzz-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*& +(gxyy*gzzx+gxzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)& +*(gyyy*gzzy+gyzy*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*& +gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(& +gxyz*gzzx+gxzx*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyyz*gzzx+gyzx*gyzz) + CAZyy = Gamyy - (MapleGenVar4-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyyy-2.0*gupyy(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyyz-6.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyyz*gyzz-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& +gyzx*gzzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzx*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzx*gzzz-2.0*& +gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzy*gzzx-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& +gupzz(i,j,k)*gyzz*gzzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz& +*gzzy+gyzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzy-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+& +gyzz*gyzz)-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz) + MapleGenVar3 = gupyz(i,j,k)*gupxx(i,j,k)*gxyxy+gupxz(i,j,k)*gupyy(i,j,k)*gyyxy+gupzz(i,j,k)*gupxy(i,j,k)*gyyxz+2.0*& +gupxz(i,j,k)*gupzz(i,j,k)*gyzxz+gupzz(i,j,k)*gupxy(i,j,k)*gxyyz+gupyz(i,j,k)*gupxy(i,j,k)*gxyyy+gupyz(i,j,k)*gupxy(i,j,k)*gyyxy+gupyz(i,j,k)*& +gupyy(i,j,k)*gyyyy+gupxz(i,j,k)*gupxz(i,j,k)*gyzxx+gupxz(i,j,k)*gupyz(i,j,k)*gyyxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz& +-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz+gupxz(i,j,k)*gupxy(i,j,k)*gxyxy+gupzz(i,j,k)*gupyy(i,j,k)*gyyyz+gupxz(i,j,k)*& +gupxy(i,j,k)*gyyxx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz+gupyz(i,j,k)*gupyz(i,j,k)*gyzyy+2.0*gupyz(i,j,k)*gupzz(i,j,k)*& +gyzyz+gupzz(i,j,k)*gupxx(i,j,k)*gxyxz+gupyz(i,j,k)*gupxz(i,j,k)*gxyyz+gupxz(i,j,k)*gupxx(i,j,k)*gxyxx+2.0*gupxz(i,j,k)*gupyz(i,j,k)*& +gyzxy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz+gupzz(i,j,k)*& +gupzz(i,j,k)*gyzzz + MapleGenVar4 = MapleGenVar3+gupzz(i,j,k)*gupxz(i,j,k)*gxyzz-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzy*& +gyzx+gupyz(i,j,k)*gupyz(i,j,k)*gyyyz+gupxz(i,j,k)*gupxz(i,j,k)*gxyxz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-2.0*& +gupzz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz+gupzz(i,j,k)*gupyz(i,j,k)*gyyzz-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyz*gyyx& +-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxyx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxyx-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupxx(i,j,k)*gxyx*gxzx-gupxz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyyx+gxyx*gxyx) + MapleGenVar2 = MapleGenVar4-3.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-& +gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*& +gyzx)-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxyy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxzy-gupxz(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyyy+gxyy*gyyx)& +-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxyx*& +gxzy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*& +gzzy+gxzy*gyzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxyx*gxxz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxyz& +-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyx+gxyx*gxyz) + MapleGenVar4 = MapleGenVar2-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxyx*& +gxzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gyzz+gxyz*gyzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*& +gzzz+gxzz*gyzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxyy-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyyy+& +gxyx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*& +gyzy+gxzx*gxyy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*& +gupxy(i,j,k)*gxyy*gxyy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxyy*gxzy + MapleGenVar3 = MapleGenVar4-gupxz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-2.0*& +gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gxyy*gyyy-3.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxz(i,j,k)*& +gupxz(i,j,k)*gupyy(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyy*gxzz-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*& +gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*& +gyyy)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxyy*gxzz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+& +gxyz*gyzy)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*& +gxxx*gxyz + MapleGenVar4 = MapleGenVar3-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyyz+gxyx*gxyz)-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxzx*gxyz)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxyz-& +gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyyz+gxyy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*& +gyyz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+& +gxzy*gyzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxyz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxyz*gxzz-& +gupxz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyyz+gxyz*gxyz) + MapleGenVar1 = MapleGenVar4-3.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-& +gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*& +gyzz)-gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gyyx+gxyx*gxyx)-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyyx& +-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gyyx*gyzx-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxyx*gyyx-2.0*gupxz(i,j,k)*& +gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxxy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*& +gxxx*gxyy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxyy-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*& +gupxz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxyy*gxxz-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gxyz + MapleGenVar4 = MapleGenVar1-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxyz-2.0*gupxz(i,j,k)*& +gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxyz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gxyz*gyyz-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*& +gxyz*gyzz-4.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyyx-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx& +*gyzx)-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*gyyx+gxyx*gxyy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyyy& ++gxyy*gyyx)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyyx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyyx*gyzy-& +gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzy*gyyx) + MapleGenVar3 = MapleGenVar4-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyyx*gyzy+gyzx*gyyy)& +-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gyyx+gxyx*& +gxyz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyyz+gxyz*gyyx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyyx*& +gyzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyyx*gyzz+& +gyzx*gyyz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*& +gyyy+gxyx*gxyy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gyyy-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gyyy& +-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+gyzx*& +gyzy) + MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gyyy+gxyy*gxyy)-4.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyzy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyz(i,j,k)*& +gupyz(i,j,k)*gupxx(i,j,k)*(gxxz*gyyy+gxyy*gxyz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyyz+gxyz*gyyy)& +-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyz*gyyy-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyyz-gupyz(i,j,k)*gupyz(i,j,k)*& +gupxz(i,j,k)*(gxyz*gyzy+gxzz*gyyy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gyyz+gxyx*gxyz)& +-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gyyz + MapleGenVar2 = MapleGenVar4-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzx*gyyz)-2.0*& +gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gyyz+gxyy*gxyz)& +-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gyyz-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzy*gyyz)-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-gupyz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*(gxxz*gyyz+gxyz*gxyz)& +-2.0*gupyz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyyz-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyyz*gyzz-2.0*gupyz(i,j,k)*& +gupzz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-gupzz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupzz(i,j,k)& +*gupxx(i,j,k)*gupxy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-2.0*gupzz(i,j,k)*& +gupzz(i,j,k)*gupxx(i,j,k)*gyzx*gzzx + MapleGenVar4 = MapleGenVar2-gupzz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzx+gxyx*gxzy)-2.0*& +gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxyy*gyzx)-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyy*gyzx+gxzy*gyyx)& +-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gyyx*gyzy+gyzx*gyyy)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gyzx*gzzy-& +gupzz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gyzx+gxyx*gxzz)-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzz+gxyz*& +gyzx)-gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyz*gyzx+gxzz*gyyx)-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyx*gyzz+& +gyzx*gyyz)-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*gyzx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gyzx*gzzz-& +gupzz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyzy+gxzx*gxyy) + MapleGenVar3 = MapleGenVar4-gupzz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxzx*gyyy)-4.0*& +gupyz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyyx*gyyy-4.0*gupyz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gyyx*gyyz-4.0*gupyz(i,j,k)*gupyy(i,j,k)*& +gupxy(i,j,k)*gxyy*gyyy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gyyz-4.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyyz& +-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyzx-2.0*gupzz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyzx-2.0*gupzz(i,j,k)*& +gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gyzx-4.0*gupzz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-4.0*gupzz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*& +gyzx*gyzz-2.0*gupzz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gyzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gyzy*gzzx + MapleGenVar4 = MapleGenVar3-gupzz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupzz(i,j,k)& +*gupyy(i,j,k)*gupxy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyzy-2.0*gupzz(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyzy*gzzy-gupzz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxz*& +gyzy+gxyy*gxzz)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gyzz+gxyz*gyzy)-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(& +gxyz*gyzy+gxzz*gyyy)-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gyzz+gyzy*gyyz)-4.0*gupzz(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzy*gzzz-gupzz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*& +gyzz+gxzx*gxyz)-gupzz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gyzz+gxzx*gyyz) + CAZzy = Gamzy -(MapleGenVar4-2.0*gupzz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gyzz-2.0*gupzz(i,j,k)*& +gupzz(i,j,k)*gupxz(i,j,k)*gyzz*gzzx-gupzz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gyzz+gxzy*gxyz)-gupzz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)& +*(gxyy*gyzz+gxzy*gyyz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gzzy-gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*(gxxz*& +gyzz+gxyz*gxzz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyzz-gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*(gxyz*gyzz+& +gxzz*gyyz)-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyzz-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gyzz-2.0*& +gupzz(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyzy-2.0*gupzz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gyzy-2.0*gupzz(i,j,k)*gupyz(i,j,k)*& +gupxz(i,j,k)*gxzz*gyzy-2.0*gupzz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gyzz) + MapleGenVar3 = gupxx(i,j,k)*gupyy(i,j,k)*gyzxy-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gzzz+gupxz(i,j,k)*& +gupzz(i,j,k)*gzzzz+gupxy(i,j,k)*gupxy(i,j,k)*gxzyy+2.0*gupxx(i,j,k)*gupxy(i,j,k)*gxzxy+2.0*gupxy(i,j,k)*gupxz(i,j,k)*gxzyz-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxzx+gupxz(i,j,k)*gupxy(i,j,k)*gyzxz+gupxx(i,j,k)*gupyz(i,j,k)*gzzxy+gupxy(i,j,k)*gupxy(i,j,k)*& +gyzxy+gupxz(i,j,k)*gupyz(i,j,k)*gzzyz+gupxy(i,j,k)*gupyy(i,j,k)*gyzyy+gupxz(i,j,k)*gupyy(i,j,k)*gyzyz+gupxz(i,j,k)*gupxz(i,j,k)*gzzxz& +-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyzx+2.0*gupxx(i,j,k)*gupxz(i,j,k)*gxzxz+gupxx(i,j,k)*gupxx(i,j,k)*gxzxx-2.0*& +gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gzzz*gzzz+gupxx(i,j,k)*gupyz(i,j,k)*gyzxz+gupxz(i,j,k)*gupxz(i,j,k)*gxzzz-2.0*gupxx(i,j,k)*gupxx(i,j,k)& +*gupxx(i,j,k)*gxxx*gxzx+gupxy(i,j,k)*gupxz(i,j,k)*gzzxy+gupxx(i,j,k)*gupxy(i,j,k)*gyzxx+gupxy(i,j,k)*gupyz(i,j,k)*gyzyz-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gyzy + MapleGenVar4 = MapleGenVar3+gupxx(i,j,k)*gupxz(i,j,k)*gzzxx+gupxx(i,j,k)*gupzz(i,j,k)*gzzxz+gupxy(i,j,k)*& +gupyz(i,j,k)*gzzyy+gupxy(i,j,k)*gupzz(i,j,k)*gzzyz+gupxz(i,j,k)*gupyz(i,j,k)*gyzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*gzzx& +-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gxzx-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-& +gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*& +gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx) + + MapleGenVar2 = MapleGenVar4-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*gupxx(i,j,k)*& +gupxx(i,j,k)*gupxy(i,j,k)*gxzx*gxxy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxzx*gxyy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(& +gxxy*gyzx+gxzx*gxyy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*& +gupyz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxx(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)& +-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-4.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*gupxx(i,j,k)*& +gupxz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-2.0*& +gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzx*gyzz+gxzz*gyzx) + MapleGenVar4 = MapleGenVar2-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-& +gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxzx*gzzz+gxzz*& +gzzx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxxx*gxzy-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxzy-2.0*gupxx(i,j,k)& +*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-2.0*& +gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)& +-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gxxy*gxzy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gxzy-2.0*gupxx(i,j,k)*& +gupyy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzy+gxyy*gxzy) + MapleGenVar3 = MapleGenVar4-gupxx(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*& +gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)& +-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzy*gxxz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-& +gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxzy*gyzz+gxzz*& +gyzy)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+& +gxzy*gyzz)-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxzy*gzzz+gxzz*gzzy)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*& +gxxx*gxzz-4.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxyz + MapleGenVar4 = MapleGenVar3-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gxzy-2.0*gupxx(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*& +gxzy*gxyz-4.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyx*gxzz-2.0*& +gupxx(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzz*gyyx)& +-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzz*& +gyzx)-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxxy*gxzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxxy*gyzz+gxyy*& +gxzz) + MapleGenVar1 = MapleGenVar4-gupxx(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*& +gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)& +-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxxz*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz-2.0*gupxx(i,j,k)*& +gupzz(i,j,k)*gupxy(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*& +gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)& +-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*gzzz-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-3.0*gupxy(i,j,k)*gupxx(i,j,k)*& +gupxz(i,j,k)*(gxyx*gzzx+gxzx*gyzx) + MapleGenVar4 = MapleGenVar1-gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupxy(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)& +-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyzx*gyyy-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyzx*gzzy+gyzy*gzzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyz*gyzx+gxzx*gyyz)& +-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gyzz+gxzz*gyzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyz*gyzx + MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-& +gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyzx*gzzz+gyzz*& +gzzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gyyx*gyzy& +-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gzzy+gyzx*& +gyzy)-gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gyzy& +-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy-3.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzy+gyzy*gyzy) + MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-4.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupxy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)-& +gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gyzz-2.0*& +gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)& +-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy) + MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-2.0*gupxy(i,j,k)*& +gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupzz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gyzz-2.0*gupxy(i,j,k)*& +gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz-3.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-gupxy(i,j,k)*gupzz(i,j,k)*& +gupyz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*gxyy*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gxzz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz& +-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*gyyx*gyzx + MapleGenVar4 = MapleGenVar2-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gyzx*gzzx-2.0*gupxy(i,j,k)*& +gupxz(i,j,k)*gupyy(i,j,k)*gyzx*gyyz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyzz-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*& +gxzy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gyyz-2.0*& +gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gyyx*gyzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyyy*gyzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*& +gupxz(i,j,k)*gxzz*gyzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*gyyz*gyzz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gzzx& +-gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gyyx*gzzx+gyzx*gyzx) + MapleGenVar3 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gzzx*gzzx-gupxz(i,j,k)*gupxy(i,j,k)*& +gupxy(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxzx*gzzy+gxzy*gzzx)-gupxz(i,j,k)*& +gupxy(i,j,k)*gupyy(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyzx*gzzy+gyzy*gzzx)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzy*gzzx-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gzzz+gxzz*gzzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyz*gzzx+gyzx*gyzz)& +-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyzx*gzzz+gyzz*gzzx)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzz*gzzx& +-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gzzx*gzzz-gupxz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gzzy+gxzy*gyzx) + MapleGenVar4 = MapleGenVar3-gupxz(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-2.0*& +gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gzzy-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxzy*gzzy-gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(& +gyyy*gzzy+gyzy*gyzy)-2.0*gupxz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gzzy*gzzy-gupxz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gxyz*& +gzzy+gxzy*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzy*gzzz+gxzz*gzzy)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(& +gyyz*gzzy+gyzy*gyzz)-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*gxzz*gzzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzz*gzzy-gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*& +gzzz+gxzz*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gyyx*gzzz+gyzx*gyzz) + CAZxz = Gamxz - (MapleGenVar4-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gzzz-gupxz(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-gupxz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-2.0*gupxz(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gzzz-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*& +gxzz*gzzz-gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-4.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*& +gzzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzy*gzzx-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gzzx*gzzy-2.0*gupxz(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gzzy-4.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gzzy-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*& +gzzy*gzzz-4.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gzzz) + MapleGenVar3 = gupyz(i,j,k)*gupyz(i,j,k)*gzzyz+gupyy(i,j,k)*gupyy(i,j,k)*gyzyy+gupyz(i,j,k)*gupzz(i,j,k)*gzzzz-2.0*& +gupyy(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*gyyy*gyzy+2.0*gupyy(i,j,k)*gupyz(i,j,k)*gyzyz+gupxy(i,j,k)*gupyz(i,j,k)*gzzxy-2.0*gupyy(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyzy+gupyy(i,j,k)*gupxx(i,j,k)*gxzxy+gupyz(i,j,k)*gupyz(i,j,k)*gyzzz+gupxy(i,j,k)*gupxz(i,j,k)*gxzxz+2.0& +*gupxy(i,j,k)*gupyz(i,j,k)*gyzxz+gupxy(i,j,k)*gupxx(i,j,k)*gxzxx+gupyy(i,j,k)*gupxz(i,j,k)*gzzxy+gupyy(i,j,k)*gupxz(i,j,k)*gxzyz+gupxy(i,j,k)*& +gupzz(i,j,k)*gzzxz-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxzx*gxyy+gupyz(i,j,k)*gupxy(i,j,k)*gxzyz-2.0*gupyz(i,j,k)*gupzz(i,j,k)*& +gupzz(i,j,k)*gzzz*gzzz+gupxy(i,j,k)*gupxz(i,j,k)*gzzxx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gzzz-2.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyzz*gzzy-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxxx*gxzy+2.0*gupxy(i,j,k)*gupyy(i,j,k)*gyzxy+& +gupyz(i,j,k)*gupxz(i,j,k)*gxzzz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxzx*gzzz+gxzz*gzzx) + MapleGenVar4 = MapleGenVar3+gupxy(i,j,k)*gupxy(i,j,k)*gyzxx+gupxy(i,j,k)*gupxy(i,j,k)*gxzxy+gupyy(i,j,k)*& +gupyz(i,j,k)*gzzyy+gupyz(i,j,k)*gupxz(i,j,k)*gzzxz+gupyz(i,j,k)*gupxx(i,j,k)*gxzxz+gupyy(i,j,k)*gupzz(i,j,k)*gzzyz-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxy(i,j,k)*gxyx*gxzy-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyy*gyzz+gupyy(i,j,k)*gupxy(i,j,k)*gxzyy-2.0*& +gupxy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*gxxx*gxzx-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxyx*gxzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*& +gupxz(i,j,k)*gxzx*gxzx + MapleGenVar2 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*& +gupxy(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx)-gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)& +-3.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*gxzx*gxxy& +-4.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxzy-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxzx*gyzy+gxzy*& +gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+& +gxzx*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*& +gxzx*gxyz-4.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz + MapleGenVar4 = MapleGenVar2-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*& +gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzx+gxzx*gyyz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzx*gyzz+gxzz*& +gyzx)-gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+& +gxzx*gyzz)-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*& +gupxy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gxxz-gupxy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupyy(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzy*gyzx) + MapleGenVar3 = MapleGenVar4-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gxzy-gupxy(i,j,k)*gupxy(i,j,k)*gupyy(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*& +gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-3.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxzy*gxyz-gupxy(i,j,k)*gupxy(i,j,k)*& +gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)& +-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxzy*gzzz+& +gxzz*gzzy) + MapleGenVar4 = MapleGenVar3-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-gupxy(i,j,k)*gupxy(i,j,k)*& +gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupxy(i,j,k)*& +gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)& +-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gxzz-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)& +-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxyz*gxzz& +-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gxzz + MapleGenVar1 = MapleGenVar4-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-2.0*& +gupxy(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)& +-3.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gxzz*gzzz-& +gupyy(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gyyx*gyzx-2.0*& +gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyzx*gyzx-gupyy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-2.0*gupyy(i,j,k)*& +gupxx(i,j,k)*gupyz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-gupyy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*& +gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*gxyy*gyzx-2.0*& +gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gyzx*gyyy + MapleGenVar4 = MapleGenVar1-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-2.0*& +gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyy*gzzx+gyzx*gyzy)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyzx*gzzy+gyzy*& +gzzx)-gupyy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gyzz+& +gxzz*gyzx)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gyzx*gyyz-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzz*& +gyzx)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyzx*& +gzzz+gyzz*gzzx)-gupyy(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gyzy+gxyx*gxzy)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*& +gxyx*gyzy + MapleGenVar3 = MapleGenVar4-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxy(i,j,k)*gyyx*gyzy-gupyy(i,j,k)*gupxy(i,j,k)*& +gupxz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-gupyy(i,j,k)*& +gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxzy*gyzy-2.0*gupyy(i,j,k)*& +gupyy(i,j,k)*gupxy(i,j,k)*gxyy*gyzy-gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*& +gupyz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-gupyy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(& +gxxz*gyzy+gxzy*gxyz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-2.0*gupyy(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-4.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz + MapleGenVar4 = MapleGenVar3-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-2.0*& +gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzy+gyzy*gyzz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyzy*gzzz+gyzz*& +gzzy)-gupyy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*gxxy*gxzy& +-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupxy(i,j,k)*& +gupyz(i,j,k)*gupxx(i,j,k)*gxzy*gxxz-4.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxzz-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*& +gxxx*gxzz-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gxxy*gxzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gxxz*gxzz + MapleGenVar2 = MapleGenVar4-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz-2.0*gupyy(i,j,k)*& +gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gyzx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupxy(i,j,k)*gxyx*gyzx-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& +gyzx*gzzx-4.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxyz*gyzx-4.0*& +gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyzz-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gxyz*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*& +gupxy(i,j,k)*gxyx*gyzz-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gyyx*gyzz-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gzzz+& +gxzx*gyzz)-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-gupyy(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*& +gyzz+gxyy*gxzz)-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzz + MapleGenVar4 = MapleGenVar2-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-2.0*& +gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyy(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*(gxxz*gyzz+gxyz*gxzz)& +-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyyz*gyzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyzz*gyzz-gupyy(i,j,k)*gupzz(i,j,k)*& +gupxz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-2.0*& +gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-gupyz(i,j,k)*gupxx(i,j,k)*gupxx(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-4.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupxx(i,j,k)*gyzx*gzzx-2.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gzzx*gzzx-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxy*& +gzzx+gxzx*gxzy) + MapleGenVar3 = MapleGenVar4-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)-& +gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*(gyzx*gzzy+gyzy*& +gzzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzy*gzzx-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(gxxz*gzzx+gxzx*gxzz)& +-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxzx*gzzz+gxzz*gzzx)-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyz*gzzx+gxzz*& +gyzx)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyzx*gzzz+gyzz*gzzx)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzz*& +gzzx-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzz*gzzx-gupyz(i,j,k)*gupxy(i,j,k)*gupxx(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-& +gupyz(i,j,k)*gupxy(i,j,k)*gupxy(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gzzy + MapleGenVar4 = MapleGenVar3-gupyz(i,j,k)*gupyy(i,j,k)*gupxx(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-4.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gzzy-2.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gzzy*gzzy-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(& +gxxz*gzzy+gxzy*gxzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxzy*gzzz+gxzz*gzzy)-gupyz(i,j,k)*gupyz(i,j,k)*& +gupxy(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)-2.0*& +gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzz*gzzy-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gzzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*(& +gxxx*gzzz+gxzx*gxzz)-gupyz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& +gupxz(i,j,k)*gxzx*gzzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gzzz + CAZyz = Gamyz - (MapleGenVar4-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupyz(i,j,k)*& +gupyz(i,j,k)*gupxy(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gzzz-gupyz(i,j,k)*gupzz(i,j,k)*& +gupxx(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*& +gupxz(i,j,k)*gxzz*gyzz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gxyz*gyzz-4.0*gupyz(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxzx*gzzx& +-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzy*gzzx-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gzzx*gzzy-4.0*gupyz(i,j,k)*& +gupxz(i,j,k)*gupzz(i,j,k)*gzzx*gzzz-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gzzy-4.0*gupyz(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*& +gxzy*gzzy-4.0*gupyz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxzz*gzzz) + MapleGenVar3 = -4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*& +gxzz*gxzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gyzz-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*gyzy*gyzy+gupxz(i,j,k)& +*gupzz(i,j,k)*gxzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxx(i,j,k)*gxzx*gxzx+gupxy(i,j,k)*gupyz(i,j,k)*gyzxy+gupyz(i,j,k)*gupyz(i,j,k)*& +gyzyz+gupxx(i,j,k)*gupyz(i,j,k)*gxzxy+gupxy(i,j,k)*gupzz(i,j,k)*gxzyz+gupyy(i,j,k)*gupzz(i,j,k)*gyzyz+2.0*gupxz(i,j,k)*gupzz(i,j,k)*& +gzzxz+gupxy(i,j,k)*gupxz(i,j,k)*gyzxx+gupyy(i,j,k)*gupxz(i,j,k)*gyzxy+gupyz(i,j,k)*gupxz(i,j,k)*gyzxz+gupyy(i,j,k)*gupyz(i,j,k)*gyzyy& +-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*gyzx*gyzx+gupxx(i,j,k)*gupxz(i,j,k)*gxzxx-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxx(i,j,k)*gzzx*& +gzzx-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyy(i,j,k)*gxzy*gxzy-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyzz+gupxx(i,j,k)*& +gupzz(i,j,k)*gxzxz+gupxz(i,j,k)*gupyz(i,j,k)*gxzyz+gupyz(i,j,k)*gupzz(i,j,k)*gyzzz+gupxz(i,j,k)*gupxz(i,j,k)*gzzxx+gupxy(i,j,k)*gupyz(i,j,k)*& +gxzyy + MapleGenVar4 = MapleGenVar3+gupzz(i,j,k)*gupzz(i,j,k)*gzzzz+gupxy(i,j,k)*gupzz(i,j,k)*gyzxz+2.0*gupyz(i,j,k)& +*gupzz(i,j,k)*gzzyz+gupyz(i,j,k)*gupyz(i,j,k)*gzzyy+gupxy(i,j,k)*gupxz(i,j,k)*gxzxy+gupxz(i,j,k)*gupxz(i,j,k)*gxzxz-2.0*gupzz(i,j,k)*& +gupzz(i,j,k)*gupyy(i,j,k)*gzzy*gzzy+2.0*gupxz(i,j,k)*gupyz(i,j,k)*gzzxy-2.0*gupxx(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxxx*gxzx-& +gupxx(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxx(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxxx*gzzx+gxzx*gxzx)& +-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxx*gyzy+gxyx*gxzy) + MapleGenVar2 = MapleGenVar4-gupxx(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-2.0*& +gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxxx*gxzz-gupxx(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-gupxx(i,j,k)*gupxz(i,j,k)& +*gupzz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxx(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-gupxx(i,j,k)*& +gupxy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxx(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxx(i,j,k)& +*gupyy(i,j,k)*gupzz(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupxx(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-& +gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-2.0*gupxx(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxxz-gupxx(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxx(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupxx(i,j,k)& +*gupyz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzy+gxzy*gxyz) + MapleGenVar4 = MapleGenVar2-gupxx(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxx(i,j,k)& +*gupzz(i,j,k)*gupyz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxx(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-& +gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*(gxxx*gyzx+gxyx*gxzx)-gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gyzx+gxzx*gyyx)& +-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxxx*gyzy+gxyx*& +gxzy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyx*gyzy-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)-& +gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gyzz+gxyx*gxzz)-2.0*gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxxx*gxzy-2.0*& +gupxx(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxxy + MapleGenVar3 = MapleGenVar4-2.0*gupxx(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxxy*gxzy-2.0*gupxx(i,j,k)*& +gupyz(i,j,k)*gupxz(i,j,k)*gxxy*gxzz-2.0*gupxx(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxxz-2.0*gupxx(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*& +gxxz*gxzz-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxyx*gyzx-2.0*gupxy(i,j,k)*gupxx(i,j,k)*gupxz(i,j,k)*gxyx*gxzx-2.0*& +gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxyx*gyzz-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-gupxy(i,j,k)*gupxy(i,j,k)& +*gupxz(i,j,k)*(gxxy*gyzx+gxzx*gxyy)-2.0*gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gxyy*gyzx-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*& +(gxyy*gzzx+gxzy*gyzx)-gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*(gxxy*gyzy+gxyy*gxzy)-gupxy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)& +*(gxyy*gyzy+gxzy*gyyy)-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*(gxyy*gzzy+gxzy*gyzy) + MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxxy*gyzz+gxyy*gxzz)-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyy*gyzz-gupxy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gxyy*gzzz+gxzy*gyzz)-gupxy(i,j,k)*gupxz(i,j,k)& +*gupxz(i,j,k)*(gxxz*gyzx+gxzx*gxyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-gupxy(i,j,k)*& +gupyz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzy+gxzy*gxyz)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gxyz*gyzy-gupxy(i,j,k)*gupyz(i,j,k)*& +gupzz(i,j,k)*(gxyz*gzzy+gxzz*gyzy)-gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*(gxxz*gyzz+gxyz*gxzz)-gupxy(i,j,k)*gupzz(i,j,k)& +*gupyz(i,j,k)*(gxyz*gyzz+gxzz*gyyz)-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-gupxz(i,j,k)*& +gupxz(i,j,k)*gupxx(i,j,k)*(gxxx*gzzx+gxzx*gxzx)-gupxz(i,j,k)*gupxx(i,j,k)*gupyy(i,j,k)*(gxyx*gyzx+gxzx*gyyx) + MapleGenVar1 = MapleGenVar4-2.0*gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*(gxyx*gzzx+gxzx*gyzx)-& +gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*(gxxx*gzzy+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gzzy+gxzx*gyzy)& +-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupxy(i,j,k)*gxzx*gxzy-gupxz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxxx*gzzz+gxzx*gxzz)-gupxz(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*(gxyx*gzzz+gxzx*gyzz)-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gxzx*gzzz-gupxz(i,j,k)*gupxz(i,j,k)*& +gupxy(i,j,k)*(gxxy*gzzx+gxzx*gxzy)-gupxz(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzx+gxzy*gyzx)-gupxz(i,j,k)*gupxz(i,j,k)& +*gupyy(i,j,k)*(gxxy*gzzy+gxzy*gxzy)-gupxz(i,j,k)*gupyy(i,j,k)*gupyy(i,j,k)*(gxyy*gyzy+gxzy*gyyy)-2.0*gupxz(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*(gxyy*gzzy+gxzy*gyzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxy*gzzz+gxzy*gxzz)-gupxz(i,j,k)& +*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gzzz+gxzy*gyzz) + MapleGenVar4 = MapleGenVar1-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gxzy*gxzz-gupxz(i,j,k)*gupxz(i,j,k)*& +gupxz(i,j,k)*(gxxz*gzzx+gxzx*gxzz)-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzx+gxzz*gyzx)-2.0*gupxy(i,j,k)*& +gupyy(i,j,k)*gupyz(i,j,k)*gxyy*gyzy-2.0*gupxy(i,j,k)*gupyy(i,j,k)*gupxz(i,j,k)*gxyy*gxzy-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*& +gxyz*gyzx-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxyz*gyzz-2.0*gupxy(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gxyz*gxzz-4.0*& +gupxz(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gxzx*gyzx-6.0*gupxz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*gxzx*gzzx-2.0*gupxz(i,j,k)*gupxy(i,j,k)*& +gupzz(i,j,k)*gxzx*gzzy-2.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gxzy*gzzx + MapleGenVar3 = MapleGenVar4-4.0*gupxz(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gxzy*gyzy-6.0*gupxz(i,j,k)*& +gupyy(i,j,k)*gupzz(i,j,k)*gxzy*gzzy-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzy*gzzz-2.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*& +gxzz*gzzx-gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxxz*gzzy+gxzy*gxzz)-gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzy+& +gxzz*gyzy)-gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxxz*gzzz+gxzz*gxzz)-gupxz(i,j,k)*gupzz(i,j,k)*gupyy(i,j,k)*(gxyz*gyzz& ++gxzz*gyyz)-2.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*(gxyz*gzzz+gxzz*gyzz)-6.0*gupxz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*& +gxzz*gzzz-2.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gxzz*gzzy-4.0*gupxz(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gxzz*gyzz-2.0*& +gupxy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*gxyx*gxzy + MapleGenVar4 = MapleGenVar3-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupxy(i,j,k)& +*gupxy(i,j,k)*gupzz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxyx*gxzz-gupxy(i,j,k)*gupxz(i,j,k)*& +gupyz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-2.0*gupxy(i,j,k)*& +gupxy(i,j,k)*gupxz(i,j,k)*gxzx*gxyy-gupxy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-gupxy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)& +*(gxyy*gzzx+gxzx*gyzy)-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-gupxy(i,j,k)*gupyz(i,j,k)*& +gupzz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-2.0*gupxy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*gxzx*gxyz-gupxy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(& +gxyz*gyzx+gxzx*gyyz)-gupxy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzx+gxzx*gyzz) + MapleGenVar2 = MapleGenVar4-gupxy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-gupxy(i,j,k)& +*gupyz(i,j,k)*gupzz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-gupyy(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*(gyyx*gzzx+gyzx*gyzx)-& +gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gyzy+gxzy*gyyx)-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyx*gzzy+gyzx*gyzy)& +-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyx*gyzz+gxzz*gyyx)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyx*gzzz+gyzx*gyzz& +)-gupyy(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gyzx+gxzx*gyyy)-2.0*gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxyy*gxzz-2.0*& +gupxy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*gxzy*gxyz-2.0*gupyy(i,j,k)*gupxx(i,j,k)*gupyz(i,j,k)*gyyx*gyzx-2.0*gupyy(i,j,k)*gupxy(i,j,k)*& +gupyz(i,j,k)*gyyx*gyzy-2.0*gupyy(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*gyyx*gyzz-gupyy(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyyy*gzzx+& +gyzx*gyzy) + MapleGenVar4 = MapleGenVar2-2.0*gupyy(i,j,k)*gupyy(i,j,k)*gupyz(i,j,k)*gyyy*gyzy-gupyy(i,j,k)*gupyy(i,j,k)*& +gupzz(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyy(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyy*gyzz+gxzz*gyyy)-2.0*gupyy(i,j,k)*& +gupyz(i,j,k)*gupyz(i,j,k)*gyyy*gyzz-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-gupyy(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)& +*(gxyz*gyzx+gxzx*gyyz)-gupyy(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzx+gyzx*gyzz)-gupyy(i,j,k)*gupyz(i,j,k)*& +gupxz(i,j,k)*(gxyz*gyzy+gxzy*gyyz)-2.0*gupyy(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*gyzy*gyyz-gupyy(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(& +gyyz*gzzy+gyzy*gyzz)-gupyy(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+gyzz*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxx(i,j,k)*& +(gyyx*gzzx+gyzx*gyzx) + MapleGenVar3 = MapleGenVar4-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyx*gzzy+gxzy*gyzx)-gupyz(i,j,k)& +*gupyz(i,j,k)*gupxy(i,j,k)*(gyyx*gzzy+gyzx*gyzy)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)*gyzx*gyzy-gupyz(i,j,k)*gupxz(i,j,k)*& +gupxz(i,j,k)*(gxyx*gzzz+gxzz*gyzx)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gyyx*gzzz+gyzx*gyzz)-4.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupxz(i,j,k)*gyzx*gyzz-gupyz(i,j,k)*gupxy(i,j,k)*gupxz(i,j,k)*(gxyy*gzzx+gxzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupxy(i,j,k)& +*(gyyy*gzzx+gyzx*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyy(i,j,k)*(gyyy*gzzy+gyzy*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*& +gupxz(i,j,k)*(gxyy*gzzz+gxzz*gyzy)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyy*gzzz+gyzy*gyzz)-2.0*gupyz(i,j,k)*& +gupyz(i,j,k)*gupzz(i,j,k)*gyzy*gzzz-gupyz(i,j,k)*gupxz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzx+gxzx*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)& +*(gyyz*gzzx+gyzx*gyzz) + MapleGenVar4 = MapleGenVar3-2.0*gupyy(i,j,k)*gupxy(i,j,k)*gupyz(i,j,k)*gyzx*gyyy-2.0*gupyy(i,j,k)*& +gupxz(i,j,k)*gupyz(i,j,k)*gyzx*gyyz-2.0*gupyy(i,j,k)*gupzz(i,j,k)*gupyz(i,j,k)*gyyz*gyzz-6.0*gupyz(i,j,k)*gupxx(i,j,k)*gupzz(i,j,k)*& +gyzx*gzzx-2.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzx*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*gyzx*gzzz-2.0*& +gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*gyzy*gzzx-6.0*gupyz(i,j,k)*gupyy(i,j,k)*gupzz(i,j,k)*gyzy*gzzy-2.0*gupyz(i,j,k)*gupxz(i,j,k)*& +gupzz(i,j,k)*gyzz*gzzx-gupyz(i,j,k)*gupyz(i,j,k)*gupxz(i,j,k)*(gxyz*gzzy+gxzy*gyzz)-gupyz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gyyz& +*gzzy+gyzy*gyzz)-2.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*gyzz*gzzy-gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyyz*gzzz+& +gyzz*gyzz) + CAZzz = Gamzz - (MapleGenVar4-6.0*gupyz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gyzz*gzzz-4.0*gupxz(i,j,k)*& +gupxy(i,j,k)*gupyz(i,j,k)*(gxzx*gyzy+gxzy*gyzx)-4.0*gupxz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gxzx*gzzy+gxzy*gzzx)& +-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupyz(i,j,k)*(gxzx*gyzz+gxzz*gyzx)-4.0*gupxz(i,j,k)*gupxz(i,j,k)*gupzz(i,j,k)*(gxzx*gzzz+& +gxzz*gzzx)-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupyz(i,j,k)*(gxzy*gyzz+gxzz*gyzy)-4.0*gupxz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(& +gxzy*gzzz+gxzz*gzzy)-4.0*gupyz(i,j,k)*gupxy(i,j,k)*gupzz(i,j,k)*(gyzx*gzzy+gyzy*gzzx)-4.0*gupyz(i,j,k)*& +gupxz(i,j,k)*gupzz(i,j,k)*(gyzx*gzzz+gyzz*gzzx)-4.0*gupyz(i,j,k)*gupyz(i,j,k)*gupzz(i,j,k)*(gyzy*gzzz+gyzz*gzzy)& +-4.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxy(i,j,k)*gzzx*gzzy-4.0*gupzz(i,j,k)*gupzz(i,j,k)*gupxz(i,j,k)*gzzx*gzzz-4.0*gupzz(i,j,k)*& +gupzz(i,j,k)*gupyz(i,j,k)*gzzy*gzzz-2.0*gupzz(i,j,k)*gupzz(i,j,k)*gupzz(i,j,k)*gzzz*gzzz) + +! second kind of connection + Gamxxx =HALF*( gupxx(i,j,k)*gxxx + gupxy(i,j,k)*(TWO*gxyx - gxxy ) + gupxz(i,j,k)*(TWO*gxzx - gxxz )) + Gamyxx =HALF*( gupxy(i,j,k)*gxxx + gupyy(i,j,k)*(TWO*gxyx - gxxy ) + gupyz(i,j,k)*(TWO*gxzx - gxxz )) + Gamzxx =HALF*( gupxz(i,j,k)*gxxx + gupyz(i,j,k)*(TWO*gxyx - gxxy ) + gupzz(i,j,k)*(TWO*gxzx - gxxz )) + + Gamxyy =HALF*( gupxx(i,j,k)*(TWO*gxyy - gyyx ) + gupxy(i,j,k)*gyyy + gupxz(i,j,k)*(TWO*gyzy - gyyz )) + Gamyyy =HALF*( gupxy(i,j,k)*(TWO*gxyy - gyyx ) + gupyy(i,j,k)*gyyy + gupyz(i,j,k)*(TWO*gyzy - gyyz )) + Gamzyy =HALF*( gupxz(i,j,k)*(TWO*gxyy - gyyx ) + gupyz(i,j,k)*gyyy + gupzz(i,j,k)*(TWO*gyzy - gyyz )) + + Gamxzz =HALF*( gupxx(i,j,k)*(TWO*gxzz - gzzx ) + gupxy(i,j,k)*(TWO*gyzz - gzzy ) + gupxz(i,j,k)*gzzz) + Gamyzz =HALF*( gupxy(i,j,k)*(TWO*gxzz - gzzx ) + gupyy(i,j,k)*(TWO*gyzz - gzzy ) + gupyz(i,j,k)*gzzz) + Gamzzz =HALF*( gupxz(i,j,k)*(TWO*gxzz - gzzx ) + gupyz(i,j,k)*(TWO*gyzz - gzzy ) + gupzz(i,j,k)*gzzz) + + Gamxxy =HALF*( gupxx(i,j,k)*gxxy + gupxy(i,j,k)*gyyx + gupxz(i,j,k)*( gxzy + gyzx - gxyz ) ) + Gamyxy =HALF*( gupxy(i,j,k)*gxxy + gupyy(i,j,k)*gyyx + gupyz(i,j,k)*( gxzy + gyzx - gxyz ) ) + Gamzxy =HALF*( gupxz(i,j,k)*gxxy + gupyz(i,j,k)*gyyx + gupzz(i,j,k)*( gxzy + gyzx - gxyz ) ) + + Gamxxz =HALF*( gupxx(i,j,k)*gxxz + gupxy(i,j,k)*( gxyz + gyzx - gxzy ) + gupxz(i,j,k)*gzzx ) + Gamyxz =HALF*( gupxy(i,j,k)*gxxz + gupyy(i,j,k)*( gxyz + gyzx - gxzy ) + gupyz(i,j,k)*gzzx ) + Gamzxz =HALF*( gupxz(i,j,k)*gxxz + gupyz(i,j,k)*( gxyz + gyzx - gxzy ) + gupzz(i,j,k)*gzzx ) + + Gamxyz =HALF*( gupxx(i,j,k)*( gxyz + gxzy - gyzx ) + gupxy(i,j,k)*gyyz + gupxz(i,j,k)*gzzy ) + Gamyyz =HALF*( gupxy(i,j,k)*( gxyz + gxzy - gyzx ) + gupyy(i,j,k)*gyyz + gupyz(i,j,k)*gzzy ) + Gamzyz =HALF*( gupxz(i,j,k)*( gxyz + gxzy - gyzx ) + gupyz(i,j,k)*gyyz + gupzz(i,j,k)*gzzy ) + + Gamxa = gupxx(i,j,k) * Gamxxx + gupyy(i,j,k) * Gamxyy + gupzz(i,j,k) * Gamxzz + & + TWO*( gupxy(i,j,k) * Gamxxy + gupxz(i,j,k) * Gamxxz + gupyz(i,j,k) * Gamxyz ) + Gamya = gupxx(i,j,k) * Gamyxx + gupyy(i,j,k) * Gamyyy + gupzz(i,j,k) * Gamyzz + & + TWO*( gupxy(i,j,k) * Gamyxy + gupxz(i,j,k) * Gamyxz + gupyz(i,j,k) * Gamyyz ) + Gamza = gupxx(i,j,k) * Gamzxx + gupyy(i,j,k) * Gamzyy + gupzz(i,j,k) * Gamzzz + & + TWO*( gupxy(i,j,k) * Gamzxy + gupxz(i,j,k) * Gamzxz + gupyz(i,j,k) * Gamzyz ) + + call point_fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,betax,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,betay,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,betaz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst,& + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + + AAxx = gupxx(i,j,k) * Axx(i,j,k) * Axx(i,j,k) + gupyy(i,j,k) * Axy(i,j,k) * Axy(i,j,k) + gupzz(i,j,k) * Axz(i,j,k) * Axz(i,j,k) + & + TWO * (gupxy(i,j,k) * Axx(i,j,k) * Axy(i,j,k) + gupxz(i,j,k) * Axx(i,j,k) * Axz(i,j,k) + gupyz(i,j,k) * Axy(i,j,k) * Axz(i,j,k)) + AAyy = gupxx(i,j,k) * Axy(i,j,k) * Axy(i,j,k) + gupyy(i,j,k) * Ayy(i,j,k) * Ayy(i,j,k) + gupzz(i,j,k) * Ayz(i,j,k) * Ayz(i,j,k) + & + TWO * (gupxy(i,j,k) * Axy(i,j,k) * Ayy(i,j,k) + gupxz(i,j,k) * Axy(i,j,k) * Ayz(i,j,k) + gupyz(i,j,k) * Ayy(i,j,k) * Ayz(i,j,k)) + AAzz = gupxx(i,j,k) * Axz(i,j,k) * Axz(i,j,k) + gupyy(i,j,k) * Ayz(i,j,k) * Ayz(i,j,k) + gupzz(i,j,k) * Azz(i,j,k) * Azz(i,j,k) + & + TWO * (gupxy(i,j,k) * Axz(i,j,k) * Ayz(i,j,k) + gupxz(i,j,k) * Axz(i,j,k) * Azz(i,j,k) + gupyz(i,j,k) * Ayz(i,j,k) * Azz(i,j,k)) + AAxy = gupxx(i,j,k) * Axx(i,j,k) * Axy(i,j,k) + gupyy(i,j,k) * Axy(i,j,k) * Ayy(i,j,k) + gupzz(i,j,k) * Axz(i,j,k) * Ayz(i,j,k) + & + gupxy(i,j,k) *(Axx(i,j,k) * Ayy(i,j,k) + Axy(i,j,k) * Axy(i,j,k)) + & + gupxz(i,j,k) *(Axx(i,j,k) * Ayz(i,j,k) + Axz(i,j,k) * Axy(i,j,k)) + & + gupyz(i,j,k) *(Axy(i,j,k) * Ayz(i,j,k) + Axz(i,j,k) * Ayy(i,j,k)) + AAxz = gupxx(i,j,k) * Axx(i,j,k) * Axz(i,j,k) + gupyy(i,j,k) * Axy(i,j,k) * Ayz(i,j,k) + gupzz(i,j,k) * Axz(i,j,k) * Azz(i,j,k) + & + gupxy(i,j,k) *(Axx(i,j,k) * Ayz(i,j,k) + Axy(i,j,k) * Axz(i,j,k)) + & + gupxz(i,j,k) *(Axx(i,j,k) * Azz(i,j,k) + Axz(i,j,k) * Axz(i,j,k)) + & + gupyz(i,j,k) *(Axy(i,j,k) * Azz(i,j,k) + Axz(i,j,k) * Ayz(i,j,k)) + AAyz = gupxx(i,j,k) * Axy(i,j,k) * Axz(i,j,k) + gupyy(i,j,k) * Ayy(i,j,k) * Ayz(i,j,k) + gupzz(i,j,k) * Ayz(i,j,k) * Azz(i,j,k) + & + gupxy(i,j,k) *(Axy(i,j,k) * Ayz(i,j,k) + Ayy(i,j,k) * Axz(i,j,k)) + & + gupxz(i,j,k) *(Axy(i,j,k) * Azz(i,j,k) + Ayz(i,j,k) * Axz(i,j,k)) + & + gupyz(i,j,k) *(Ayy(i,j,k) * Azz(i,j,k) + Ayz(i,j,k) * Ayz(i,j,k)) + + betas = betax(i,j,k)*slx(i,j,k)+betay(i,j,k)*sly(i,j,k)+betaz(i,j,k)*slz(i,j,k) + fxx = trK(i,j,k)+TWO*TZ(i,j,k) + fxy = fxx*Axy(i,j,k)-TWO*AAxy + fxz = fxx*Axz(i,j,k)-TWO*AAxz + fyy = fxx*Ayy(i,j,k)-TWO*AAyy + fyz = fxx*Ayz(i,j,k)-TWO*AAyz + fzz = fxx*Azz(i,j,k)-TWO*AAzz + fxx = fxx*Axx(i,j,k)-TWO*AAxx + + muL = 2.d0/alpn1(i,j,k) + tmuSL = chin1(i,j,k)*2.d0/dsqrt(3.d0)/alpn1(i,j,k)**2 + tmuST = chin1(i,j,k)/alpn1(i,j,k)**2 +! Eq.(17) + totrK_rhs = (betax(i,j,k)*Kx+betay(i,j,k)*Ky+betaz(i,j,k)*Kz) & + -dsqrt(muL)*alpn1(i,j,k)*(vx(i,j,k)*Kx+vy(i,j,k)*Ky+vz(i,j,k)*Kz+trK(i,j,k)/R(k)) +#if 0 + -0.5d0*(qupxx(i,j,k)*Lapxx+qupyy(i,j,k)*Lapyy+qupzz(i,j,k)*Lapzz+ & + TWO*(qupxy(i,j,k)*Lapxy+qupxz(i,j,k)*Lapxz+qupyz(i,j,k)*Lapyz)) & + -trK(i,j,k)/R(k)*betas & + -0.5d0*alpn1(i,j,k)*(gupxx(i,j,k)*AAxx+gupyy(i,j,k)*AAyy+gupzz(i,j,k)*AAzz+ & + TWO*(gupxy(i,j,k)*AAxy+gupxz(i,j,k)*AAxz+gupyz(i,j,k)*AAyz)+(trK(i,j,k)+TWO*TZ(i,j,k))**2/3.d0 & + +kappa1*(ONE-kappa2)*TZ(i,j,k))+(ONE+betas/dsqrt(muL)/alpn1(i,j,k))/R(k)*(vx(i,j,k)*Lapx+vy(i,j,k)*Lapy+vz(i,j,k)*Lapz) & + +ha/R(k)**4-kappa3*alpn1(i,j,k)*trK(i,j,k) +#endif + +! Eq.(18) + toGams_rhs = -alpn1(i,j,k)*dsqrt(tmuSL)*(Gamxx+Gamyy+Gamzz) + ( & + slx(i,j,k)*(qupxx(i,j,k)*sfxxx+qupyy(i,j,k)*sfxyy+qupzz(i,j,k)*sfxzz+TWO*(qupxy(i,j,k)*sfxxy+qupxz(i,j,k)*sfxxz+qupyz(i,j,k)*sfxyz)) & + +sly(i,j,k)*(qupxx(i,j,k)*sfyxx+qupyy(i,j,k)*sfyyy+qupzz(i,j,k)*sfyzz+TWO*(qupxy(i,j,k)*sfyxy+qupxz(i,j,k)*sfyxz+qupyz(i,j,k)*sfyyz)) & + +slz(i,j,k)*(qupxx(i,j,k)*sfzxx+qupyy(i,j,k)*sfzyy+qupzz(i,j,k)*sfzzz+TWO*(qupxy(i,j,k)*sfzxy+qupxz(i,j,k)*sfzxz+qupyz(i,j,k)*sfzyz)) ) & + /chin1(i,j,k) - ( & + vx(i,j,k)*(qulxx(i,j,k)*sfxxx+qulxy(i,j,k)*sfxxy+qulxz(i,j,k)*sfxxz+ & + qulxy(i,j,k)*sfyxx+qulyy(i,j,k)*sfyxy+qulyz(i,j,k)*sfyxz+ & + qulxz(i,j,k)*sfzxx+qulyz(i,j,k)*sfzxy+qulzz(i,j,k)*sfzxz) & + +vy(i,j,k)*(qulxx(i,j,k)*sfxxy+qulxy(i,j,k)*sfxyy+qulxz(i,j,k)*sfxyz+ & + qulxy(i,j,k)*sfyxy+qulyy(i,j,k)*sfyyy+qulyz(i,j,k)*sfyyz+ & + qulxz(i,j,k)*sfzxy+qulyz(i,j,k)*sfzyy+qulzz(i,j,k)*sfzyz) & + +vz(i,j,k)*(qulxx(i,j,k)*sfxxz+qulxy(i,j,k)*sfxyz+qulxz(i,j,k)*sfxzz+ & + qulxy(i,j,k)*sfyxz+qulyy(i,j,k)*sfyyz+qulyz(i,j,k)*sfyzz+ & + qulxz(i,j,k)*sfzxz+qulyz(i,j,k)*sfzyz+qulzz(i,j,k)*sfzzz) )/chin1(i,j,k) & + -4.d0*alpn1(i,j,k)*dsqrt(muL)/3.d0/(dsqrt(tmuSL)+dsqrt(muL))/chin1(i,j,k)*(vx(i,j,k)*Kx+vy(i,j,k)*Ky+vz(i,j,k)*Kz) & + -2.d0*alpn1(i,j,k)/3.d0/(dsqrt(tmuSL)+ONE)/chin1(i,j,k)*(vx(i,j,k)*TZx+vy(i,j,k)*TZy+vz(i,j,k)*TZz) & + +thbs-kappa3*alpn1(i,j,k)*(slx(i,j,k)*Gamx(i,j,k)+sly(i,j,k)*Gamy(i,j,k)+slz(i,j,k)*Gamz(i,j,k)) & + +(slx(i,j,k)*(betax(i,j,k)*Gamxx+betay(i,j,k)*Gamxy+betaz(i,j,k)*Gamxz) & + +sly(i,j,k)*(betax(i,j,k)*Gamyx+betay(i,j,k)*Gamyy+betaz(i,j,k)*Gamyz) & + +slz(i,j,k)*(betax(i,j,k)*Gamzx+betay(i,j,k)*Gamzy+betaz(i,j,k)*Gamzz)) + + toTZ_rhs = -alpn1(i,j,k)*(vx(i,j,k)*TZx+vy(i,j,k)*TZy+vz(i,j,k)*TZz)+(betax(i,j,k)*TZx+betay(i,j,k)*TZy+betaz(i,j,k)*TZz) + + toAss_rhs = -alpn1(i,j,k)*chin1(i,j,k)*( & + TWO*((gupxx(i,j,k)*(Axxx-(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axxy-(Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axxz-(Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axxy-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & + + gupyy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axxz-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Axyz-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & + - (Gamxa*Axx(i,j,k)+Gamya*Axy(i,j,k)+Gamza*Axz(i,j,k)) )*vx(i,j,k) & + + (gupxx(i,j,k)*(Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k))) & + + gupyy(i,j,k)*(Ayyy-(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Ayyz-(Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Ayyz-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & + - (Gamxa*Axy(i,j,k)+Gamya*Ayy(i,j,k)+Gamza*Ayz(i,j,k)) )*vy(i,j,k) & + + (gupxx(i,j,k)*(Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axzy-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & + + gupyy(i,j,k)*(Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Azzz-(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k))) & + - (Gamxa*Axz(i,j,k)+Gamya*Ayz(i,j,k)+Gamza*Azz(i,j,k)) )*vz(i,j,k) ) & + -2.d0/3.d0*chin1(i,j,k)*(vx(i,j,k)*(TWO*Kx+TZx)+vy(i,j,k)*(TWO*Ky+TZy)+vz(i,j,k)*(TWO*Kz+TZz)) & + -2.d0/3.d0*(Rxx(i,j,k)*vx(i,j,k)*vx(i,j,k)+Ryy(i,j,k)*vy(i,j,k)*vy(i,j,k)+Rzz(i,j,k)*vz(i,j,k)*vz(i,j,k) & + +TWO*(Rxy(i,j,k)*vx(i,j,k)*vy(i,j,k)+Rxz(i,j,k)*vx(i,j,k)*vz(i,j,k)+Ryz(i,j,k)*vy(i,j,k)*vz(i,j,k))) & + + ONE/3.d0*(Rxx(i,j,k)*qupxx(i,j,k)+Ryy(i,j,k)*qupyy(i,j,k)+Rzz(i,j,k)*qupzz(i,j,k) & + +TWO*(Rxy(i,j,k)*qupxy(i,j,k)+Rxz(i,j,k)*qupxz(i,j,k)+Ryz(i,j,k)*qupyz(i,j,k))) & + +2.d0/3.d0*chin1(i,j,k)*(slx(i,j,k)*vx(i,j,k)*CAZxx+slx(i,j,k)*vy(i,j,k)*CAZxy+slx(i,j,k)*vz(i,j,k)*CAZxz & + +sly(i,j,k)*vx(i,j,k)*CAZyx+sly(i,j,k)*vy(i,j,k)*CAZyy+sly(i,j,k)*vz(i,j,k)*CAZyz & + +slz(i,j,k)*vx(i,j,k)*CAZzx+slz(i,j,k)*vy(i,j,k)*CAZzy+slz(i,j,k)*vz(i,j,k)*CAZzz) & + -ONE/3.d0*chin1(i,j,k)*(qulxx(i,j,k)*CAZxx+qulyx(i,j,k)*CAZxy+qulzx(i,j,k)*CAZxz & + +qulxy(i,j,k)*CAZyx+qulyy(i,j,k)*CAZyy+qulzy(i,j,k)*CAZyz & + +qulxz(i,j,k)*CAZzx+qulyz(i,j,k)*CAZzy+qulzz(i,j,k)*CAZzz) & + -3.d0/chin1(i,j,k)*(vx(i,j,k)*(gupxx(i,j,k)*chix*Axx(i,j,k)+gupxy(i,j,k)*chix*Axy(i,j,k)+gupxz(i,j,k)*chix*Axz(i,j,k) & + +gupxy(i,j,k)*chiy*Axx(i,j,k)+gupyy(i,j,k)*chiy*Axy(i,j,k)+gupyz(i,j,k)*chiy*Axz(i,j,k) & + +gupxz(i,j,k)*chiz*Axx(i,j,k)+gupyz(i,j,k)*chiz*Axy(i,j,k)+gupzz(i,j,k)*chiz*Axz(i,j,k)) & + +vy(i,j,k)*(gupxx(i,j,k)*chix*Axy(i,j,k)+gupxy(i,j,k)*chix*Ayy(i,j,k)+gupxz(i,j,k)*chix*Ayz(i,j,k) & + +gupxy(i,j,k)*chiy*Axy(i,j,k)+gupyy(i,j,k)*chiy*Ayy(i,j,k)+gupyz(i,j,k)*chiy*Ayz(i,j,k) & + +gupxz(i,j,k)*chiz*Axy(i,j,k)+gupyz(i,j,k)*chiz*Ayy(i,j,k)+gupzz(i,j,k)*chiz*Ayz(i,j,k)) & + +vz(i,j,k)*(gupxx(i,j,k)*chix*Axz(i,j,k)+gupxy(i,j,k)*chix*Ayz(i,j,k)+gupxz(i,j,k)*chix*Azz(i,j,k) & + +gupxy(i,j,k)*chiy*Axz(i,j,k)+gupyy(i,j,k)*chiy*Ayz(i,j,k)+gupyz(i,j,k)*chiy*Azz(i,j,k) & + +gupxz(i,j,k)*chiz*Axz(i,j,k)+gupyz(i,j,k)*chiz*Ayz(i,j,k)+gupzz(i,j,k)*chiz*Azz(i,j,k)) ) & + -kappa1*(vx(i,j,k)*Gmxcon(i,j,k)+vy(i,j,k)*Gmycon(i,j,k)+vz(i,j,k)*Gmzcon(i,j,k)) ) & + +alpn1(i,j,k)*(fxx*vx(i,j,k)*vx(i,j,k)+fyy*vy(i,j,k)*vy(i,j,k)+fzz*vz(i,j,k)*vz(i,j,k) & + +TWO*(fxy*vx(i,j,k)*vy(i,j,k)+fxz*vx(i,j,k)*vz(i,j,k)+fyz*vy(i,j,k)*vz(i,j,k))) + +! Eq.(22) + toAs1_rhs = alpn1(i,j,k)*(fxx*vx(i,j,k)*ux(i,j,k)+fxy*vy(i,j,k)*ux(i,j,k)+fxz*vz(i,j,k)*ux(i,j,k) & + +fxy*vx(i,j,k)*uy(i,j,k)+fyy*vy(i,j,k)*uy(i,j,k)+fyz*vz(i,j,k)*uy(i,j,k) & + +fxz*vx(i,j,k)*uz(i,j,k)+fyz*vy(i,j,k)*uz(i,j,k)+fzz*vz(i,j,k)*uz(i,j,k)) + + toAs2_rhs = alpn1(i,j,k)*(fxx*vx(i,j,k)*wx(i,j,k)+fxy*vy(i,j,k)*wx(i,j,k)+fxz*vz(i,j,k)*wx(i,j,k) & + +fxy*vx(i,j,k)*wy(i,j,k)+fyy*vy(i,j,k)*wy(i,j,k)+fyz*vz(i,j,k)*wy(i,j,k) & + +fxz*vx(i,j,k)*wz(i,j,k)+fyz*vy(i,j,k)*wz(i,j,k)+fzz*vz(i,j,k)*wz(i,j,k)) + + fxx = Lapxx - (Gamxxx-((chix+chix)/chin1(i,j,k)-gxx(i,j,k)*gxxx)*HALF)*Lapx - (Gamyxx+gxx(i,j,k)*gxxy*HALF)*Lapy - (Gamzxx+gxx(i,j,k)*gxxz*HALF)*Lapz + fyy = Lapyy - (Gamxyy+gyy(i,j,k)*gxxx*HALF)*Lapx - (Gamyyy-((chiy+chiy)/chin1(i,j,k)-gyy(i,j,k)*gxxy)*HALF)*Lapy - (Gamzyy+gyy(i,j,k)*gxxz*HALF)*Lapz + fzz = Lapzz - (Gamxzz+gzz(i,j,k)*gxxx*HALF)*Lapx - (Gamyzz+gzz(i,j,k)*gxxy*HALF)*Lapy - (Gamzzz-((chiz+chiz)/chin1(i,j,k)-gzz(i,j,k)*gxxz)*HALF)*Lapz + fxy = Lapxy - (Gamxxy-(chiy/chin1(i,j,k)-gxy(i,j,k)*gxxx)*HALF)*Lapx - (Gamyxy-(chix/chin1(i,j,k)-gxy(i,j,k)*gxxy)*HALF)*Lapy& + - (Gamzxy+gxy(i,j,k)*gxxz*HALF)*Lapz + fxz = Lapxz - (Gamxxz-(chiz/chin1(i,j,k)-gxz(i,j,k)*gxxx)*HALF)*Lapx - (Gamyxz+gxz(i,j,k)*gxxy*HALF)*Lapy& + - (Gamzxz-(chix/chin1(i,j,k)-gxz(i,j,k)*gxxz)*HALF)*Lapz + fyz = Lapyz - (Gamxyz+gyz(i,j,k)*gxxx*HALF)*Lapx - (Gamyyz-(chiz/chin1(i,j,k)-gyz(i,j,k)*gxxy)*HALF)*Lapy& + - (Gamzyz-(chiy/chin1(i,j,k)-gyz(i,j,k)*gxxz)*HALF)*Lapz + + TFxx = -chin1(i,j,k)*fxx + TFxy = -chin1(i,j,k)*fxy + TFxz = -chin1(i,j,k)*fxz + TFyy = -chin1(i,j,k)*fyy + TFyz = -chin1(i,j,k)*fyz + TFzz = -chin1(i,j,k)*fzz + toAss_rhs = toAss_rhs -2.d0/3.d0*chin1(i,j,k)*(fxx*vx(i,j,k)*vx(i,j,k)+fyy*vy(i,j,k)*vy(i,j,k)+fzz*vz(i,j,k)*vz(i,j,k) & + +TWO*(fxy*vx(i,j,k)*vy(i,j,k)+fxz*vx(i,j,k)*vz(i,j,k)+fyz*vy(i,j,k)*vz(i,j,k))) & + +ONE/3.d0*chin1(i,j,k)*(fxx*qupxx(i,j,k)+fyy*qupyy(i,j,k)+fzz*qupzz(i,j,k) & + +TWO*(fxy*qupxy(i,j,k)+fxz*qupxz(i,j,k)+fyz*qupyz(i,j,k))) + toAs1_rhs = toAs1_rhs -chin1(i,j,k)*(fxx*vx(i,j,k)*ux(i,j,k)+fxy*vy(i,j,k)*ux(i,j,k)+fxz*vz(i,j,k)*ux(i,j,k) & + +fxy*vx(i,j,k)*uy(i,j,k)+fyy*vy(i,j,k)*uy(i,j,k)+fyz*vz(i,j,k)*uy(i,j,k) & + +fxz*vx(i,j,k)*uz(i,j,k)+fyz*vy(i,j,k)*uz(i,j,k)+fzz*vz(i,j,k)*uz(i,j,k)) + toAs2_rhs = toAs2_rhs -chin1(i,j,k)*(fxx*vx(i,j,k)*wx(i,j,k)+fxy*vy(i,j,k)*wx(i,j,k)+fxz*vz(i,j,k)*wx(i,j,k) & + +fxy*vx(i,j,k)*wy(i,j,k)+fyy*vy(i,j,k)*wy(i,j,k)+fyz*vz(i,j,k)*wy(i,j,k) & + +fxz*vx(i,j,k)*wz(i,j,k)+fyz*vy(i,j,k)*wz(i,j,k)+fzz*vz(i,j,k)*wz(i,j,k)) + + fxx = (betax(i,j,k)*Axxx+betay(i,j,k)*Axxy+betaz(i,j,k)*Axxz)-TWO*(Axx(i,j,k)*sfxx+Axy(i,j,k)*sfyx+Axz(i,j,k)*sfzx) + fxy = (betax(i,j,k)*Axyx+betay(i,j,k)*Axyy+betaz(i,j,k)*Axyz)- & + (Axx(i,j,k)*sfxy+Axy(i,j,k)*sfyy+Axz(i,j,k)*sfzy)-(Axy(i,j,k)*sfxx+Ayy(i,j,k)*sfyx+Ayz(i,j,k)*sfzx) + fxz = (betax(i,j,k)*Axzx+betay(i,j,k)*Axzy+betaz(i,j,k)*Axzz)- & + (Axx(i,j,k)*sfxz+Axy(i,j,k)*sfyz+Axz(i,j,k)*sfzz)-(Axz(i,j,k)*sfxx+Ayz(i,j,k)*sfyx+Azz(i,j,k)*sfzx) + fyy = (betax(i,j,k)*Ayyx+betay(i,j,k)*Ayyy+betaz(i,j,k)*Ayyz)-TWO*(Axy(i,j,k)*sfxy+Ayy(i,j,k)*sfyy+Ayz(i,j,k)*sfzy) + fyz = (betax(i,j,k)*Ayzx+betay(i,j,k)*Ayzy+betaz(i,j,k)*Ayzz)- & + (Axy(i,j,k)*sfxz+Ayy(i,j,k)*sfyz+Ayz(i,j,k)*sfzz)-(Axz(i,j,k)*sfxy+Ayz(i,j,k)*sfyy+Azz(i,j,k)*sfzy) + fzz = (betax(i,j,k)*Azzx+betay(i,j,k)*Azzy+betaz(i,j,k)*Azzz)-TWO*(Axz(i,j,k)*sfxz+Ayz(i,j,k)*sfyz+Azz(i,j,k)*sfzz) + TFxx = TFxx+fxx + TFxy = TFxy+fxy + TFxz = TFxz+fxz + TFyy = TFyy+fyy + TFyz = TFyz+fyz + TFzz = TFzz+fzz + + toAss_rhs = toAss_rhs + (fxx*vx(i,j,k)*vx(i,j,k)+fyy*vy(i,j,k)*vy(i,j,k)+fzz*vz(i,j,k)*vz(i,j,k) & + +TWO*(fxy*vx(i,j,k)*vy(i,j,k)+fxz*vx(i,j,k)*vz(i,j,k)+fyz*vy(i,j,k)*vz(i,j,k))) + toAs1_rhs = toAs1_rhs +(fxx*vx(i,j,k)*ux(i,j,k)+fxy*vy(i,j,k)*ux(i,j,k)+fxz*vz(i,j,k)*ux(i,j,k) & + + fxy*vx(i,j,k)*uy(i,j,k)+fyy*vy(i,j,k)*uy(i,j,k)+fyz*vz(i,j,k)*uy(i,j,k) & + + fxz*vx(i,j,k)*uz(i,j,k)+fyz*vy(i,j,k)*uz(i,j,k)+fzz*vz(i,j,k)*uz(i,j,k)) + toAs2_rhs = toAs2_rhs +(fxx*vx(i,j,k)*wx(i,j,k)+fxy*vy(i,j,k)*wx(i,j,k)+fxz*vz(i,j,k)*wx(i,j,k) & + + fxy*vx(i,j,k)*wy(i,j,k)+fyy*vy(i,j,k)*wy(i,j,k)+fyz*vz(i,j,k)*wy(i,j,k) & + + fxz*vx(i,j,k)*wz(i,j,k)+fyz*vy(i,j,k)*wz(i,j,k)+fzz*vz(i,j,k)*wz(i,j,k)) + toAs1_rhs = toAs1_rhs-alpn1(i,j,k)*chin1(i,j,k)*( & + (gupxx(i,j,k)*(Axxx-(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axxy-(Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axxz-(Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axxy-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & + + gupyy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axxz-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Axyz-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & + - (Gamxa*Axx(i,j,k)+Gamya*Axy(i,j,k)+Gamza*Axz(i,j,k)) )*ux(i,j,k) & + + (gupxx(i,j,k)*(Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k))) & + + gupyy(i,j,k)*(Ayyy-(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Ayyz-(Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Ayyz-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & + - (Gamxa*Axy(i,j,k)+Gamya*Ayy(i,j,k)+Gamza*Ayz(i,j,k)) )*uy(i,j,k) & + + (gupxx(i,j,k)*(Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axzy-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & + + gupyy(i,j,k)*(Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Azzz-(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k))) & + - (Gamxa*Axz(i,j,k)+Gamya*Ayz(i,j,k)+Gamza*Azz(i,j,k)) )*uz(i,j,k) & + -2.d0/3.d0*(Kx*ux(i,j,k)+Ky*uy(i,j,k)+Kz*uz(i,j,k)) & + -ONE/3.d0* (TZx*ux(i,j,k)+TZy*uy(i,j,k)+TZz*uz(i,j,k)) & + -1.5d0/chin1(i,j,k)* & + (ux(i,j,k)*(gupxx(i,j,k)*chix*Axx(i,j,k)+gupxy(i,j,k)*chix*Axy(i,j,k)+gupxz(i,j,k)*chix*Axz(i,j,k) & + +gupxy(i,j,k)*chiy*Axx(i,j,k)+gupyy(i,j,k)*chiy*Axy(i,j,k)+gupyz(i,j,k)*chiy*Axz(i,j,k) & + +gupxz(i,j,k)*chiz*Axx(i,j,k)+gupyz(i,j,k)*chiz*Axy(i,j,k)+gupzz(i,j,k)*chiz*Axz(i,j,k)) & + +uy(i,j,k)*(gupxx(i,j,k)*chix*Axy(i,j,k)+gupxy(i,j,k)*chix*Ayy(i,j,k)+gupxz(i,j,k)*chix*Ayz(i,j,k) & + +gupxy(i,j,k)*chiy*Axy(i,j,k)+gupyy(i,j,k)*chiy*Ayy(i,j,k)+gupyz(i,j,k)*chiy*Ayz(i,j,k) & + +gupxz(i,j,k)*chiz*Axy(i,j,k)+gupyz(i,j,k)*chiz*Ayy(i,j,k)+gupzz(i,j,k)*chiz*Ayz(i,j,k)) & + +uz(i,j,k)*(gupxx(i,j,k)*chix*Axz(i,j,k)+gupxy(i,j,k)*chix*Ayz(i,j,k)+gupxz(i,j,k)*chix*Azz(i,j,k) & + +gupxy(i,j,k)*chiy*Axz(i,j,k)+gupyy(i,j,k)*chiy*Ayz(i,j,k)+gupyz(i,j,k)*chiy*Azz(i,j,k) & + +gupxz(i,j,k)*chiz*Axz(i,j,k)+gupyz(i,j,k)*chiz*Ayz(i,j,k)+gupzz(i,j,k)*chiz*Azz(i,j,k)) ) & + -0.5d0*kappa1*(Gmxcon(i,j,k)*ulx(i,j,k)+Gmycon(i,j,k)*uly(i,j,k)+Gmzcon(i,j,k)*ulz(i,j,k)) & + -(Rxx(i,j,k)*vx(i,j,k)*ux(i,j,k)+Rxy(i,j,k)*vy(i,j,k)*ux(i,j,k)+Rxz(i,j,k)*vz(i,j,k)*ux(i,j,k) & + +Rxy(i,j,k)*vx(i,j,k)*uy(i,j,k)+Ryy(i,j,k)*vy(i,j,k)*uy(i,j,k)+Ryz(i,j,k)*vz(i,j,k)*uy(i,j,k) & + +Rxz(i,j,k)*vx(i,j,k)*uz(i,j,k)+Ryz(i,j,k)*vy(i,j,k)*uz(i,j,k)+Rzz(i,j,k)*vz(i,j,k)*uz(i,j,k)) & + +0.5d0*chin1(i,j,k)*(ulx(i,j,k)*vx(i,j,k)*CAZxx+ulx(i,j,k)*vy(i,j,k)*CAZxy+ulx(i,j,k)*vz(i,j,k)*CAZxz & + +uly(i,j,k)*vx(i,j,k)*CAZyx+uly(i,j,k)*vy(i,j,k)*CAZyy+uly(i,j,k)*vz(i,j,k)*CAZyz & + +ulz(i,j,k)*vx(i,j,k)*CAZzx+ulz(i,j,k)*vy(i,j,k)*CAZzy+ulz(i,j,k)*vz(i,j,k)*CAZzz)) + toAs2_rhs = toAs2_rhs-alpn1(i,j,k)*chin1(i,j,k)*( & + (gupxx(i,j,k)*(Axxx-(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axxy-(Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axxz-(Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axxy-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & + + gupyy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axxz-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Axyz-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & + - (Gamxa*Axx(i,j,k)+Gamya*Axy(i,j,k)+Gamza*Axz(i,j,k)) )*wx(i,j,k) & + + (gupxx(i,j,k)*(Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axyy-(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axyz-(Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k))) & + + gupyy(i,j,k)*(Ayyy-(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Ayyz-(Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Ayyz-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & + - (Gamxa*Axy(i,j,k)+Gamya*Ayy(i,j,k)+Gamza*Ayz(i,j,k)) )*wy(i,j,k) & + + (gupxx(i,j,k)*(Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k))) & + + gupxy(i,j,k)*(Axzy-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k))) & + + gupxz(i,j,k)*(Axzz-(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k))) & + + gupxy(i,j,k)*(Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k))) & + + gupyy(i,j,k)*(Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k))) & + + gupyz(i,j,k)*(Ayzz-(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k))) & + + gupxz(i,j,k)*(Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k))) & + + gupyz(i,j,k)*(Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k))) & + + gupzz(i,j,k)*(Azzz-(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k))) & + - (Gamxa*Axz(i,j,k)+Gamya*Ayz(i,j,k)+Gamza*Azz(i,j,k)) )*wz(i,j,k) & + -2.d0/3.d0*(Kx*wx(i,j,k)+ky*wy(i,j,k)+Kz*wz(i,j,k)) & + -ONE/3.d0* (TZx*wx(i,j,k)+TZy*wy(i,j,k)+TZz*wz(i,j,k)) & + -1.5d0/chin1(i,j,k)* & + (wx(i,j,k)*(gupxx(i,j,k)*chix*Axx(i,j,k)+gupxy(i,j,k)*chix*Axy(i,j,k)+gupxz(i,j,k)*chix*Axz(i,j,k) & + +gupxy(i,j,k)*chiy*Axx(i,j,k)+gupyy(i,j,k)*chiy*Axy(i,j,k)+gupyz(i,j,k)*chiy*Axz(i,j,k) & + +gupxz(i,j,k)*chiz*Axx(i,j,k)+gupyz(i,j,k)*chiz*Axy(i,j,k)+gupzz(i,j,k)*chiz*Axz(i,j,k)) & + +wy(i,j,k)*(gupxx(i,j,k)*chix*Axy(i,j,k)+gupxy(i,j,k)*chix*Ayy(i,j,k)+gupxz(i,j,k)*chix*Ayz(i,j,k) & + +gupxy(i,j,k)*chiy*Axy(i,j,k)+gupyy(i,j,k)*chiy*Ayy(i,j,k)+gupyz(i,j,k)*chiy*Ayz(i,j,k) & + +gupxz(i,j,k)*chiz*Axy(i,j,k)+gupyz(i,j,k)*chiz*Ayy(i,j,k)+gupzz(i,j,k)*chiz*Ayz(i,j,k)) & + +wz(i,j,k)*(gupxx(i,j,k)*chix*Axz(i,j,k)+gupxy(i,j,k)*chix*Ayz(i,j,k)+gupxz(i,j,k)*chix*Azz(i,j,k) & + +gupxy(i,j,k)*chiy*Axz(i,j,k)+gupyy(i,j,k)*chiy*Ayz(i,j,k)+gupyz(i,j,k)*chiy*Azz(i,j,k) & + +gupxz(i,j,k)*chiz*Axz(i,j,k)+gupyz(i,j,k)*chiz*Ayz(i,j,k)+gupzz(i,j,k)*chiz*Azz(i,j,k)) ) & + -0.5d0*kappa1*(Gmxcon(i,j,k)*wlx(i,j,k)+Gmycon(i,j,k)*wly(i,j,k)+Gmzcon(i,j,k)*wlz(i,j,k)) & + -(Rxx(i,j,k)*vx(i,j,k)*wx(i,j,k)+Rxy(i,j,k)*vy(i,j,k)*wx(i,j,k)+Rxz(i,j,k)*vz(i,j,k)*wx(i,j,k) & + +Rxy(i,j,k)*vx(i,j,k)*wy(i,j,k)+Ryy(i,j,k)*vy(i,j,k)*wy(i,j,k)+Ryz(i,j,k)*vz(i,j,k)*wy(i,j,k) & + +Rxz(i,j,k)*vx(i,j,k)*wz(i,j,k)+Ryz(i,j,k)*vy(i,j,k)*wz(i,j,k)+Rzz(i,j,k)*vz(i,j,k)*wz(i,j,k)) & + +0.5d0*chin1(i,j,k)*(wlx(i,j,k)*vx(i,j,k)*CAZxx+wlx(i,j,k)*vy(i,j,k)*CAZxy+wlx(i,j,k)*vz(i,j,k)*CAZxz & + +wly(i,j,k)*vx(i,j,k)*CAZyx+wly(i,j,k)*vy(i,j,k)*CAZyy+wly(i,j,k)*vz(i,j,k)*CAZyz & + +wlz(i,j,k)*vx(i,j,k)*CAZzx+wlz(i,j,k)*vy(i,j,k)*CAZzy+wlz(i,j,k)*vz(i,j,k)*CAZzz)) + + toGam1_rhs = -alpn1(i,j,k)*dsqrt(tmuST)*((Gamxx*vx(i,j,k)*ulx(i,j,k)+Gamxy*vy(i,j,k)*ulx(i,j,k)+Gamxz*vz(i,j,k)*ulx(i,j,k) & + +Gamyx*vx(i,j,k)*uly(i,j,k)+Gamyy*vy(i,j,k)*uly(i,j,k)+Gamyz*vz(i,j,k)*uly(i,j,k) & + +Gamzx*vx(i,j,k)*ulz(i,j,k)+Gamzy*vy(i,j,k)*ulz(i,j,k)+Gamzz*vz(i,j,k)*ulz(i,j,k)) & + -(Gamxx*ux(i,j,k)*slx(i,j,k)+Gamxy*uy(i,j,k)*slx(i,j,k)+Gamxz*uz(i,j,k)*slx(i,j,k) & + +Gamyx*ux(i,j,k)*sly(i,j,k)+Gamyy*uy(i,j,k)*sly(i,j,k)+Gamyz*uz(i,j,k)*sly(i,j,k) & + +Gamzx*ux(i,j,k)*slz(i,j,k)+Gamzy*uy(i,j,k)*slz(i,j,k)+Gamzz*uz(i,j,k)*slz(i,j,k))/chin1(i,j,k) ) & + +((qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx & + +TWO*(qupxy(i,j,k)*sfxxy+qupxz(i,j,k)*sfxxz+qupyz(i,j,k)*sfxyz))*ulx(i,j,k) & + +(qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx & + +TWO*(qupxy(i,j,k)*sfyxy+qupxz(i,j,k)*sfyxz+qupyz(i,j,k)*sfyyz))*uly(i,j,k) & + +(qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx & + +TWO*(qupxy(i,j,k)*sfzxy+qupxz(i,j,k)*sfzxz+qupyz(i,j,k)*sfzyz))*ulz(i,j,k) & + )/chin1(i,j,k) & + +4.d0/3.d0/chin1(i,j,k)*(ux(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxx+vx(i,j,k)*sly(i,j,k)*sfyxx+vx(i,j,k)*slz(i,j,k)*sfzxx & + +vy(i,j,k)*slx(i,j,k)*sfxxy+vy(i,j,k)*sly(i,j,k)*sfyxy+vy(i,j,k)*slz(i,j,k)*sfzxy & + +vz(i,j,k)*slx(i,j,k)*sfxxz+vz(i,j,k)*sly(i,j,k)*sfyxz+vz(i,j,k)*slz(i,j,k)*sfzxz) & + +uy(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxy+vx(i,j,k)*sly(i,j,k)*sfyxy+vx(i,j,k)*slz(i,j,k)*sfzxy & + +vy(i,j,k)*slx(i,j,k)*sfxyy+vy(i,j,k)*sly(i,j,k)*sfyyy+vy(i,j,k)*slz(i,j,k)*sfzyy & + +vz(i,j,k)*slx(i,j,k)*sfxyz+vz(i,j,k)*sly(i,j,k)*sfyyz+vz(i,j,k)*slz(i,j,k)*sfzyz) & + +uz(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxz+vx(i,j,k)*sly(i,j,k)*sfyxz+vx(i,j,k)*slz(i,j,k)*sfzxz & + +vy(i,j,k)*slx(i,j,k)*sfxyz+vy(i,j,k)*sly(i,j,k)*sfyyz+vy(i,j,k)*slz(i,j,k)*sfzyz & + +vz(i,j,k)*slx(i,j,k)*sfxzz+vz(i,j,k)*sly(i,j,k)*sfyzz+vz(i,j,k)*slz(i,j,k)*sfzzz)) & + +ONE/3.d0/chin1(i,j,k)* (ux(i,j,k)*(qulxx(i,j,k)*sfxxx+qulxy(i,j,k)*sfyxx+qulxz(i,j,k)*sfzxx & + +qulyx(i,j,k)*sfxxy+qulyy(i,j,k)*sfyxy+qulyz(i,j,k)*sfzxy & + +qulzx(i,j,k)*sfxxz+qulzy(i,j,k)*sfyxz+qulzz(i,j,k)*sfzxz) & + +uy(i,j,k)*(qulxx(i,j,k)*sfxxy+qulxy(i,j,k)*sfyxy+qulxz(i,j,k)*sfzxy & + +qulyx(i,j,k)*sfxyy+qulyy(i,j,k)*sfyyy+qulyz(i,j,k)*sfzyy & + +qulzx(i,j,k)*sfxyz+qulzy(i,j,k)*sfyyz+qulzz(i,j,k)*sfzyz) & + +uz(i,j,k)*(qulxx(i,j,k)*sfxxz+qulxy(i,j,k)*sfyxz+qulxz(i,j,k)*sfzxz & + +qulyx(i,j,k)*sfxyz+qulyy(i,j,k)*sfyyz+qulyz(i,j,k)*sfzyz & + +qulzx(i,j,k)*sfxzz+qulzy(i,j,k)*sfyzz+qulzz(i,j,k)*sfzzz)) & + -2.d0/3.d0*alpn1(i,j,k)/chin1(i,j,k)*(ux(i,j,k)*(TWO*Kx+TZx)+uy(i,j,k)*(TWO*Ky+TZy)+uz(i,j,k)*(TWO*Kz+TZz)) & + +hu-kappa3*alpn1(i,j,k)*(Gamx(i,j,k)*ulx(i,j,k)+Gamx(i,j,k)*uly(i,j,k)+Gamz(i,j,k)*ulz(i,j,k)) & + +(betax(i,j,k)*Gamxx+betay(i,j,k)*Gamxy+betaz(i,j,k)*Gamxz)*ulx(i,j,k) & + +(betax(i,j,k)*Gamyx+betay(i,j,k)*Gamyy+betaz(i,j,k)*Gamyz)*uly(i,j,k) & + +(betax(i,j,k)*Gamzx+betay(i,j,k)*Gamzy+betaz(i,j,k)*Gamzz)*ulz(i,j,k) + + toGam2_rhs = -alpn1(i,j,k)*dsqrt(tmuST)*((Gamxx*vx(i,j,k)*wlx(i,j,k)+Gamxy*vy(i,j,k)*wlx(i,j,k)+Gamxz*vz(i,j,k)*wlx(i,j,k) & + +Gamyx*vx(i,j,k)*wly(i,j,k)+Gamyy*vy(i,j,k)*wly(i,j,k)+Gamyz*vz(i,j,k)*wly(i,j,k) & + +Gamzx*vx(i,j,k)*wlz(i,j,k)+Gamzy*vy(i,j,k)*wlz(i,j,k)+Gamzz*vz(i,j,k)*wlz(i,j,k)) & + -(Gamxx*wx(i,j,k)*slx(i,j,k)+Gamxy*wy(i,j,k)*slx(i,j,k)+Gamxz*wz(i,j,k)*slx(i,j,k) & + +Gamyx*wx(i,j,k)*sly(i,j,k)+Gamyy*wy(i,j,k)*sly(i,j,k)+Gamyz*wz(i,j,k)*sly(i,j,k) & + +Gamzx*wx(i,j,k)*slz(i,j,k)+Gamzy*wy(i,j,k)*slz(i,j,k)+Gamzz*wz(i,j,k)*slz(i,j,k))/chin1(i,j,k) ) & + +((qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx+qupxx(i,j,k)*sfxxx & + +TWO*(qupxy(i,j,k)*sfxxy+qupxz(i,j,k)*sfxxz+qupyz(i,j,k)*sfxyz))*wlx(i,j,k) & + +(qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx+qupxx(i,j,k)*sfyxx & + +TWO*(qupxy(i,j,k)*sfyxy+qupxz(i,j,k)*sfyxz+qupyz(i,j,k)*sfyyz))*wly(i,j,k) & + +(qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx+qupxx(i,j,k)*sfzxx & + +TWO*(qupxy(i,j,k)*sfzxy+qupxz(i,j,k)*sfzxz+qupyz(i,j,k)*sfzyz))*wlz(i,j,k) & + )/chin1(i,j,k) & + +4.d0/3.d0/chin1(i,j,k)*(wx(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxx+vx(i,j,k)*sly(i,j,k)*sfyxx+vx(i,j,k)*slz(i,j,k)*sfzxx & + +vy(i,j,k)*slx(i,j,k)*sfxxy+vy(i,j,k)*sly(i,j,k)*sfyxy+vy(i,j,k)*slz(i,j,k)*sfzxy & + +vz(i,j,k)*slx(i,j,k)*sfxxz+vz(i,j,k)*sly(i,j,k)*sfyxz+vz(i,j,k)*slz(i,j,k)*sfzxz) & + +wy(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxy+vx(i,j,k)*sly(i,j,k)*sfyxy+vx(i,j,k)*slz(i,j,k)*sfzxy & + +vy(i,j,k)*slx(i,j,k)*sfxyy+vy(i,j,k)*sly(i,j,k)*sfyyy+vy(i,j,k)*slz(i,j,k)*sfzyy & + +vz(i,j,k)*slx(i,j,k)*sfxyz+vz(i,j,k)*sly(i,j,k)*sfyyz+vz(i,j,k)*slz(i,j,k)*sfzyz) & + +wz(i,j,k)*(vx(i,j,k)*slx(i,j,k)*sfxxz+vx(i,j,k)*sly(i,j,k)*sfyxz+vx(i,j,k)*slz(i,j,k)*sfzxz & + +vy(i,j,k)*slx(i,j,k)*sfxyz+vy(i,j,k)*sly(i,j,k)*sfyyz+vy(i,j,k)*slz(i,j,k)*sfzyz & + +vz(i,j,k)*slx(i,j,k)*sfxzz+vz(i,j,k)*sly(i,j,k)*sfyzz+vz(i,j,k)*slz(i,j,k)*sfzzz)) & + +ONE/3.d0/chin1(i,j,k)* (wx(i,j,k)*(qulxx(i,j,k)*sfxxx+qulxy(i,j,k)*sfyxx+qulxz(i,j,k)*sfzxx & + +qulyx(i,j,k)*sfxxy+qulyy(i,j,k)*sfyxy+qulyz(i,j,k)*sfzxy & + +qulzx(i,j,k)*sfxxz+qulzy(i,j,k)*sfyxz+qulzz(i,j,k)*sfzxz) & + +wy(i,j,k)*(qulxx(i,j,k)*sfxxy+qulxy(i,j,k)*sfyxy+qulxz(i,j,k)*sfzxy & + +qulyx(i,j,k)*sfxyy+qulyy(i,j,k)*sfyyy+qulyz(i,j,k)*sfzyy & + +qulzx(i,j,k)*sfxyz+qulzy(i,j,k)*sfyyz+qulzz(i,j,k)*sfzyz) & + +wz(i,j,k)*(qulxx(i,j,k)*sfxxz+qulxy(i,j,k)*sfyxz+qulxz(i,j,k)*sfzxz & + +qulyx(i,j,k)*sfxyz+qulyy(i,j,k)*sfyyz+qulyz(i,j,k)*sfzyz & + +qulzx(i,j,k)*sfxzz+qulzy(i,j,k)*sfyzz+qulzz(i,j,k)*sfzzz)) & + -2.d0/3.d0*alpn1(i,j,k)/chin1(i,j,k)*(wx(i,j,k)*(TWO*Kx+TZx)+wy(i,j,k)*(TWO*Ky+TZy)+wz(i,j,k)*(TWO*Kz+TZz)) & + +hw-kappa3*alpn1(i,j,k)*(Gamx(i,j,k)*wlx(i,j,k)+Gamx(i,j,k)*wly(i,j,k)+Gamz(i,j,k)*wlz(i,j,k)) & + +(betax(i,j,k)*Gamxx+betay(i,j,k)*Gamxy+betaz(i,j,k)*Gamxz)*wlx(i,j,k) & + +(betax(i,j,k)*Gamyx+betay(i,j,k)*Gamyy+betaz(i,j,k)*Gamyz)*wly(i,j,k) & + +(betax(i,j,k)*Gamzx+betay(i,j,k)*Gamzy+betaz(i,j,k)*Gamzz)*wlz(i,j,k) + +! \tilde{D} A_ij + gxxx = Axxx-TWO*(Gamxxx*Axx(i,j,k)+Gamyxx*Axy(i,j,k)+Gamzxx*Axz(i,j,k)) + gxxy = Axxy-TWO*(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k)) + gxxz = Axxz-TWO*(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k)) + gyyx = Ayyx-TWO*(Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k)) + gyyy = Ayyy-TWO*(Gamxyy*Axy(i,j,k)+Gamyyy*Ayy(i,j,k)+Gamzyy*Ayz(i,j,k)) + gyyz = Ayyz-TWO*(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k)) + gzzx = Azzx-TWO*(Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k)) + gzzy = Azzy-TWO*(Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k)) + gzzz = Azzz-TWO*(Gamxzz*Axz(i,j,k)+Gamyzz*Ayz(i,j,k)+Gamzzz*Azz(i,j,k)) + gxyx = Axyx-(Gamxxy*Axx(i,j,k)+Gamyxy*Axy(i,j,k)+Gamzxy*Axz(i,j,k)+Gamxxx*Axy(i,j,k)+Gamyxx*Ayy(i,j,k)+Gamzxx*Ayz(i,j,k)) + gxyy = Axyy-(Gamxyy*Axx(i,j,k)+Gamyyy*Axy(i,j,k)+Gamzyy*Axz(i,j,k)+Gamxxy*Axy(i,j,k)+Gamyxy*Ayy(i,j,k)+Gamzxy*Ayz(i,j,k)) + gxyz = Axyz-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k)+Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k)) + gxzx = Axzx-(Gamxxz*Axx(i,j,k)+Gamyxz*Axy(i,j,k)+Gamzxz*Axz(i,j,k)+Gamxxx*Axz(i,j,k)+Gamyxx*Ayz(i,j,k)+Gamzxx*Azz(i,j,k)) + gxzy = Axzy-(Gamxyz*Axx(i,j,k)+Gamyyz*Axy(i,j,k)+Gamzyz*Axz(i,j,k)+Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k)) + gxzz = Axzz-(Gamxzz*Axx(i,j,k)+Gamyzz*Axy(i,j,k)+Gamzzz*Axz(i,j,k)+Gamxxz*Axz(i,j,k)+Gamyxz*Ayz(i,j,k)+Gamzxz*Azz(i,j,k)) + gyzx = Ayzx-(Gamxxz*Axy(i,j,k)+Gamyxz*Ayy(i,j,k)+Gamzxz*Ayz(i,j,k)+Gamxxy*Axz(i,j,k)+Gamyxy*Ayz(i,j,k)+Gamzxy*Azz(i,j,k)) + gyzy = Ayzy-(Gamxyz*Axy(i,j,k)+Gamyyz*Ayy(i,j,k)+Gamzyz*Ayz(i,j,k)+Gamxyy*Axz(i,j,k)+Gamyyy*Ayz(i,j,k)+Gamzyy*Azz(i,j,k)) + gyzz = Ayzz-(Gamxzz*Axy(i,j,k)+Gamyzz*Ayy(i,j,k)+Gamzzz*Ayz(i,j,k)+Gamxyz*Axz(i,j,k)+Gamyyz*Ayz(i,j,k)+Gamzyz*Azz(i,j,k)) + + f = (trK(i,j,k)+TWO*TZ(i,j,k))*TWO/3.d0 + fxx = (vx(i,j,k)*gxxx + vy(i,j,k)*gxxy + vz(i,j,k)*gxxz & + -(vx(i,j,k)*gxxx + vy(i,j,k)*gxyx + vz(i,j,k)*gxzx)) & + +AAxx-f*Axx(i,j,k) + fyy = (vx(i,j,k)*gyyx + vy(i,j,k)*gyyy + vz(i,j,k)*gyyz & + -(vx(i,j,k)*gxyy + vy(i,j,k)*gyyy + vz(i,j,k)*gyzy)) & + +AAyy-f*Ayy(i,j,k) + fzz = (vx(i,j,k)*gzzx + vy(i,j,k)*gzzy + vz(i,j,k)*gzzz & + -(vx(i,j,k)*gxzz + vy(i,j,k)*gyzz + vz(i,j,k)*gzzz)) & + +AAzz-f*Azz(i,j,k) + fxy = (vx(i,j,k)*gxyx + vy(i,j,k)*gxyy + vz(i,j,k)*gxyz & + -(vx(i,j,k)*gxxy + vy(i,j,k)*gxyy + vz(i,j,k)*gxzy + vx(i,j,k)*gxyx + vy(i,j,k)*gyyx + vz(i,j,k)*gyzx)/TWO) & + +AAxy-f*Axy(i,j,k) + fxz = (vx(i,j,k)*gxzx + vy(i,j,k)*gxzy + vz(i,j,k)*gxzz & + -(vx(i,j,k)*gxxz + vy(i,j,k)*gxyz + vz(i,j,k)*gxzz + vx(i,j,k)*gyzx + vy(i,j,k)*gyzx + vz(i,j,k)*gzzx)/TWO) & + +AAxz-f*Axz(i,j,k) + fyz = (vx(i,j,k)*gyzx + vy(i,j,k)*gyzy + vz(i,j,k)*gyzz & + -(vx(i,j,k)*gxyz + vy(i,j,k)*gyyz + vz(i,j,k)*gyzz + vx(i,j,k)*gyzy + vy(i,j,k)*gyzy + vz(i,j,k)*gzzy)/TWO) & + +AAyz-f*Ayz(i,j,k) + +! 1/2 A_ij D_k(ln chi) + gxxx = Axx(i,j,k)*chix/TWO/chin1(i,j,k) + gxxy = Axx(i,j,k)*chiy/TWO/chin1(i,j,k) + gxxz = Axx(i,j,k)*chiz/TWO/chin1(i,j,k) + gxyx = Axy(i,j,k)*chix/TWO/chin1(i,j,k) + gxyy = Axy(i,j,k)*chiy/TWO/chin1(i,j,k) + gxyz = Axy(i,j,k)*chiz/TWO/chin1(i,j,k) + gxzx = Axz(i,j,k)*chix/TWO/chin1(i,j,k) + gxzy = Axz(i,j,k)*chiy/TWO/chin1(i,j,k) + gxzz = Axz(i,j,k)*chiz/TWO/chin1(i,j,k) + gyyx = Ayy(i,j,k)*chix/TWO/chin1(i,j,k) + gyyy = Ayy(i,j,k)*chiy/TWO/chin1(i,j,k) + gyyz = Ayy(i,j,k)*chiz/TWO/chin1(i,j,k) + gyzx = Ayz(i,j,k)*chix/TWO/chin1(i,j,k) + gyzy = Ayz(i,j,k)*chiy/TWO/chin1(i,j,k) + gyzz = Ayz(i,j,k)*chiz/TWO/chin1(i,j,k) + gzzx = Azz(i,j,k)*chix/TWO/chin1(i,j,k) + gzzy = Azz(i,j,k)*chiy/TWO/chin1(i,j,k) + gzzz = Azz(i,j,k)*chiz/TWO/chin1(i,j,k) + + fxx = fxx - (vx(i,j,k)*gxxx + vy(i,j,k)*gxxy + vz(i,j,k)*gxxz & + -(vx(i,j,k)*gxxx + vy(i,j,k)*gxyx + vz(i,j,k)*gxzx)) + fyy = fyy - (vx(i,j,k)*gyyx + vy(i,j,k)*gyyy + vz(i,j,k)*gyyz & + -(vx(i,j,k)*gxyy + vy(i,j,k)*gyyy + vz(i,j,k)*gyzy)) + fzz = fzz - (vx(i,j,k)*gzzx + vy(i,j,k)*gzzy + vz(i,j,k)*gzzz & + -(vx(i,j,k)*gxzz + vy(i,j,k)*gyzz + vz(i,j,k)*gzzz)) + fxy = fxy - (vx(i,j,k)*gxyx + vy(i,j,k)*gxyy + vz(i,j,k)*gxyz & + -(vx(i,j,k)*gxxy + vy(i,j,k)*gxyy + vz(i,j,k)*gxzy + vx(i,j,k)*gxyx + vy(i,j,k)*gyyx + vz(i,j,k)*gyzx)/TWO) + fxz = fxz - (vx(i,j,k)*gxzx + vy(i,j,k)*gxzy + vz(i,j,k)*gxzz & + -(vx(i,j,k)*gxxz + vy(i,j,k)*gxyz + vz(i,j,k)*gxzz + vx(i,j,k)*gyzx + vy(i,j,k)*gyzx + vz(i,j,k)*gzzx)/TWO) + fyz = fyz - (vx(i,j,k)*gyzx + vy(i,j,k)*gyzy + vz(i,j,k)*gyzz & + -(vx(i,j,k)*gxyz + vy(i,j,k)*gyyz + vz(i,j,k)*gyzz + vx(i,j,k)*gyzy + vy(i,j,k)*gyzy + vz(i,j,k)*gzzy)/TWO) + + TFxx = TFxx-alpn1(i,j,k)*fxx + TFxy = TFxy-alpn1(i,j,k)*fxy + TFxz = TFxz-alpn1(i,j,k)*fxz + TFyy = TFyy-alpn1(i,j,k)*fyy + TFyz = TFyz-alpn1(i,j,k)*fyz + TFzz = TFzz-alpn1(i,j,k)*fzz + + f = 0.5d0*(qupxx(i,j,k)*TFxx+qupyy(i,j,k)*TFyy+qupzz(i,j,k)*TFzz & + +TWO*(qupxy(i,j,k)*TFxy+qupxz(i,j,k)*TFxz+qupyz(i,j,k)*TFyz)) + + toA11_rhs = ux(i,j,k)*ux(i,j,k)*TFxx+uy(i,j,k)*uy(i,j,k)*TFyy+uz(i,j,k)*uz(i,j,k)*TFzz+ & + TWO*(ux(i,j,k)*uy(i,j,k)*TFxy+ux(i,j,k)*uz(i,j,k)*TFxz+uy(i,j,k)*uz(i,j,k)*TFyz)-f + toA22_rhs = wx(i,j,k)*wx(i,j,k)*TFxx+wy(i,j,k)*wy(i,j,k)*TFyy+wz(i,j,k)*wz(i,j,k)*TFzz+ & + TWO*(wx(i,j,k)*wy(i,j,k)*TFxy+wx(i,j,k)*wz(i,j,k)*TFxz+wy(i,j,k)*wz(i,j,k)*TFyz)-f + toA12_rhs = ux(i,j,k)*wx(i,j,k)*TFxx+ux(i,j,k)*wy(i,j,k)*TFxy+ux(i,j,k)*wz(i,j,k)*TFxz & + +uy(i,j,k)*wx(i,j,k)*TFxy+uy(i,j,k)*wy(i,j,k)*TFyy+uy(i,j,k)*wz(i,j,k)*TFyz & + +uz(i,j,k)*wx(i,j,k)*TFxz+uz(i,j,k)*wy(i,j,k)*TFyz+uz(i,j,k)*wz(i,j,k)*TFzz + + toA11_rhs = toA11_rhs +alpn1(i,j,k)*chin1(i,j,k)*Rhpsi0 + toA22_rhs = toA22_rhs -alpn1(i,j,k)*chin1(i,j,k)*Rhpsi0 + toA12_rhs = toA12_rhs +alpn1(i,j,k)*chin1(i,j,k)*Ihpsi0 + +#if 0 + toAqq_rhs = qupxx(i,j,k)*Axx_rhs(i,j,k)+qupyy(i,j,k)*Ayy_rhs(i,j,k)+qupzz(i,j,k)*Azz_rhs(i,j,k) & + +TWO*(qupxy(i,j,k)*Axy_rhs(i,j,k)+qupxz(i,j,k)*Axz_rhs(i,j,k)+qupyz(i,j,k)*Ayz_rhs(i,j,k)) +#else + Ainvxx = gupxx(i,j,k)*gupxx(i,j,k)*Axx(i,j,k)+2.0*gupxx(i,j,k)*gupxy(i,j,k)*Axy(i,j,k)+ & + 2.0*gupxx(i,j,k)*gupxz(i,j,k)*Axz(i,j,k)+gupxy(i,j,k)*gupxy(i,j,k)*Ayy(i,j,k)+ & + 2.0*gupxy(i,j,k)*gupxz(i,j,k)*Ayz(i,j,k)+gupxz(i,j,k)*gupxz(i,j,k)*Azz(i,j,k) + + Ainvxy = gupxx(i,j,k)*gupxy(i,j,k)*Axx(i,j,k)+gupxx(i,j,k)*gupyy(i,j,k)*Axy(i,j,k)+ & + gupxx(i,j,k)*gupyz(i,j,k)*Axz(i,j,k)+gupxy(i,j,k)*gupxy(i,j,k)*Axy(i,j,k)+ & + gupxy(i,j,k)*gupyy(i,j,k)*Ayy(i,j,k)+gupxy(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+ & + gupxz(i,j,k)*gupxy(i,j,k)*Axz(i,j,k)+gupxz(i,j,k)*gupyy(i,j,k)*Ayz(i,j,k)+gupxz(i,j,k)*gupyz(i,j,k)*Azz(i,j,k) + + Ainvxz = gupxx(i,j,k)*gupxz(i,j,k)*Axx(i,j,k)+gupxx(i,j,k)*gupyz(i,j,k)*Axy(i,j,k)+ & + gupxx(i,j,k)*gupzz(i,j,k)*Axz(i,j,k)+gupxy(i,j,k)*gupxz(i,j,k)*Axy(i,j,k)+ & + gupxy(i,j,k)*gupyz(i,j,k)*Ayy(i,j,k)+gupxy(i,j,k)*gupzz(i,j,k)*Ayz(i,j,k)+ & + gupxz(i,j,k)*gupxz(i,j,k)*Axz(i,j,k)+gupxz(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+gupxz(i,j,k)*gupzz(i,j,k)*Azz(i,j,k) + Ainvyy = gupxy(i,j,k)*gupxy(i,j,k)*Axx(i,j,k)+2.0*gupxy(i,j,k)*gupyy(i,j,k)*Axy(i,j,k)+ & + 2.0*gupxy(i,j,k)*gupyz(i,j,k)*Axz(i,j,k)+gupyy(i,j,k)*gupyy(i,j,k)*Ayy(i,j,k)+ & + 2.0*gupyy(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+gupyz(i,j,k)*gupyz(i,j,k)*Azz(i,j,k) + + Ainvyz = gupxy(i,j,k)*gupxz(i,j,k)*Axx(i,j,k)+gupxy(i,j,k)*gupyz(i,j,k)*Axy(i,j,k)+ & + gupxy(i,j,k)*gupzz(i,j,k)*Axz(i,j,k)+gupyy(i,j,k)*gupxz(i,j,k)*Axy(i,j,k)+ & + gupyy(i,j,k)*gupyz(i,j,k)*Ayy(i,j,k)+gupyy(i,j,k)*gupzz(i,j,k)*Ayz(i,j,k)+ & + gupyz(i,j,k)*gupxz(i,j,k)*Axz(i,j,k)+gupyz(i,j,k)*gupyz(i,j,k)*Ayz(i,j,k)+gupyz(i,j,k)*gupzz(i,j,k)*Azz(i,j,k) + Ainvzz = gupxz(i,j,k)*gupxz(i,j,k)*Axx(i,j,k)+2.0*gupxz(i,j,k)*gupyz(i,j,k)*Axy(i,j,k)+ & + 2.0*gupxz(i,j,k)*gupzz(i,j,k)*Axz(i,j,k)+gupyz(i,j,k)*gupyz(i,j,k)*Ayy(i,j,k)+ & + 2.0*gupyz(i,j,k)*gupzz(i,j,k)*Ayz(i,j,k)+gupzz(i,j,k)*gupzz(i,j,k)*Azz(i,j,k) + + toAqq_rhs = -TWO*alpn1(i,j,k)*chin1(i,j,k)*(gupxx(i,j,k)*AAxx+gupyy(i,j,k)*AAyy+gupzz(i,j,k)*AAzz & + +TWO*(gupxy(i,j,k)*AAxy+gupxz(i,j,k)*AAxz+gupyz(i,j,k)*AAyz))+chin1(i,j,k)*(Ainvxx+liegxx+Ainvyy*liegyy+Ainvzz*liegzz & + +TWO*(Ainvxy*liegxy+Ainvxz*liegxz+Ainvyz*liegyz))-toAss_rhs +#endif +! reconstruct rhs for dynamical variables + trK_rhs(i,j,k) = totrK_rhs + TZ_rhs(i,j,k) = toTZ_rhs + Gamx_rhs(i,j,k) = toGams_rhs*vx(i,j,k)+toGam1_rhs*ux(i,j,k)+toGam2_rhs*wx(i,j,k) + Gamy_rhs(i,j,k) = toGams_rhs*vy(i,j,k)+toGam1_rhs*uy(i,j,k)+toGam2_rhs*wy(i,j,k) + Gamz_rhs(i,j,k) = toGams_rhs*vz(i,j,k)+toGam1_rhs*uz(i,j,k)+toGam2_rhs*wz(i,j,k) + Axx_rhs(i,j,k) = (ulx(i,j,k)*ulx(i,j,k)-0.5d0*qxx(i,j,k))*toA11_rhs+(wlx(i,j,k)*wlx(i,j,k)-0.5d0*qxx(i,j,k))*toA22_rhs+ulx(i,j,k)*wlx(i,j,k)*toA12_rhs & + + ulx(i,j,k)*slx(i,j,k)*toAs1_rhs+wlx(i,j,k)*slx(i,j,k)*toAs2_rhs+slx(i,j,k)*slx(i,j,k)*toAss_rhs & + + 0.5d0*qxx(i,j,k)*toAqq_rhs + Ayy_rhs(i,j,k) = (uly(i,j,k)*uly(i,j,k)-0.5d0*qyy(i,j,k))*toA11_rhs+(wly(i,j,k)*wly(i,j,k)-0.5d0*qyy(i,j,k))*toA22_rhs+uly(i,j,k)*wly(i,j,k)*toA12_rhs & + + uly(i,j,k)*sly(i,j,k)*toAs1_rhs+wly(i,j,k)*sly(i,j,k)*toAs2_rhs+sly(i,j,k)*sly(i,j,k)*toAss_rhs & + + 0.5d0*qyy(i,j,k)*toAqq_rhs + Azz_rhs(i,j,k) = (ulz(i,j,k)*ulz(i,j,k)-0.5d0*qzz(i,j,k))*toA11_rhs+(wlz(i,j,k)*wlz(i,j,k)-0.5d0*qzz(i,j,k))*toA22_rhs+ulz(i,j,k)*wlz(i,j,k)*toA12_rhs & + + ulz(i,j,k)*slz(i,j,k)*toAs1_rhs+wlz(i,j,k)*slz(i,j,k)*toAs2_rhs+slz(i,j,k)*slz(i,j,k)*toAss_rhs & + + 0.5d0*qzz(i,j,k)*toAqq_rhs + Axy_rhs(i,j,k) = (ulx(i,j,k)*uly(i,j,k)-0.5d0*qxy(i,j,k))*toA11_rhs+(wlx(i,j,k)*wly(i,j,k)-0.5d0*qxy(i,j,k))*toA22_rhs+ & + (ulx(i,j,k)*wly(i,j,k)+uly(i,j,k)*wlx(i,j,k))/TWO*toA12_rhs & + +(ulx(i,j,k)*sly(i,j,k)+uly(i,j,k)*slx(i,j,k))/TWO*toAs1_rhs & + +(wlx(i,j,k)*sly(i,j,k)+wly(i,j,k)*slx(i,j,k))/TWO*toAs2_rhs & + +(slx(i,j,k)*sly(i,j,k)+sly(i,j,k)*slx(i,j,k))/TWO*toAss_rhs & + + 0.5d0*qxy(i,j,k)*toAqq_rhs + Axz_rhs(i,j,k) = (ulx(i,j,k)*ulz(i,j,k)-0.5d0*qxz(i,j,k))*toA11_rhs+(wlx(i,j,k)*wlz(i,j,k)-0.5d0*qxz(i,j,k))*toA22_rhs+ & + (ulx(i,j,k)*wlz(i,j,k)+ulz(i,j,k)*wlx(i,j,k))/TWO*toA12_rhs & + +(ulx(i,j,k)*slz(i,j,k)+ulz(i,j,k)*slx(i,j,k))/TWO*toAs1_rhs & + +(wlx(i,j,k)*slz(i,j,k)+wlz(i,j,k)*slx(i,j,k))/TWO*toAs2_rhs & + +(slx(i,j,k)*slz(i,j,k)+slz(i,j,k)*slx(i,j,k))/TWO*toAss_rhs & + + 0.5d0*qxz(i,j,k)*toAqq_rhs + Ayz_rhs(i,j,k) = (uly(i,j,k)*ulz(i,j,k)-0.5d0*qyz(i,j,k))*toA11_rhs+(wlz(i,j,k)*wlz(i,j,k)-0.5d0*qyz(i,j,k))*toA22_rhs+ & + (uly(i,j,k)*wlz(i,j,k)+ulz(i,j,k)*wly(i,j,k))/TWO*toA12_rhs & + +(uly(i,j,k)*slz(i,j,k)+ulz(i,j,k)*sly(i,j,k))/TWO*toAs1_rhs & + +(wly(i,j,k)*slz(i,j,k)+wlz(i,j,k)*sly(i,j,k))/TWO*toAs2_rhs & + +(sly(i,j,k)*slz(i,j,k)+slz(i,j,k)*sly(i,j,k))/TWO*toAss_rhs & + + 0.5d0*qyz(i,j,k)*toAqq_rhs + enddo + enddo + enddo + + endif + + SSS(1)=SYM + SSS(2)=SYM + SSS(3)=SYM + + AAS(1)=ANTI + AAS(2)=ANTI + AAS(3)=SYM + + ASA(1)=ANTI + ASA(2)=SYM + ASA(3)=ANTI + + SAA(1)=SYM + SAA(2)=ANTI + SAA(3)=ANTI + + ASS(1)=ANTI + ASS(2)=SYM + ASS(3)=SYM + + SAS(1)=SYM + SAS(2)=ANTI + SAS(3)=SYM + + SSA(1)=SYM + SSA(2)=SYM + SSA(3)=ANTI + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + if(eps>0)then +! usual Kreiss-Oliger dissipation + call kodis_sh(ex,crho,sigma,R,chi,chi_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,trK,trK_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dxx,gxx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxy,gxy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gxz,gxz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dyy,gyy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,gyz,gyz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dzz,gzz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axx,Axx_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axy,Axy_rhs,AAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Axz,Axz_rhs,ASA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayy,Ayy_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Ayz,Ayz_rhs,SAA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Azz,Azz_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamx,Gamx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamy,Gamy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,Gamz,Gamz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,Lap,Lap_rhs,SSS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betax,betax_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betay,betay_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,betaz,betaz_rhs,SSA,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfx,dtSfx_rhs,ASS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfy,dtSfy_rhs,SAS,Symmetry,eps,sst) + call kodis_sh(ex,crho,sigma,R,dtSfz,dtSfz_rhs,SSA,Symmetry,eps,sst) + + call kodis_sh(ex,crho,sigma,R,TZ,TZ_rhs,SSS,Symmetry,eps,sst) + endif + + return + + end subroutine david_milton_cpbc_ss +#endif +! repopulate the buffer points of outer boundary through extroplation +! need CPBC_ghost_width + subroutine repo_extro_ss(ex,x,y,z,f,zmin,zmax,tpp) + implicit none + integer,intent(in ):: ex(1:3) + double precision,intent(in),dimension(ex(1))::x + double precision,intent(in),dimension(ex(2))::y + double precision,intent(in),dimension(ex(3))::z + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: f + real*8, intent(in):: zmin,zmax +! extraplate type +! 0: Lagange polynomial; 1: D+^n f = 0 + integer,intent(in) :: tpp +!~~~~~~~~~~~> local variables + logical :: gont + real*8 :: dZ + integer :: i, j, k + integer :: layer(1:6,1:6),gp + real*8 :: extroplate_lag,extroplate_cg + + integer :: NP + +!sanity check + if(ex(3) .le. CPBC_ghost_width +(ghost_width*2+1))then + write(*,*) "repo_extro_ss has assumed ex(3) > CPBC_ghost_width +(ghost_width*2+1) but ex(3) = ",ex(3),"CPBC_ghost_width = ",CPBC_ghost_width + stop + endif + + dZ = Z(2) - Z(1) + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(Z(ex(3))-zmax) < dZ)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(3,3) = ex(3) - CPBC_ghost_width + layer(4,3) = ex(1) + layer(5,3) = ex(2) + layer(6,3) = ex(3) - CPBC_ghost_width +endif +! extroplate point by point + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + +!!! fixme: note the assumption points requirement is enough or not + select case (tpp) + case (0) + NP = ghost_width*2+1 +! NP = ghost_width*2-1 + + do k = layer(3,gp) + 1,ex(3) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + f(i,j,k) = extroplate_lag(NP,f(i,j,k-NP:k-1)) + enddo + enddo + enddo + + case (1) +! NP = (ghost_width-1)*2 + NP = ghost_width*2 + + do k = layer(3,gp) + 1,ex(3) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + f(i,j,k) = extroplate_cg(NP,f(i,j,k-NP:k-1)) + enddo + enddo + enddo + + case (2) + NP = ghost_width*2+1 +! NP = ghost_width*2-1 + + NP = NP + CPBC_ghost_width + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + call extroplate_lag2(NP,f(i,j,ex(3)-NP+1:ex(3))) + enddo + enddo + + case default + write(*,*) "repo_extro_ss: not recognized extraplation type = ",tpp + return + end select + + + endif + + return + + end subroutine repo_extro_ss +! extroplate for unigrid with Lagange polynomial + function extroplate_lag(N,f) result(gont) + implicit none + integer,intent(in ) :: N + real*8,dimension(N),intent(in) :: f + + real*8 :: gont + + real*8,parameter :: THR=3.d0 + real*8,parameter :: FIV=5.d0,TEN=1.d1,NIN=9.d0 + real*8,parameter :: SEV=7.d0,TYO=2.1d1,F35=3.5d1 + real*8,parameter :: F36=3.6d1,F84=8.4d1,F126=1.26d2 + real*8,parameter :: F11=1.1d1,F55=5.5d1,F165=1.65d2,F330=3.3d2,F462=4.62d2 + +! Lagange polynomial + select case (N) +! for 2nd order code + case (3) + gont = THR*f(3)-THR*f(2)+f(1) +! for 2nd order code + case (5) + gont = FIV*f(5)-TEN*f(4)+TEN*f(3)-FIV*f(2)+f(1) +! for 4th order code + case (7) + gont = SEV*f(7)-TYO*f(6)+F35*f(5)-F35*f(4)+TYO*f(3)-SEV*f(2)+f(1) +! for 6th order code + case (9) + gont = NIN*f(9)-F36*f(8)+F84*f(7)-F126*f(6)+F126*f(5)-F84*f(4)+F36*f(3)-NIN*f(2)+f(1) +! for 8th order code + case (11) + gont = F11*f(11)-F55*f(10)+F165*f(9)-F330*f(8)+F462*f(7)-F462*f(6)+F330*f(5)-F165*f(4)+F55*f(3)-F11*f(2)+f(1) + end select + + return + + end function extroplate_lag +! extroplate for unigrid with Lagange polynomial +! but using inner N-ghost_width points for all of the outer ghost_width points + subroutine extroplate_lag2(N,f) + implicit none + integer,intent(in ) :: N + real*8,dimension(N),intent(inout) :: f + + integer :: NI,i + real*8 :: s1,s2 + + NI = N - CPBC_ghost_width + + do i=1,CPBC_ghost_width + +! Lagange polynomial + select case (NI) +! for 2nd order code + case (3) + f(NI+i) = i**2*f(1)/2+i*f(1)/2-i**2*f(2)-2*i*f(2)+f(3)*i**2/2+3.D0/2.D0*f(3)*i+f(3) +! for 2nd order code + case (5) + f(NI+i) = i**4*f(1)/24+i**3*f(1)/4+11.D0/24.D0*i**2*f(1)+i*f(1)/4-i**4*f(2)/6 & + -7.D0/6.D0*i**3*f(2)-7.D0/3.D0*i**2*f(2)-4.D0/3.D0*i*f(2)+f(3)*i**4/4 & + +2*f(3)*i**3+19.D0/4.D0*f(3)*i**2+3*f(3)*i-i**4*f(4)/6 & + -3.D0/2.D0*i**3*f(4)-13.D0/3.D0*i**2*f(4)-4*i*f(4) & + +f(5)*i**4/24+5.D0/12.D0*f(5)*i**3+35.D0/24.D0*f(5)*i**2 & + +25.D0/12.D0*f(5)*i+f(5) +! for 4th order code + case (7) + s1 = 33.D0/4.D0*f(3)*i**2+15.D0/2.D0*f(5)*i+117.D0/8.D0*f(5)*i**2 & + -121.D0/36.D0*i**4*f(4)+i**5*f(1)/48-i**6*f(2)/120-20.D0/3.D0*i*f(4) & + +35.D0/144.D0*f(7)*i**4+137.D0/48.D0*f(5)*i**4+107.D0/48.D0*f(3)*i**4 & + +203.D0/90.D0*f(7)*i**2-31.D0/3.D0*i**3*f(4)-27.D0/10.D0*i**2*f(2) & + +f(5)*i**6/48+15.D0/4.D0*f(3)*i+17.D0/144.D0*i**4*f(1)-i**5*f(4)/2 & + -i**5*f(6)/6-13.D0/6.D0*i**3*f(2)+137.D0/360.D0*i**2*f(1) & + +49.D0/48.D0*f(7)*i**3 + f(NI+i) = s1-19.D0/24.D0*i**4*f(2)+7.D0/240.D0*f(7)*i**5+f(7)*i**6/720 & + +461.D0/48.D0*f(5)*i**3-6*i*f(6)-87.D0/10.D0*i**2*f(6) & + +i**6*f(1)/720-127.D0/9.D0*i**2*f(4)+19.D0/48.D0*f(5)*i**5 & + +5.D0/16.D0*i**3*f(1)-i**6*f(6)/120+49.D0/20.D0*f(7)*i & + -29.D0/6.D0*i**3*f(6)-31.D0/24.D0*i**4*f(6)-6.D0/5.D0*i*f(2) & + +i*f(1)/6-2.D0/15.D0*i**5*f(2)-i**6*f(4)/36 & + +307.D0/48.D0*f(3)*i**3+17.D0/48.D0*f(3)*i**5+f(3)*i**6/48+f(7) +! for 6th order code + case (9) + s1 = -8*i*f(8)-527.D0/180.D0*i**3*f(2)+2803.D0/480.D0*f(3)*i**4 & + -i**8*f(8)/5040+18353.D0/720.D0*f(7)*i**3-391.D0/720.D0*i**6*f(4) & + +1457.D0/36.D0*f(5)*i**3+9.D0/80.D0*f(9)*i**5+23.D0/2880.D0*i**6*f(1) & + +17.D0/720.D0*f(7)*i**7-56.D0/3.D0*i*f(6)+761.D0/280.D0*f(9)*i & + -67.D0/45.D0*i**4*f(2)+14*f(7)*i+f(3)*i**7/48-268.D0/15.D0*i**4*f(6) & + -2003.D0/45.D0*i**2*f(6)+13.D0/960.D0*f(9)*i**6-73.D0/720.D0*i**6*f(8) & + +f(7)*i**8/1440+363.D0/1120.D0*i**2*f(1)-797.D0/20.D0*i**3*f(6) & + -11.D0/240.D0*i**7*f(6)-329.D0/90.D0*i**4*f(8)+179.D0/36.D0*f(5)*i**5 & + +967.D0/5760.D0*i**4*f(1)-103.D0/35.D0*i**2*f(2)-481.D0/35.D0*i**2*f(8) & + +179.D0/72.D0*f(7)*i**5-349.D0/36.D0*i**3*f(8)+61.D0/240.D0*f(3)*i**6 & + -115.D0/144.D0*i**5*f(8)+f(5)*i**8/576-56.D0/5.D0*i*f(4) & + +187.D0/16.D0*f(3)*i**3-149.D0/240.D0*i**6*f(6) + f(NI+i) = s1+i**8*f(1)/40320+2143.D0/180.D0*f(3)*i**2+469.D0/1440.D0*i**3*f(1) & + +f(5)*i**7/18+621.D0/20.D0*f(7)*i**2+f(9)+267.D0/160.D0*f(9)*i**3 & + +7.D0/144.D0*i**5*f(1)-i**7*f(8)/144+1069.D0/1920.D0*f(9)*i**4 & + -141.D0/5.D0*i**2*f(4)-29.D0/5040.D0*i**7*f(2)-i**8*f(4)/720 & + +691.D0/16.D0*f(5)*i**2+f(9)*i**7/1120-2581.D0/720.D0*i**5*f(4) & + -i**8*f(2)/5040+10993.D0/576.D0*f(5)*i**4+14.D0/3.D0*f(3)*i & + -i**8*f(6)/720-4891.D0/180.D0*i**3*f(4)+13.D0/8.D0*f(3)*i**5 & + +239.D0/720.D0*f(7)*i**6+15289.D0/1440.D0*f(7)*i**4+f(3)*i**8/1440 & + -49.D0/720.D0*i**6*f(2)+35.D0/2.D0*f(5)*i-71.D0/16.D0*i**5*f(6) & + +f(9)*i**8/40320+29531.D0/10080.D0*f(9)*i**2+209.D0/288.D0*f(5)*i**6 & + -1193.D0/90.D0*i**4*f(4)+i*f(1)/8-61.D0/144.D0*i**5*f(2)+i**7*f(1)/1440 & + -31.D0/720.D0*i**7*f(4)-8.D0/7.D0*i*f(2) +! for 8th order code + case (11) + s2 = -433739.D0/7560.D0*i**4*f(8)+7129.D0/25200.D0*i**2*f(1) & + -6947.D0/8640.D0*i**5*f(2)+3013.D0/172800.D0*i**6*f(1) & + -107.D0/1440.D0*i**8*f(6)-119.D0/4320.D0*i**7*f(2)+i*f(1)/10 & + +f(7)*i**10/17280+i**10*f(1)/3628800+59.D0/5040.D0*f(3)*i**8 & + -67.D0/1440.D0*i**7*f(10)+105.D0/2.D0*f(7)*i & + +84095.D0/36288.D0*f(11)*i**3-62549.D0/720.D0*i**4*f(6) & + -263.D0/84.D0*i**2*f(2)-5419.D0/1440.D0*i**6*f(8) & + +11.D0/30240.D0*f(11)*i**8+757.D0/5760.D0*f(3)*i**7 & + +39867.D0/2240.D0*f(3)*i**3-i**10*f(8)/30240-8.D0/9.D0*i**7*f(6) & + -10*i*f(10)+6961.D0/72.D0*f(5)*i**2-i**10*f(10)/362880 & + +i**9*f(1)/80640+728587.D0/8640.D0*f(7)*i**4-41.D0/1260.D0*i**8*f(4) + s1 = s2-6709.D0/17280.D0*i**6*f(10)+47.D0/80640.D0*f(3)*i**9 & + +49.D0/17280.D0*f(5)*i**9-1253.D0/480.D0*i**6*f(4) & + +6751.D0/48.D0*f(7)*i**2+10427.D0/11520.D0*f(3)*i**6-10.D0/9.D0*i*f(2) & + -23.D0/181440.D0*i**9*f(2)-i**9*f(10)/6720+45449.D0/11520.D0*f(3)*i**5 & + +2281.D0/2880.D0*f(7)*i**7-252.D0/5.D0*i*f(6)+f(9)*i**10/80640 & + +29.D0/120960.D0*i**8*f(1)-6541.D0/63.D0*i**2*f(8) & + +461789.D0/4320.D0*f(5)*i**3-161353.D0/45360.D0*i**3*f(2) & + +435893.D0/40320.D0*f(3)*i**4-97.D0/2520.D0*i**8*f(8) & + +1123.D0/5760.D0*f(9)*i**7-i**10*f(4)/30240-1003.D0/21.D0*i**2*f(4) & + -4861.D0/252.D0*i**2*f(10)-40*i*f(8)-i**9*f(6)/288-i**10*f(6)/14400 & + -13.D0/7560.D0*i**9*f(8)+1303.D0/4032.D0*i**3*f(1) + s2 = s1-151.D0/60480.D0*i**8*f(2)+19.D0/256.D0*i**5*f(1) & + +71689.D0/480.D0*f(7)*i**3-6877.D0/50.D0*i**2*f(6)+34343.D0/5760.D0*f(7)*i**6 & + -211.D0/60480.D0*i**8*f(10)+129067.D0/5760.D0*f(5)*i**5+35*f(5)*i & + -8321.D0/720.D0*i**5*f(4)+i**7*f(1)/384-1197.D0/8.D0*i**3*f(6) & + +3533.D0/224.D0*f(3)*i**2+18047.D0/11520.D0*f(9)*i**6 & + +163313.D0/5760.D0*f(7)*i**5+f(5)*i**10/17280+f(11)*i**10/3628800 & + +11.D0/725760.D0*f(11)*i**9-120.D0/7.D0*i*f(4)-i**9*f(4)/630 & + +177133.D0/50400.D0*f(11)*i**2-93773.D0/14400.D0*i**6*f(6) & + +121.D0/24192.D0*f(11)*i**7+28603.D0/5760.D0*f(5)*i**6 & + -197741.D0/90720.D0*i**4*f(2)+f(3)*i**10/80640+7381.D0/2520.D0*f(11)*i-3229.D0/17280.D0*i**6*f(2) + f(NI+i) = s2+17.D0/5760.D0*f(7)*i**9-22439.D0/420.D0*i**3*f(4) & + -1877.D0/5040.D0*i**7*f(4)-i**10*f(2)/362880-43319.D0/1440.D0*i**5*f(6) & + +31.D0/480.D0*f(7)*i**8+1999.D0/2880.D0*f(5)*i**7+45.D0/8.D0*f(3)*i & + +19.D0/320.D0*f(5)*i**8-349.D0/720.D0*i**7*f(8) & + +273431.D0/4320.D0*f(5)*i**4-242639.D0/7560.D0*i**4*f(4) & + +4523.D0/22680.D0*i**4*f(1)+607.D0/40320.D0*f(9)*i**8 & + +92771.D0/11520.D0*f(9)*i**5+264767.D0/10080.D0*f(9)*i**4 & + +115923.D0/2240.D0*f(9)*i**3+6121.D0/112.D0*f(9)*i**2+45.D0/2.D0*f(9)*i & + +53.D0/80640.D0*f(9)*i**9-6041.D0/2880.D0*i**5*f(10) & + -663941.D0/90720.D0*i**4*f(10)-79913.D0/5040.D0*i**3*f(10) & + +7513.D0/172800.D0*f(11)*i**6+8591.D0/34560.D0*f(11)*i**5 & + +341693.D0/362880.D0*f(11)*i**4-13349.D0/720.D0*i**5*f(8) & + -400579.D0/3780.D0*i**3*f(8)+f(11) + + end select + + enddo + + return + + end subroutine extroplate_lag2 +! extroplate for unigrid with Calabrese Gundlach type, Eq.(16) of CQG 23 S343 (2006) + function extroplate_cg(N,f) result(gont) + implicit none + integer,intent(in ) :: N + real*8,dimension(N),intent(in) :: f + + real*8 :: gont + +! Eq.(16) of CQG 23 S343 (2006) + select case (N) +! for 2nd order code + case (2) + gont = 2.d0*f(2)-f(1) +! for 4th order code + case (4) + gont = 4.d0*f(4)-6.d0*f(3)+4.d0*f(2)-f(1) +! for 6th order code + case (6) +! Eq.(C7) of PRD 83, 024025 + gont = 6.d0*f(6)-1.5d1*f(5)+2.d1*f(4)-1.5d1*f(3)+6.d0*f(2)-f(1) +! for 8th order code + case (8) + gont = 8.d0*f(8)-2.8d1*f(7)+5.6d1*f(6)-7.d1*f(5)+5.6d1*f(4)-2.8d1*f(3)+8.d0*f(2)-f(1) + end select + + return + + end function extroplate_cg +! need CPBC_ghost_width + subroutine david_milton_extroplate_ss(ex,crho,sigma,R, & + TZ,chi,trK, & + dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Gmx,Gmy,Gmz, & + Lap , betax , betay , betaz , & + dtSfx , dtSfy , dtSfz,zmin,zmax) + +! NOTE: we need Kreiss-Oliger dissipation here instead of rhs calculation routine + implicit none + +!~~~~~~> Input parameters: + + integer,intent(in ):: ex(1:3) + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: TZ,chi,dxx,dyy,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: trK + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: gxy,gxz,gyz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Gmx,Gmy,Gmz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: Lap, betax, betay, betaz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) :: dtSfx, dtSfy, dtSfz + real*8, intent(in):: zmin,zmax + +#define tptype 1 +#if (tptype == 0) +! default we always use hp (tpp=0) + + call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,0) +#elif (tptype == 1) +! all D+ f = 0 (tpp=1) + + call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,1) +#elif (tptype == 2) +! Lagange polynomial but all used inner points (tpp=2) + + call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,2) + call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,2) + +#elif (tptype == 3) +! thumb of rule: D+ f = 0 (tpp=1) for outgoing ones; hp (tpp=0) for ingoing ones + + call repo_extro_ss(ex,crho,sigma,R,TZ,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,chi,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dxx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dyy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dzz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,gxy,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,gxz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,gyz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,trK,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Axx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Ayy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Azz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Axy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Axz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Ayz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Gmx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Gmy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Gmz,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,Lap,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,betax,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,betay,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,betaz,zmin,zmax,0) + call repo_extro_ss(ex,crho,sigma,R,dtSfx,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dtSfy,zmin,zmax,1) + call repo_extro_ss(ex,crho,sigma,R,dtSfz,zmin,zmax,1) + +#else +#error "not recognized tptype" +#endif + +#undef tptype + + return + + end subroutine david_milton_extroplate_ss +!construct rACqq rhs + subroutine cpbcrACqq(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,rACqq,& + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,Sfx,Sfy,Sfz,Axx,Axy,Axz,Ayy,Ayz,Azz,rACss,Symmetry,sst) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,Axx,Axy,Axz,Ayy,Ayz,Azz,rACss + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rACqq +!~~~~~~> Other variables: + real*8 :: chin1,alpha,gxx,gyy,gzz + real*8 :: sfxx,sfxy,sfxz,sfyx,sfyy,sfyz,sfzx,sfzy,sfzz + real*8 :: gxxx,gxxy,gxxz + real*8 :: gxyx,gxyy,gxyz + real*8 :: gxzx,gxzy,gxzz + real*8 :: gyyx,gyyy,gyyz + real*8 :: gyzx,gyzy,gyzz + real*8 :: gzzx,gzzy,gzzz + logical :: gont + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + real*8 :: dR + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + dR = R(2)-R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) +! consider buffer points near boundary + layer(3,3) = ex(3) - CPBC_ghost_width + layer(6,3) = ex(3) - CPBC_ghost_width +endif + + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + alpha = Lap(i,j,k)+1.d0 + chin1 = chi(i,j,k)+1.d0 + gxx = dxx(i,j,k)+1.d0 + gyy = dyy(i,j,k)+1.d0 + gzz = dzz(i,j,k)+1.d0 + call point_fderivs_shc(ex,Sfx,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfy,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call racqq_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & + alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & + sfxx,sfyx,sfzx,sfxy,sfyy,sfzy,sfxz,sfyz,sfzz, & + gxxx,gxyx,gxzx,gyyx,gyzx,gzzx, & + gxxy,gxyy,gxzy,gyyy,gyzy,gzzy, & + gxxz,gxyz,gxzz,gyyz,gyzz,gzzz, & + gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz, & + rACqq(i,j,k),rACss(i,j,k)) + enddo + enddo + enddo + endif + + return + + end subroutine cpbcrACqq +!construct rtrK rhs + subroutine cpbcrtrK(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,rtrK,& + chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,Sfx,Sfy,Sfz,TZ,Symmetry,sst,kappa1,kappa2) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,trK,dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,kappa1,kappa2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rtrK +!~~~~~~> Other variables: + real*8 :: chin1,alpha,gxx,gyy,gzz + real*8 :: Kx,Ky,Kz,TZx,TZy,TZz + logical :: gont + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + real*8 :: dR + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + dR = R(2)-R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) +! consider buffer points near boundary + layer(3,3) = ex(3) - CPBC_ghost_width + layer(6,3) = ex(3) - CPBC_ghost_width +endif + + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + alpha = Lap(i,j,k)+1.d0 + chin1 = chi(i,j,k)+1.d0 + gxx = dxx(i,j,k)+1.d0 + gyy = dyy(i,j,k)+1.d0 + gzz = dzz(i,j,k)+1.d0 + call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call rkhat_point(alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & + Kx,Ky,Kz,TZx,TZy,TZz, & + gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz,kappa1,kappa2, & + trK(i,j,k),R(k),rtrK(i,j,k),TZ(i,j,k),x(i,j,k),y(i,j,k),z(i,j,k)) + enddo + enddo + enddo + endif + + return + + end subroutine cpbcrtrK +!construct rTZ rhs + subroutine cpbcrtheta(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,rTheta,& + chi,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,Sfx,Sfy,Sfz,TZ,Symmetry,sst,kappa1,kappa2) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: chi,dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,kappa1,kappa2 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rTheta +!~~~~~~> Other variables: + real*8 :: alpha,chin1,gxx,gyy,gzz + real*8 :: TZx,TZy,TZz + logical :: gont + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + real*8 :: dR + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + dR = R(2)-R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) +! consider buffer points near boundary + layer(3,3) = ex(3) - CPBC_ghost_width + layer(6,3) = ex(3) - CPBC_ghost_width +endif + + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + alpha = Lap(i,j,k)+1.d0 + chin1 = chi(i,j,k)+1.d0 + gxx = dxx(i,j,k)+1.d0 + gyy = dyy(i,j,k)+1.d0 + gzz = dzz(i,j,k)+1.d0 + call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call rtheta_point(alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & + TZx,TZy,TZz, & + gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz,kappa1,kappa2, & + R(k),rTheta(i,j,k),TZ(i,j,k),x(i,j,k),y(i,j,k),z(i,j,k)) + enddo + enddo + enddo + endif + + return + + end subroutine cpbcrtheta +!construct rGam rhs + subroutine cpbcrgam(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax,rGamAx,rGamAy,rGamAz,rGams,& + chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & + Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,eta) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK,chi,dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,eta + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rGamAx,rGamAy,rGamAz,rGams +!~~~~~~> Other variables: + real*8 :: alpha,chin1,gxx,gyy,gzz + real*8 :: sfxx,sfyx,sfzx + real*8 :: sfxy,sfyy,sfzy + real*8 :: sfxz,sfyz,sfzz + real*8 :: sfxxx,sfyxx,sfzxx + real*8 :: sfxxy,sfyxy,sfzxy + real*8 :: sfxxz,sfyxz,sfzxz + real*8 :: sfxyy,sfyyy,sfzyy + real*8 :: sfxyz,sfyyz,sfzyz + real*8 :: sfxzz,sfyzz,sfzzz + real*8 :: Gamxx,Gamyx,Gamzx + real*8 :: Gamxy,Gamyy,Gamzy + real*8 :: Gamxz,Gamyz,Gamzz + real*8 :: Kx,Ky,Kz,TZx,TZy,TZz + logical :: gont + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + real*8 :: dR + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + dR = R(2)-R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) +! consider buffer points near boundary + layer(3,3) = ex(3) - CPBC_ghost_width + layer(6,3) = ex(3) - CPBC_ghost_width +endif + + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + alpha = Lap(i,j,k)+1.d0 + chin1 = chi(i,j,k)+1.d0 + gxx = dxx(i,j,k)+1.d0 + gyy = dyy(i,j,k)+1.d0 + gzz = dzz(i,j,k)+1.d0 + call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfx,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfy,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fdderivs_shc(ex,Sfx,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,Sfy,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM ,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,Sfz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call rgam_point(alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & + sfxx,sfyx,sfzx, & + sfxy,sfyy,sfzy, & + sfxz,sfyz,sfzz, & + sfxxx,sfyxx,sfzxx, & + sfxxy,sfyxy,sfzxy, & + sfxxz,sfyxz,sfzxz, & + sfxyy,sfyyy,sfzyy, & + sfxyz,sfyyz,sfzyz, & + sfxzz,sfyzz,sfzzz, & + Gamxx,Gamyx,Gamzx, & + Gamxy,Gamyy,Gamzy, & + Gamxz,Gamyz,Gamzz, & + Kx,Ky,Kz,TZx,TZy,TZz, & + gxx,gxy(i,j,k),gxz(i,j,k),gyy,gyz(i,j,k),gzz,& + R(k),rGamAx(i,j,k),rGamAy(i,j,k),rGamAz(i,j,k),rGams(i,j,k), & + eta,x(i,j,k),y(i,j,k),z(i,j,k)) + enddo + enddo + enddo + endif + + return + + end subroutine cpbcrgam +!construct rA rhs + subroutine cpbcra(ex,crho,sigma,R,x,y,z, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz, & + xmin,ymin,zmin,xmax,ymax,zmax, & + rACABTFxx,rACABTFxy,rACABTFxz,rACABTFyy,rACABTFyz,rACABTFzz,& + rACsAx,rACsAy,rACsAz,rACss, & + chi,trK,dxx,gxy,gxz,dyy,gyz,dzz, & + Axx,Axy,Axz,Ayy,Ayz,Azz, & + Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz,Symmetry,sst,kappa1) + + implicit none + +!~~~~~~> Input parameters: + integer, intent(in):: ex(1:3),Symmetry,sst + double precision,intent(in),dimension(ex(1))::crho + double precision,intent(in),dimension(ex(2))::sigma + double precision,intent(in),dimension(ex(3))::R + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::x,y,z + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodx, drhody, drhodz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadx,dsigmady,dsigmadz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdx,dRdy,dRdz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double precision,intent(in),dimension(ex(1),ex(2),ex(3))::dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: trK,chi,dxx,gxy,gxz,dyy,gyz,dzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(in ) :: Lap,Sfx,Sfy,Sfz,TZ,Gamx,Gamy,Gamz,Axx,Axy,Axz,Ayy,Ayz,Azz + real*8, intent(in):: xmin,ymin,zmin,xmax,ymax,zmax,kappa1 + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rACABTFxx,rACABTFxy,rACABTFxz,rACABTFyy,rACABTFyz,rACABTFzz + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout)::rACsAx,rACsAy,rACsAz,rACss +!~~~~~~> Other variables: + real*8 :: alpha,chin1,gxx,gyy,gzz + real*8 :: sfxx,sfyx,sfzx + real*8 :: sfxy,sfyy,sfzy + real*8 :: sfxz,sfyz,sfzz + real*8 :: sfxxx,sfyxx,sfzxx + real*8 :: sfxxy,sfyxy,sfzxy + real*8 :: sfxxz,sfyxz,sfzxz + real*8 :: sfxyy,sfyyy,sfzyy + real*8 :: sfxyz,sfyyz,sfzyz + real*8 :: sfxzz,sfyzz,sfzzz + real*8 :: Gamxx,Gamyx,Gamzx + real*8 :: Gamxy,Gamyy,Gamzy + real*8 :: Gamxz,Gamyz,Gamzz + real*8 :: Kx,Ky,Kz,TZx,TZy,TZz + real*8 :: Lapx,Lapy,Lapz,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz + real*8 :: chix,chiy,chiz + real*8 :: chixx,chixy,chixz,chiyy,chiyz,chizz + real*8 :: Axxx,Axxy,Axxz + real*8 :: Axyx,Axyy,Axyz + real*8 :: Axzx,Axzy,Axzz + real*8 :: Ayyx,Ayyy,Ayyz + real*8 :: Ayzx,Ayzy,Ayzz + real*8 :: Azzx,Azzy,Azzz + real*8 :: gxxx,gxxy,gxxz + real*8 :: gxyx,gxyy,gxyz + real*8 :: gxzx,gxzy,gxzz + real*8 :: gyyx,gyyy,gyyz + real*8 :: gyzx,gyzy,gyzz + real*8 :: gzzx,gzzy,gzzz + real*8 :: gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz + real*8 :: gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz + real*8 :: gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz + real*8 :: gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz + real*8 :: gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz + real*8 :: gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz + logical :: gont + integer :: i, j, k + integer :: layer(1:6,1:6),gp +! index of layer, first one: i,j,k; second one: front back etc. boundary + integer :: kmin,kmax + real*8, parameter :: ZEO = 0.d0, ONE = 1.d0, TWO=2.d0 + real*8 :: dR + real*8, parameter :: SYM = 1.D0, ANTI= - 1.D0 + + dR = R(2)-R(1) + + kmax = ex(3) + + kmin = 1 + +layer(1:3,:) = 1 +layer(4:6,:) =-1 + +if(dabs(R(ex(3))-zmax) < dR)then + layer(1,3) = 1 + layer(2,3) = 1 + layer(4,3) = ex(1) + layer(5,3) = ex(2) +! consider buffer points near boundary + layer(3,3) = ex(3) - CPBC_ghost_width + layer(6,3) = ex(3) - CPBC_ghost_width +endif + + gp = 3 + + gont = any( layer(:,gp) == - 1 ) + + if( .not. gont ) then + + do k = layer(3,gp), layer(6,gp) + do j = layer(2,gp), layer(5,gp) + do i = layer(1,gp), layer(4,gp) + alpha = Lap(i,j,k)+1.d0 + chin1 = chi(i,j,k)+1.d0 + gxx = dxx(i,j,k)+1.d0 + gyy = dyy(i,j,k)+1.d0 + gzz = dzz(i,j,k)+1.d0 + call point_fderivs_shc(ex,trK,Kx,Ky,Kz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,TZ,TZx,TZy,TZz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axx,Axxx,Axxy,Axxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axy,Axyx,Axyy,Axyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Axz,Axzx,Axzy,Axzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Ayy,Ayyx,Ayyy,Ayyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Ayz,Ayzx,Ayzy,Ayzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Azz,Azzx,Azzy,Azzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dxx,gxxx,gxxy,gxxz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxy,gxyx,gxyy,gxyz,crho,sigma,R,ANTI,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gxz,gxzx,gxzy,gxzz,crho,sigma,R,ANTI,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dyy,gyyx,gyyy,gyyz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,gyz,gyzx,gyzy,gyzz,crho,sigma,R,SYM,ANTI,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,dzz,gzzx,gzzy,gzzz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamx,Gamxx,Gamxy,Gamxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamy,Gamyx,Gamyy,Gamyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Gamz,Gamzx,Gamzy,Gamzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfx,sfxx,sfxy,sfxz,crho,sigma,R,ANTI,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfy,sfyx,sfyy,sfyz,crho,sigma,R,SYM,ANTI,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Sfz,sfzx,sfzy,sfzz,crho,sigma,R,SYM,SYM,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fdderivs_shc(ex,Sfx,sfxxx,sfxxy,sfxxz,sfxyy,sfxyz,sfxzz,crho,sigma,R,ANTI,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,Sfy,sfyxx,sfyxy,sfyxz,sfyyy,sfyyz,sfyzz,crho,sigma,R,SYM ,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,Sfz,sfzxx,sfzxy,sfzxz,sfzyy,sfzyz,sfzzz,crho,sigma,R,SYM ,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + + call point_fderivs_shc(ex,chi,chix,chiy,chiz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fderivs_shc(ex,Lap,Lapx,Lapy,Lapz,crho,sigma,R,SYM,SYM,SYM,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz,i,j,k) + call point_fdderivs_shc(ex,Lap,Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,chi,chixx,chixy,chixz,chiyy,chiyz,chizz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dxx,gxxxx,gxxxy,gxxxz,gxxyy,gxxyz,gxxzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dyy,gyyxx,gyyxy,gyyxz,gyyyy,gyyyz,gyyzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,dzz,gzzxx,gzzxy,gzzxz,gzzyy,gzzyz,gzzzz,crho,sigma,R,SYM ,SYM ,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gxy,gxyxx,gxyxy,gxyxz,gxyyy,gxyyz,gxyzz,crho,sigma,R,ANTI,ANTI,SYM ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gxz,gxzxx,gxzxy,gxzxz,gxzyy,gxzyz,gxzzz,crho,sigma,R,ANTI,SYM ,ANTI,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call point_fdderivs_shc(ex,gyz,gyzxx,gyzxy,gyzxz,gyzyy,gyzyz,gyzzz,crho,sigma,R,SYM ,ANTI,ANTI ,Symmetry,0,sst, & + drhodx, drhody, drhodz, & + dsigmadx,dsigmady,dsigmadz, & + dRdx,dRdy,dRdz, & + drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz, & + dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz, & + dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz,i,j,k) + call ra_point(Axx(i,j,k),Axy(i,j,k),Axz(i,j,k),Ayy(i,j,k),Ayz(i,j,k),Azz(i,j,k), & + alpha,Sfx(i,j,k),Sfy(i,j,k),Sfz(i,j,k),chin1, & + Lapx,Axxx,Axyx,Axzx,Ayyx,Ayzx,Azzx, & + Lapy,Axxy,Axyy,Axzy,Ayyy,Ayzy,Azzy, & + Lapz,Axxz,Axyz,Axzz,Ayyz,Ayzz,Azzz, & + sfxx,sfyx,sfzx, & + sfxy,sfyy,sfzy, & + sfxz,sfyz,sfzz, & + chix,chiy,chiz, & + Lapxx,Lapxy,Lapxz,Lapyy,Lapyz,Lapzz, & + sfxxx,sfyxx,sfzxx, & + sfxxy,sfyxy,sfzxy, & + sfxxz,sfyxz,sfzxz, & + sfxyy,sfyyy,sfzyy, & + sfxyz,sfyyz,sfzyz, & + sfxzz,sfyzz,sfzzz, & + chixx,chixy,chixz,chiyy,chiyz,chizz, & + gxxxx,gxyxx,gxzxx,gyyxx,gyzxx,gzzxx, & + gxxxy,gxyxy,gxzxy,gyyxy,gyzxy,gzzxy, & + gxxxz,gxyxz,gxzxz,gyyxz,gyzxz,gzzxz, & + gxxyy,gxyyy,gxzyy,gyyyy,gyzyy,gzzyy, & + gxxyz,gxyyz,gxzyz,gyyyz,gyzyz,gzzyz, & + gxxzz,gxyzz,gxzzz,gyyzz,gyzzz,gzzzz, & + Gamxx,gxxx,gxyx,gxzx, & + Gamyx,gyyx,gyzx, & + Gamzx,gzzx, & + Gamxy,gxxy,gxyy,gxzy, & + Gamyy,gyyy,gyzy, & + Gamzy,gzzy, & + Gamxz,gxxz,gxyz,gxzz, & + Gamyz,gyyz,gyzz, & + Gamzz,gzzz, & + Kx,Ky,Kz,TZx,TZy,TZz, & + Gamx(i,j,k),gxx,gxy(i,j,k),gxz(i,j,k), & + Gamy(i,j,k),gyy,gyz(i,j,k), & + Gamz(i,j,k),gzz, & + kappa1,trK(i,j,k), & + R(k),rACABTFxx(i,j,k),rACABTFxy(i,j,k),rACABTFxz(i,j,k), & + rACABTFyy(i,j,k),rACABTFyz(i,j,k),rACABTFzz(i,j,k), & + rACsAx(i,j,k),rACsAy(i,j,k),rACsAz(i,j,k), & + rACss(i,j,k),TZ(i,j,k), & + x(i,j,k),y(i,j,k),z(i,j,k)) + enddo + enddo + enddo + endif + + return + + end subroutine cpbcra diff --git a/AMSS_NCKU_source/cpbc.h b/AMSS_NCKU_source/Z4C/cpbc.h similarity index 98% rename from AMSS_NCKU_source/cpbc.h rename to AMSS_NCKU_source/Z4C/cpbc.h index 0da495c..aa16c90 100644 --- a/AMSS_NCKU_source/cpbc.h +++ b/AMSS_NCKU_source/Z4C/cpbc.h @@ -1,56 +1,56 @@ - -#ifndef CPBC_H -#define CPBC_H - -#ifdef fortran1 -#define f_david_milton_extroplate_ss david_milton_extroplate_ss -#define f_david_milton_cpbc_ss david_milton_cpbc_ss -#endif -#ifdef fortran2 -#define f_david_milton_extroplate_ss DAVID_MILTON_EXTROPLATE_SS -#define f_david_milton_cpbc_ss DAVID_MILTON_CPBC_SS -#endif -#ifdef fortran3 -#define f_david_milton_extroplate_ss david_milton_extroplate_ss_ -#define f_david_milton_cpbc_ss david_milton_cpbc_ss_ -#endif -extern "C" -{ - int f_david_milton_extroplate_ss(int *, double *, double *, double *, // ex,crho,sigma,R - double *, double *, double *, // TZ, chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double &, double &); -} // zmin,zmax - -extern "C" -{ - int f_david_milton_cpbc_ss(int *, double *, double *, double *, // ex,crho,sigma,R - double *, double *, double *, // x,y,z - double *, double *, double *, // drhodx,drhody,drhodz - double *, double *, double *, // dsigmadx,dsigmady,dsigmadz - double *, double *, double *, // dRdx,dRdy,dRdz - double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz - double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz - double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz - double &, double &, double &, double &, double &, double &, // xmin,ymin,zmin,xmax,ymax,zmax - double *, double *, double *, // TZ,chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, double *, // TZ, chi, trK - double *, double *, double *, double *, double *, double *, // gij - double *, double *, double *, double *, double *, double *, // Aij - double *, double *, double *, // Gam - double *, double *, double *, double *, double *, double *, double *, // Gauge - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Christoffel - double *, double *, double *, double *, double *, double *, // Ricci - double *, double *, double *, // Gama constraint - int &, double &, int &); -} // Symmetry, eps, sst -#endif /* CPBC_H */ + +#ifndef CPBC_H +#define CPBC_H + +#ifdef fortran1 +#define f_david_milton_extroplate_ss david_milton_extroplate_ss +#define f_david_milton_cpbc_ss david_milton_cpbc_ss +#endif +#ifdef fortran2 +#define f_david_milton_extroplate_ss DAVID_MILTON_EXTROPLATE_SS +#define f_david_milton_cpbc_ss DAVID_MILTON_CPBC_SS +#endif +#ifdef fortran3 +#define f_david_milton_extroplate_ss david_milton_extroplate_ss_ +#define f_david_milton_cpbc_ss david_milton_cpbc_ss_ +#endif +extern "C" +{ + int f_david_milton_extroplate_ss(int *, double *, double *, double *, // ex,crho,sigma,R + double *, double *, double *, // TZ, chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double &, double &); +} // zmin,zmax + +extern "C" +{ + int f_david_milton_cpbc_ss(int *, double *, double *, double *, // ex,crho,sigma,R + double *, double *, double *, // x,y,z + double *, double *, double *, // drhodx,drhody,drhodz + double *, double *, double *, // dsigmadx,dsigmady,dsigmadz + double *, double *, double *, // dRdx,dRdy,dRdz + double *, double *, double *, double *, double *, double *, // drhodxx,drhodxy,drhodxz,drhodyy,drhodyz,drhodzz + double *, double *, double *, double *, double *, double *, // dsigmadxx,dsigmadxy,dsigmadxz,dsigmadyy,dsigmadyz,dsigmadzz + double *, double *, double *, double *, double *, double *, // dRdxx,dRdxy,dRdxz,dRdyy,dRdyz,dRdzz + double &, double &, double &, double &, double &, double &, // xmin,ymin,zmin,xmax,ymax,zmax + double *, double *, double *, // TZ,chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, double *, // TZ, chi, trK + double *, double *, double *, double *, double *, double *, // gij + double *, double *, double *, double *, double *, double *, // Aij + double *, double *, double *, // Gam + double *, double *, double *, double *, double *, double *, double *, // Gauge + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Christoffel + double *, double *, double *, double *, double *, double *, // Ricci + double *, double *, double *, // Gama constraint + int &, double &, int &); +} // Symmetry, eps, sst +#endif /* CPBC_H */ diff --git a/AMSS_NCKU_source/cpbc_util.C b/AMSS_NCKU_source/Z4C/cpbc_util.C similarity index 96% rename from AMSS_NCKU_source/cpbc_util.C rename to AMSS_NCKU_source/Z4C/cpbc_util.C index d4d3237..82067d6 100644 --- a/AMSS_NCKU_source/cpbc_util.C +++ b/AMSS_NCKU_source/Z4C/cpbc_util.C @@ -1,13026 +1,13026 @@ - - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - - -#define Power(x,y) (pow((double) (x), (double) (y))) -#define Sqrt(x) sqrt(x) -#define Log(x) log((double) (x)) -#define pow2(x) ((x)*(x)) -#define pow3(x) ((x)*(x)*(x)) -#define pow4(x) ((x)*(x)*(x)*(x)) -#define pow2inv(x) (1.0/((x)*(x))) - -#define Cal(x,y,z) ((x)?(y):(z)) - -#define Tan(x) tan(x) -#define ArcTan(x) atan(x) -#define Sin(x) sin(x) -#define Cos(x) cos(x) -#define Csc(x) (1./sin(x)) -#define Abs(x) (fabs(x)) -#define sqrt2 (sqrt(2)) -#define Tanh(x) tanh(x) -#define Sech(x) (1/cosh(x)) - - -extern "C" { - -#ifdef fortran1 -void cpbc_point -#endif -#ifdef fortran2 -void CPBC_POINT -#endif -#ifdef fortran3 -void cpbc_point_ -#endif -(double & r,double & xp,double & yp,double & zp, - double & Theta,double & chi,double & Khat, - double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, - double & A11,double & A12,double & A13,double & A22,double & A23,double & A33, - double & G1,double & G2,double & G3, - double & alpha,double & beta1,double & beta2,double & beta3, - double & da1,double & da2,double & da3, - double & dda11,double & dda12,double & dda13,double & dda22,double & dda23,double & dda33, - double & db11,double & db21,double & db31, - double & db12,double & db22,double & db32, - double & db13,double & db23,double & db33, - double & ddb111,double & ddb121,double & ddb131,double & ddb221,double & ddb231,double & ddb331, - double & ddb112,double & ddb122,double & ddb132,double & ddb222,double & ddb232,double & ddb332, - double & ddb113,double & ddb123,double & ddb133,double & ddb223,double & ddb233,double & ddb333, - double & dchi1,double & dchi2,double & dchi3, - double & ddchi11,double & ddchi12,double & ddchi13,double & ddchi22,double & ddchi23,double & ddchi33, - double & dg111,double & dg112,double & dg113,double & dg122,double & dg123,double & dg133, - double & dg211,double & dg212,double & dg213,double & dg222,double & dg223,double & dg233, - double & dg311,double & dg312,double & dg313,double & dg322,double & dg323,double & dg333, - double & ddg1111,double & ddg1211,double & ddg1311,double & ddg2211,double & ddg2311,double & ddg3311, - double & ddg1112,double & ddg1212,double & ddg1312,double & ddg2212,double & ddg2312,double & ddg3312, - double & ddg1113,double & ddg1213,double & ddg1313,double & ddg2213,double & ddg2313,double & ddg3313, - double & ddg1122,double & ddg1222,double & ddg1322,double & ddg2222,double & ddg2322,double & ddg3322, - double & ddg1123,double & ddg1223,double & ddg1323,double & ddg2223,double & ddg2323,double & ddg3323, - double & ddg1133,double & ddg1233,double & ddg1333,double & ddg2233,double & ddg2333,double & ddg3333, - double & dKhat1,double & dKhat2,double & dKhat3, - double & dA111,double & dA112,double & dA113,double & dA122,double & dA123,double & dA133, - double & dA211,double & dA212,double & dA213,double & dA222,double & dA223,double & dA233, - double & dA311,double & dA312,double & dA313,double & dA322,double & dA323,double & dA333, - double & dG11,double & dG21,double & dG31, - double & dG12,double & dG22,double & dG32, - double & dG13,double & dG23,double & dG33, - double & dTheta1,double & dTheta2,double & dTheta3, - double & rKhat,double & rTheta, - double & rA11,double & rA12,double & rA13,double & rA22,double & rA23,double & rA33, - double & rG1,double & rG2,double & rG3, - double &kappa1,double &kappa2,double &shiftdriver) -{ - -double AA11; -double AA12; -double AA13; -double AA21; -double AA22; -double AA23; -double AA31; -double AA32; -double AA33; -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double Ainv11; -double Ainv12; -double Ainv13; -double Ainv22; -double Ainv23; -double Ainv33; -double betaA1; -double betaA2; -double betaA3; -double betas; -double cdA111; -double cdA112; -double cdA113; -double cdA122; -double cdA123; -double cdA133; -double cdA211; -double cdA212; -double cdA213; -double cdA222; -double cdA223; -double cdA233; -double cdA311; -double cdA312; -double cdA313; -double cdA322; -double cdA323; -double cdA333; -double cdda11; -double cdda12; -double cdda13; -double cdda22; -double cdda23; -double cdda33; -double cddf11; -double cddf12; -double cddf13; -double cddf22; -double cddf23; -double cddf33; -const double chipsipower = -4; -double Dalpha; -double DbetaA1; -double DbetaA2; -double DbetaA3; -double Dbetas; -double ddf11; -double ddf12; -double ddf13; -double ddf22; -double ddf23; -double ddf33; -double detginv; -double df1; -double df2; -double df3; -double DGamA1; -double DGamA2; -double DGamA3; -double DGams; -double dGfromgdu11; -double dGfromgdu12; -double dGfromgdu13; -double dGfromgdu21; -double dGfromgdu22; -double dGfromgdu23; -double dGfromgdu31; -double dGfromgdu32; -double dGfromgdu33; -double dginv111; -double dginv112; -double dginv113; -double dginv122; -double dginv123; -double dginv133; -double dginv211; -double dginv212; -double dginv213; -double dginv222; -double dginv223; -double dginv233; -double dginv311; -double dginv312; -double dginv313; -double dginv322; -double dginv323; -double dginv333; -double divbeta; -double DK; -double dK1; -double dK2; -double dK3; -double DKhat; -double DTheta; -double f; -double ff; -double gADM11; -double gADM12; -double gADM13; -double gADM21; -double gADM22; -double gADM23; -double gADM31; -double gADM32; -double gADM33; -double GamA1; -double GamA2; -double GamA3; -double gamma111; -double gamma112; -double gamma113; -double gamma122; -double gamma123; -double gamma133; -double gamma211; -double gamma212; -double gamma213; -double gamma222; -double gamma223; -double gamma233; -double gamma311; -double gamma312; -double gamma313; -double gamma322; -double gamma323; -double gamma333; -double gammado111; -double gammado112; -double gammado113; -double gammado122; -double gammado123; -double gammado133; -double gammado211; -double gammado212; -double gammado213; -double gammado222; -double gammado223; -double gammado233; -double gammado311; -double gammado312; -double gammado313; -double gammado322; -double gammado323; -double gammado333; -double Gams; -double Gfromg1; -double Gfromg2; -double Gfromg3; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -const bool givehPsi0 = false; -const double hPsi0para = 0; -const double hPsi0parb = 0; -const double hPsi0parc = 0; -double ImhPsi0; -double K; -double lieA11; -double lieA12; -double lieA13; -double lieA22; -double lieA23; -double lieA33; -double lieg11; -double lieg12; -double lieg13; -double lieg22; -double lieg23; -double lieg33; -double lienK; -double lienKhat; -double lienTheta; -double modshatARG; -double muL; -double muStilde; -double oochipsipower; -double oomodshat; -double psim4; -double qdd11; -double qdd12; -double qdd13; -double qdd22; -double qdd23; -double qdd33; -double qPhysuudd1111; -double qPhysuudd1112; -double qPhysuudd1113; -double qPhysuudd1122; -double qPhysuudd1123; -double qPhysuudd1133; -double qPhysuudd1211; -double qPhysuudd1212; -double qPhysuudd1213; -double qPhysuudd1222; -double qPhysuudd1223; -double qPhysuudd1233; -double qPhysuudd1311; -double qPhysuudd1312; -double qPhysuudd1313; -double qPhysuudd1322; -double qPhysuudd1323; -double qPhysuudd1333; -double qPhysuudd2211; -double qPhysuudd2212; -double qPhysuudd2213; -double qPhysuudd2222; -double qPhysuudd2223; -double qPhysuudd2233; -double qPhysuudd2311; -double qPhysuudd2312; -double qPhysuudd2313; -double qPhysuudd2322; -double qPhysuudd2323; -double qPhysuudd2333; -double qPhysuudd3311; -double qPhysuudd3312; -double qPhysuudd3313; -double qPhysuudd3322; -double qPhysuudd3323; -double qPhysuudd3333; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double quu11; -double quu12; -double quu13; -double quu22; -double quu23; -double quu33; -double R11; -double R12; -double R13; -double R22; -double R23; -double R33; -double rACABTF11; -double rACABTF12; -double rACABTF13; -double rACABTF22; -double rACABTF23; -double rACABTF33; -double rACqq; -double rACsA1; -double rACsA2; -double rACsA3; -double rACss; -double RehPsi0; -double Rf11; -double Rf12; -double Rf13; -double Rf22; -double Rf23; -double Rf33; -double rGamA1; -double rGamA2; -double rGamA3; -double rGams; -double Rhat; -double Rphi11; -double Rphi12; -double Rphi13; -double Rphi22; -double Rphi23; -double Rphi33; -double sdotv; -double sdotw; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; -const double time = 0; -double totdivbeta; -double trcdda; -double trcddf; -double vbetaA; -double vbetas; -double vd1; -double vd2; -double vd3; -double vdotv; -double vdotw; -double vu1; -double vu2; -double vu3; -double wd1; -double wd2; -double wd3; -double wdotw; -double wu1; -double wu2; -double wu3; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -#if 0 -// my code -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -qdd11 -= -g11/chi - pow2(sdown1) -; - -qdd12 -= -g12/chi - sdown1*sdown2 -; - -qdd13 -= -g13/chi - sdown1*sdown3 -; - -qdd22 -= -g22/chi - pow2(sdown2) -; - -qdd23 -= -g23/chi - sdown2*sdown3 -; - -qdd33 -= -g33/chi - pow2(sdown3) -; - -quu11 -= -ADMginv11 - pow2(sup1) -; - -quu12 -= -ADMginv12 - sup1*sup2 -; - -quu13 -= -ADMginv13 - sup1*sup3 -; - -quu22 -= -ADMginv22 - pow2(sup2) -; - -quu23 -= -ADMginv23 - sup2*sup3 -; - -quu33 -= -ADMginv33 - pow2(sup3) -; - -qPhysuudd1111 -= --0.5*qdd11*quu11 + pow2(qud11) -; - -qPhysuudd1112 -= -qud11*qud12 - 0.5*qdd12*quu11 -; - -qPhysuudd1113 -= -qud11*qud13 - 0.5*qdd13*quu11 -; - -qPhysuudd1122 -= --0.5*qdd22*quu11 + pow2(qud12) -; - -qPhysuudd1123 -= -qud12*qud13 - 0.5*qdd23*quu11 -; - -qPhysuudd1133 -= --0.5*qdd33*quu11 + pow2(qud13) -; - -qPhysuudd1211 -= -qud11*qud21 - 0.5*qdd11*quu12 -; - -qPhysuudd1212 -= -0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) -; - -qPhysuudd1213 -= -0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) -; - -qPhysuudd1222 -= -qud12*qud22 - 0.5*qdd22*quu12 -; - -qPhysuudd1223 -= -0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) -; - -qPhysuudd1233 -= -qud13*qud23 - 0.5*qdd33*quu12 -; - -qPhysuudd1311 -= -qud11*qud31 - 0.5*qdd11*quu13 -; - -qPhysuudd1312 -= -0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) -; - -qPhysuudd1313 -= -0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) -; - -qPhysuudd1322 -= -qud12*qud32 - 0.5*qdd22*quu13 -; - -qPhysuudd1323 -= -0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) -; - -qPhysuudd1333 -= -qud13*qud33 - 0.5*qdd33*quu13 -; - -qPhysuudd2211 -= --0.5*qdd11*quu22 + pow2(qud21) -; - -qPhysuudd2212 -= -qud21*qud22 - 0.5*qdd12*quu22 -; - -qPhysuudd2213 -= -qud21*qud23 - 0.5*qdd13*quu22 -; - -qPhysuudd2222 -= --0.5*qdd22*quu22 + pow2(qud22) -; - -qPhysuudd2223 -= -qud22*qud23 - 0.5*qdd23*quu22 -; - -qPhysuudd2233 -= --0.5*qdd33*quu22 + pow2(qud23) -; - -qPhysuudd2311 -= -qud21*qud31 - 0.5*qdd11*quu23 -; - -qPhysuudd2312 -= -0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) -; - -qPhysuudd2313 -= -0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) -; - -qPhysuudd2322 -= -qud22*qud32 - 0.5*qdd22*quu23 -; - -qPhysuudd2323 -= -0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) -; - -qPhysuudd2333 -= -qud23*qud33 - 0.5*qdd33*quu23 -; - -qPhysuudd3311 -= --0.5*qdd11*quu33 + pow2(qud31) -; - -qPhysuudd3312 -= -qud31*qud32 - 0.5*qdd12*quu33 -; - -qPhysuudd3313 -= -qud31*qud33 - 0.5*qdd13*quu33 -; - -qPhysuudd3322 -= --0.5*qdd22*quu33 + pow2(qud32) -; - -qPhysuudd3323 -= -qud32*qud33 - 0.5*qdd23*quu33 -; - -qPhysuudd3333 -= --0.5*qdd33*quu33 + pow2(qud33) -; - -muL -= -2./alpha -; - -muStilde -= -1/chi -; - -vbetas -= -2.*sqrt(0.33333333333333333333*muStilde) -; - -vbetaA -= -sqrt(muStilde) -; - -K -= -Khat + 2.*Theta -; - -dK1 -= -dKhat1 + 2.*dTheta1 -; - -dK2 -= -dKhat2 + 2.*dTheta2 -; - -dK3 -= -dKhat3 + 2.*dTheta3 -; - -dginv111 -= --2.*(dg123*ginv12*ginv13 + ginv11*(dg112*ginv12 + dg113*ginv13)) - - dg111*pow2(ginv11) - dg122*pow2(ginv12) - dg133*pow2(ginv13) -; - -dginv112 -= --(ginv11*(dg111*ginv12 + dg112*ginv22 + dg113*ginv23)) - - ginv12*(dg113*ginv13 + dg122*ginv22 + dg123*ginv23) - - ginv13*(dg123*ginv22 + dg133*ginv23) - dg112*pow2(ginv12) -; - -dginv113 -= --(ginv11*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33)) - - ginv12*(dg112*ginv13 + dg122*ginv23 + dg123*ginv33) - - ginv13*(dg123*ginv23 + dg133*ginv33) - dg113*pow2(ginv13) -; - -dginv122 -= --2.*(dg123*ginv22*ginv23 + ginv12*(dg112*ginv22 + dg113*ginv23)) - - dg111*pow2(ginv12) - dg122*pow2(ginv22) - dg133*pow2(ginv23) -; - -dginv123 -= --(ginv13*(dg112*ginv22 + dg113*ginv23)) - dg133*ginv23*ginv33 - - ginv12*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33) - - ginv22*(dg122*ginv23 + dg123*ginv33) - dg123*pow2(ginv23) -; - -dginv133 -= --2.*(dg123*ginv23*ginv33 + ginv13*(dg112*ginv23 + dg113*ginv33)) - - dg111*pow2(ginv13) - dg122*pow2(ginv23) - dg133*pow2(ginv33) -; - -dginv211 -= --2.*(dg223*ginv12*ginv13 + ginv11*(dg212*ginv12 + dg213*ginv13)) - - dg211*pow2(ginv11) - dg222*pow2(ginv12) - dg233*pow2(ginv13) -; - -dginv212 -= --(ginv11*(dg211*ginv12 + dg212*ginv22 + dg213*ginv23)) - - ginv12*(dg213*ginv13 + dg222*ginv22 + dg223*ginv23) - - ginv13*(dg223*ginv22 + dg233*ginv23) - dg212*pow2(ginv12) -; - -dginv213 -= --(ginv11*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33)) - - ginv12*(dg212*ginv13 + dg222*ginv23 + dg223*ginv33) - - ginv13*(dg223*ginv23 + dg233*ginv33) - dg213*pow2(ginv13) -; - -dginv222 -= --2.*(dg223*ginv22*ginv23 + ginv12*(dg212*ginv22 + dg213*ginv23)) - - dg211*pow2(ginv12) - dg222*pow2(ginv22) - dg233*pow2(ginv23) -; - -dginv223 -= --(ginv13*(dg212*ginv22 + dg213*ginv23)) - dg233*ginv23*ginv33 - - ginv12*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33) - - ginv22*(dg222*ginv23 + dg223*ginv33) - dg223*pow2(ginv23) -; - -dginv233 -= --2.*(dg223*ginv23*ginv33 + ginv13*(dg212*ginv23 + dg213*ginv33)) - - dg211*pow2(ginv13) - dg222*pow2(ginv23) - dg233*pow2(ginv33) -; - -dginv311 -= --2.*(dg323*ginv12*ginv13 + ginv11*(dg312*ginv12 + dg313*ginv13)) - - dg311*pow2(ginv11) - dg322*pow2(ginv12) - dg333*pow2(ginv13) -; - -dginv312 -= --(ginv11*(dg311*ginv12 + dg312*ginv22 + dg313*ginv23)) - - ginv12*(dg313*ginv13 + dg322*ginv22 + dg323*ginv23) - - ginv13*(dg323*ginv22 + dg333*ginv23) - dg312*pow2(ginv12) -; - -dginv313 -= --(ginv11*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33)) - - ginv12*(dg312*ginv13 + dg322*ginv23 + dg323*ginv33) - - ginv13*(dg323*ginv23 + dg333*ginv33) - dg313*pow2(ginv13) -; - -dginv322 -= --2.*(dg323*ginv22*ginv23 + ginv12*(dg312*ginv22 + dg313*ginv23)) - - dg311*pow2(ginv12) - dg322*pow2(ginv22) - dg333*pow2(ginv23) -; - -dginv323 -= --(ginv13*(dg312*ginv22 + dg313*ginv23)) - dg333*ginv23*ginv33 - - ginv12*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33) - - ginv22*(dg322*ginv23 + dg323*ginv33) - dg323*pow2(ginv23) -; - -dginv333 -= --2.*(dg323*ginv23*ginv33 + ginv13*(dg312*ginv23 + dg313*ginv33)) - - dg311*pow2(ginv13) - dg322*pow2(ginv23) - dg333*pow2(ginv33) -; - -gammado111 -= -0.5*dg111 -; - -gammado112 -= -0.5*dg211 -; - -gammado113 -= -0.5*dg311 -; - -gammado122 -= --0.5*dg122 + dg212 -; - -gammado123 -= -0.5*(-dg123 + dg213 + dg312) -; - -gammado133 -= --0.5*dg133 + dg313 -; - -gammado211 -= -dg112 - 0.5*dg211 -; - -gammado212 -= -0.5*dg122 -; - -gammado213 -= -0.5*(dg123 - dg213 + dg312) -; - -gammado222 -= -0.5*dg222 -; - -gammado223 -= -0.5*dg322 -; - -gammado233 -= --0.5*dg233 + dg323 -; - -gammado311 -= -dg113 - 0.5*dg311 -; - -gammado312 -= -0.5*(dg123 + dg213 - dg312) -; - -gammado313 -= -0.5*dg133 -; - -gammado322 -= -dg223 - 0.5*dg322 -; - -gammado323 -= -0.5*dg233 -; - -gammado333 -= -0.5*dg333 -; - -gamma111 -= -gammado111*ginv11 + gammado211*ginv12 + gammado311*ginv13 -; - -gamma112 -= -gammado112*ginv11 + gammado212*ginv12 + gammado312*ginv13 -; - -gamma113 -= -gammado113*ginv11 + gammado213*ginv12 + gammado313*ginv13 -; - -gamma122 -= -gammado122*ginv11 + gammado222*ginv12 + gammado322*ginv13 -; - -gamma123 -= -gammado123*ginv11 + gammado223*ginv12 + gammado323*ginv13 -; - -gamma133 -= -gammado133*ginv11 + gammado233*ginv12 + gammado333*ginv13 -; - -gamma211 -= -gammado111*ginv12 + gammado211*ginv22 + gammado311*ginv23 -; - -gamma212 -= -gammado112*ginv12 + gammado212*ginv22 + gammado312*ginv23 -; - -gamma213 -= -gammado113*ginv12 + gammado213*ginv22 + gammado313*ginv23 -; - -gamma222 -= -gammado122*ginv12 + gammado222*ginv22 + gammado322*ginv23 -; - -gamma223 -= -gammado123*ginv12 + gammado223*ginv22 + gammado323*ginv23 -; - -gamma233 -= -gammado133*ginv12 + gammado233*ginv22 + gammado333*ginv23 -; - -gamma311 -= -gammado111*ginv13 + gammado211*ginv23 + gammado311*ginv33 -; - -gamma312 -= -gammado112*ginv13 + gammado212*ginv23 + gammado312*ginv33 -; - -gamma313 -= -gammado113*ginv13 + gammado213*ginv23 + gammado313*ginv33 -; - -gamma322 -= -gammado122*ginv13 + gammado222*ginv23 + gammado322*ginv33 -; - -gamma323 -= -gammado123*ginv13 + gammado223*ginv23 + gammado323*ginv33 -; - -gamma333 -= -gammado133*ginv13 + gammado233*ginv23 + gammado333*ginv33 -; - -Gfromg1 -= -gamma111*ginv11 + gamma122*ginv22 + - 2.*(gamma112*ginv12 + gamma113*ginv13 + gamma123*ginv23) + gamma133*ginv33 -; - -Gfromg2 -= -gamma211*ginv11 + gamma222*ginv22 + - 2.*(gamma212*ginv12 + gamma213*ginv13 + gamma223*ginv23) + gamma233*ginv33 -; - -Gfromg3 -= -gamma311*ginv11 + gamma322*ginv22 + - 2.*(gamma312*ginv12 + gamma313*ginv13 + gamma323*ginv23) + gamma333*ginv33 -; - -dGfromgdu11 -= --((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)* - Power(ginv12,3)) - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + - dg111*dg333)*Power(ginv13,3) - 2.*Power(ginv11,3)*pow2(dg111) + - (ddg1111 - dg111*((8.*dg112 + 2.*dg211)*ginv12 + - (8.*dg113 + 2.*dg311)*ginv13) - - (dg113*(4.*dg112 + dg211) + dg112*dg311 + dg111*(dg213 + dg312))* - ginv23 - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - - ginv33*(dg113*dg311 + dg111*dg313 + 2.*pow2(dg113)))*pow2(ginv11) + - (ddg1122 + ddg1212 - (dg123*(8.*dg112 + 2.*dg211) + - dg113*(4.*dg122 + 2.*dg212) + dg122*dg311 + - 2.*(dg111*dg223 + dg112*(dg213 + dg312)) + dg111*dg322)*ginv13 - - (dg123*(4.*dg122 + 2.*dg212) + - 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* - ginv23 - ginv22*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122)) - - ginv33*(dg123*(dg213 + dg312) + dg122*dg313 + dg113*(dg223 + dg322) + - dg112*dg323 + 2.*pow2(dg123)))*pow2(ginv12) + - (ddg1133 + ddg1313 - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*ginv23 - - ginv22*(dg133*dg212 + dg113*dg223 + dg123*(dg213 + dg312) + - dg112*(dg233 + dg323) + 2.*pow2(dg123)) - - ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133)))*pow2(ginv13) \ -+ ginv13*(ddg1333*ginv33 + ginv22* - (ddg1223 - (dg133*dg222 + dg123*(4.*dg223 + dg322) + - dg122*(dg233 + dg323))*ginv23 - - (dg133*dg223 + dg123*(dg233 + 2.*dg323))*ginv33) + - ginv23*(ddg1233 + ddg1323 - - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)*ginv33) - - (dg123*dg222 + dg122*dg223)*pow2(ginv22) - - (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + - dg122*dg333)*pow2(ginv23) - 2.*dg133*dg333*pow2(ginv33)) + - ginv11*(ddg1313*ginv33 + ginv12* - (2.*ddg1112 + ddg1211 - - (dg113*(12.*dg112 + 3.*dg211) + 3.*dg112*dg311 + - dg111*(8.*dg123 + 3.*(dg213 + dg312)))*ginv13 - - (dg122*(4.*dg112 + dg211) + 6.*dg112*dg212 + dg111*dg222)*ginv22 - - (dg123*dg211 + dg122*dg311 + - 4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213 + dg312)) + - dg111*(dg223 + dg322))*ginv23 - - (dg123*dg311 + dg113*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*dg112*dg313 + dg111*dg323)*ginv33) + - ginv22*(ddg1212 - (dg113*dg222 + 2.*(dg123*dg212 + dg112*dg223) + - dg122*(dg213 + dg312) + dg112*dg322)*ginv23 - - (dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323)*ginv33) + - ginv13*(2.*ddg1113 + ddg1311 - - (dg123*(4.*dg112 + dg211) + dg111*dg223 + - 2.*(dg113*dg212 + dg112*(dg213 + dg312)))*ginv22 - - (dg133*dg211 + dg123*dg311 + - 4.*(dg113*(dg123 + dg213 + dg312) + dg112*(dg133 + dg313)) + - dg111*(dg233 + dg323))*ginv23 - - (dg133*(4.*dg113 + dg311) + 6.*dg113*dg313 + dg111*dg333)*ginv33) + - ginv23*(ddg1213 + ddg1312 - - (dg133*(dg213 + dg312) + 2.*dg123*dg313 + - dg113*(dg233 + 2.*dg323) + dg112*dg333)*ginv33) - - (3.*dg112*dg211 + dg111*(4.*dg122 + 3.*dg212) + 6.*pow2(dg112))* - pow2(ginv12) - (3.*dg113*dg311 + dg111*(4.*dg133 + 3.*dg313) + - 6.*pow2(dg113))*pow2(ginv13) - - (dg122*dg212 + dg112*dg222)*pow2(ginv22) - - (dg133*dg212 + dg123*(dg213 + dg312) + dg122*dg313 + - dg113*(dg223 + dg322) + dg112*(dg233 + dg323))*pow2(ginv23) - - (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + - ginv12*(ddg1323*ginv33 + ginv22* - (ddg1222 - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*ginv23 - - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33) + - ginv23*(ddg1223 + ddg1322 - - (dg133*(dg223 + dg322) + dg123*(dg233 + 4.*dg323) + dg122*dg333)* - ginv33) + ginv13*(2.*ddg1123 + ddg1213 + ddg1312 - - (dg113*dg222 + 4.*(dg123*(dg122 + dg212) + dg112*dg223) + - dg122*(dg213 + dg312) + dg112*dg322)*ginv22 - - (dg133*(4.*dg123 + dg213 + dg312) + 4.*dg123*dg313 + - dg113*(dg233 + 4.*dg323) + dg112*dg333)*ginv33 - - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg122*dg313 + - dg113*dg322) + 4.* - (dg122*dg133 + dg113*dg223 + dg123*(dg213 + dg312) + - dg112*dg323 + pow2(dg123)))) - - (dg133*(4.*dg112 + dg211) + dg113*(8.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* - pow2(ginv13) - 2.*dg122*dg222*pow2(ginv22) - - (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* - pow2(ginv23) - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) -; - -dGfromgdu12 -= --((dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + dg122*dg333)* - Power(ginv23,3)) - 2.*(dg122*dg222*Power(ginv22,3) + - Power(ginv12,3)*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)) + - (dg111*(dg112*ginv22 + dg113*ginv23) + ginv12*pow2(dg111))*pow2(ginv11)\ -) + (ddg1112 + ddg1211 - (4.*(dg112*dg113 + dg111*dg123) + - 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))*ginv13 - - (dg122*(6.*dg112 + 2.*dg211) + 6.*dg112*dg212 + 2.*dg111*dg222)* - ginv22 - (4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213)) + - dg122*dg311 + 2.*(dg123*dg211 + dg111*dg223 + dg112*dg312) + - dg111*dg322)*ginv23 - - (dg123*dg311 + dg113*(2.*(dg123 + dg213) + dg312) + dg112*dg313 + - dg111*dg323)*ginv33)*pow2(ginv12) - - ((2.*(dg113*dg123 + dg112*dg133) + dg123*dg311 + dg113*dg312 + - dg112*dg313 + dg111*dg323)*ginv22 + - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*ginv23)* - pow2(ginv13) + (ddg1222 - (4.*(dg123*dg222 + dg122*dg223) + - 2.*dg122*dg322)*ginv23 - - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33)*pow2(ginv22) + - (ddg1233 + ddg1323 - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)* - ginv33)*pow2(ginv23) + ginv11* - (ginv23*(ddg1113 - 2.*dg113*(dg133 + dg313)*ginv33) + - ginv22*(ddg1112 - (dg112*(4.*dg123 + 2.*dg213) + - 2.*(dg113*(dg122 + dg212) + dg112*dg312))*ginv23 - - (dg113*(2.*dg123 + dg312) + dg112*dg313)*ginv33) + - ginv12*(ddg1111 - dg111*(6.*dg113 + 2.*dg311)*ginv13 - - (dg113*(8.*dg112 + 2.*dg211) + dg112*dg311 + - dg111*(2.*(dg123 + dg213) + dg312))*ginv23 - - ginv22*(2.*(dg112*dg211 + dg111*(dg122 + dg212)) + - 6.*pow2(dg112)) - ginv33* - (dg113*dg311 + dg111*dg313 + 2.*pow2(dg113))) - - ginv13*((dg112*(4.*dg113 + dg311) + dg111*(2.*dg123 + dg312))* - ginv22 + ginv23*(dg113*dg311 + dg111*(2.*dg133 + dg313) + - 4.*pow2(dg113))) - dg111*(6.*dg112 + 2.*dg211)*pow2(ginv12) - - 2.*dg112*(dg122 + dg212)*pow2(ginv22) - - (2.*(dg112*dg133 + dg113*(dg123 + dg213)) + dg113*dg312 + dg112*dg313)* - pow2(ginv23)) + ginv13*(ginv22* - (ddg1123 + ddg1312 - (dg133*(2.*dg123 + dg312) + - 2.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33 - - ginv23*(2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg113*dg223 + - dg112*dg233) + dg122*dg313 + dg113*dg322 + - 4.*(dg123*dg312 + dg112*dg323 + pow2(dg123)))) + - ginv23*(ddg1133 + ddg1313 - - ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))) - - (2.*(dg123*(dg122 + dg212) + dg112*dg223) + dg122*dg312 + - dg112*dg322)*pow2(ginv22) - - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*pow2(ginv23)\ -) + ginv23*(ddg1333*ginv33 - 2.*dg133*dg333*pow2(ginv33)) + - ginv12*(ddg1313*ginv33 + ginv13* - (ddg1113 + ddg1311 - (2.* - (dg123*dg211 + dg113*(dg122 + dg212) + dg111*dg223) + - dg122*dg311 + dg112*(8.*dg123 + 2.*dg213 + 4.*dg312) + - dg111*dg322)*ginv22 - - (dg133*(4.*dg112 + 2.*dg211) + - dg113*(8.*dg123 + 4.*(dg213 + dg312)) + 4.*dg112*dg313 + - 2.*(dg123*dg311 + dg111*(dg233 + dg323)))*ginv23 - - (dg133*(2.*dg113 + dg311) + 4.*dg113*dg313 + dg111*dg333)*ginv33) + - ginv23*(ddg1123 + 2.*ddg1213 + ddg1312 - - (2.*(dg133*(dg123 + dg213) + dg113*dg233) + dg133*dg312 + - 4.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33) + - ginv22*(ddg1122 + 2.*ddg1212 - - (4.*(dg122*dg213 + dg113*dg222) + - 6.*(dg123*(dg122 + dg212) + dg112*dg223) + - 3.*(dg122*dg312 + dg112*dg322))*ginv23 - - ginv33*(dg122*dg313 + dg113*dg322 + - 2.*(dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323 + - pow2(dg123)))) - - 2.*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow2(ginv13) - - (4.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))*pow2(ginv22) - - (4.*(dg123*dg213 + dg113*dg223) + - 2.*(dg133*(dg122 + dg212) + dg123*dg312 + dg122*dg313 + - dg113*dg322 + dg112*(dg233 + dg323) + pow2(dg123)))*pow2(ginv23) \ -- (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + - ginv22*(ddg1323*ginv33 + ginv23* - (2.*ddg1223 + ddg1322 - (2.*(dg133*dg223 + dg123*dg233) + - dg133*dg322 + 6.*dg123*dg323 + dg122*dg333)*ginv33) - - (2.*(dg133*dg222 + dg122*dg233) + dg123*(6.*dg223 + 3.*dg322) + - 3.*dg122*dg323)*pow2(ginv23) - - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) -; - -dGfromgdu13 -= --((dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* - Power(ginv23,3)) - 2.*(dg133*dg333*Power(ginv33,3) + - Power(ginv13,3)*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113)) + - (dg111*(dg112*ginv23 + dg113*ginv33) + ginv13*pow2(dg111))*pow2(ginv11)\ -) - ((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*ginv23 + - (2.*(dg113*dg122 + dg112*dg123) + dg123*dg211 + dg113*dg212 + - dg112*dg213 + dg111*dg223)*ginv33 + - 2.*ginv13*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)))* - pow2(ginv12) + (ddg1113 + ddg1311 - - (dg123*(2.*dg112 + dg211) + dg113*dg212 + dg111*dg223 + - dg112*(dg213 + 2.*dg312))*ginv22 - - (dg133*dg211 + 2.*(dg113*dg213 + dg123*dg311) + - 4.*(dg113*(dg123 + dg312) + dg112*(dg133 + dg313)) + - dg111*(dg233 + 2.*dg323))*ginv23 - - (dg133*(6.*dg113 + 2.*dg311) + 6.*dg113*dg313 + 2.*dg111*dg333)*ginv33\ -)*pow2(ginv13) - (2.*dg122*dg222*ginv23 + - (dg123*dg222 + dg122*dg223)*ginv33)*pow2(ginv22) + - (ddg1223 + ddg1322 - (3.*(dg133*dg223 + dg123*dg233) + 6.*dg123*dg323 + - 2.*(dg133*dg322 + dg122*dg333))*ginv33)*pow2(ginv23) + - ddg1333*pow2(ginv33) + ginv11* - (ddg1113*ginv33 - ginv22*(2.*dg112*(dg122 + dg212)*ginv23 + - (dg113*dg212 + dg112*(2.*dg123 + dg213))*ginv33) + - ginv23*(ddg1112 - (dg113*(4.*dg123 + 2.*dg213) + - 2.*(dg113*dg312 + dg112*(dg133 + dg313)))*ginv33) - - ginv12*(dg111*(6.*dg112 + 2.*dg211)*ginv13 + - (dg113*(4.*dg112 + dg211) + dg111*(2.*dg123 + dg213))*ginv33 + - ginv23*(dg112*dg211 + dg111*(2.*dg122 + dg212) + 4.*pow2(dg112))) + - ginv13*(ddg1111 - (dg113*(8.*dg112 + dg211) + 2.*dg112*dg311 + - dg111*(dg213 + 2.*(dg123 + dg312)))*ginv23 - - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - - ginv33*(2.*(dg113*dg311 + dg111*(dg133 + dg313)) + 6.*pow2(dg113))) \ -- dg111*(6.*dg113 + 2.*dg311)*pow2(ginv13) - - (dg113*dg212 + dg112*dg213 + - 2.*(dg113*dg122 + dg112*(dg123 + dg312)))*pow2(ginv23) - - 2.*dg113*(dg133 + dg313)*pow2(ginv33)) + - ginv12*((ddg1123 + ddg1213)*ginv33 + - ginv13*(ddg1112 + ddg1211 - - (dg122*(2.*dg112 + dg211) + 4.*dg112*dg212 + dg111*dg222)*ginv22 - - (dg123*(8.*dg112 + 2.*dg211) + - 4.*(dg113*(dg122 + dg212) + dg112*(dg213 + dg312)) + - 2.*(dg122*dg311 + dg111*(dg223 + dg322)))*ginv23 - - (dg133*(2.*dg112 + dg211) + - dg113*(8.*dg123 + 4.*dg213 + 2.*dg312) + - 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* - ginv33) - ginv22*((dg122*dg213 + dg113*dg222 + - 2.*(dg123*(dg122 + dg212) + dg112*dg223))*ginv33 + - ginv23*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))) + - ginv23*(ddg1122 + ddg1212 - - ginv33*(dg133*(2.*dg122 + dg212) + - 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322) + - dg112*(dg233 + 2.*dg323) + - 4.*(dg123*dg213 + dg113*dg223 + pow2(dg123)))) - - (4.*(dg112*dg113 + dg111*dg123) + - 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))* - pow2(ginv13) - (dg123*(4.*dg122 + 2.*dg212) + - 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* - pow2(ginv23) - (dg133*(2.*dg123 + dg213) + 2.*dg123*dg313 + - dg113*(dg233 + 2.*dg323))*pow2(ginv33)) + - ginv22*(ddg1223*ginv33 + ginv23* - (ddg1222 - (dg133*dg222 + dg123*(6.*dg223 + 2.*dg322) + - dg122*(dg233 + 2.*dg323))*ginv33) - - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*pow2(ginv23) - - (dg133*dg223 + dg123*(dg233 + 2.*dg323))*pow2(ginv33)) + - ginv23*((ddg1233 + 2.*ddg1323)*ginv33 - - (dg133*(2.*dg233 + 4.*dg323) + 4.*dg123*dg333)*pow2(ginv33)) + - ginv13*((ddg1133 + 2.*ddg1313)*ginv33 + - ginv23*(ddg1123 + ddg1213 + 2.*ddg1312 - - (dg133*(6.*dg123 + 3.*dg213 + 4.*dg312) + 6.*dg123*dg313 + - dg113*(3.*dg233 + 6.*dg323) + 4.*dg112*dg333)*ginv33) + - ginv22*(ddg1212 - (dg123*(2.*dg122 + 4.*dg212) + dg113*dg222 + - dg122*(dg213 + 2.*dg312) + dg112*(4.*dg223 + 2.*dg322))*ginv23 - - ginv33*(dg133*dg212 + dg112*(dg233 + 2.*dg323) + - 2.*(dg113*dg223 + dg123*(dg213 + dg312) + pow2(dg123)))) - - (dg122*dg212 + dg112*dg222)*pow2(ginv22) - - (4.*(dg123*dg312 + dg112*dg323) + - 2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg112*dg233 + - dg122*dg313 + dg113*(dg223 + dg322) + pow2(dg123)))*pow2(ginv23) \ -- (4.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))*pow2(ginv33)) -; - -dGfromgdu21 -= --((dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + dg211*dg333)* - Power(ginv13,3)) - 2.*(dg111*dg211*Power(ginv11,3) + - Power(ginv12,3)*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212))) + - (ddg1211 - (4.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - - 2.*(dg112 + dg211)*dg212*ginv22 - - (2.*(dg113*dg212 + (dg112 + dg211)*dg213) + dg212*dg311 + - dg211*dg312)*ginv23 - - (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33 - - ginv12*(4.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211)))*pow2(ginv11) \ -+ (ddg1222 + ddg2212 - (4.*(dg212*(dg123 + dg213) + - (dg112 + dg211)*dg223) + dg222*dg311 + - 2.*(dg122*dg213 + dg113*dg222 + dg212*dg312) + dg211*dg322)*ginv13 \ -- (2.*dg122 + 6.*dg212)*dg222*ginv22 - - ((2.*dg122 + 4.*dg212)*dg223 + - dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)*ginv23 - - (dg223*(2.*(dg123 + dg213) + dg312) + dg222*dg313 + dg213*dg322 + - dg212*dg323)*ginv33)*pow2(ginv12) + - (ddg1233 + ddg2313 - (2.*((dg123 + dg213)*dg223 + dg212*dg233) + - dg223*dg312 + dg212*dg323)*ginv22 - - (dg233*(4.*dg213 + 2.*dg312) + - 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + - dg212*dg333))*ginv23 - - (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33)*pow2(ginv13) + - ginv11*(ddg2313*ginv33 + ginv22* - (ddg2212 - (dg222*(2.*dg213 + dg312) + dg212*(4.*dg223 + dg322))* - ginv23 - (dg223*(2.*dg213 + dg312) + dg212*dg323)*ginv33) + - ginv23*(ddg2213 + ddg2312 - - (dg233*(2.*dg213 + dg312) + 2.*(dg223*dg313 + dg213*dg323) + - dg212*dg333)*ginv33) + - ginv13*(2.*ddg1213 + ddg2311 - - (2.*(dg112 + dg211)*dg223 + - dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv22 - - (2.*(dg133*dg213 + dg113*dg233) + dg233*dg311 + 6.*dg213*dg313 + - dg211*dg333)*ginv33 - - ginv23*(2.*(dg133*dg212 + dg123*dg213 + dg113*dg223 + - (dg112 + dg211)*dg233) + dg223*dg311 + dg211*dg323 + - 4.*(dg213*dg312 + dg212*dg313 + pow2(dg213)))) + - ginv12*(2.*ddg1212 + ddg2211 - - (6.*(dg113*dg212 + dg112*dg213) + 4.*dg111*dg223 + - 3.*dg212*dg311 + dg211*(4.*dg123 + 6.*dg213 + 3.*dg312))*ginv13 \ -- (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + - (dg112 + dg211)*dg223) + dg222*dg311 + - dg212*(8.*dg213 + 4.*dg312) + dg211*dg322)*ginv23 - - ginv22*(2.*(dg122*dg212 + (dg112 + dg211)*dg222) + - 6.*pow2(dg212)) - ginv33* - (dg223*dg311 + dg211*dg323 + - 2.*(dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313 + - pow2(dg213)))) - - (6.*dg112*dg212 + dg211*(2.*dg122 + 6.*dg212) + 2.*dg111*dg222)* - pow2(ginv12) - (2.*(dg133*dg211 + dg111*dg233) + - dg213*(6.*dg113 + 3.*dg311) + 3.*dg211*dg313)*pow2(ginv13) - - 2.*dg212*dg222*pow2(ginv22) - - (2.*(dg213*dg223 + dg212*dg233) + dg223*dg312 + dg222*dg313 + - dg213*dg322 + dg212*dg323)*pow2(ginv23) - - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + - ginv12*(ddg2323*ginv33 + ginv13* - (2.*ddg1223 + ddg2213 + ddg2312 - - (2.*((dg123 + dg213)*dg222 + dg122*dg223) + dg222*dg312 + - dg212*(8.*dg223 + dg322))*ginv22 - - (dg223*(8.*dg213 + 4.*(dg123 + dg312)) + - 2.*(dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322) + - 4.*dg212*(dg233 + dg323))*ginv23 - - (2.*(dg133*dg223 + (dg123 + dg213)*dg233) + dg233*dg312 + - 4.*(dg223*dg313 + dg213*dg323) + dg212*dg333)*ginv33) + - ginv23*(ddg2223 + ddg2322 - - (dg233*(2.*dg223 + dg322) + 4.*dg223*dg323 + dg222*dg333)*ginv33) + - ginv22*(ddg2222 - dg222*(6.*dg223 + 2.*dg322)*ginv23 - - ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223))) - - (4.*(dg123*dg213 + dg113*dg223) + - 2.*((dg112 + dg211)*dg233 + dg223*dg311 + dg213*dg312 + - dg212*(dg133 + dg313) + dg211*dg323 + pow2(dg213)))*pow2(ginv13) \ -- 2.*(pow2(dg222)*pow2(ginv22) + - (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))*pow2(ginv23)) - - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) + - ginv13*(ddg2333*ginv33 + ginv22* - (ddg2223 - 2.*dg223*(dg233 + dg323)*ginv33 - - ginv23*(dg223*dg322 + dg222*(2.*dg233 + dg323) + 4.*pow2(dg223))) + - ginv23*(ddg2233 + ddg2323 - - ginv33*(3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))) - - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)* - pow2(ginv23) - 2.*(dg222*dg223*pow2(ginv22) + dg233*dg333*pow2(ginv33))\ -) -; - -dGfromgdu22 -= --((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)* - Power(ginv12,3)) - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + - dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv22,3)*pow2(dg222) - - (2.*dg111*dg211*ginv12 + (dg112*dg211 + dg111*dg212)*ginv22 + - (dg113*dg211 + dg111*dg213)*ginv23)*pow2(ginv11) + - (ddg1212 + ddg2211 - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + - dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))*ginv13 - - (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + dg112*dg223) + - dg222*dg311 + dg212*(8.*dg213 + 2.*dg312) + - dg211*(4.*dg223 + dg322))*ginv23 - - ginv22*(4.*dg211*dg222 + 3.*(dg122*dg212 + dg112*dg222) + - 6.*pow2(dg212)) - ginv33* - (dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + dg212*dg313 + - dg211*dg323 + 2.*pow2(dg213)))*pow2(ginv12) - - ((dg112*dg233 + dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + - dg212*(dg133 + dg313) + dg211*dg323)*ginv22 + - (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + - dg211*dg333)*ginv23)*pow2(ginv13) + - (ddg2222 - dg222*(8.*dg223 + 2.*dg322)*ginv23 - - ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223)))*pow2(ginv22) + - (ddg2233 + ddg2323 - ginv33* - (3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233)))*pow2(ginv23) + - ginv13*(ginv22*(ddg1223 + ddg2312 - - (dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322 + - 4.*(dg223*(dg123 + dg213 + dg312) + dg212*(dg233 + dg323)))* - ginv23 - (dg233*(dg123 + dg312) + dg223*(dg133 + 2.*dg313) + - 2.*dg213*dg323 + dg212*dg333)*ginv33) + - ginv23*(ddg1233 + ddg2313 - - (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33) - - ((dg122 + 4.*dg212)*dg223 + dg222*(dg123 + dg312) + dg212*dg322)* - pow2(ginv22) - (dg233*(4.*dg213 + 2.*dg312) + - 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + - dg212*dg333))*pow2(ginv23)) + - ginv11*(-(ginv13*((2.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + - dg212*dg311 + dg211*(dg123 + dg312))*ginv22 + - (dg111*dg233 + dg213*(4.*dg113 + dg311) + dg211*(dg133 + dg313))* - ginv23)) + ginv12*(ddg1211 - - (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - - (6.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv22 - - (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + dg212*dg311 + - dg211*(dg123 + 4.*dg213 + dg312))*ginv23 - - (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33) + - ginv22*(ddg1212 - (dg122*dg213 + dg113*dg222 + 2.*dg112*dg223 + - dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv23 - - (dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313)*ginv33) + - ginv23*(ddg1213 - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*ginv33) - - (3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))*pow2(ginv12) - - (dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))*pow2(ginv22) - - (dg113*dg223 + dg112*dg233 + dg213*(dg123 + dg312) + - dg212*(dg133 + dg313) + 2.*pow2(dg213))*pow2(ginv23)) + - ginv23*(ddg2333*ginv33 - 2.*dg233*dg333*pow2(ginv33)) + - ginv12*(ddg2313*ginv33 + ginv22* - (ddg1222 + 2.*ddg2212 - - ((3.*dg122 + 12.*dg212)*dg223 + - dg222*(8.*dg213 + 3.*(dg123 + dg312)) + 3.*dg212*dg322)*ginv23 \ -- (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + dg222*dg313 + dg213*dg322 + - 2.*dg212*dg323)*ginv33) + - ginv23*(ddg1223 + 2.*ddg2213 + ddg2312 - - (dg233*(dg123 + 4.*dg213 + dg312) + dg223*(dg133 + 4.*dg313) + - 4.*dg213*dg323 + dg212*dg333)*ginv33) + - ginv13*(ddg1213 + ddg2311 - - (dg122*dg213 + dg222*(dg113 + dg311) + - 4.*((dg112 + dg211)*dg223 + dg212*(dg123 + dg213 + dg312)) + - dg211*dg322)*ginv22 - - (dg233*(dg113 + dg311) + dg213*(dg133 + 4.*dg313) + dg211*dg333)* - ginv33 - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg223*dg311 + - dg211*dg323) + 4.* - (dg113*dg223 + dg211*dg233 + dg213*(dg123 + dg312) + - dg212*dg313 + pow2(dg213)))) - - (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* - pow2(ginv13) - (2.*dg122 + 8.*dg212)*dg222*pow2(ginv22) - - ((dg122 + 4.*dg212)*dg233 + dg223*(8.*dg213 + 2.*(dg123 + dg312)) + - dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* - pow2(ginv23) - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + - ginv22*(ddg2323*ginv33 + ginv23* - (2.*ddg2223 + ddg2322 - (dg233*(4.*dg223 + dg322) + 6.*dg223*dg323 + - dg222*dg333)*ginv33) - - (3.*dg223*dg322 + dg222*(4.*dg233 + 3.*dg323) + 6.*pow2(dg223))* - pow2(ginv23) - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) -; - -dGfromgdu23 -= --((dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* - Power(ginv13,3)) - (2.*dg111*dg211*ginv13 + - (dg112*dg211 + dg111*dg212)*ginv23 + - (dg113*dg211 + dg111*dg213)*ginv33)*pow2(ginv11) - - ((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv13 + - (dg122*dg213 + dg212*(dg123 + 2.*dg213) + dg113*dg222 + - (dg112 + 2.*dg211)*dg223)*ginv33 + - 2.*ginv23*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212)))* - pow2(ginv12) + (ddg1213 + ddg2311 - - ((dg112 + 2.*dg211)*dg223 + dg212*(dg123 + 2.*(dg213 + dg312)))* - ginv22 - (3.*(dg133*dg213 + dg113*dg233) + 6.*dg213*dg313 + - 2.*(dg233*dg311 + dg211*dg333))*ginv33 - - ginv23*(4.*(dg213*dg312 + dg212*dg313) + - 2.*(dg133*dg212 + dg123*dg213 + (dg112 + dg211)*dg233 + - dg223*(dg113 + dg311) + dg211*dg323 + pow2(dg213))))*pow2(ginv13) \ -- 2.*(dg233*dg333*Power(ginv33,3) + - Power(ginv23,3)*(dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223)) + - (dg222*dg223*ginv33 + ginv23*pow2(dg222))*pow2(ginv22)) + - (ddg2223 + ddg2322 - (dg233*(6.*dg223 + 2.*dg322) + 6.*dg223*dg323 + - 2.*dg222*dg333)*ginv33)*pow2(ginv23) + ddg2333*pow2(ginv33) + - ginv11*(ddg1213*ginv33 + ginv13* - (ddg1211 - 2.*(dg112 + dg211)*dg212*ginv22 - - (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + 2.*dg212*dg311 + - dg211*(dg123 + 2.*(dg213 + dg312)))*ginv23 - - (dg111*dg233 + dg213*(6.*dg113 + 2.*dg311) + - dg211*(dg133 + 2.*dg313))*ginv33) - - ginv12*((4.*dg112*dg212 + dg211*(dg122 + 2.*dg212) + dg111*dg222)* - ginv23 + (dg211*(dg123 + 2.*dg213) + - 2.*(dg113*dg212 + dg112*dg213) + dg111*dg223)*ginv33 + - ginv13*(3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))) - - ginv22*((dg212*(dg123 + 2.*dg213) + dg112*dg223)*ginv33 + - ginv23*(dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))) + - ginv23*(ddg1212 - ginv33* - (dg112*dg233 + dg212*(dg133 + 2.*dg313) + - 2.*(dg113*dg223 + dg213*(dg123 + dg312) + pow2(dg213)))) - - (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*pow2(ginv13) - - (dg122*dg213 + dg113*dg222 + dg112*dg223 + - dg212*(dg123 + 2.*(dg213 + dg312)))*pow2(ginv23) - - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*pow2(ginv33)) + - ginv22*(ddg2223*ginv33 + ginv23* - (ddg2222 - ginv33*(2.*(dg223*dg322 + dg222*(dg233 + dg323)) + - 6.*pow2(dg223))) - dg222*(6.*dg223 + 2.*dg322)*pow2(ginv23) - - 2.*dg223*(dg233 + dg323)*pow2(ginv33)) + - ginv12*((ddg1223 + ddg2213)*ginv33 - - ginv22*((2.*dg122 + 6.*dg212)*dg222*ginv23 + - ((dg123 + 2.*dg213)*dg222 + (dg122 + 4.*dg212)*dg223)*ginv33) + - ginv23*(ddg1222 + ddg2212 - - ((dg122 + 2.*dg212)*dg233 + - dg223*(4.*dg123 + 8.*dg213 + 2.*dg312) + - dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* - ginv33) + ginv13*(ddg1212 + ddg2211 - - (4.*(dg112 + dg211)*dg223 + - dg212*(8.*dg213 + 4.*(dg123 + dg312)) + - 2.*(dg122*dg213 + dg222*(dg113 + dg311) + dg211*dg322))*ginv23 \ -- ginv22*(dg122*dg212 + (dg112 + 2.*dg211)*dg222 + 4.*pow2(dg212)) - - ginv33*((dg112 + 2.*dg211)*dg233 + dg212*(dg133 + 2.*dg313) + - 2.*(dg223*dg311 + dg213*dg312 + dg211*dg323) + - 4.*(dg123*dg213 + dg113*dg223 + pow2(dg213)))) - - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + - dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))* - pow2(ginv13) - ((2.*dg122 + 4.*dg212)*dg223 + - dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)* - pow2(ginv23) - ((dg123 + 2.*dg213)*dg233 + - dg223*(dg133 + 2.*dg313) + 2.*dg213*dg323)*pow2(ginv33)) + - ginv13*((ddg1233 + 2.*ddg2313)*ginv33 + - ginv22*(ddg2212 - ((dg122 + 8.*dg212)*dg223 + - dg222*(dg123 + 2.*(dg213 + dg312)) + 2.*dg212*dg322)*ginv23 - - (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*(dg233 + dg323))* - ginv33) + ginv23*(ddg1223 + ddg2213 + 2.*ddg2312 - - (3.*(dg133*dg223 + dg123*dg233) + dg233*(6.*dg213 + 4.*dg312) + - 6.*(dg223*dg313 + dg213*dg323) + 4.*dg212*dg333)*ginv33) - - 2.*dg212*dg222*pow2(ginv22) - - ((dg122 + 4.*dg212)*dg233 + dg223*(2.*dg123 + 4.*(dg213 + dg312)) + - dg222*(dg133 + 2.*dg313) + 2.*dg213*dg322 + 4.*dg212*dg323)* - pow2(ginv23) - (dg233*(2.*dg133 + 4.*dg313) + 4.*dg213*dg333)* - pow2(ginv33)) + ginv23*((ddg2233 + 2.*ddg2323)*ginv33 - - (4.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))*pow2(ginv33)) -; - -dGfromgdu31 -= --((dg222*dg311 + dg211*dg322 + 2.*((dg122 + dg212)*dg312 + dg112*dg322))* - Power(ginv12,3)) - 2.*(dg111*dg311*Power(ginv11,3) + - Power(ginv13,3)*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313))) + - (ddg1311 - ((4.*dg112 + 2.*dg211)*dg311 + 4.*dg111*dg312)*ginv12 - - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - - (dg311*(dg213 + 2.*dg312) + dg211*dg313 + - 2.*(dg113*dg312 + dg112*dg313))*ginv23 - - 2.*(dg113 + dg311)*dg313*ginv33 - - ginv13*(4.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311)))*pow2(ginv11) \ -+ (ddg1322 + ddg2312 - (2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))* - ginv22 - ((2.*dg213 + 4.*dg312)*dg322 + - 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + - (dg122 + dg212)*dg323))*ginv23 - - (dg313*(dg223 + 2.*dg322) + (dg213 + 2.*(dg123 + dg312))*dg323)* - ginv33 - ginv13*(4.*(dg123*dg312 + dg112*dg323) + - 2.*(dg213*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + - dg311*(dg223 + dg322) + dg211*dg323 + pow2(dg312))))*pow2(ginv12) \ -+ (ddg1333 + ddg3313 - (dg233*dg312 + dg223*dg313 + - (dg213 + 2.*(dg123 + dg312))*dg323 + dg212*dg333)*ginv22 - - (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + - 4.*(dg313*dg323 + dg312*dg333))*ginv23 - - (2.*dg133 + 6.*dg313)*dg333*ginv33)*pow2(ginv13) + - ginv11*(ddg3313*ginv33 + ginv22* - (ddg2312 - (dg222*dg313 + dg213*dg322 + - 2.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - - (dg223*dg313 + (dg213 + 2.*dg312)*dg323)*ginv33) + - ginv23*(ddg2313 + ddg3312 - - (dg313*(dg233 + 4.*dg323) + (dg213 + 2.*dg312)*dg333)*ginv33) + - ginv12*(2.*ddg1312 + ddg2311 - - (dg311*(4.*dg123 + 3.*dg213 + 6.*dg312) + 3.*dg211*dg313 + - 6.*(dg113*dg312 + dg112*dg313) + 4.*dg111*dg323)*ginv13 - - (dg222*dg311 + (2.*dg122 + 6.*dg212)*dg312 + - (2.*dg112 + dg211)*dg322)*ginv22 - - (4.*dg312*dg313 + 2.*((dg123 + dg213)*dg313 + - (dg113 + dg311)*dg323))*ginv33 - - ginv23*((2.*dg123 + 4.*dg213)*dg312 + dg311*(dg223 + 2.*dg322) + - dg211*dg323 + 2.*(dg122*dg313 + dg113*dg322 + dg112*dg323) + - 4.*(dg212*dg313 + pow2(dg312)))) + - ginv13*(2.*ddg1313 + ddg3311 - - ((4.*dg213 + 8.*dg312)*dg313 + dg311*(dg233 + 2.*dg323) + - dg211*dg333 + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + - dg112*dg333))*ginv23 - - ginv22*(dg223*dg311 + dg211*dg323 + - 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + - pow2(dg312))) - - ginv33*(2.*(dg133*dg313 + (dg113 + dg311)*dg333) + 6.*pow2(dg313))) \ -- ((2.*dg122 + 3.*dg212)*dg311 + (6.*dg112 + 3.*dg211)*dg312 + - 2.*dg111*dg322)*pow2(ginv12) - - (6.*dg113*dg313 + dg311*(2.*dg133 + 6.*dg313) + 2.*dg111*dg333)* - pow2(ginv13) - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - - (dg313*(dg223 + 2.*dg322) + dg213*dg323 + dg312*(dg233 + 2.*dg323) + - dg212*dg333)*pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + - ginv12*(ddg3323*ginv33 + ginv13* - (2.*ddg1323 + ddg2313 + ddg3312 - - (dg222*dg313 + (2.*dg123 + dg213)*dg322 + - dg312*(4.*dg223 + 2.*dg322) + (2.*dg122 + 4.*dg212)*dg323)* - ginv22 - ((4.*dg213 + 8.*dg312)*dg323 + - 4.*(dg313*(dg223 + dg322) + dg123*dg323) + - 2.*(dg233*dg312 + dg133*dg322 + (dg122 + dg212)*dg333))*ginv23 \ -- (dg313*(dg233 + 8.*dg323) + (dg213 + 2.*dg312)*dg333 + - 2.*(dg133*dg323 + dg123*dg333))*ginv33) + - ginv22*(ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - - ginv23*(3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))) + - ginv23*(ddg2323 + ddg3322 - - ginv33*(dg233*dg323 + (dg223 + 2.*dg322)*dg333 + 4.*pow2(dg323))) - - (dg311*(dg233 + 4.*dg323) + - 4.*((dg123 + dg312)*dg313 + dg113*dg323) + dg211*dg333 + - 2.*(dg133*dg312 + dg213*dg313 + dg112*dg333))*pow2(ginv13) - - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* - pow2(ginv23) - 2.*(dg222*dg322*pow2(ginv22) + - dg323*dg333*pow2(ginv33))) + - ginv13*(ddg3333*ginv33 + ginv23* - (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33) + - ginv22*(ddg2323 - (4.*dg223*dg323 + dg322*(dg233 + 2.*dg323) + - dg222*dg333)*ginv23 - - ginv33*(dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))) - - (dg223*dg322 + dg222*dg323)*pow2(ginv22) - - 2.*((dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow2(ginv23) + - pow2(dg333)*pow2(ginv33))) -; - -dGfromgdu32 -= --(((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* - Power(ginv12,3)) - 2.*(dg222*dg322*Power(ginv22,3) + - Power(ginv23,3)*(dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))) - - (2.*dg111*dg311*ginv12 + (dg112*dg311 + dg111*dg312)*ginv22 + - (dg113*dg311 + dg111*dg313)*ginv23)*pow2(ginv11) + - (ddg1312 + ddg2311 - (4.*dg311*dg312 + - 2.*((dg123 + dg213)*dg311 + dg113*dg312 + - (dg112 + dg211)*dg313 + dg111*dg323))*ginv13 - - ((3.*dg122 + 6.*dg212)*dg312 + 3.*dg112*dg322 + - 2.*(dg222*dg311 + dg211*dg322))*ginv22 - - ((dg123 + 2.*(dg213 + dg312))*dg313 + (dg113 + 2.*dg311)*dg323)* - ginv33 - ginv23*(4.*(dg213*dg312 + dg212*dg313) + - 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322 + - dg311*(dg223 + dg322) + (dg112 + dg211)*dg323 + pow2(dg312))))* - pow2(ginv12) - ((dg123*dg313 + dg312*(dg133 + 2.*dg313) + - (dg113 + 2.*dg311)*dg323 + dg112*dg333)*ginv22 + - 2.*ginv23*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313)))* - pow2(ginv13) + (ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - - ginv23*(4.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322)))*pow2(ginv22) \ -+ (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33)*pow2(ginv23) + - ginv11*(-(ginv13*((dg311*(dg123 + 2.*dg312) + - 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv22 + - (4.*dg113*dg313 + dg311*(dg133 + 2.*dg313) + dg111*dg333)*ginv23)\ -) + ginv12*(ddg1311 - ((dg122 + 2.*dg212)*dg311 + - (6.*dg112 + 2.*dg211)*dg312 + dg111*dg322)*ginv22 - - (dg311*(dg123 + 2.*(dg213 + dg312)) + 2.*dg211*dg313 + - 4.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv23 - - 2.*(dg113 + dg311)*dg313*ginv33 - - ginv13*(3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))) + - ginv22*(ddg1312 - ((dg123 + 2.*dg312)*dg313 + dg113*dg323)*ginv33 - - ginv23*(dg122*dg313 + dg113*dg322 + - 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + - pow2(dg312)))) + - ginv23*(ddg1313 - ginv33* - (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))) - - ((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*pow2(ginv12) - - ((dg122 + 2.*dg212)*dg312 + dg112*dg322)*pow2(ginv22) - - (dg133*dg312 + (dg123 + 2.*(dg213 + dg312))*dg313 + dg113*dg323 + - dg112*dg333)*pow2(ginv23)) + - ginv13*(ginv23*(ddg1333 + ddg3313 - (2.*dg133 + 6.*dg313)*dg333*ginv33) + - ginv22*(ddg1323 + ddg3312 - - (dg133*dg322 + (4.*dg123 + 2.*dg213 + 8.*dg312)*dg323 + - dg122*dg333 + 2.*(dg233*dg312 + dg313*(dg223 + dg322) + - dg212*dg333))*ginv23 - - ((dg133 + 4.*dg313)*dg323 + (dg123 + 2.*dg312)*dg333)*ginv33) - - (dg123*dg322 + dg122*dg323 + - 2.*(dg312*(dg223 + dg322) + dg212*dg323))*pow2(ginv22) - - (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + - 4.*(dg313*dg323 + dg312*dg333))*pow2(ginv23)) + - ginv12*(ddg3313*ginv33 + ginv22* - (ddg1322 + 2.*ddg2312 - - (4.*(dg222*dg313 + dg213*dg322) + - 3.*(dg123*dg322 + dg122*dg323) + - 6.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - - ((2.*dg213 + 4.*dg312)*dg323 + - 2.*(dg313*(dg223 + dg322) + dg123*dg323))*ginv33) + - ginv23*(ddg1323 + 2.*ddg2313 + ddg3312 - - (dg133*dg323 + dg313*(2.*dg233 + 8.*dg323) + - (dg123 + 2.*(dg213 + dg312))*dg333)*ginv33) + - ginv13*(ddg1313 + ddg3311 - - (8.*dg312*dg313 + 4.* - ((dg123 + dg213)*dg313 + (dg113 + dg311)*dg323) + - 2.*(dg233*dg311 + dg133*dg312 + (dg112 + dg211)*dg333))*ginv23 \ -- ginv22*(dg122*dg313 + dg113*dg322 + - 2.*(dg213*dg312 + dg212*dg313 + dg311*(dg223 + dg322) + - dg211*dg323) + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg312))) \ -- ginv33*(dg133*dg313 + (dg113 + 2.*dg311)*dg333 + 4.*pow2(dg313))) - - (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* - pow2(ginv13) - (2.*dg122*dg322 + 4.*(dg222*dg312 + dg212*dg322))* - pow2(ginv22) - (dg133*dg322 + - 4.*(dg313*(dg223 + dg322) + (dg213 + dg312)*dg323) + - dg122*dg333 + 2.*(dg233*dg312 + dg123*dg323 + dg212*dg333))* - pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + - ginv22*(ddg3323*ginv33 + ginv23* - (2.*ddg2323 + ddg3322 - - ginv33*(2.*(dg233*dg323 + (dg223 + dg322)*dg333) + 6.*pow2(dg323))) \ -- (6.*dg223*dg323 + dg322*(2.*dg233 + 6.*dg323) + 2.*dg222*dg333)* - pow2(ginv23) - 2.*dg323*dg333*pow2(ginv33)) + - ginv23*(ddg3333*ginv33 - 2.*pow2(dg333)*pow2(ginv33)) -; - -dGfromgdu33 -= --((2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* - Power(ginv13,3)) - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + - dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv33,3)*pow2(dg333) - - (2.*dg111*dg311*ginv13 + (dg112*dg311 + dg111*dg312)*ginv23 + - (dg113*dg311 + dg111*dg313)*ginv33)*pow2(ginv11) - - (((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* - ginv13 + (dg222*dg311 + dg211*dg322 + - 2.*((dg122 + dg212)*dg312 + dg112*dg322))*ginv23 + - (dg223*dg311 + (dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + - dg113*dg322 + (dg112 + dg211)*dg323)*ginv33)*pow2(ginv12) + - (ddg1313 + ddg3311 - ((2.*dg213 + 8.*dg312)*dg313 + - dg311*(dg233 + 4.*dg323) + dg211*dg333 + - 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + dg112*dg333))*ginv23 \ -- ginv22*(dg223*dg311 + (dg123 + dg213)*dg312 + dg212*dg313 + - (dg112 + dg211)*dg323 + 2.*pow2(dg312)) - - ginv33*(4.*dg311*dg333 + 3.*(dg133*dg313 + dg113*dg333) + - 6.*pow2(dg313)))*pow2(ginv13) - - (2.*dg222*dg322*ginv23 + (dg223*dg322 + dg222*dg323)*ginv33)* - pow2(ginv22) + (ddg2323 + ddg3322 - - ginv33*(4.*dg322*dg333 + 3.*(dg233*dg323 + dg223*dg333) + - 6.*pow2(dg323)))*pow2(ginv23) + ddg3333*pow2(ginv33) + - ginv13*((ddg1333 + 2.*ddg3313)*ginv33 + - ginv22*(ddg2312 - (dg222*dg313 + (dg123 + dg213)*dg322 + - dg122*dg323 + 4.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 \ -- (dg312*(dg233 + 4.*dg323) + 2.*(dg223*dg313 + (dg123 + dg213)*dg323) + - dg212*dg333)*ginv33) + - ginv23*(ddg1323 + ddg2313 + 2.*ddg3312 - - (12.*dg313*dg323 + (3.*dg213 + 8.*dg312)*dg333 + - 3.*(dg233*dg313 + dg133*dg323 + dg123*dg333))*ginv33) - - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - - ((dg133 + 4.*dg313)*dg322 + (2.*dg213 + 8.*dg312)*dg323 + - dg122*dg333 + 2.*(dg233*dg312 + dg223*dg313 + dg123*dg323 + - dg212*dg333))*pow2(ginv23) - - (2.*dg133 + 8.*dg313)*dg333*pow2(ginv33)) + - ginv23*((ddg2333 + 2.*ddg3323)*ginv33 - - (2.*dg233 + 8.*dg323)*dg333*pow2(ginv33)) + - ginv12*((ddg1323 + ddg2313)*ginv33 - - ginv22*((2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))*ginv23 + - (dg222*dg313 + (dg123 + dg213)*dg322 + dg122*dg323 + - 2.*(dg223*dg312 + dg212*dg323))*ginv33) + - ginv23*(ddg1322 + ddg2312 - - (dg233*dg312 + dg133*dg322 + - 4.*(dg313*(dg223 + dg322) + (dg123 + dg213 + dg312)*dg323) + - (dg122 + dg212)*dg333)*ginv33) + - ginv13*(ddg1312 + ddg2311 - - (dg222*dg311 + (dg122 + 4.*dg212)*dg312 + (dg112 + dg211)*dg322)* - ginv22 - (dg133*dg312 + dg311*(dg233 + 4.*dg323) + - 4.*((dg123 + dg213 + dg312)*dg313 + dg113*dg323) + - (dg112 + dg211)*dg333)*ginv33 - - ginv23*(2.*(dg223*dg311 + dg122*dg313 + dg113*dg322 + - dg211*dg323) + 4.* - ((dg123 + dg213)*dg312 + dg212*dg313 + dg311*dg322 + - dg112*dg323 + pow2(dg312)))) - - (4.*dg311*dg312 + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + - (dg112 + dg211)*dg313 + dg111*dg323))*pow2(ginv13) - - ((2.*dg213 + 4.*dg312)*dg322 + - 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + - (dg122 + dg212)*dg323))*pow2(ginv23) - - (dg133*dg323 + dg313*(dg233 + 4.*dg323) + (dg123 + dg213)*dg333)* - pow2(ginv33)) + ginv11*(ddg1313*ginv33 - - ginv12*(((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*ginv13 + - ((dg122 + dg212)*dg311 + (4.*dg112 + dg211)*dg312 + dg111*dg322)* - ginv23 + ((dg123 + dg213)*dg311 + dg211*dg313 + - 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv33) - - ginv22*(((dg122 + 2.*dg212)*dg312 + dg112*dg322)*ginv23 + - ((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323)*ginv33) + - ginv13*(ddg1311 - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - - ((dg123 + dg213)*dg311 + 4.*(dg113 + dg311)*dg312 + - (4.*dg112 + dg211)*dg313 + dg111*dg323)*ginv23 - - (6.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)*ginv33) + - ginv23*(ddg1312 - (dg312*(dg133 + 4.*dg313) + - 2.*((dg123 + dg213)*dg313 + dg113*dg323) + dg112*dg333)*ginv33) \ -- (3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))*pow2(ginv13) - - ((dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + - dg112*dg323 + 2.*pow2(dg312))*pow2(ginv23) - - (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))*pow2(ginv33)) + - ginv22*(ddg2323*ginv33 + ginv23* - (ddg2322 - (6.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* - ginv33) - (3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))* - pow2(ginv23) - (dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))* - pow2(ginv33)) -; - -R11 -= -dG11*g11 + dG12*g12 + dG13*g13 + gammado111*Gfromg1 + gammado112*Gfromg2 + - gammado113*Gfromg3 + (-0.5*ddg1111 + 3.*gamma111*gammado111 + - 2.*(gamma211*gammado112 + gamma311*gammado113) + - gamma211*gammado211 + gamma311*gammado311)*ginv11 + - (-ddg1211 + 3.*(gamma112*gammado111 + gamma111*gammado112) + - 2.*(gamma212*gammado112 + gamma312*gammado113 + - gamma211*gammado122 + gamma311*gammado123) + gamma212*gammado211 + - gamma211*gammado212 + gamma312*gammado311 + gamma311*gammado312)*ginv12 \ -+ (-ddg1311 + 3.*(gamma113*gammado111 + gamma111*gammado113) + - 2.*(gamma213*gammado112 + gamma313*gammado113 + - gamma211*gammado123 + gamma311*gammado133) + gamma213*gammado211 + - gamma211*gammado213 + gamma313*gammado311 + gamma311*gammado313)*ginv13 \ -+ (-0.5*ddg2211 + 3.*gamma112*gammado112 + - 2.*(gamma212*gammado122 + gamma312*gammado123) + - gamma212*gammado212 + gamma312*gammado312)*ginv22 + - (-ddg2311 + 3.*(gamma113*gammado112 + gamma112*gammado113) + - 2.*(gamma213*gammado122 + (gamma212 + gamma313)*gammado123 + - gamma312*gammado133) + gamma213*gammado212 + gamma212*gammado213 + - gamma313*gammado312 + gamma312*gammado313)*ginv23 + - (-0.5*ddg3311 + 3.*gamma113*gammado113 + - 2.*(gamma213*gammado123 + gamma313*gammado133) + gamma213*gammado213 + - gamma313*gammado313)*ginv33 -; - -R12 -= -0.5*(dG21*g11 + (dG11 + dG22)*g12 + dG23*g13 + dG12*g22 + dG13*g23 + - (gammado112 + gammado211)*Gfromg1 + - (gammado122 + gammado212)*Gfromg2 + (gammado123 + gammado213)*Gfromg3) \ -+ (-0.5*ddg1112 + gamma112*gammado111 + (gamma111 + gamma212)*gammado112 + - gamma312*gammado113 + gamma111*gammado211 + 2.*gamma211*gammado212 + - gamma311*(gammado213 + gammado312))*ginv11 + - (-ddg1212 + gamma122*gammado111 + (2.*gamma112 + gamma222)*gammado112 + - gamma322*gammado113 + (gamma111 + gamma212)*gammado122 + - gamma112*gammado211 + (gamma111 + 2.*gamma212)*gammado212 + - 2.*gamma211*gammado222 + - gamma312*(gammado123 + gammado213 + gammado312) + - gamma311*(gammado223 + gammado322))*ginv12 + - (-ddg1312 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + - (gamma112 + gamma323)*gammado113 + (gamma111 + gamma212)*gammado123 + - gamma312*gammado133 + gamma113*gammado211 + - (gamma111 + gamma313)*gammado213 + - 2.*(gamma213*gammado212 + gamma211*gammado223) + - gamma313*gammado312 + gamma311*(gammado233 + gammado323))*ginv13 + - (-0.5*ddg2212 + gamma122*gammado112 + (gamma112 + gamma222)*gammado122 + - gamma322*gammado123 + gamma112*gammado212 + 2.*gamma212*gammado222 + - gamma312*(gammado223 + gammado322))*ginv22 + - (-ddg2312 + gamma123*gammado112 + gamma122*gammado113 + - (gamma113 + gamma223)*gammado122 + - (gamma112 + gamma222 + gamma323)*gammado123 + gamma322*gammado133 + - gamma113*gammado212 + gamma112*gammado213 + - 2.*(gamma213*gammado222 + gamma212*gammado223) + - gamma313*(gammado223 + gammado322) + - gamma312*(gammado233 + gammado323))*ginv23 + - (-0.5*ddg3312 + gamma123*gammado113 + (gamma113 + gamma223)*gammado123 + - gamma323*gammado133 + gamma113*gammado213 + 2.*gamma213*gammado223 + - gamma313*(gammado233 + gammado323))*ginv33 -; - -R13 -= -0.5*(dG31*g11 + dG32*g12 + (dG11 + dG33)*g13 + dG12*g23 + dG13*g33 + - (gammado113 + gammado311)*Gfromg1 + - (gammado123 + gammado312)*Gfromg2 + (gammado133 + gammado313)*Gfromg3) \ -+ (-0.5*ddg1113 + gamma113*gammado111 + gamma213*gammado112 + - (gamma111 + gamma313)*gammado113 + gamma111*gammado311 + - gamma211*(gammado213 + gammado312) + 2.*gamma311*gammado313)*ginv11 + - (-ddg1213 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + - (gamma112 + gamma323)*gammado113 + gamma213*gammado122 + - (gamma111 + gamma313)*gammado123 + gamma112*gammado311 + - gamma111*gammado312 + gamma212*(gammado213 + gammado312) + - gamma211*(gammado223 + gammado322) + - 2.*(gamma312*gammado313 + gamma311*gammado323))*ginv12 + - (-ddg1313 + gamma133*gammado111 + gamma233*gammado112 + - (2.*gamma113 + gamma333)*gammado113 + - (gamma111 + gamma313)*gammado133 + gamma113*gammado311 + - gamma213*(gammado123 + gammado213 + gammado312) + - (gamma111 + 2.*gamma313)*gammado313 + - gamma211*(gammado233 + gammado323) + 2.*gamma311*gammado333)*ginv13 + - (-0.5*ddg2213 + gamma123*gammado112 + gamma223*gammado122 + - (gamma112 + gamma323)*gammado123 + gamma112*gammado312 + - gamma212*(gammado223 + gammado322) + 2.*gamma312*gammado323)*ginv22 + - (-ddg2313 + gamma133*gammado112 + gamma123*gammado113 + - gamma233*gammado122 + (gamma113 + gamma223 + gamma333)*gammado123 + - (gamma112 + gamma323)*gammado133 + gamma113*gammado312 + - gamma112*gammado313 + gamma213*(gammado223 + gammado322) + - gamma212*(gammado233 + gammado323) + - 2.*(gamma313*gammado323 + gamma312*gammado333))*ginv23 + - (-0.5*ddg3313 + gamma133*gammado113 + gamma233*gammado123 + - (gamma113 + gamma333)*gammado133 + gamma113*gammado313 + - gamma213*(gammado233 + gammado323) + 2.*gamma313*gammado333)*ginv33 -; - -R22 -= -dG21*g12 + dG22*g22 + dG23*g23 + gammado212*Gfromg1 + gammado222*Gfromg2 + - gammado223*Gfromg3 + (-0.5*ddg1122 + - gamma112*(gammado112 + 2.*gammado211) + 3.*gamma212*gammado212 + - gamma312*(2.*gammado213 + gammado312))*ginv11 + - (-ddg1222 + gamma122*(gammado112 + 2.*gammado211) + - gamma112*(gammado122 + 2.*gammado212) + - 3.*(gamma222*gammado212 + gamma212*gammado222) + - 2.*(gamma322*gammado213 + gamma312*gammado223) + - gamma322*gammado312 + gamma312*gammado322)*ginv12 + - (-ddg1322 + gamma123*(gammado112 + 2.*gammado211) + - gamma112*(gammado123 + 2.*gammado213) + - 3.*(gamma223*gammado212 + gamma212*gammado223) + - 2.*(gamma323*gammado213 + gamma312*gammado233) + - gamma323*gammado312 + gamma312*gammado323)*ginv13 + - (-0.5*ddg2222 + gamma122*(gammado122 + 2.*gammado212) + - 3.*gamma222*gammado222 + gamma322*(2.*gammado223 + gammado322))*ginv22 \ -+ (-ddg2322 + gamma123*(gammado122 + 2.*gammado212) + - gamma122*(gammado123 + 2.*gammado213) + - 3.*(gamma223*gammado222 + gamma222*gammado223) + - 2.*(gamma323*gammado223 + gamma322*gammado233) + - gamma323*gammado322 + gamma322*gammado323)*ginv23 + - (-0.5*ddg3322 + gamma123*(gammado123 + 2.*gammado213) + - 3.*gamma223*gammado223 + gamma323*(2.*gammado233 + gammado323))*ginv33 -; - -R23 -= -0.5*(dG31*g12 + dG21*g13 + dG32*g22 + (dG22 + dG33)*g23 + dG23*g33 + - (gammado213 + gammado312)*Gfromg1 + - (gammado223 + gammado322)*Gfromg2 + (gammado233 + gammado323)*Gfromg3) \ -+ (-0.5*ddg1123 + gamma113*gammado211 + gamma213*gammado212 + - (gamma212 + gamma313)*gammado213 + - gamma112*(gammado113 + gammado311) + gamma212*gammado312 + - 2.*gamma312*gammado313)*ginv11 + - (-ddg1223 + gamma123*gammado211 + (gamma113 + gamma223)*gammado212 + - (gamma222 + gamma323)*gammado213 + gamma213*gammado222 + - (gamma212 + gamma313)*gammado223 + - gamma122*(gammado113 + gammado311) + gamma222*gammado312 + - gamma112*(gammado123 + gammado312) + gamma212*gammado322 + - 2.*(gamma322*gammado313 + gamma312*gammado323))*ginv12 + - (-ddg1323 + gamma133*gammado211 + gamma233*gammado212 + - (gamma113 + gamma223 + gamma333)*gammado213 + gamma213*gammado223 + - (gamma212 + gamma313)*gammado233 + - gamma123*(gammado113 + gammado311) + gamma223*gammado312 + - gamma112*(gammado133 + gammado313) + gamma212*gammado323 + - 2.*(gamma323*gammado313 + gamma312*gammado333))*ginv13 + - (-0.5*ddg2223 + gamma123*gammado212 + gamma223*gammado222 + - (gamma222 + gamma323)*gammado223 + - gamma122*(gammado123 + gammado312) + gamma222*gammado322 + - 2.*gamma322*gammado323)*ginv22 + - (-ddg2323 + gamma133*gammado212 + gamma233*gammado222 + - (2.*gamma223 + gamma333)*gammado223 + - (gamma222 + gamma323)*gammado233 + - gamma123*(gammado123 + gammado213 + gammado312) + - gamma122*(gammado133 + gammado313) + gamma223*gammado322 + - (gamma222 + 2.*gamma323)*gammado323 + 2.*gamma322*gammado333)*ginv23 + - (-0.5*ddg3323 + gamma133*gammado213 + gamma233*gammado223 + - (gamma223 + gamma333)*gammado233 + - gamma123*(gammado133 + gammado313) + gamma223*gammado323 + - 2.*gamma323*gammado333)*ginv33 -; - -R33 -= -dG31*g13 + dG32*g23 + dG33*g33 + gammado313*Gfromg1 + gammado323*Gfromg2 + - gammado333*Gfromg3 + (-0.5*ddg1133 + - gamma113*(gammado113 + 2.*gammado311) + - gamma213*(gammado213 + 2.*gammado312) + 3.*gamma313*gammado313)*ginv11 \ -+ (-ddg1233 + gamma123*(gammado113 + 2.*gammado311) + - gamma113*(gammado123 + 2.*gammado312) + - gamma223*(gammado213 + 2.*gammado312) + - gamma213*(gammado223 + 2.*gammado322) + - 3.*(gamma323*gammado313 + gamma313*gammado323))*ginv12 + - (-ddg1333 + gamma133*(gammado113 + 2.*gammado311) + - gamma233*(gammado213 + 2.*gammado312) + - gamma113*(gammado133 + 2.*gammado313) + - gamma213*(gammado233 + 2.*gammado323) + - 3.*(gamma333*gammado313 + gamma313*gammado333))*ginv13 + - (-0.5*ddg2233 + gamma123*(gammado123 + 2.*gammado312) + - gamma223*(gammado223 + 2.*gammado322) + 3.*gamma323*gammado323)*ginv22 \ -+ (-ddg2333 + gamma133*(gammado123 + 2.*gammado312) + - gamma123*(gammado133 + 2.*gammado313) + - gamma233*(gammado223 + 2.*gammado322) + - gamma223*(gammado233 + 2.*gammado323) + - 3.*(gamma333*gammado323 + gamma323*gammado333))*ginv23 + - (-0.5*ddg3333 + gamma133*(gammado133 + 2.*gammado313) + - gamma233*(gammado233 + 2.*gammado323) + 3.*gamma333*gammado333)*ginv33 -; - -ff -= -chi -; - -oochipsipower -= -1/chipsipower -; - -f -= -oochipsipower*log(ff) -; - -psim4 -= -exp(-4.*f) -; - -df1 -= -(dchi1*oochipsipower)/chi -; - -df2 -= -(dchi2*oochipsipower)/chi -; - -df3 -= -(dchi3*oochipsipower)/chi -; - -ddf11 -= -(ddchi11*oochipsipower)/chi - chipsipower*pow2(df1) -; - -ddf12 -= --(chipsipower*df1*df2) + (ddchi12*oochipsipower)/chi -; - -ddf13 -= --(chipsipower*df1*df3) + (ddchi13*oochipsipower)/chi -; - -ddf22 -= -(ddchi22*oochipsipower)/chi - chipsipower*pow2(df2) -; - -ddf23 -= --(chipsipower*df2*df3) + (ddchi23*oochipsipower)/chi -; - -ddf33 -= -(ddchi33*oochipsipower)/chi - chipsipower*pow2(df3) -; - -cddf11 -= -ddf11 - df1*gamma111 - df2*gamma211 - df3*gamma311 -; - -cddf12 -= -ddf12 - df1*gamma112 - df2*gamma212 - df3*gamma312 -; - -cddf13 -= -ddf13 - df1*gamma113 - df2*gamma213 - df3*gamma313 -; - -cddf22 -= -ddf22 - df1*gamma122 - df2*gamma222 - df3*gamma322 -; - -cddf23 -= -ddf23 - df1*gamma123 - df2*gamma223 - df3*gamma323 -; - -cddf33 -= -ddf33 - df1*gamma133 - df2*gamma233 - df3*gamma333 -; - -trcddf -= -cddf11*ginv11 + cddf22*ginv22 + - 2.*(cddf12*ginv12 + cddf13*ginv13 + cddf23*ginv23) + cddf33*ginv33 -; - -Rphi11 -= --2.*(cddf11 + g11*trcddf) + (4. - 4.*g11*ginv11)*pow2(df1) - - g11*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi12 -= -df1*df2*(4. - 8.*g12*ginv12) - 2.*(cddf12 + g12*trcddf) - - g12*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi13 -= -df1*(4.*df3 - 8.*df2*g13*ginv12) - 2.*(cddf13 + g13*trcddf) - - g13*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi22 -= --2.*(cddf22 + g22*trcddf) + (4. - 4.*g22*ginv22)*pow2(df2) - - g22*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv11*pow2(df1) + ginv33*pow2(df3))) -; - -Rphi23 -= -df2*(-8.*df1*g23*ginv12 + df3*(4. - 8.*g23*ginv23)) - - 2.*(cddf23 + g23*trcddf) - g23* - (8.*df1*df3*ginv13 + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + - ginv33*pow2(df3))) -; - -Rphi33 -= --2.*(cddf33 + g33*trcddf) - g33* - (8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2))) + - (4. - 4.*g33*ginv33)*pow2(df3) -; - -Rf11 -= -R11 + Rphi11 -; - -Rf12 -= -R12 + Rphi12 -; - -Rf13 -= -R13 + Rphi13 -; - -Rf22 -= -R22 + Rphi22 -; - -Rf23 -= -R23 + Rphi23 -; - -Rf33 -= -R33 + Rphi33 -; - -Rhat -= -psim4*(ginv11*Rf11 + ginv22*Rf22 + - 2.*(ginv12*Rf12 + ginv13*Rf13 + ginv23*Rf23) + ginv33*Rf33) -; - -cdda11 -= -dda11 - da2*gamma211 - da3*gamma311 + - da1*(-gamma111 + df1*(-4. + 2.*g11*ginv11)) + - 2.*g11*((da2*df1 + da1*df2)*ginv12 + (da3*df1 + da1*df3)*ginv13 + - da2*df2*ginv22 + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) -; - -cdda12 -= -dda12 - da1*gamma112 - da2*gamma212 - da3*gamma312 + - 2.*(-(da2*df1) - da1*df2 + g12* - (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) -; - -cdda13 -= -dda13 - da1*gamma113 - da2*gamma213 - da3*gamma313 + - 2.*(-(da3*df1) - da1*df3 + g13* - (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) -; - -cdda22 -= -dda22 - da1*gamma122 - da2*(4.*df2 + gamma222) - da3*gamma322 + - 2.*g22*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) -; - -cdda23 -= -dda23 - da1*gamma123 - da2*gamma223 - da3*gamma323 + - 2.*(-(da3*df2) - da2*df3 + g23* - (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) -; - -cdda33 -= -dda33 - da1*gamma133 - da2*gamma233 - da3*(4.*df3 + gamma333) + - 2.*g33*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) -; - -trcdda -= -(cdda11*ginv11 + cdda22*ginv22 + - 2.*(cdda12*ginv12 + cdda13*ginv13 + cdda23*ginv23) + cdda33*ginv33)*psim4 -; - -AA11 -= -2.*(A11*(A12*ginv12 + A13*ginv13) + A12*A13*ginv23) + ginv11*pow2(A11) + - ginv22*pow2(A12) + ginv33*pow2(A13) -; - -AA12 -= -(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + - (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) -; - -AA13 -= -(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + - A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) -; - -AA21 -= -(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + - (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) -; - -AA22 -= -2.*(A12*(A22*ginv12 + A23*ginv13) + A22*A23*ginv23) + ginv11*pow2(A12) + - ginv22*pow2(A22) + ginv33*pow2(A23) -; - -AA23 -= -A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + - A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) -; - -AA31 -= -(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + - A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) -; - -AA32 -= -A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + - A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) -; - -AA33 -= -2.*(A13*(A23*ginv12 + A33*ginv13) + A23*A33*ginv23) + ginv11*pow2(A13) + - ginv22*pow2(A23) + ginv33*pow2(A33) -; - -Ainv11 -= -2.*(A23*ginv12*ginv13 + ginv11*(A12*ginv12 + A13*ginv13)) + - A11*pow2(ginv11) + A22*pow2(ginv12) + A33*pow2(ginv13) -; - -Ainv12 -= -ginv11*(A11*ginv12 + A12*ginv22 + A13*ginv23) + - ginv12*(A13*ginv13 + A22*ginv22 + A23*ginv23) + - ginv13*(A23*ginv22 + A33*ginv23) + A12*pow2(ginv12) -; - -Ainv13 -= -ginv11*(A11*ginv13 + A12*ginv23 + A13*ginv33) + - ginv12*(A12*ginv13 + A22*ginv23 + A23*ginv33) + - ginv13*(A23*ginv23 + A33*ginv33) + A13*pow2(ginv13) -; - -Ainv22 -= -2.*(A23*ginv22*ginv23 + ginv12*(A12*ginv22 + A13*ginv23)) + - A11*pow2(ginv12) + A22*pow2(ginv22) + A33*pow2(ginv23) -; - -Ainv23 -= -ginv13*(A12*ginv22 + A13*ginv23) + A33*ginv23*ginv33 + - ginv12*(A11*ginv13 + A12*ginv23 + A13*ginv33) + - ginv22*(A22*ginv23 + A23*ginv33) + A23*pow2(ginv23) -; - -Ainv33 -= -2.*(A23*ginv23*ginv33 + ginv13*(A12*ginv23 + A13*ginv33)) + - A11*pow2(ginv13) + A22*pow2(ginv23) + A33*pow2(ginv33) -; - -cdA111 -= -dA111 - 2.*(A11*gamma111 + A12*gamma211 + A13*gamma311) -; - -cdA112 -= -dA112 - A11*gamma112 - A22*gamma211 - A12*(gamma111 + gamma212) - - A23*gamma311 - A13*gamma312 -; - -cdA113 -= -dA113 - A11*gamma113 - A23*gamma211 - A12*gamma213 - A33*gamma311 - - A13*(gamma111 + gamma313) -; - -cdA122 -= -dA122 - 2.*(A12*gamma112 + A22*gamma212 + A23*gamma312) -; - -cdA123 -= -dA123 - A13*gamma112 - A12*gamma113 - A22*gamma213 - A33*gamma312 - - A23*(gamma212 + gamma313) -; - -cdA133 -= -dA133 - 2.*(A13*gamma113 + A23*gamma213 + A33*gamma313) -; - -cdA211 -= -dA211 - 2.*(A11*gamma112 + A12*gamma212 + A13*gamma312) -; - -cdA212 -= -dA212 - A11*gamma122 - A22*gamma212 - A12*(gamma112 + gamma222) - - A23*gamma312 - A13*gamma322 -; - -cdA213 -= -dA213 - A11*gamma123 - A23*gamma212 - A12*gamma223 - A33*gamma312 - - A13*(gamma112 + gamma323) -; - -cdA222 -= -dA222 - 2.*(A12*gamma122 + A22*gamma222 + A23*gamma322) -; - -cdA223 -= -dA223 - A13*gamma122 - A12*gamma123 - A22*gamma223 - A33*gamma322 - - A23*(gamma222 + gamma323) -; - -cdA233 -= -dA233 - 2.*(A13*gamma123 + A23*gamma223 + A33*gamma323) -; - -cdA311 -= -dA311 - 2.*(A11*gamma113 + A12*gamma213 + A13*gamma313) -; - -cdA312 -= -dA312 - A11*gamma123 - A22*gamma213 - A12*(gamma113 + gamma223) - - A23*gamma313 - A13*gamma323 -; - -cdA313 -= -dA313 - A11*gamma133 - A23*gamma213 - A12*gamma233 - A33*gamma313 - - A13*(gamma113 + gamma333) -; - -cdA322 -= -dA322 - 2.*(A12*gamma123 + A22*gamma223 + A23*gamma323) -; - -cdA323 -= -dA323 - A13*gamma123 - A12*gamma133 - A22*gamma233 - A33*gamma323 - - A23*(gamma223 + gamma333) -; - -cdA333 -= -dA333 - 2.*(A13*gamma133 + A23*gamma233 + A33*gamma333) -; - -divbeta -= -db11 + db22 + db33 -; - -totdivbeta -= -0.66666666666666666667*divbeta -; - -lieg11 -= -beta1*dg111 + beta2*dg211 + beta3*dg311 + - 2.*(db11*g11 + db12*g12 + db13*g13) - g11*totdivbeta -; - -lieg12 -= -beta1*dg112 + beta2*dg212 + beta3*dg312 + db21*g11 + db23*g13 + db12*g22 + - db13*g23 + g12*(db11 + db22 - totdivbeta) -; - -lieg13 -= -beta1*dg113 + beta2*dg213 + beta3*dg313 + db31*g11 + db32*g12 + db12*g23 + - db13*g33 + g13*(db11 + db33 - totdivbeta) -; - -lieg22 -= -beta1*dg122 + beta2*dg222 + beta3*dg322 + - 2.*(db21*g12 + db22*g22 + db23*g23) - g22*totdivbeta -; - -lieg23 -= -beta1*dg123 + beta2*dg223 + beta3*dg323 + db31*g12 + db21*g13 + db32*g22 + - db23*g33 + g23*(db22 + db33 - totdivbeta) -; - -lieg33 -= -beta1*dg133 + beta2*dg233 + beta3*dg333 + - 2.*(db31*g13 + db32*g23 + db33*g33) - g33*totdivbeta -; - -lieA11 -= -beta1*dA111 + beta2*dA211 + beta3*dA311 + - 2.*(A11*db11 + A12*db12 + A13*db13) - A11*totdivbeta -; - -lieA12 -= -beta1*dA112 + beta2*dA212 + beta3*dA312 + A22*db12 + A23*db13 + A11*db21 + - A13*db23 + A12*(db11 + db22 - totdivbeta) -; - -lieA13 -= -beta1*dA113 + beta2*dA213 + beta3*dA313 + A23*db12 + A33*db13 + A11*db31 + - A12*db32 + A13*(db11 + db33 - totdivbeta) -; - -lieA22 -= -beta1*dA122 + beta2*dA222 + beta3*dA322 + - 2.*(A12*db21 + A22*db22 + A23*db23) - A22*totdivbeta -; - -lieA23 -= -beta1*dA123 + beta2*dA223 + beta3*dA323 + A13*db21 + A33*db23 + A12*db31 + - A22*db32 + A23*(db22 + db33 - totdivbeta) -; - -lieA33 -= -beta1*dA133 + beta2*dA233 + beta3*dA333 + - 2.*(A13*db31 + A23*db32 + A33*db33) - A33*totdivbeta -; - -betas -= -beta1*sdown1 + beta2*sdown2 + beta3*sdown3 -; - -Dbetas -= -(db11*sdown1 + db12*sdown2 + db13*sdown3)*sup1 + - (db21*sdown1 + db22*sdown2 + db23*sdown3)*sup2 + - (db31*sdown1 + db32*sdown2 + db33*sdown3)*sup3 -; - -Dalpha -= -da1*sup1 + da2*sup2 + da3*sup3 -; - -DKhat -= -dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3 -; - -DK -= -dK1*sup1 + dK2*sup2 + dK3*sup3 -; - -DTheta -= -dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 -; - -Gams -= -G1*sdown1 + G2*sdown2 + G3*sdown3 -; - -DGams -= -(dG11*sdown1 + dG12*sdown2 + dG13*sdown3)*sup1 + - (dG21*sdown1 + dG22*sdown2 + dG23*sdown3)*sup2 + - (dG31*sdown1 + dG32*sdown2 + dG33*sdown3)*sup3 -; - -GamA1 -= -G1*qud11 + G2*qud12 + G3*qud13 -; - -GamA2 -= -G1*qud21 + G2*qud22 + G3*qud23 -; - -GamA3 -= -G1*qud31 + G2*qud32 + G3*qud33 -; - -DGamA1 -= -(dG11*qud11 + dG12*qud12 + dG13*qud13)*sup1 + - (dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + - (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3 -; - -DGamA2 -= -(dG11*qud21 + dG12*qud22 + dG13*qud23)*sup1 + - (dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + - (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3 -; - -DGamA3 -= -(dG11*qud31 + dG12*qud32 + dG13*qud33)*sup1 + - (dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + - (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3 -; - -betaA1 -= -beta1*qud11 + beta2*qud12 + beta3*qud13 -; - -betaA2 -= -beta1*qud21 + beta2*qud22 + beta3*qud23 -; - -betaA3 -= -beta1*qud31 + beta2*qud32 + beta3*qud33 -; - -DbetaA1 -= -(db11*qud11 + db12*qud12 + db13*qud13)*sup1 + - (db21*qud11 + db22*qud12 + db23*qud13)*sup2 + - (db31*qud11 + db32*qud12 + db33*qud13)*sup3 -; - -DbetaA2 -= -(db11*qud21 + db12*qud22 + db13*qud23)*sup1 + - (db21*qud21 + db22*qud22 + db23*qud23)*sup2 + - (db31*qud21 + db32*qud22 + db33*qud23)*sup3 -; - -DbetaA3 -= -(db11*qud31 + db12*qud32 + db13*qud33)*sup1 + - (db21*qud31 + db22*qud32 + db23*qud33)*sup2 + - (db31*qud31 + db32*qud32 + db33*qud33)*sup3 -; - -lienKhat -= --((DKhat + Khat/r)*sqrt(muL)) -; - -lienTheta -= --DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta -; - -lienK -= -lienKhat + 2.*lienTheta -; - -rKhat -= -beta1*dKhat1 + beta2*dKhat2 + beta3*dKhat3 + alpha*lienKhat -; - -#if 0 -// David's new version -rGams -= -(beta1*dG11 + beta2*dG21 + beta3*dG31 + - (ddb111*quu11 + ddb221*quu22 + - 2.*(ddb121*quu12 + ddb131*quu13 + ddb231*quu23) + ddb331*quu33)/chi\ -)*sdown1 + (beta1*dG12 + beta2*dG22 + beta3*dG32 + - (ddb112*quu11 + ddb222*quu22 + - 2.*(ddb122*quu12 + ddb132*quu13 + ddb232*quu23) + ddb332*quu33)/chi\ -)*sdown2 + (beta1*dG13 + beta2*dG23 + beta3*dG33 + - (ddb113*quu11 + ddb223*quu22 + - 2.*(ddb123*quu12 + ddb133*quu13 + ddb233*quu23) + ddb333*quu33)/chi\ -)*sdown3 - ((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + ddb121*qud21 + - ddb122*qud22 + ddb123*qud23 + ddb131*qud31 + ddb132*qud32 + - ddb133*qud33)*sup1 + (ddb121*qud11 + ddb122*qud12 + - ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + ddb223*qud23 + - ddb231*qud31 + ddb232*qud32 + ddb233*qud33)*sup2 + - (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + - ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + ddb332*qud32 + - ddb333*qud33)*sup3)/chi - (dG11 + dG22 + dG33)*vbetas + - 2.*((0.33333333333333333333*alpha* - (dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3))/(chi + chi*vbetas) + - ((db11 + db22 + db33)*shiftdriver)/(vbetaA*sqrt(3.))) + - (1.3333333333333333333*alpha*(dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3)* - sqrt(muL))/(chi*(vbetas + sqrt(muL))) -; -#else -//David's old version -rGams -= -shiftdriver*((beta1*db11 + beta2*db21)*(db12*sdown2 + db13*sdown3) + - 2.*beta1*((beta2*ddb121 + beta3*ddb131)*sdown1 + - (beta2*ddb122 + beta3*ddb132)*sdown2 + - (beta2*ddb123 + beta3*ddb133)*sdown3) + - sdown1*(db21*(beta1*db12 + beta2*(db11 + db22) + beta3*db32) + - db31*(beta1*db13 + beta2*db23 + beta3*(db11 + db33)) + - beta2*(2.*beta3*ddb231 + dG21) + beta3*dG31 + ddb111*pow2(beta1) + - ddb221*pow2(beta2) + ddb331*pow2(beta3) + beta1*(dG11 + pow2(db11))\ -) + sdown2*(db12*(beta1*db22 + beta3*db31) + - db32*(beta1*db13 + beta2*db23 + beta3*(db22 + db33)) + beta1*dG12 + - beta3*dG32 + ddb112*pow2(beta1) + ddb222*pow2(beta2) + - ddb332*pow2(beta3) + beta2*(2.*beta3*ddb232 + dG22 + pow2(db22)))) - - ((beta1*db11 + beta2*db21 + beta3*db31)*sdown1 + - (beta2*db22 + beta3*db32)*sdown2 + beta2*db23*sdown3 + - beta1*(db12*sdown2 + db13*sdown3))*pow2(shiftdriver) + - sdown3*(shiftdriver*((beta1*db12 + beta2*db22)*db23 + beta1*dG13 + - beta2*dG23 + ddb113*pow2(beta1) + ddb223*pow2(beta2) + - ddb333*pow2(beta3) + beta3* - (db13*db31 + db23*db32 + 2.*beta2*ddb233 + dG33 + pow2(db33))) + - db33*((beta1*db13 + beta2*db23)*shiftdriver - beta3*pow2(shiftdriver))) -; -#endif - -rTheta -= -beta1*dTheta1 + beta2*dTheta2 + beta3*dTheta3 + alpha*lienTheta -; - -rACss -= -2.*((A23*alpha*K + lieA23)*sup2*sup3 + - sup1*((A12*alpha*K + lieA12)*sup2 + A13*alpha*K*sup3) + - psim4*((-cdda23 + alpha*Rf23)*sup2*sup3 + - sup1*((-cdda12 + alpha*Rf12)*sup2 - cdda13*sup3))) + - 0.66666666666666666667*(g13*sup1 + g23*sup2)*sup3*trcdda + - sup1*(2.*(-(AA31*alpha) + lieA13)*sup3 + - 0.66666666666666666667*g12*sup2*trcdda) + - (lieA11 + psim4*(-cdda11 + alpha*Rf11) + - 0.33333333333333333333*g11*(-(alpha*Rhat) + trcdda))*pow2(sup1) + - (lieA22 - cdda22*psim4 + alpha* - (A22*K + psim4*Rf22 - 0.33333333333333333333*g22*Rhat) + - 0.33333333333333333333*g22*trcdda)*pow2(sup2) + - (lieA33 - cdda33*psim4 + alpha* - (A33*K + psim4*Rf33 - 0.33333333333333333333*g33*Rhat) + - 0.33333333333333333333*g33*trcdda)*pow2(sup3) + - alpha*(ginv11*((-2.*cdA111*chi + 3.*A11*dchi1)*sup1 + - (-2.*cdA112*chi + 3.*A12*dchi1)*sup2 + - (-2.*cdA113*chi + 3.*A13*dchi1)*sup3) + - ginv22*((-2.*cdA212*chi + 3.*A12*dchi2)*sup1 + - (-2.*cdA222*chi + 3.*A22*dchi2)*sup2 + - (-2.*cdA223*chi + 3.*A23*dchi2)*sup3) + - ginv33*((-2.*cdA313*chi + 3.*A13*dchi3)*sup1 + - (-2.*cdA323*chi + 3.*A23*dchi3)*sup2 + - (-2.*cdA333*chi + 3.*A33*dchi3)*sup3) + - chi*(-2.*DTheta + 1.3333333333333333333* - (dK1*sup1 + dK2*sup2 + dK3*sup3)) + - ginv12*((-2.*cdA212*chi + 3.*A12*dchi2)*sup2 + - (-2.*cdA213*chi + 3.*A13*dchi2)*sup3 - - 2.*chi*((cdA112 + cdA211)*sup1 + cdA122*sup2 + cdA123*sup3) + - 3.*((A12*dchi1 + A11*dchi2)*sup1 + dchi1*(A22*sup2 + A23*sup3))) + - ginv13*((-2.*cdA312*chi + 3.*A12*dchi3)*sup2 + - (-2.*cdA313*chi + 3.*A13*dchi3)*sup3 - - 2.*chi*((cdA113 + cdA311)*sup1 + cdA123*sup2 + cdA133*sup3) + - 3.*((A13*dchi1 + A11*dchi3)*sup1 + dchi1*(A23*sup2 + A33*sup3))) + - ginv23*((-2.*cdA322*chi + 3.*A22*dchi3)*sup2 + - (-2.*cdA323*chi + 3.*A23*dchi3)*sup3 - - 2.*chi*((cdA213 + cdA312)*sup1 + cdA223*sup2 + cdA233*sup3) + - 3.*((A13*dchi2 + A12*dchi3)*sup1 + dchi2*(A23*sup2 + A33*sup3))) + - (0.33333333333333333333*((dG11 - dGfromgdu11)*qud11 + - (dG12 - dGfromgdu12)*qud12 + (dG13 - dGfromgdu13)*qud13 + - (dG21 - dGfromgdu21)*qud21 + (dG22 - dGfromgdu22)*qud22 + - (dG23 - dGfromgdu23)*qud23 + (dG31 - dGfromgdu31)*qud31 + - (dG32 - dGfromgdu32)*qud32 + (dG33 - dGfromgdu33)*qud33) + - kappa1*((G1 - Gfromg1)*sdown1 + (G2 - Gfromg2)*sdown2 + - (G3 - Gfromg3)*sdown3) + - 0.66666666666666666667* - ((dGfromgdu21*sdown1 + dGfromgdu22*sdown2)*sup2 + - sdown3*((-dG13 + dGfromgdu13)*sup1 - dG23*sup2 - dG33*sup3) + - sdown1*((-dG11 + dGfromgdu11)*sup1 - dG21*sup2 - dG31*sup3 + - dGfromgdu31*sup3) + - sdown2*((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3 + - dGfromgdu32*sup3)))*pow2(chi) + - 0.66666666666666666667*sup2* - (-(Rhat*(g12*sup1 + g23*sup3)) + dGfromgdu23*sdown3*pow2(chi)) + - sup3*((2.*psim4*Rf13 - 0.66666666666666666667*g13*Rhat)*sup1 + - 0.66666666666666666667*dGfromgdu33*sdown3*pow2(chi)) + - (-2.*AA11 + A11*K)*pow2(sup1) - - 2.*((AA23 + AA32)*sup2*sup3 + sup1*((AA12 + AA21)*sup2 + AA13*sup3) + - AA22*pow2(sup2) + AA33*pow2(sup3))) -; - -rACqq -= -chi*(-((4.*(A12*Ainv12 + A13*Ainv13 + A23*Ainv23) + - 2.*(A11*Ainv11 + A22*Ainv22 + A33*Ainv33))*alpha) + - Ainv11*lieg11 + Ainv22*lieg22 + - 2.*(Ainv12*lieg12 + Ainv13*lieg13 + Ainv23*lieg23) + Ainv33*lieg33) - - rACss -; - -rGamA1 -= --(((dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + - (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3)*vbetaA) + - qud11*(beta2*dG21 + beta3*dG31 + - (1.3333333333333333333*ddb111*quu11 + - 2.3333333333333333333*(ddb121*quu12 + ddb131*quu13) + - ddb221*quu22 + ddb331*quu33 + - (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + - dG11*(beta1 - sup1*vbetaA)) + - qud12*(beta2*dG22 + beta3*dG32 + - (1.3333333333333333333*ddb112*quu11 + - 2.3333333333333333333*(ddb122*quu12 + ddb132*quu13) + - ddb222*quu22 + 2.*ddb232*quu23 + ddb332*quu33 + - (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + - dG12*(beta1 - sup1*vbetaA)) + - qud13*(beta2*dG23 + beta3*dG33 + - (1.3333333333333333333*ddb113*quu11 + - 2.3333333333333333333*(ddb123*quu12 + ddb133*quu13) + - ddb223*quu22 + 2.*ddb233*quu23 + ddb333*quu33 + - (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + - dG13*(beta1 - sup1*vbetaA)) + - (0.33333333333333333333*((ddb121*qud21 + ddb122*qud22 + ddb123*qud23 + - ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu11 + - (ddb221*qud21 + ddb223*qud23 + ddb231*qud31 + ddb232*qud32 + - ddb233*qud33)*quu12 + - (ddb231*qud21 + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + - ddb332*qud32)*quu13) - - alpha*((1.3333333333333333333*dKhat1 + - 0.66666666666666666667*dTheta1)*quu11 + - 1.3333333333333333333*(dKhat2*quu12 + dKhat3*quu13)) + - 1.3333333333333333333*((ddb132*quu13*sdown2 + ddb113*quu11*sdown3)* - sup1 + (quu13*(ddb231*sdown1 + ddb232*sdown2) + - quu12*(ddb222*sdown2 + ddb223*sdown3))*sup2 + - (quu12*(ddb232*sdown2 + ddb233*sdown3) + - quu13*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + - sdown1*((ddb121*quu12 + ddb131*quu13)*sup1 + ddb221*quu12*sup2 + - ddb131*quu11*sup3) + - sdown2*((ddb112*quu11 + ddb122*quu12)*sup1 + - quu11*(ddb122*sup2 + ddb132*sup3)) + - sdown3*((ddb123*quu12 + ddb133*quu13)*sup1 + - quu11*(ddb123*sup2 + ddb133*sup3))) + - qud11*(2.*ddb231*quu23 + (db21*shiftdriver*sup2)/vbetaA) - - (((db11*quu11 + db21*quu12)*sdown1 + - (db12*quu11 + db22*quu12 + db32*quu13)*sdown2 + - (db13*quu11 + db23*quu12 + db33*quu13)*sdown3)*shiftdriver)/ - vbetaA + ((dG22*quu12 + dG32*quu13)*sdown2 + - (dG13*quu11 + dG23*quu12)*sdown3)*vbetaA + - quu11*(1.3333333333333333333*sdown1*(ddb111*sup1 + ddb121*sup2) + - (dG11*sdown1 + dG12*sdown2)*vbetaA) + - quu12*(-0.66666666666666666667*alpha*dTheta2 + - 0.33333333333333333333*ddb222*qud22 + - sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + - quu13*(-0.66666666666666666667*alpha*dTheta3 + - 0.33333333333333333333*ddb333*qud33 - - (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + - sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi -; - -rGamA2 -= --(((dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + - (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3)*vbetaA) + - qud21*(beta2*dG21 + beta3*dG31 + - (ddb111*quu11 + 2.*ddb131*quu13 + - 1.3333333333333333333*ddb221*quu22 + - 2.3333333333333333333*(ddb121*quu12 + ddb231*quu23) + - ddb331*quu33 + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + - dG11*(beta1 - sup1*vbetaA)) + - qud22*(beta2*dG22 + beta3*dG32 + - (ddb112*quu11 + 2.*ddb132*quu13 + - 1.3333333333333333333*ddb222*quu22 + - 2.3333333333333333333*(ddb122*quu12 + ddb232*quu23) + - ddb332*quu33 + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/ - vbetaA)/chi + dG12*(beta1 - sup1*vbetaA)) + - qud23*(beta2*dG23 + beta3*dG33 + - (ddb113*quu11 + 2.*ddb133*quu13 + - 1.3333333333333333333*ddb223*quu22 + - 2.3333333333333333333*(ddb123*quu12 + ddb233*quu23) + - ddb333*quu33 + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/ - vbetaA)/chi + dG13*(beta1 - sup1*vbetaA)) + - (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + - ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu12 + - (ddb121*qud11 + ddb123*qud13 + ddb231*qud31 + ddb232*qud32 + - ddb233*qud33)*quu22 + - (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb331*qud31 + - ddb332*qud32)*quu23) - - alpha*((1.3333333333333333333*dKhat1 + - 0.66666666666666666667*dTheta1)*quu12 + - 1.3333333333333333333*(dKhat2*quu22 + dKhat3*quu23)) + - 1.3333333333333333333*((ddb132*quu23*sdown2 + ddb113*quu12*sdown3)* - sup1 + (quu23*(ddb231*sdown1 + ddb232*sdown2) + - quu22*(ddb222*sdown2 + ddb223*sdown3))*sup2 + - (quu22*(ddb232*sdown2 + ddb233*sdown3) + - quu23*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + - sdown1*((ddb121*quu22 + ddb131*quu23)*sup1 + ddb221*quu22*sup2 + - ddb131*quu12*sup3) + - sdown2*((ddb112*quu12 + ddb122*quu22)*sup1 + - quu12*(ddb122*sup2 + ddb132*sup3)) + - sdown3*((ddb123*quu22 + ddb133*quu23)*sup1 + - quu12*(ddb123*sup2 + ddb133*sup3))) - - (((db11*quu12 + db21*quu22)*sdown1 + - (db12*quu12 + db22*quu22 + db32*quu23)*sdown2 + - (db13*quu12 + db23*quu22 + db33*quu23)*sdown3)*shiftdriver)/ - vbetaA + (db21*qud21*shiftdriver*sup2)/vbetaA + - ((dG22*quu22 + dG32*quu23)*sdown2 + (dG13*quu12 + dG23*quu22)*sdown3)* - vbetaA + quu12*(1.3333333333333333333*sdown1* - (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ -+ quu22*(-0.66666666666666666667*alpha*dTheta2 + - 0.33333333333333333333*ddb122*qud12 + - sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + - quu23*(-0.66666666666666666667*alpha*dTheta3 + - 0.33333333333333333333*ddb333*qud33 - - (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + - sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi -; - -rGamA3 -= --(((dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + - (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3)*vbetaA) + - qud31*(beta2*dG21 + beta3*dG31 + - (ddb111*quu11 + 2.*ddb121*quu12 + ddb221*quu22 + - 2.3333333333333333333*(ddb131*quu13 + ddb231*quu23) + - 1.3333333333333333333*ddb331*quu33 + - (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + - dG11*(beta1 - sup1*vbetaA)) + - qud32*(beta2*dG22 + beta3*dG32 + - (ddb112*quu11 + 2.*ddb122*quu12 + ddb222*quu22 + - 2.3333333333333333333*(ddb132*quu13 + ddb232*quu23) + - 1.3333333333333333333*ddb332*quu33 + - (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + - dG12*(beta1 - sup1*vbetaA)) + - qud33*(beta2*dG23 + beta3*dG33 + - (ddb113*quu11 + 2.*ddb123*quu12 + ddb223*quu22 + - 2.3333333333333333333*(ddb133*quu13 + ddb233*quu23) + - 1.3333333333333333333*ddb333*quu33 + - (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + - dG13*(beta1 - sup1*vbetaA)) + - (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + - ddb121*qud21 + ddb122*qud22 + ddb123*qud23)*quu13 + - (ddb121*qud11 + ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + - ddb223*qud23)*quu23 + - (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + - ddb232*qud22)*quu33) - - alpha*((1.3333333333333333333*dKhat1 + - 0.66666666666666666667*dTheta1)*quu13 + - 1.3333333333333333333*(dKhat2*quu23 + dKhat3*quu33)) + - 1.3333333333333333333*((ddb132*quu33*sdown2 + ddb113*quu13*sdown3)* - sup1 + (quu33*(ddb231*sdown1 + ddb232*sdown2) + - quu23*(ddb222*sdown2 + ddb223*sdown3))*sup2 + - (quu23*(ddb232*sdown2 + ddb233*sdown3) + - quu33*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + - sdown1*((ddb121*quu23 + ddb131*quu33)*sup1 + ddb221*quu23*sup2 + - ddb131*quu13*sup3) + - sdown2*((ddb112*quu13 + ddb122*quu23)*sup1 + - quu13*(ddb122*sup2 + ddb132*sup3)) + - sdown3*((ddb123*quu23 + ddb133*quu33)*sup1 + - quu13*(ddb123*sup2 + ddb133*sup3))) - - (((db11*quu13 + db21*quu23)*sdown1 + - (db12*quu13 + db22*quu23 + db32*quu33)*sdown2 + - (db13*quu13 + db23*quu23 + db33*quu33)*sdown3)*shiftdriver)/ - vbetaA + (db21*qud31*shiftdriver*sup2)/vbetaA + - ((dG22*quu23 + dG32*quu33)*sdown2 + (dG13*quu13 + dG23*quu23)*sdown3)* - vbetaA + quu13*(1.3333333333333333333*sdown1* - (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ -+ quu33*(-0.66666666666666666667*alpha*dTheta3 + - ddb233*(0.33333333333333333333*qud23 + - 1.3333333333333333333*sdown3*sup2) - - (db31*sdown1*shiftdriver)/vbetaA + - (dG31*sdown1 + dG33*sdown3)*vbetaA) + - quu23*(-0.66666666666666666667*alpha*dTheta2 + - 0.33333333333333333333*ddb122*qud12 + - sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)))/chi -; - -rACsA1 -= -(qud11*(lieA11 + alpha*chi*Rf11) + - qud21*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + - qud31*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + - qud11*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + - (A13*alpha*K + lieA13)*sup3 + - alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + - qud21*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + - (A23*alpha*K + lieA23)*sup3 + - alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + - qud31*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + - (A33*alpha*K + lieA33)*sup3 + - alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + - alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud11 + - (-(cdA112*chi) + 1.5*A12*dchi1)*qud21 + - (-(cdA113*chi) + 1.5*A13*dchi1)*qud31) + - ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud11 + - (-(cdA222*chi) + 1.5*A22*dchi2)*qud21 + - (-(cdA223*chi) + 1.5*A23*dchi2)*qud31) + - ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud11 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud21 + - (-(cdA333*chi) + 1.5*A33*dchi3)*qud31) + - chi*((0.66666666666666666667*dK1 - dTheta1)*qud11 + - (0.66666666666666666667*dK2 - dTheta2)*qud21 + - (0.66666666666666666667*dK3 - dTheta3)*qud31) + - ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud21 + - (-(cdA213*chi) + 1.5*A13*dchi2)*qud31 - - chi*((cdA112 + cdA211)*qud11 + cdA122*qud21 + cdA123*qud31) + - 1.5*((A12*dchi1 + A11*dchi2)*qud11 + dchi1*(A22*qud21 + A23*qud31))\ -) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud21 + - (-(cdA313*chi) + 1.5*A13*dchi3)*qud31 - - chi*((cdA113 + cdA311)*qud11 + cdA123*qud21 + cdA133*qud31) + - 1.5*((A13*dchi1 + A11*dchi3)*qud11 + dchi1*(A23*qud21 + A33*qud31))\ -) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud21 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud31 - - chi*((cdA213 + cdA312)*qud11 + cdA223*qud21 + cdA233*qud31) + - 1.5*((A13*dchi2 + A12*dchi3)*qud11 + dchi2*(A23*qud21 + A33*qud31))\ -) + 0.5*(kappa1*((G1 - Gfromg1)*qdd11 + (G2 - Gfromg2)*qdd12 + - (G3 - Gfromg3)*qdd13) - dG13*qdd13*sup1 - dG21*qdd11*sup2 + - (dGfromgdu22*qdd12 - dG23*qdd13)*sup2 + - (dGfromgdu31*qdd11 + dGfromgdu32*qdd12 - dG33*qdd13)*sup3 + - qdd11*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - - dG31*sup3) + qdd12* - ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + - sup1*(-2.*AA11*qud11 + 0.5*dGfromgdu13*qdd13*pow2(chi))) + - sup2*(chi*(-(cdda12*qud11) - cdda22*qud21 - cdda23*qud31 + - alpha*qud21*Rf22) + alpha* - (chi*(qud11*Rf12 + qud31*Rf23) + 0.5*dGfromgdu23*qdd13*pow2(chi))) + - sup3*(chi*(-(cdda13*qud11) - cdda23*qud21 - cdda33*qud31 + - alpha*qud21*Rf23) + alpha* - (chi*(qud11*Rf13 + qud31*Rf33) + 0.5*dGfromgdu33*qdd13*pow2(chi))) -; - -rACsA2 -= -(qud12*(lieA11 + alpha*chi*Rf11) + - qud22*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + - qud32*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + - qud12*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + - (A13*alpha*K + lieA13)*sup3 + - alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + - qud22*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + - (A23*alpha*K + lieA23)*sup3 + - alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + - qud32*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + - (A33*alpha*K + lieA33)*sup3 + - alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + - alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud12 + - (-(cdA112*chi) + 1.5*A12*dchi1)*qud22 + - (-(cdA113*chi) + 1.5*A13*dchi1)*qud32) + - ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud12 + - (-(cdA222*chi) + 1.5*A22*dchi2)*qud22 + - (-(cdA223*chi) + 1.5*A23*dchi2)*qud32) + - ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud12 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud22 + - (-(cdA333*chi) + 1.5*A33*dchi3)*qud32) + - chi*((0.66666666666666666667*dK1 - dTheta1)*qud12 + - (0.66666666666666666667*dK2 - dTheta2)*qud22 + - (0.66666666666666666667*dK3 - dTheta3)*qud32) + - ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud22 + - (-(cdA213*chi) + 1.5*A13*dchi2)*qud32 - - chi*((cdA112 + cdA211)*qud12 + cdA122*qud22 + cdA123*qud32) + - 1.5*((A12*dchi1 + A11*dchi2)*qud12 + dchi1*(A22*qud22 + A23*qud32))\ -) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud22 + - (-(cdA313*chi) + 1.5*A13*dchi3)*qud32 - - chi*((cdA113 + cdA311)*qud12 + cdA123*qud22 + cdA133*qud32) + - 1.5*((A13*dchi1 + A11*dchi3)*qud12 + dchi1*(A23*qud22 + A33*qud32))\ -) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud22 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud32 - - chi*((cdA213 + cdA312)*qud12 + cdA223*qud22 + cdA233*qud32) + - 1.5*((A13*dchi2 + A12*dchi3)*qud12 + dchi2*(A23*qud22 + A33*qud32))\ -) + 0.5*(kappa1*((G1 - Gfromg1)*qdd12 + (G2 - Gfromg2)*qdd22 + - (G3 - Gfromg3)*qdd23) - dG13*qdd23*sup1 - dG21*qdd12*sup2 + - (dGfromgdu22*qdd22 - dG23*qdd23)*sup2 + - (dGfromgdu31*qdd12 + dGfromgdu32*qdd22 - dG33*qdd23)*sup3 + - qdd12*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - - dG31*sup3) + qdd22* - ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + - sup1*(-2.*AA11*qud12 + 0.5*dGfromgdu13*qdd23*pow2(chi))) + - sup2*(chi*(-(cdda12*qud12) - cdda22*qud22 - cdda23*qud32 + - alpha*qud22*Rf22) + alpha* - (chi*(qud12*Rf12 + qud32*Rf23) + 0.5*dGfromgdu23*qdd23*pow2(chi))) + - sup3*(chi*(-(cdda13*qud12) - cdda23*qud22 - cdda33*qud32 + - alpha*qud22*Rf23) + alpha* - (chi*(qud12*Rf13 + qud32*Rf33) + 0.5*dGfromgdu33*qdd23*pow2(chi))) -; - -rACsA3 -= -(qud13*(lieA11 + alpha*chi*Rf11) + - qud23*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + - qud33*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + - qud13*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + - (A13*alpha*K + lieA13)*sup3 + - alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + - qud23*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + - (A23*alpha*K + lieA23)*sup3 + - alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + - qud33*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + - (A33*alpha*K + lieA33)*sup3 + - alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + - alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud13 + - (-(cdA112*chi) + 1.5*A12*dchi1)*qud23 + - (-(cdA113*chi) + 1.5*A13*dchi1)*qud33) + - ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud13 + - (-(cdA222*chi) + 1.5*A22*dchi2)*qud23 + - (-(cdA223*chi) + 1.5*A23*dchi2)*qud33) + - ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud13 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud23 + - (-(cdA333*chi) + 1.5*A33*dchi3)*qud33) + - chi*((0.66666666666666666667*dK1 - dTheta1)*qud13 + - (0.66666666666666666667*dK2 - dTheta2)*qud23 + - (0.66666666666666666667*dK3 - dTheta3)*qud33) + - ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud23 + - (-(cdA213*chi) + 1.5*A13*dchi2)*qud33 - - chi*((cdA112 + cdA211)*qud13 + cdA122*qud23 + cdA123*qud33) + - 1.5*((A12*dchi1 + A11*dchi2)*qud13 + dchi1*(A22*qud23 + A23*qud33))\ -) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud23 + - (-(cdA313*chi) + 1.5*A13*dchi3)*qud33 - - chi*((cdA113 + cdA311)*qud13 + cdA123*qud23 + cdA133*qud33) + - 1.5*((A13*dchi1 + A11*dchi3)*qud13 + dchi1*(A23*qud23 + A33*qud33))\ -) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud23 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud33 - - chi*((cdA213 + cdA312)*qud13 + cdA223*qud23 + cdA233*qud33) + - 1.5*((A13*dchi2 + A12*dchi3)*qud13 + dchi2*(A23*qud23 + A33*qud33))\ -) + 0.5*(kappa1*((G1 - Gfromg1)*qdd13 + (G2 - Gfromg2)*qdd23 + - (G3 - Gfromg3)*qdd33) - dG13*qdd33*sup1 - dG21*qdd13*sup2 + - (dGfromgdu22*qdd23 - dG23*qdd33)*sup2 + - (dGfromgdu31*qdd13 + dGfromgdu32*qdd23 - dG33*qdd33)*sup3 + - qdd13*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - - dG31*sup3) + qdd23* - ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + - sup1*(-2.*AA11*qud13 + 0.5*dGfromgdu13*qdd33*pow2(chi))) + - sup2*(chi*(-(cdda12*qud13) - cdda22*qud23 - cdda23*qud33 + - alpha*qud23*Rf22) + alpha* - (chi*(qud13*Rf12 + qud33*Rf23) + 0.5*dGfromgdu23*qdd33*pow2(chi))) + - sup3*(chi*(-(cdda13*qud13) - cdda23*qud23 - cdda33*qud33 + - alpha*qud23*Rf23) + alpha* - (chi*(qud13*Rf13 + qud33*Rf33) + 0.5*dGfromgdu33*qdd33*pow2(chi))) -; - -rACABTF11 -= --(qPhysuudd1211*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3311*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1111*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1211* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1311*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2211*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2311*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1311 + AA22*qPhysuudd2211 + AA23*qPhysuudd2311 + - AA33*qPhysuudd3311 + qPhysuudd1111*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1311 + - (0.5*(A12*dchi1*qPhysuudd1111 + A23*dchi3*qPhysuudd3311))/chi)* - sup2) - qPhysuudd3311*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1211*sup3 + - qPhysuudd1211*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1311*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2211* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2311*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2311*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1211 + A13*dchi2*qPhysuudd1311)*sup2 + - (A12*dchi3*qPhysuudd1211 - - 0.5*dchi1*(A13*qPhysuudd1111 + A23*qPhysuudd1211))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1211 - - dchi3*(A11*qPhysuudd1311 + A12*qPhysuudd2311) + - dchi1*(A22*qPhysuudd2211 + A33*qPhysuudd3311))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1311) - - A22*dchi3*qPhysuudd2311 + - dchi2*(A11*qPhysuudd1111 + A33*qPhysuudd3311))*sup2 + - (-(A33*dchi1*qPhysuudd1311) + - A13*(-(dchi2*qPhysuudd1211) + dchi3*qPhysuudd1311) + - dchi3*(A11*qPhysuudd1111 + A22*qPhysuudd2211) + - A23*(-(dchi2*qPhysuudd2211) + dchi3*qPhysuudd2311))*sup3))/chi) -; - -rACABTF12 -= --(qPhysuudd1212*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3312*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1112*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1212* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1312*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2212*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2312*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1312 + AA22*qPhysuudd2212 + AA23*qPhysuudd2312 + - AA33*qPhysuudd3312 + qPhysuudd1112*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1312 + - (0.5*(A12*dchi1*qPhysuudd1112 + A23*dchi3*qPhysuudd3312))/chi)* - sup2) - qPhysuudd3312*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1212*sup3 + - qPhysuudd1212*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1312*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2212* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2312*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2312*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1212 + A13*dchi2*qPhysuudd1312)*sup2 + - (A12*dchi3*qPhysuudd1212 - - 0.5*dchi1*(A13*qPhysuudd1112 + A23*qPhysuudd1212))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1212 - - dchi3*(A11*qPhysuudd1312 + A12*qPhysuudd2312) + - dchi1*(A22*qPhysuudd2212 + A33*qPhysuudd3312))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1312) - - A22*dchi3*qPhysuudd2312 + - dchi2*(A11*qPhysuudd1112 + A33*qPhysuudd3312))*sup2 + - (-(A33*dchi1*qPhysuudd1312) + - A13*(-(dchi2*qPhysuudd1212) + dchi3*qPhysuudd1312) + - dchi3*(A11*qPhysuudd1112 + A22*qPhysuudd2212) + - A23*(-(dchi2*qPhysuudd2212) + dchi3*qPhysuudd2312))*sup3))/chi) -; - -rACABTF13 -= --(qPhysuudd1213*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3313*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1113*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1213* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1313*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2213*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2313*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1313 + AA22*qPhysuudd2213 + AA23*qPhysuudd2313 + - AA33*qPhysuudd3313 + qPhysuudd1113*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1313 + - (0.5*(A12*dchi1*qPhysuudd1113 + A23*dchi3*qPhysuudd3313))/chi)* - sup2) - qPhysuudd3313*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1213*sup3 + - qPhysuudd1213*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1313*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2213* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2313*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2313*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1213 + A13*dchi2*qPhysuudd1313)*sup2 + - (A12*dchi3*qPhysuudd1213 - - 0.5*dchi1*(A13*qPhysuudd1113 + A23*qPhysuudd1213))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1213 - - dchi3*(A11*qPhysuudd1313 + A12*qPhysuudd2313) + - dchi1*(A22*qPhysuudd2213 + A33*qPhysuudd3313))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1313) - - A22*dchi3*qPhysuudd2313 + - dchi2*(A11*qPhysuudd1113 + A33*qPhysuudd3313))*sup2 + - (-(A33*dchi1*qPhysuudd1313) + - A13*(-(dchi2*qPhysuudd1213) + dchi3*qPhysuudd1313) + - dchi3*(A11*qPhysuudd1113 + A22*qPhysuudd2213) + - A23*(-(dchi2*qPhysuudd2213) + dchi3*qPhysuudd2313))*sup3))/chi) -; - -rACABTF22 -= --(qPhysuudd1222*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3322*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1122*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1222* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1322*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2222*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2322*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1322 + AA22*qPhysuudd2222 + AA23*qPhysuudd2322 + - AA33*qPhysuudd3322 + qPhysuudd1122*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1322 + - (0.5*(A12*dchi1*qPhysuudd1122 + A23*dchi3*qPhysuudd3322))/chi)* - sup2) - qPhysuudd3322*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1222*sup3 + - qPhysuudd1222*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1322*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2222* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2322*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2322*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1222 + A13*dchi2*qPhysuudd1322)*sup2 + - (A12*dchi3*qPhysuudd1222 - - 0.5*dchi1*(A13*qPhysuudd1122 + A23*qPhysuudd1222))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1222 - - dchi3*(A11*qPhysuudd1322 + A12*qPhysuudd2322) + - dchi1*(A22*qPhysuudd2222 + A33*qPhysuudd3322))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1322) - - A22*dchi3*qPhysuudd2322 + - dchi2*(A11*qPhysuudd1122 + A33*qPhysuudd3322))*sup2 + - (-(A33*dchi1*qPhysuudd1322) + - A13*(-(dchi2*qPhysuudd1222) + dchi3*qPhysuudd1322) + - dchi3*(A11*qPhysuudd1122 + A22*qPhysuudd2222) + - A23*(-(dchi2*qPhysuudd2222) + dchi3*qPhysuudd2322))*sup3))/chi) -; - -rACABTF23 -= --(qPhysuudd1223*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3323*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1123*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1223* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1323*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2223*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2323*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1323 + AA22*qPhysuudd2223 + AA23*qPhysuudd2323 + - AA33*qPhysuudd3323 + qPhysuudd1123*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1323 + - (0.5*(A12*dchi1*qPhysuudd1123 + A23*dchi3*qPhysuudd3323))/chi)* - sup2) - qPhysuudd3323*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1223*sup3 + - qPhysuudd1223*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1323*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2223* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2323*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2323*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1223 + A13*dchi2*qPhysuudd1323)*sup2 + - (A12*dchi3*qPhysuudd1223 - - 0.5*dchi1*(A13*qPhysuudd1123 + A23*qPhysuudd1223))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1223 - - dchi3*(A11*qPhysuudd1323 + A12*qPhysuudd2323) + - dchi1*(A22*qPhysuudd2223 + A33*qPhysuudd3323))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1323) - - A22*dchi3*qPhysuudd2323 + - dchi2*(A11*qPhysuudd1123 + A33*qPhysuudd3323))*sup2 + - (-(A33*dchi1*qPhysuudd1323) + - A13*(-(dchi2*qPhysuudd1223) + dchi3*qPhysuudd1323) + - dchi3*(A11*qPhysuudd1123 + A22*qPhysuudd2223) + - A23*(-(dchi2*qPhysuudd2223) + dchi3*qPhysuudd2323))*sup3))/chi) -; - -rACABTF33 -= --(qPhysuudd1233*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3333*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1133*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1233* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1333*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2233*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2333*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1333 + AA22*qPhysuudd2233 + AA23*qPhysuudd2333 + - AA33*qPhysuudd3333 + qPhysuudd1133*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1333 + - (0.5*(A12*dchi1*qPhysuudd1133 + A23*dchi3*qPhysuudd3333))/chi)* - sup2) - qPhysuudd3333*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1233*sup3 + - qPhysuudd1233*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1333*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2233* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2333*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2333*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1233 + A13*dchi2*qPhysuudd1333)*sup2 + - (A12*dchi3*qPhysuudd1233 - - 0.5*dchi1*(A13*qPhysuudd1133 + A23*qPhysuudd1233))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1233 - - dchi3*(A11*qPhysuudd1333 + A12*qPhysuudd2333) + - dchi1*(A22*qPhysuudd2233 + A33*qPhysuudd3333))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1333) - - A22*dchi3*qPhysuudd2333 + - dchi2*(A11*qPhysuudd1133 + A33*qPhysuudd3333))*sup2 + - (-(A33*dchi1*qPhysuudd1333) + - A13*(-(dchi2*qPhysuudd1233) + dchi3*qPhysuudd1333) + - dchi3*(A11*qPhysuudd1133 + A22*qPhysuudd2233) + - A23*(-(dchi2*qPhysuudd2233) + dchi3*qPhysuudd2333))*sup3))/chi) -; - - -if (givehPsi0) { - -gADM11 -= -g11/chi -; - -gADM12 -= -g12/chi -; - -gADM13 -= -g13/chi -; - -gADM21 -= -g12/chi -; - -gADM22 -= -g22/chi -; - -gADM23 -= -g23/chi -; - -gADM31 -= -g13/chi -; - -gADM32 -= -g23/chi -; - -gADM33 -= -g33/chi -; - -vu1 -= --yp -; - -vu2 -= -xp -; - -vu3 -= -0 -; - -wu1 -= -((-(ADMginv13*sup2) + ADMginv12*sup3)*vu1 + - (ADMginv13*sup1 - ADMginv11*sup3)*vu2 + - (-(ADMginv12*sup1) + ADMginv11*sup2)*vu3)/Power(chi,1.5) -; - -wu2 -= -((-(ADMginv23*sup2) + ADMginv22*sup3)*vu1 + - (ADMginv23*sup1 - ADMginv12*sup3)*vu2 + - (-(ADMginv22*sup1) + ADMginv12*sup2)*vu3)/Power(chi,1.5) -; - -wu3 -= -((-(ADMginv33*sup2) + ADMginv23*sup3)*vu1 + - (ADMginv33*sup1 - ADMginv13*sup3)*vu2 + - (-(ADMginv23*sup1) + ADMginv13*sup2)*vu3)/Power(chi,1.5) -; - -sdotv -= -(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*vu1 + - (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*vu2 + - (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*vu3 -; - -vu1 -= --(sdotv*sup1) + vu1 -; - -vu2 -= --(sdotv*sup2) + vu2 -; - -vu3 -= --(sdotv*sup3) + vu3 -; - -vdotv -= -(gADM31*vu1 + (gADM23 + gADM32)*vu2)*vu3 + - vu1*((gADM12 + gADM21)*vu2 + gADM13*vu3) + gADM11*pow2(vu1) + - gADM22*pow2(vu2) + gADM33*pow2(vu3) -; - -vu1 -= -vu1/Sqrt(vdotv) -; - -vu2 -= -vu2/Sqrt(vdotv) -; - -vu3 -= -vu3/Sqrt(vdotv) -; - -sdotw -= -(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*wu1 + - (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*wu2 + - (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*wu3 -; - -vdotw -= -(gADM11*vu1 + gADM21*vu2 + gADM31*vu3)*wu1 + - (gADM12*vu1 + gADM22*vu2 + gADM32*vu3)*wu2 + - (gADM13*vu1 + gADM23*vu2 + gADM33*vu3)*wu3 -; - -wu1 -= --(sdotw*sup1) - vdotw*vu1 + wu1 -; - -wu2 -= --(sdotw*sup2) - vdotw*vu2 + wu2 -; - -wu3 -= --(sdotw*sup3) - vdotw*vu3 + wu3 -; - -wdotw -= -(gADM31*wu1 + (gADM23 + gADM32)*wu2)*wu3 + - wu1*((gADM12 + gADM21)*wu2 + gADM13*wu3) + gADM11*pow2(wu1) + - gADM22*pow2(wu2) + gADM33*pow2(wu3) -; - -wu1 -= -wu1/Sqrt(wdotw) -; - -wu2 -= -wu2/Sqrt(wdotw) -; - -wu3 -= -wu3/Sqrt(wdotw) -; - -vd1 -= -gADM11*vu1 + gADM12*vu2 + gADM13*vu3 -; - -vd2 -= -gADM21*vu1 + gADM22*vu2 + gADM23*vu3 -; - -vd3 -= -gADM31*vu1 + gADM32*vu2 + gADM33*vu3 -; - -wd1 -= -gADM11*wu1 + gADM12*wu2 + gADM13*wu3 -; - -wd2 -= -gADM21*wu1 + gADM22*wu2 + gADM23*wu3 -; - -wd3 -= -gADM31*wu1 + gADM32*wu2 + gADM33*wu3 -; - -RehPsi0 -= -Power(2.7182818284590452354,pow2(hPsi0parb)* - (2.*hPsi0parc*time - pow2(hPsi0parc) - pow2(time)))*hPsi0para -; - -ImhPsi0 -= -0 -; - -rACABTF11 -= -rACABTF11 + alpha*chi*(2.*ImhPsi0*vd1*wd1 + RehPsi0*(pow2(vd1) - pow2(wd1))) -; - -rACABTF12 -= -rACABTF12 + alpha*chi*(vd2*(RehPsi0*vd1 + ImhPsi0*wd1) + - (ImhPsi0*vd1 - RehPsi0*wd1)*wd2) -; - -rACABTF13 -= -rACABTF13 + alpha*chi*(vd3*(RehPsi0*vd1 + ImhPsi0*wd1) + - (ImhPsi0*vd1 - RehPsi0*wd1)*wd3) -; - -rACABTF22 -= -rACABTF22 + alpha*chi*(2.*ImhPsi0*vd2*wd2 + RehPsi0*(pow2(vd2) - pow2(wd2))) -; - -rACABTF23 -= -rACABTF23 + alpha*chi*(vd3*(RehPsi0*vd2 + ImhPsi0*wd2) + - (ImhPsi0*vd2 - RehPsi0*wd2)*wd3) -; - -rACABTF33 -= -rACABTF33 + alpha*chi*(2.*ImhPsi0*vd3*wd3 + RehPsi0*(pow2(vd3) - pow2(wd3))) -; - - - } - -rA11 -= -rACABTF11 + 0.5*qdd11*rACqq + 2.* - (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)*sdown1 + rACss*pow2(sdown1) -; - -rA12 -= -rACABTF12 + 0.5*qdd12*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* - sdown2 + sdown1*(qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3 + - rACss*sdown2) -; - -rA13 -= -rACABTF13 + 0.5*qdd13*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* - sdown3 + sdown1*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + - rACss*sdown3) -; - -rA22 -= -rACABTF22 + 0.5*qdd22*rACqq + 2.* - (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)*sdown2 + rACss*pow2(sdown2) -; - -rA23 -= -rACABTF23 + 0.5*qdd23*rACqq + (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)* - sdown3 + sdown2*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + - rACss*sdown3) -; - -rA33 -= -rACABTF33 + 0.5*qdd33*rACqq + 2.* - (qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3)*sdown3 + rACss*pow2(sdown3) -; - -rG1 -= -qud11*rGamA1 + qud12*rGamA2 + qud13*rGamA3 + rGams*sup1 -; - -rG2 -= -qud21*rGamA1 + qud22*rGamA2 + qud23*rGamA3 + rGams*sup2 -; - -rG3 -= -qud31*rGamA1 + qud32*rGamA2 + qud33*rGamA3 + rGams*sup3 -; -#else -// code adapted from David 2012-8-18 - -detginv -= -1/(2.*g12*g13*g23 + g11*g22*g33 - - g33*pow2(g12) - g22*pow2(g13) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -ginv11*chi -; - -ADMginv12 -= -ginv12*chi -; - -ADMginv13 -= -ginv13*chi -; - -ADMginv22 -= -ginv22*chi -; - -ADMginv23 -= -ginv23*chi -; - -ADMginv33 -= -ginv33*chi -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -qdd11 -= -g11/chi - pow2(sdown1) -; - -qdd12 -= --(sdown1*sdown2) + g12/chi -; - -qdd13 -= --(sdown1*sdown3) + g13/chi -; - -qdd22 -= -g22/chi - pow2(sdown2) -; - -qdd23 -= --(sdown2*sdown3) + g23/chi -; - -qdd33 -= -g33/chi - pow2(sdown3) -; - -quu11 -= -ADMginv11 - pow2(sup1) -; - -quu12 -= -ADMginv12 - sup1*sup2 -; - -quu13 -= -ADMginv13 - sup1*sup3 -; - -quu22 -= -ADMginv22 - pow2(sup2) -; - -quu23 -= -ADMginv23 - sup2*sup3 -; - -quu33 -= -ADMginv33 - pow2(sup3) -; - -qPhysuudd1111 -= --0.5*qdd11*quu11 + pow2(qud11) -; - -qPhysuudd1112 -= -qud11*qud12 - 0.5*qdd12*quu11 -; - -qPhysuudd1113 -= -qud11*qud13 - 0.5*qdd13*quu11 -; - -qPhysuudd1122 -= --0.5*qdd22*quu11 + pow2(qud12) -; - -qPhysuudd1123 -= -qud12*qud13 - 0.5*qdd23*quu11 -; - -qPhysuudd1133 -= --0.5*qdd33*quu11 + pow2(qud13) -; - -qPhysuudd1211 -= -qud11*qud21 - 0.5*qdd11*quu12 -; - -qPhysuudd1212 -= -0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) -; - -qPhysuudd1213 -= -0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) -; - -qPhysuudd1222 -= -qud12*qud22 - 0.5*qdd22*quu12 -; - -qPhysuudd1223 -= -0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) -; - -qPhysuudd1233 -= -qud13*qud23 - 0.5*qdd33*quu12 -; - -qPhysuudd1311 -= -qud11*qud31 - 0.5*qdd11*quu13 -; - -qPhysuudd1312 -= -0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) -; - -qPhysuudd1313 -= -0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) -; - -qPhysuudd1322 -= -qud12*qud32 - 0.5*qdd22*quu13 -; - -qPhysuudd1323 -= -0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) -; - -qPhysuudd1333 -= -qud13*qud33 - 0.5*qdd33*quu13 -; - -qPhysuudd2211 -= --0.5*qdd11*quu22 + pow2(qud21) -; - -qPhysuudd2212 -= -qud21*qud22 - 0.5*qdd12*quu22 -; - -qPhysuudd2213 -= -qud21*qud23 - 0.5*qdd13*quu22 -; - -qPhysuudd2222 -= --0.5*qdd22*quu22 + pow2(qud22) -; - -qPhysuudd2223 -= -qud22*qud23 - 0.5*qdd23*quu22 -; - -qPhysuudd2233 -= --0.5*qdd33*quu22 + pow2(qud23) -; - -qPhysuudd2311 -= -qud21*qud31 - 0.5*qdd11*quu23 -; - -qPhysuudd2312 -= -0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) -; - -qPhysuudd2313 -= -0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) -; - -qPhysuudd2322 -= -qud22*qud32 - 0.5*qdd22*quu23 -; - -qPhysuudd2323 -= -0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) -; - -qPhysuudd2333 -= -qud23*qud33 - 0.5*qdd33*quu23 -; - -qPhysuudd3311 -= --0.5*qdd11*quu33 + pow2(qud31) -; - -qPhysuudd3312 -= -qud31*qud32 - 0.5*qdd12*quu33 -; - -qPhysuudd3313 -= -qud31*qud33 - 0.5*qdd13*quu33 -; - -qPhysuudd3322 -= --0.5*qdd22*quu33 + pow2(qud32) -; - -qPhysuudd3323 -= -qud32*qud33 - 0.5*qdd23*quu33 -; - -qPhysuudd3333 -= --0.5*qdd33*quu33 + pow2(qud33) -; - -muL -= -2./alpha -; - -muStilde -= -1/chi -; - -vbetas -= -2.*sqrt(0.33333333333333333333*muStilde) -; - -vbetaA -= -sqrt(muStilde) -; - -K -= -Khat + 2.*Theta -; - -dK1 -= -dKhat1 + 2.*dTheta1 -; - -dK2 -= -dKhat2 + 2.*dTheta2 -; - -dK3 -= -dKhat3 + 2.*dTheta3 -; - -dginv111 -= --2.*(dg123*ginv12*ginv13 + ginv11*(dg112*ginv12 + dg113*ginv13)) - - dg111*pow2(ginv11) - dg122*pow2(ginv12) - dg133*pow2(ginv13) -; - -dginv112 -= --(ginv11*(dg111*ginv12 + dg112*ginv22 + dg113*ginv23)) - - ginv12*(dg113*ginv13 + dg122*ginv22 + dg123*ginv23) - - ginv13*(dg123*ginv22 + dg133*ginv23) - dg112*pow2(ginv12) -; - -dginv113 -= --(ginv11*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33)) - - ginv12*(dg112*ginv13 + dg122*ginv23 + dg123*ginv33) - - ginv13*(dg123*ginv23 + dg133*ginv33) - dg113*pow2(ginv13) -; - -dginv122 -= --2.*(dg123*ginv22*ginv23 + ginv12*(dg112*ginv22 + dg113*ginv23)) - - dg111*pow2(ginv12) - dg122*pow2(ginv22) - dg133*pow2(ginv23) -; - -dginv123 -= --(ginv13*(dg112*ginv22 + dg113*ginv23)) - dg133*ginv23*ginv33 - - ginv12*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33) - - ginv22*(dg122*ginv23 + dg123*ginv33) - dg123*pow2(ginv23) -; - -dginv133 -= --2.*(dg123*ginv23*ginv33 + ginv13*(dg112*ginv23 + dg113*ginv33)) - - dg111*pow2(ginv13) - dg122*pow2(ginv23) - dg133*pow2(ginv33) -; - -dginv211 -= --2.*(dg223*ginv12*ginv13 + ginv11*(dg212*ginv12 + dg213*ginv13)) - - dg211*pow2(ginv11) - dg222*pow2(ginv12) - dg233*pow2(ginv13) -; - -dginv212 -= --(ginv11*(dg211*ginv12 + dg212*ginv22 + dg213*ginv23)) - - ginv12*(dg213*ginv13 + dg222*ginv22 + dg223*ginv23) - - ginv13*(dg223*ginv22 + dg233*ginv23) - dg212*pow2(ginv12) -; - -dginv213 -= --(ginv11*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33)) - - ginv12*(dg212*ginv13 + dg222*ginv23 + dg223*ginv33) - - ginv13*(dg223*ginv23 + dg233*ginv33) - dg213*pow2(ginv13) -; - -dginv222 -= --2.*(dg223*ginv22*ginv23 + ginv12*(dg212*ginv22 + dg213*ginv23)) - - dg211*pow2(ginv12) - dg222*pow2(ginv22) - dg233*pow2(ginv23) -; - -dginv223 -= --(ginv13*(dg212*ginv22 + dg213*ginv23)) - dg233*ginv23*ginv33 - - ginv12*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33) - - ginv22*(dg222*ginv23 + dg223*ginv33) - dg223*pow2(ginv23) -; - -dginv233 -= --2.*(dg223*ginv23*ginv33 + ginv13*(dg212*ginv23 + dg213*ginv33)) - - dg211*pow2(ginv13) - dg222*pow2(ginv23) - dg233*pow2(ginv33) -; - -dginv311 -= --2.*(dg323*ginv12*ginv13 + ginv11*(dg312*ginv12 + dg313*ginv13)) - - dg311*pow2(ginv11) - dg322*pow2(ginv12) - dg333*pow2(ginv13) -; - -dginv312 -= --(ginv11*(dg311*ginv12 + dg312*ginv22 + dg313*ginv23)) - - ginv12*(dg313*ginv13 + dg322*ginv22 + dg323*ginv23) - - ginv13*(dg323*ginv22 + dg333*ginv23) - dg312*pow2(ginv12) -; - -dginv313 -= --(ginv11*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33)) - - ginv12*(dg312*ginv13 + dg322*ginv23 + dg323*ginv33) - - ginv13*(dg323*ginv23 + dg333*ginv33) - dg313*pow2(ginv13) -; - -dginv322 -= --2.*(dg323*ginv22*ginv23 + ginv12*(dg312*ginv22 + dg313*ginv23)) - - dg311*pow2(ginv12) - dg322*pow2(ginv22) - dg333*pow2(ginv23) -; - -dginv323 -= --(ginv13*(dg312*ginv22 + dg313*ginv23)) - dg333*ginv23*ginv33 - - ginv12*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33) - - ginv22*(dg322*ginv23 + dg323*ginv33) - dg323*pow2(ginv23) -; - -dginv333 -= --2.*(dg323*ginv23*ginv33 + ginv13*(dg312*ginv23 + dg313*ginv33)) - - dg311*pow2(ginv13) - dg322*pow2(ginv23) - dg333*pow2(ginv33) -; - -gammado111 -= -0.5*dg111 -; - -gammado112 -= -0.5*dg211 -; - -gammado113 -= -0.5*dg311 -; - -gammado122 -= --0.5*dg122 + dg212 -; - -gammado123 -= -0.5*(-dg123 + dg213 + dg312) -; - -gammado133 -= --0.5*dg133 + dg313 -; - -gammado211 -= -dg112 - 0.5*dg211 -; - -gammado212 -= -0.5*dg122 -; - -gammado213 -= -0.5*(dg123 - dg213 + dg312) -; - -gammado222 -= -0.5*dg222 -; - -gammado223 -= -0.5*dg322 -; - -gammado233 -= --0.5*dg233 + dg323 -; - -gammado311 -= -dg113 - 0.5*dg311 -; - -gammado312 -= -0.5*(dg123 + dg213 - dg312) -; - -gammado313 -= -0.5*dg133 -; - -gammado322 -= -dg223 - 0.5*dg322 -; - -gammado323 -= -0.5*dg233 -; - -gammado333 -= -0.5*dg333 -; - -gamma111 -= -gammado111*ginv11 + gammado211*ginv12 + gammado311*ginv13 -; - -gamma112 -= -gammado112*ginv11 + gammado212*ginv12 + gammado312*ginv13 -; - -gamma113 -= -gammado113*ginv11 + gammado213*ginv12 + gammado313*ginv13 -; - -gamma122 -= -gammado122*ginv11 + gammado222*ginv12 + gammado322*ginv13 -; - -gamma123 -= -gammado123*ginv11 + gammado223*ginv12 + gammado323*ginv13 -; - -gamma133 -= -gammado133*ginv11 + gammado233*ginv12 + gammado333*ginv13 -; - -gamma211 -= -gammado111*ginv12 + gammado211*ginv22 + gammado311*ginv23 -; - -gamma212 -= -gammado112*ginv12 + gammado212*ginv22 + gammado312*ginv23 -; - -gamma213 -= -gammado113*ginv12 + gammado213*ginv22 + gammado313*ginv23 -; - -gamma222 -= -gammado122*ginv12 + gammado222*ginv22 + gammado322*ginv23 -; - -gamma223 -= -gammado123*ginv12 + gammado223*ginv22 + gammado323*ginv23 -; - -gamma233 -= -gammado133*ginv12 + gammado233*ginv22 + gammado333*ginv23 -; - -gamma311 -= -gammado111*ginv13 + gammado211*ginv23 + gammado311*ginv33 -; - -gamma312 -= -gammado112*ginv13 + gammado212*ginv23 + gammado312*ginv33 -; - -gamma313 -= -gammado113*ginv13 + gammado213*ginv23 + gammado313*ginv33 -; - -gamma322 -= -gammado122*ginv13 + gammado222*ginv23 + gammado322*ginv33 -; - -gamma323 -= -gammado123*ginv13 + gammado223*ginv23 + gammado323*ginv33 -; - -gamma333 -= -gammado133*ginv13 + gammado233*ginv23 + gammado333*ginv33 -; - -Gfromg1 -= -gamma111*ginv11 + gamma122*ginv22 + - 2.*(gamma112*ginv12 + gamma113*ginv13 + gamma123*ginv23) + gamma133*ginv33 -; - -Gfromg2 -= -gamma211*ginv11 + gamma222*ginv22 + - 2.*(gamma212*ginv12 + gamma213*ginv13 + gamma223*ginv23) + gamma233*ginv33 -; - -Gfromg3 -= -gamma311*ginv11 + gamma322*ginv22 + - 2.*(gamma312*ginv12 + gamma313*ginv13 + gamma323*ginv23) + gamma333*ginv33 -; - -dGfromgdu11 -= -(ddg1111 - dg111*((8.*dg112 + 2.*dg211)*ginv12 + - (8.*dg113 + 2.*dg311)*ginv13) - - (dg113*(4.*dg112 + dg211) + dg112*dg311 + dg111*(dg213 + dg312))* - ginv23 - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - - ginv33*(dg113*dg311 + dg111*dg313 + 2.*pow2(dg113)))*pow2(ginv11) + - (ddg1122 + ddg1212 - (dg123*(8.*dg112 + 2.*dg211) + - dg113*(4.*dg122 + 2.*dg212) + dg122*dg311 + - 2.*(dg111*dg223 + dg112*(dg213 + dg312)) + dg111*dg322)*ginv13 - - (dg123*(4.*dg122 + 2.*dg212) + - 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* - ginv23 - ginv22*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122)) - - ginv33*(dg123*(dg213 + dg312) + dg122*dg313 + dg113*(dg223 + dg322) + - dg112*dg323 + 2.*pow2(dg123)))*pow2(ginv12) + - (ddg1133 + ddg1313 - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*ginv23 - - ginv22*(dg133*dg212 + dg113*dg223 + dg123*(dg213 + dg312) + - dg112*(dg233 + dg323) + 2.*pow2(dg123)) - - ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133)))*pow2(ginv13) \ -+ ginv13*(ddg1333*ginv33 + ginv22* - (ddg1223 - (dg133*dg222 + dg123*(4.*dg223 + dg322) + - dg122*(dg233 + dg323))*ginv23 - - (dg133*dg223 + dg123*(dg233 + 2.*dg323))*ginv33) + - ginv23*(ddg1233 + ddg1323 - - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)*ginv33) - - (dg123*dg222 + dg122*dg223)*pow2(ginv22) - - (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + - dg122*dg333)*pow2(ginv23) - 2.*dg133*dg333*pow2(ginv33)) + - ginv11*(ddg1313*ginv33 + ginv12* - (2.*ddg1112 + ddg1211 - (dg113*(12.*dg112 + 3.*dg211) + - 3.*dg112*dg311 + dg111*(8.*dg123 + 3.*(dg213 + dg312)))*ginv13 \ -- (dg122*(4.*dg112 + dg211) + 6.*dg112*dg212 + dg111*dg222)*ginv22 - - (dg123*dg211 + dg122*dg311 + - 4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213 + dg312)) + - dg111*(dg223 + dg322))*ginv23 - - (dg123*dg311 + dg113*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*dg112*dg313 + dg111*dg323)*ginv33) + - ginv22*(ddg1212 - (dg113*dg222 + 2.*(dg123*dg212 + dg112*dg223) + - dg122*(dg213 + dg312) + dg112*dg322)*ginv23 - - (dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323)*ginv33) + - ginv13*(2.*ddg1113 + ddg1311 - - (dg123*(4.*dg112 + dg211) + dg111*dg223 + - 2.*(dg113*dg212 + dg112*(dg213 + dg312)))*ginv22 - - (dg133*dg211 + dg123*dg311 + - 4.*(dg113*(dg123 + dg213 + dg312) + dg112*(dg133 + dg313)) + - dg111*(dg233 + dg323))*ginv23 - - (dg133*(4.*dg113 + dg311) + 6.*dg113*dg313 + dg111*dg333)*ginv33) + - ginv23*(ddg1213 + ddg1312 - - (dg133*(dg213 + dg312) + 2.*dg123*dg313 + - dg113*(dg233 + 2.*dg323) + dg112*dg333)*ginv33) - - (3.*dg112*dg211 + dg111*(4.*dg122 + 3.*dg212) + 6.*pow2(dg112))* - pow2(ginv12) - (3.*dg113*dg311 + dg111*(4.*dg133 + 3.*dg313) + - 6.*pow2(dg113))*pow2(ginv13) - - (dg122*dg212 + dg112*dg222)*pow2(ginv22) - - (dg133*dg212 + dg123*(dg213 + dg312) + dg122*dg313 + - dg113*(dg223 + dg322) + dg112*(dg233 + dg323))*pow2(ginv23) - - (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + - ginv12*(ddg1323*ginv33 + ginv22* - (ddg1222 - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)* - ginv23 - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33) + - ginv23*(ddg1223 + ddg1322 - - (dg133*(dg223 + dg322) + dg123*(dg233 + 4.*dg323) + dg122*dg333)* - ginv33) + ginv13*(2.*ddg1123 + ddg1213 + ddg1312 - - (dg113*dg222 + 4.*(dg123*(dg122 + dg212) + dg112*dg223) + - dg122*(dg213 + dg312) + dg112*dg322)*ginv22 - - (dg133*(4.*dg123 + dg213 + dg312) + 4.*dg123*dg313 + - dg113*(dg233 + 4.*dg323) + dg112*dg333)*ginv33 - - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg122*dg313 + - dg113*dg322) + 4.* - (dg122*dg133 + dg113*dg223 + dg123*(dg213 + dg312) + - dg112*dg323 + pow2(dg123)))) - - (dg133*(4.*dg112 + dg211) + dg113*(8.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* - pow2(ginv13) - 2.*dg122*dg222*pow2(ginv22) - - (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* - pow2(ginv23) - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) - - 2.*pow2(dg111)*pow3(ginv11) - - (dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*pow3(ginv12) - - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*pow3(ginv13) -; - -dGfromgdu12 -= -(ddg1112 + ddg1211 - (4.*(dg112*dg113 + dg111*dg123) + - 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))*ginv13 - - (dg122*(6.*dg112 + 2.*dg211) + 6.*dg112*dg212 + 2.*dg111*dg222)* - ginv22 - (4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213)) + - dg122*dg311 + 2.*(dg123*dg211 + dg111*dg223 + dg112*dg312) + - dg111*dg322)*ginv23 - (dg123*dg311 + - dg113*(2.*(dg123 + dg213) + dg312) + dg112*dg313 + dg111*dg323)* - ginv33)*pow2(ginv12) - ((2.*(dg113*dg123 + dg112*dg133) + - dg123*dg311 + dg113*dg312 + dg112*dg313 + dg111*dg323)*ginv22 + - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*ginv23)* - pow2(ginv13) + (ddg1222 - (4.*(dg123*dg222 + dg122*dg223) + - 2.*dg122*dg322)*ginv23 - - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33)*pow2(ginv22) + - (ddg1233 + ddg1323 - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)* - ginv33)*pow2(ginv23) + ginv11* - (ginv23*(ddg1113 - 2.*dg113*(dg133 + dg313)*ginv33) + - ginv22*(ddg1112 - (dg112*(4.*dg123 + 2.*dg213) + - 2.*(dg113*(dg122 + dg212) + dg112*dg312))*ginv23 - - (dg113*(2.*dg123 + dg312) + dg112*dg313)*ginv33) + - ginv12*(ddg1111 - dg111*(6.*dg113 + 2.*dg311)*ginv13 - - (dg113*(8.*dg112 + 2.*dg211) + dg112*dg311 + - dg111*(2.*(dg123 + dg213) + dg312))*ginv23 - - ginv22*(2.*(dg112*dg211 + dg111*(dg122 + dg212)) + - 6.*pow2(dg112)) - ginv33* - (dg113*dg311 + dg111*dg313 + 2.*pow2(dg113))) - - ginv13*((dg112*(4.*dg113 + dg311) + dg111*(2.*dg123 + dg312))* - ginv22 + ginv23*(dg113*dg311 + dg111*(2.*dg133 + dg313) + - 4.*pow2(dg113))) - dg111*(6.*dg112 + 2.*dg211)*pow2(ginv12) - - 2.*dg112*(dg122 + dg212)*pow2(ginv22) - - (2.*(dg112*dg133 + dg113*(dg123 + dg213)) + dg113*dg312 + dg112*dg313)* - pow2(ginv23)) + ginv13*(ginv22* - (ddg1123 + ddg1312 - (dg133*(2.*dg123 + dg312) + - 2.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33 - - ginv23*(2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg113*dg223 + - dg112*dg233) + dg122*dg313 + dg113*dg322 + - 4.*(dg123*dg312 + dg112*dg323 + pow2(dg123)))) + - ginv23*(ddg1133 + ddg1313 - - ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))) - - (2.*(dg123*(dg122 + dg212) + dg112*dg223) + dg122*dg312 + - dg112*dg322)*pow2(ginv22) - - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*pow2(ginv23)\ -) + ginv23*(ddg1333*ginv33 - 2.*dg133*dg333*pow2(ginv33)) + - ginv12*(ddg1313*ginv33 + ginv13* - (ddg1113 + ddg1311 - (2.* - (dg123*dg211 + dg113*(dg122 + dg212) + dg111*dg223) + - dg122*dg311 + dg112*(8.*dg123 + 2.*dg213 + 4.*dg312) + - dg111*dg322)*ginv22 - - (dg133*(4.*dg112 + 2.*dg211) + - dg113*(8.*dg123 + 4.*(dg213 + dg312)) + 4.*dg112*dg313 + - 2.*(dg123*dg311 + dg111*(dg233 + dg323)))*ginv23 - - (dg133*(2.*dg113 + dg311) + 4.*dg113*dg313 + dg111*dg333)*ginv33) + - ginv23*(ddg1123 + 2.*ddg1213 + ddg1312 - - (2.*(dg133*(dg123 + dg213) + dg113*dg233) + dg133*dg312 + - 4.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33) + - ginv22*(ddg1122 + 2.*ddg1212 - - (4.*(dg122*dg213 + dg113*dg222) + - 6.*(dg123*(dg122 + dg212) + dg112*dg223) + - 3.*(dg122*dg312 + dg112*dg322))*ginv23 - - ginv33*(dg122*dg313 + dg113*dg322 + - 2.*(dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323 + - pow2(dg123)))) - - 2.*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow2(ginv13) - - (4.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))*pow2(ginv22) - - (4.*(dg123*dg213 + dg113*dg223) + - 2.*(dg133*(dg122 + dg212) + dg123*dg312 + dg122*dg313 + - dg113*dg322 + dg112*(dg233 + dg323) + pow2(dg123)))*pow2(ginv23) \ -- (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + - ginv22*(ddg1323*ginv33 + ginv23* - (2.*ddg1223 + ddg1322 - (2.*(dg133*dg223 + dg123*dg233) + - dg133*dg322 + 6.*dg123*dg323 + dg122*dg333)*ginv33) - - (2.*(dg133*dg222 + dg122*dg233) + dg123*(6.*dg223 + 3.*dg322) + - 3.*dg122*dg323)*pow2(ginv23) - - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) - - 2.*((dg111*(dg112*ginv22 + dg113*ginv23) + ginv12*pow2(dg111))* - pow2(ginv11) + (dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112))* - pow3(ginv12) + dg122*dg222*pow3(ginv22)) - - (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + dg122*dg333)* - pow3(ginv23) -; - -dGfromgdu13 -= --(((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*ginv23 + - (2.*(dg113*dg122 + dg112*dg123) + dg123*dg211 + dg113*dg212 + - dg112*dg213 + dg111*dg223)*ginv33 + - 2.*ginv13*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)))* - pow2(ginv12)) + (ddg1113 + ddg1311 - - (dg123*(2.*dg112 + dg211) + dg113*dg212 + dg111*dg223 + - dg112*(dg213 + 2.*dg312))*ginv22 - - (dg133*dg211 + 2.*(dg113*dg213 + dg123*dg311) + - 4.*(dg113*(dg123 + dg312) + dg112*(dg133 + dg313)) + - dg111*(dg233 + 2.*dg323))*ginv23 - - (dg133*(6.*dg113 + 2.*dg311) + 6.*dg113*dg313 + 2.*dg111*dg333)*ginv33\ -)*pow2(ginv13) - (2.*dg122*dg222*ginv23 + - (dg123*dg222 + dg122*dg223)*ginv33)*pow2(ginv22) + - (ddg1223 + ddg1322 - (3.*(dg133*dg223 + dg123*dg233) + 6.*dg123*dg323 + - 2.*(dg133*dg322 + dg122*dg333))*ginv33)*pow2(ginv23) + - ddg1333*pow2(ginv33) + ginv11* - (ddg1113*ginv33 - ginv22*(2.*dg112*(dg122 + dg212)*ginv23 + - (dg113*dg212 + dg112*(2.*dg123 + dg213))*ginv33) + - ginv23*(ddg1112 - (dg113*(4.*dg123 + 2.*dg213) + - 2.*(dg113*dg312 + dg112*(dg133 + dg313)))*ginv33) - - ginv12*(dg111*(6.*dg112 + 2.*dg211)*ginv13 + - (dg113*(4.*dg112 + dg211) + dg111*(2.*dg123 + dg213))*ginv33 + - ginv23*(dg112*dg211 + dg111*(2.*dg122 + dg212) + 4.*pow2(dg112))) + - ginv13*(ddg1111 - (dg113*(8.*dg112 + dg211) + 2.*dg112*dg311 + - dg111*(dg213 + 2.*(dg123 + dg312)))*ginv23 - - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - - ginv33*(2.*(dg113*dg311 + dg111*(dg133 + dg313)) + 6.*pow2(dg113))) \ -- dg111*(6.*dg113 + 2.*dg311)*pow2(ginv13) - - (dg113*dg212 + dg112*dg213 + - 2.*(dg113*dg122 + dg112*(dg123 + dg312)))*pow2(ginv23) - - 2.*dg113*(dg133 + dg313)*pow2(ginv33)) + - ginv12*((ddg1123 + ddg1213)*ginv33 + - ginv13*(ddg1112 + ddg1211 - - (dg122*(2.*dg112 + dg211) + 4.*dg112*dg212 + dg111*dg222)*ginv22 - - (dg123*(8.*dg112 + 2.*dg211) + - 4.*(dg113*(dg122 + dg212) + dg112*(dg213 + dg312)) + - 2.*(dg122*dg311 + dg111*(dg223 + dg322)))*ginv23 - - (dg133*(2.*dg112 + dg211) + - dg113*(8.*dg123 + 4.*dg213 + 2.*dg312) + - 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* - ginv33) - ginv22*((dg122*dg213 + dg113*dg222 + - 2.*(dg123*(dg122 + dg212) + dg112*dg223))*ginv33 + - ginv23*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))) + - ginv23*(ddg1122 + ddg1212 - - ginv33*(dg133*(2.*dg122 + dg212) + - 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322) + - dg112*(dg233 + 2.*dg323) + - 4.*(dg123*dg213 + dg113*dg223 + pow2(dg123)))) - - (4.*(dg112*dg113 + dg111*dg123) + - 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))* - pow2(ginv13) - (dg123*(4.*dg122 + 2.*dg212) + - 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* - pow2(ginv23) - (dg133*(2.*dg123 + dg213) + 2.*dg123*dg313 + - dg113*(dg233 + 2.*dg323))*pow2(ginv33)) + - ginv22*(ddg1223*ginv33 + ginv23* - (ddg1222 - (dg133*dg222 + dg123*(6.*dg223 + 2.*dg322) + - dg122*(dg233 + 2.*dg323))*ginv33) - - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*pow2(ginv23) - - (dg133*dg223 + dg123*(dg233 + 2.*dg323))*pow2(ginv33)) + - ginv23*((ddg1233 + 2.*ddg1323)*ginv33 - - (dg133*(2.*dg233 + 4.*dg323) + 4.*dg123*dg333)*pow2(ginv33)) + - ginv13*((ddg1133 + 2.*ddg1313)*ginv33 + - ginv23*(ddg1123 + ddg1213 + 2.*ddg1312 - - (dg133*(6.*dg123 + 3.*dg213 + 4.*dg312) + 6.*dg123*dg313 + - dg113*(3.*dg233 + 6.*dg323) + 4.*dg112*dg333)*ginv33) + - ginv22*(ddg1212 - (dg123*(2.*dg122 + 4.*dg212) + dg113*dg222 + - dg122*(dg213 + 2.*dg312) + dg112*(4.*dg223 + 2.*dg322))*ginv23 \ -- ginv33*(dg133*dg212 + dg112*(dg233 + 2.*dg323) + - 2.*(dg113*dg223 + dg123*(dg213 + dg312) + pow2(dg123)))) - - (dg122*dg212 + dg112*dg222)*pow2(ginv22) - - (4.*(dg123*dg312 + dg112*dg323) + - 2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg112*dg233 + - dg122*dg313 + dg113*(dg223 + dg322) + pow2(dg123)))*pow2(ginv23) \ -- (4.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))*pow2(ginv33)) - - (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* - pow3(ginv23) - 2.*((dg111*(dg112*ginv23 + dg113*ginv33) + - ginv13*pow2(dg111))*pow2(ginv11) + - (dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow3(ginv13) + - dg133*dg333*pow3(ginv33)) -; - -dGfromgdu21 -= -(ddg1211 - (4.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - - 2.*(dg112 + dg211)*dg212*ginv22 - - (2.*(dg113*dg212 + (dg112 + dg211)*dg213) + dg212*dg311 + - dg211*dg312)*ginv23 - (dg213*(2.*dg113 + dg311) + dg211*dg313)* - ginv33 - ginv12*(4.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211)))* - pow2(ginv11) + (ddg1222 + ddg2212 - - (4.*(dg212*(dg123 + dg213) + (dg112 + dg211)*dg223) + dg222*dg311 + - 2.*(dg122*dg213 + dg113*dg222 + dg212*dg312) + dg211*dg322)*ginv13 \ -- (2.*dg122 + 6.*dg212)*dg222*ginv22 - - ((2.*dg122 + 4.*dg212)*dg223 + - dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)*ginv23 - - (dg223*(2.*(dg123 + dg213) + dg312) + dg222*dg313 + dg213*dg322 + - dg212*dg323)*ginv33)*pow2(ginv12) + - (ddg1233 + ddg2313 - (2.*((dg123 + dg213)*dg223 + dg212*dg233) + - dg223*dg312 + dg212*dg323)*ginv22 - - (dg233*(4.*dg213 + 2.*dg312) + - 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + - dg212*dg333))*ginv23 - - (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33)*pow2(ginv13) + - ginv11*(ddg2313*ginv33 + ginv22* - (ddg2212 - (dg222*(2.*dg213 + dg312) + dg212*(4.*dg223 + dg322))* - ginv23 - (dg223*(2.*dg213 + dg312) + dg212*dg323)*ginv33) + - ginv23*(ddg2213 + ddg2312 - - (dg233*(2.*dg213 + dg312) + 2.*(dg223*dg313 + dg213*dg323) + - dg212*dg333)*ginv33) + - ginv13*(2.*ddg1213 + ddg2311 - - (2.*(dg112 + dg211)*dg223 + - dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv22 - - (2.*(dg133*dg213 + dg113*dg233) + dg233*dg311 + 6.*dg213*dg313 + - dg211*dg333)*ginv33 - - ginv23*(2.*(dg133*dg212 + dg123*dg213 + dg113*dg223 + - (dg112 + dg211)*dg233) + dg223*dg311 + dg211*dg323 + - 4.*(dg213*dg312 + dg212*dg313 + pow2(dg213)))) + - ginv12*(2.*ddg1212 + ddg2211 - - (6.*(dg113*dg212 + dg112*dg213) + 4.*dg111*dg223 + - 3.*dg212*dg311 + dg211*(4.*dg123 + 6.*dg213 + 3.*dg312))*ginv13 \ -- (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + - (dg112 + dg211)*dg223) + dg222*dg311 + - dg212*(8.*dg213 + 4.*dg312) + dg211*dg322)*ginv23 - - ginv22*(2.*(dg122*dg212 + (dg112 + dg211)*dg222) + - 6.*pow2(dg212)) - ginv33* - (dg223*dg311 + dg211*dg323 + - 2.*(dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313 + - pow2(dg213)))) - - (6.*dg112*dg212 + dg211*(2.*dg122 + 6.*dg212) + 2.*dg111*dg222)* - pow2(ginv12) - (2.*(dg133*dg211 + dg111*dg233) + - dg213*(6.*dg113 + 3.*dg311) + 3.*dg211*dg313)*pow2(ginv13) - - 2.*dg212*dg222*pow2(ginv22) - - (2.*(dg213*dg223 + dg212*dg233) + dg223*dg312 + dg222*dg313 + - dg213*dg322 + dg212*dg323)*pow2(ginv23) - - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + - ginv12*(ddg2323*ginv33 + ginv13* - (2.*ddg1223 + ddg2213 + ddg2312 - - (2.*((dg123 + dg213)*dg222 + dg122*dg223) + dg222*dg312 + - dg212*(8.*dg223 + dg322))*ginv22 - - (dg223*(8.*dg213 + 4.*(dg123 + dg312)) + - 2.*(dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322) + - 4.*dg212*(dg233 + dg323))*ginv23 - - (2.*(dg133*dg223 + (dg123 + dg213)*dg233) + dg233*dg312 + - 4.*(dg223*dg313 + dg213*dg323) + dg212*dg333)*ginv33) + - ginv23*(ddg2223 + ddg2322 - - (dg233*(2.*dg223 + dg322) + 4.*dg223*dg323 + dg222*dg333)*ginv33) + - ginv22*(ddg2222 - dg222*(6.*dg223 + 2.*dg322)*ginv23 - - ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223))) - - (4.*(dg123*dg213 + dg113*dg223) + - 2.*((dg112 + dg211)*dg233 + dg223*dg311 + dg213*dg312 + - dg212*(dg133 + dg313) + dg211*dg323 + pow2(dg213)))*pow2(ginv13) \ -- 2.*(pow2(dg222)*pow2(ginv22) + - (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))*pow2(ginv23)) - - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) + - ginv13*(ddg2333*ginv33 + ginv22* - (ddg2223 - 2.*dg223*(dg233 + dg323)*ginv33 - - ginv23*(dg223*dg322 + dg222*(2.*dg233 + dg323) + 4.*pow2(dg223))) + - ginv23*(ddg2233 + ddg2323 - - ginv33*(3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))) - - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)* - pow2(ginv23) - 2.*(dg222*dg223*pow2(ginv22) + - dg233*dg333*pow2(ginv33))) - - 2.*(dg111*dg211*pow3(ginv11) + - (dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212))*pow3(ginv12)) - - (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + dg211*dg333)* - pow3(ginv13) -; - -dGfromgdu22 -= --((2.*dg111*dg211*ginv12 + (dg112*dg211 + dg111*dg212)*ginv22 + - (dg113*dg211 + dg111*dg213)*ginv23)*pow2(ginv11)) + - (ddg1212 + ddg2211 - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + - dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))*ginv13 - - (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + dg112*dg223) + - dg222*dg311 + dg212*(8.*dg213 + 2.*dg312) + - dg211*(4.*dg223 + dg322))*ginv23 - - ginv22*(4.*dg211*dg222 + 3.*(dg122*dg212 + dg112*dg222) + - 6.*pow2(dg212)) - ginv33* - (dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + dg212*dg313 + - dg211*dg323 + 2.*pow2(dg213)))*pow2(ginv12) - - ((dg112*dg233 + dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + - dg212*(dg133 + dg313) + dg211*dg323)*ginv22 + - (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + - dg211*dg333)*ginv23)*pow2(ginv13) + - (ddg2222 - dg222*(8.*dg223 + 2.*dg322)*ginv23 - - ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223)))*pow2(ginv22) + - (ddg2233 + ddg2323 - ginv33*(3.*(dg233*dg323 + dg223*dg333) + - 2.*pow2(dg233)))*pow2(ginv23) + - ginv13*(ginv22*(ddg1223 + ddg2312 - - (dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322 + - 4.*(dg223*(dg123 + dg213 + dg312) + dg212*(dg233 + dg323)))* - ginv23 - (dg233*(dg123 + dg312) + dg223*(dg133 + 2.*dg313) + - 2.*dg213*dg323 + dg212*dg333)*ginv33) + - ginv23*(ddg1233 + ddg2313 - - (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33) - - ((dg122 + 4.*dg212)*dg223 + dg222*(dg123 + dg312) + dg212*dg322)* - pow2(ginv22) - (dg233*(4.*dg213 + 2.*dg312) + - 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + - dg212*dg333))*pow2(ginv23)) + - ginv11*(-(ginv13*((2.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + - dg212*dg311 + dg211*(dg123 + dg312))*ginv22 + - (dg111*dg233 + dg213*(4.*dg113 + dg311) + dg211*(dg133 + dg313))* - ginv23)) + ginv12*(ddg1211 - - (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - - (6.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv22 - - (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + dg212*dg311 + - dg211*(dg123 + 4.*dg213 + dg312))*ginv23 - - (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33) + - ginv22*(ddg1212 - (dg122*dg213 + dg113*dg222 + 2.*dg112*dg223 + - dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv23 - - (dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313)*ginv33) + - ginv23*(ddg1213 - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*ginv33) - - (3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))*pow2(ginv12) - - (dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))*pow2(ginv22) - - (dg113*dg223 + dg112*dg233 + dg213*(dg123 + dg312) + - dg212*(dg133 + dg313) + 2.*pow2(dg213))*pow2(ginv23)) + - ginv23*(ddg2333*ginv33 - 2.*dg233*dg333*pow2(ginv33)) + - ginv12*(ddg2313*ginv33 + ginv22* - (ddg1222 + 2.*ddg2212 - ((3.*dg122 + 12.*dg212)*dg223 + - dg222*(8.*dg213 + 3.*(dg123 + dg312)) + 3.*dg212*dg322)*ginv23 \ -- (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + dg222*dg313 + dg213*dg322 + - 2.*dg212*dg323)*ginv33) + - ginv23*(ddg1223 + 2.*ddg2213 + ddg2312 - - (dg233*(dg123 + 4.*dg213 + dg312) + dg223*(dg133 + 4.*dg313) + - 4.*dg213*dg323 + dg212*dg333)*ginv33) + - ginv13*(ddg1213 + ddg2311 - - (dg122*dg213 + dg222*(dg113 + dg311) + - 4.*((dg112 + dg211)*dg223 + dg212*(dg123 + dg213 + dg312)) + - dg211*dg322)*ginv22 - - (dg233*(dg113 + dg311) + dg213*(dg133 + 4.*dg313) + dg211*dg333)* - ginv33 - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg223*dg311 + - dg211*dg323) + 4.* - (dg113*dg223 + dg211*dg233 + dg213*(dg123 + dg312) + - dg212*dg313 + pow2(dg213)))) - - (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* - pow2(ginv13) - (2.*dg122 + 8.*dg212)*dg222*pow2(ginv22) - - ((dg122 + 4.*dg212)*dg233 + dg223*(8.*dg213 + 2.*(dg123 + dg312)) + - dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* - pow2(ginv23) - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + - ginv22*(ddg2323*ginv33 + ginv23* - (2.*ddg2223 + ddg2322 - (dg233*(4.*dg223 + dg322) + - 6.*dg223*dg323 + dg222*dg333)*ginv33) - - (3.*dg223*dg322 + dg222*(4.*dg233 + 3.*dg323) + 6.*pow2(dg223))* - pow2(ginv23) - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) - - (2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*pow3(ginv12) - - 2.*pow2(dg222)*pow3(ginv22) - - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)*pow3(ginv23) -; - -dGfromgdu23 -= --((2.*dg111*dg211*ginv13 + (dg112*dg211 + dg111*dg212)*ginv23 + - (dg113*dg211 + dg111*dg213)*ginv33)*pow2(ginv11)) - - ((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv13 + - (dg122*dg213 + dg212*(dg123 + 2.*dg213) + dg113*dg222 + - (dg112 + 2.*dg211)*dg223)*ginv33 + - 2.*ginv23*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212)))* - pow2(ginv12) + (ddg1213 + ddg2311 - - ((dg112 + 2.*dg211)*dg223 + dg212*(dg123 + 2.*(dg213 + dg312)))* - ginv22 - (3.*(dg133*dg213 + dg113*dg233) + 6.*dg213*dg313 + - 2.*(dg233*dg311 + dg211*dg333))*ginv33 - - ginv23*(4.*(dg213*dg312 + dg212*dg313) + - 2.*(dg133*dg212 + dg123*dg213 + (dg112 + dg211)*dg233 + - dg223*(dg113 + dg311) + dg211*dg323 + pow2(dg213))))*pow2(ginv13) \ -+ (ddg2223 + ddg2322 - (dg233*(6.*dg223 + 2.*dg322) + 6.*dg223*dg323 + - 2.*dg222*dg333)*ginv33)*pow2(ginv23) + ddg2333*pow2(ginv33) + - ginv11*(ddg1213*ginv33 + ginv13* - (ddg1211 - 2.*(dg112 + dg211)*dg212*ginv22 - - (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + 2.*dg212*dg311 + - dg211*(dg123 + 2.*(dg213 + dg312)))*ginv23 - - (dg111*dg233 + dg213*(6.*dg113 + 2.*dg311) + - dg211*(dg133 + 2.*dg313))*ginv33) - - ginv12*((4.*dg112*dg212 + dg211*(dg122 + 2.*dg212) + dg111*dg222)* - ginv23 + (dg211*(dg123 + 2.*dg213) + - 2.*(dg113*dg212 + dg112*dg213) + dg111*dg223)*ginv33 + - ginv13*(3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))) - - ginv22*((dg212*(dg123 + 2.*dg213) + dg112*dg223)*ginv33 + - ginv23*(dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))) + - ginv23*(ddg1212 - ginv33*(dg112*dg233 + dg212*(dg133 + 2.*dg313) + - 2.*(dg113*dg223 + dg213*(dg123 + dg312) + pow2(dg213)))) - - (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*pow2(ginv13) - - (dg122*dg213 + dg113*dg222 + dg112*dg223 + - dg212*(dg123 + 2.*(dg213 + dg312)))*pow2(ginv23) - - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*pow2(ginv33)) + - ginv22*(ddg2223*ginv33 + ginv23* - (ddg2222 - ginv33*(2.*(dg223*dg322 + dg222*(dg233 + dg323)) + - 6.*pow2(dg223))) - dg222*(6.*dg223 + 2.*dg322)*pow2(ginv23) - - 2.*dg223*(dg233 + dg323)*pow2(ginv33)) + - ginv12*((ddg1223 + ddg2213)*ginv33 - - ginv22*((2.*dg122 + 6.*dg212)*dg222*ginv23 + - ((dg123 + 2.*dg213)*dg222 + (dg122 + 4.*dg212)*dg223)*ginv33) + - ginv23*(ddg1222 + ddg2212 - - ((dg122 + 2.*dg212)*dg233 + - dg223*(4.*dg123 + 8.*dg213 + 2.*dg312) + - dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* - ginv33) + ginv13*(ddg1212 + ddg2211 - - (4.*(dg112 + dg211)*dg223 + - dg212*(8.*dg213 + 4.*(dg123 + dg312)) + - 2.*(dg122*dg213 + dg222*(dg113 + dg311) + dg211*dg322))*ginv23 \ -- ginv22*(dg122*dg212 + (dg112 + 2.*dg211)*dg222 + 4.*pow2(dg212)) - - ginv33*((dg112 + 2.*dg211)*dg233 + dg212*(dg133 + 2.*dg313) + - 2.*(dg223*dg311 + dg213*dg312 + dg211*dg323) + - 4.*(dg123*dg213 + dg113*dg223 + pow2(dg213)))) - - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + - dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))* - pow2(ginv13) - ((2.*dg122 + 4.*dg212)*dg223 + - dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)* - pow2(ginv23) - ((dg123 + 2.*dg213)*dg233 + - dg223*(dg133 + 2.*dg313) + 2.*dg213*dg323)*pow2(ginv33)) + - ginv13*((ddg1233 + 2.*ddg2313)*ginv33 + - ginv22*(ddg2212 - ((dg122 + 8.*dg212)*dg223 + - dg222*(dg123 + 2.*(dg213 + dg312)) + 2.*dg212*dg322)*ginv23 - - (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*(dg233 + dg323))* - ginv33) + ginv23*(ddg1223 + ddg2213 + 2.*ddg2312 - - (3.*(dg133*dg223 + dg123*dg233) + dg233*(6.*dg213 + 4.*dg312) + - 6.*(dg223*dg313 + dg213*dg323) + 4.*dg212*dg333)*ginv33) - - 2.*dg212*dg222*pow2(ginv22) - - ((dg122 + 4.*dg212)*dg233 + dg223*(2.*dg123 + 4.*(dg213 + dg312)) + - dg222*(dg133 + 2.*dg313) + 2.*dg213*dg322 + 4.*dg212*dg323)* - pow2(ginv23) - (dg233*(2.*dg133 + 4.*dg313) + 4.*dg213*dg333)* - pow2(ginv33)) + ginv23*((ddg2233 + 2.*ddg2323)*ginv33 - - (4.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))*pow2(ginv33)) - - (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* - pow3(ginv13) - 2.*((dg222*dg223*ginv33 + ginv23*pow2(dg222))* - pow2(ginv22) + (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))* - pow3(ginv23) + dg233*dg333*pow3(ginv33)) -; - -dGfromgdu31 -= -(ddg1311 - ((4.*dg112 + 2.*dg211)*dg311 + 4.*dg111*dg312)*ginv12 - - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - - (dg311*(dg213 + 2.*dg312) + dg211*dg313 + - 2.*(dg113*dg312 + dg112*dg313))*ginv23 - - 2.*(dg113 + dg311)*dg313*ginv33 - - ginv13*(4.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311)))*pow2(ginv11) \ -+ (ddg1322 + ddg2312 - (2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))* - ginv22 - ((2.*dg213 + 4.*dg312)*dg322 + - 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + - (dg122 + dg212)*dg323))*ginv23 - - (dg313*(dg223 + 2.*dg322) + (dg213 + 2.*(dg123 + dg312))*dg323)* - ginv33 - ginv13*(4.*(dg123*dg312 + dg112*dg323) + - 2.*(dg213*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + - dg311*(dg223 + dg322) + dg211*dg323 + pow2(dg312))))*pow2(ginv12) \ -+ (ddg1333 + ddg3313 - (dg233*dg312 + dg223*dg313 + - (dg213 + 2.*(dg123 + dg312))*dg323 + dg212*dg333)*ginv22 - - (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + - 4.*(dg313*dg323 + dg312*dg333))*ginv23 - - (2.*dg133 + 6.*dg313)*dg333*ginv33)*pow2(ginv13) + - ginv11*(ddg3313*ginv33 + ginv22* - (ddg2312 - (dg222*dg313 + dg213*dg322 + - 2.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - - (dg223*dg313 + (dg213 + 2.*dg312)*dg323)*ginv33) + - ginv23*(ddg2313 + ddg3312 - - (dg313*(dg233 + 4.*dg323) + (dg213 + 2.*dg312)*dg333)*ginv33) + - ginv12*(2.*ddg1312 + ddg2311 - - (dg311*(4.*dg123 + 3.*dg213 + 6.*dg312) + 3.*dg211*dg313 + - 6.*(dg113*dg312 + dg112*dg313) + 4.*dg111*dg323)*ginv13 - - (dg222*dg311 + (2.*dg122 + 6.*dg212)*dg312 + - (2.*dg112 + dg211)*dg322)*ginv22 - - (4.*dg312*dg313 + 2.*((dg123 + dg213)*dg313 + - (dg113 + dg311)*dg323))*ginv33 - - ginv23*((2.*dg123 + 4.*dg213)*dg312 + dg311*(dg223 + 2.*dg322) + - dg211*dg323 + 2.*(dg122*dg313 + dg113*dg322 + dg112*dg323) + - 4.*(dg212*dg313 + pow2(dg312)))) + - ginv13*(2.*ddg1313 + ddg3311 - - ((4.*dg213 + 8.*dg312)*dg313 + dg311*(dg233 + 2.*dg323) + - dg211*dg333 + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + - dg112*dg333))*ginv23 - - ginv22*(dg223*dg311 + dg211*dg323 + - 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + - pow2(dg312))) - ginv33* - (2.*(dg133*dg313 + (dg113 + dg311)*dg333) + 6.*pow2(dg313))) - - ((2.*dg122 + 3.*dg212)*dg311 + (6.*dg112 + 3.*dg211)*dg312 + - 2.*dg111*dg322)*pow2(ginv12) - - (6.*dg113*dg313 + dg311*(2.*dg133 + 6.*dg313) + 2.*dg111*dg333)* - pow2(ginv13) - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - - (dg313*(dg223 + 2.*dg322) + dg213*dg323 + dg312*(dg233 + 2.*dg323) + - dg212*dg333)*pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + - ginv12*(ddg3323*ginv33 + ginv13* - (2.*ddg1323 + ddg2313 + ddg3312 - - (dg222*dg313 + (2.*dg123 + dg213)*dg322 + - dg312*(4.*dg223 + 2.*dg322) + (2.*dg122 + 4.*dg212)*dg323)* - ginv22 - ((4.*dg213 + 8.*dg312)*dg323 + - 4.*(dg313*(dg223 + dg322) + dg123*dg323) + - 2.*(dg233*dg312 + dg133*dg322 + (dg122 + dg212)*dg333))*ginv23 \ -- (dg313*(dg233 + 8.*dg323) + (dg213 + 2.*dg312)*dg333 + - 2.*(dg133*dg323 + dg123*dg333))*ginv33) + - ginv22*(ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - - ginv23*(3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))) + - ginv23*(ddg2323 + ddg3322 - - ginv33*(dg233*dg323 + (dg223 + 2.*dg322)*dg333 + 4.*pow2(dg323))) - - (dg311*(dg233 + 4.*dg323) + - 4.*((dg123 + dg312)*dg313 + dg113*dg323) + dg211*dg333 + - 2.*(dg133*dg312 + dg213*dg313 + dg112*dg333))*pow2(ginv13) - - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* - pow2(ginv23) - 2.*(dg222*dg322*pow2(ginv22) + - dg323*dg333*pow2(ginv33))) + - ginv13*(ddg3333*ginv33 + ginv23* - (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33) + - ginv22*(ddg2323 - (4.*dg223*dg323 + dg322*(dg233 + 2.*dg323) + - dg222*dg333)*ginv23 - - ginv33*(dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))) - - (dg223*dg322 + dg222*dg323)*pow2(ginv22) - - 2.*((dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow2(ginv23) + - pow2(dg333)*pow2(ginv33))) - - (dg222*dg311 + dg211*dg322 + 2.*((dg122 + dg212)*dg312 + dg112*dg322))* - pow3(ginv12) - 2.*(dg111*dg311*pow3(ginv11) + - (dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313))*pow3(ginv13)) -; - -dGfromgdu32 -= --((2.*dg111*dg311*ginv12 + (dg112*dg311 + dg111*dg312)*ginv22 + - (dg113*dg311 + dg111*dg313)*ginv23)*pow2(ginv11)) + - (ddg1312 + ddg2311 - (4.*dg311*dg312 + - 2.*((dg123 + dg213)*dg311 + dg113*dg312 + - (dg112 + dg211)*dg313 + dg111*dg323))*ginv13 - - ((3.*dg122 + 6.*dg212)*dg312 + 3.*dg112*dg322 + - 2.*(dg222*dg311 + dg211*dg322))*ginv22 - - ((dg123 + 2.*(dg213 + dg312))*dg313 + (dg113 + 2.*dg311)*dg323)* - ginv33 - ginv23*(4.*(dg213*dg312 + dg212*dg313) + - 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322 + - dg311*(dg223 + dg322) + (dg112 + dg211)*dg323 + pow2(dg312))))* - pow2(ginv12) - ((dg123*dg313 + dg312*(dg133 + 2.*dg313) + - (dg113 + 2.*dg311)*dg323 + dg112*dg333)*ginv22 + - 2.*ginv23*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313)))* - pow2(ginv13) + (ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - - ginv23*(4.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322)))*pow2(ginv22) \ -+ (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33)*pow2(ginv23) + - ginv11*(-(ginv13*((dg311*(dg123 + 2.*dg312) + - 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv22 + - (4.*dg113*dg313 + dg311*(dg133 + 2.*dg313) + dg111*dg333)*ginv23)\ -) + ginv12*(ddg1311 - ((dg122 + 2.*dg212)*dg311 + - (6.*dg112 + 2.*dg211)*dg312 + dg111*dg322)*ginv22 - - (dg311*(dg123 + 2.*(dg213 + dg312)) + 2.*dg211*dg313 + - 4.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv23 - - 2.*(dg113 + dg311)*dg313*ginv33 - - ginv13*(3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))) + - ginv22*(ddg1312 - ((dg123 + 2.*dg312)*dg313 + dg113*dg323)*ginv33 - - ginv23*(dg122*dg313 + dg113*dg322 + - 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + - pow2(dg312)))) + - ginv23*(ddg1313 - ginv33* - (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))) - - ((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*pow2(ginv12) - - ((dg122 + 2.*dg212)*dg312 + dg112*dg322)*pow2(ginv22) - - (dg133*dg312 + (dg123 + 2.*(dg213 + dg312))*dg313 + dg113*dg323 + - dg112*dg333)*pow2(ginv23)) + - ginv13*(ginv23*(ddg1333 + ddg3313 - (2.*dg133 + 6.*dg313)*dg333*ginv33) + - ginv22*(ddg1323 + ddg3312 - - (dg133*dg322 + (4.*dg123 + 2.*dg213 + 8.*dg312)*dg323 + - dg122*dg333 + 2.*(dg233*dg312 + dg313*(dg223 + dg322) + - dg212*dg333))*ginv23 - - ((dg133 + 4.*dg313)*dg323 + (dg123 + 2.*dg312)*dg333)*ginv33) - - (dg123*dg322 + dg122*dg323 + - 2.*(dg312*(dg223 + dg322) + dg212*dg323))*pow2(ginv22) - - (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + - 4.*(dg313*dg323 + dg312*dg333))*pow2(ginv23)) + - ginv12*(ddg3313*ginv33 + ginv22* - (ddg1322 + 2.*ddg2312 - (4.*(dg222*dg313 + dg213*dg322) + - 3.*(dg123*dg322 + dg122*dg323) + - 6.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - - ((2.*dg213 + 4.*dg312)*dg323 + - 2.*(dg313*(dg223 + dg322) + dg123*dg323))*ginv33) + - ginv23*(ddg1323 + 2.*ddg2313 + ddg3312 - - (dg133*dg323 + dg313*(2.*dg233 + 8.*dg323) + - (dg123 + 2.*(dg213 + dg312))*dg333)*ginv33) + - ginv13*(ddg1313 + ddg3311 - - (8.*dg312*dg313 + 4.* - ((dg123 + dg213)*dg313 + (dg113 + dg311)*dg323) + - 2.*(dg233*dg311 + dg133*dg312 + (dg112 + dg211)*dg333))*ginv23 \ -- ginv22*(dg122*dg313 + dg113*dg322 + - 2.*(dg213*dg312 + dg212*dg313 + dg311*(dg223 + dg322) + - dg211*dg323) + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg312))) \ -- ginv33*(dg133*dg313 + (dg113 + 2.*dg311)*dg333 + 4.*pow2(dg313))) - - (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* - pow2(ginv13) - (2.*dg122*dg322 + 4.*(dg222*dg312 + dg212*dg322))* - pow2(ginv22) - (dg133*dg322 + - 4.*(dg313*(dg223 + dg322) + (dg213 + dg312)*dg323) + - dg122*dg333 + 2.*(dg233*dg312 + dg123*dg323 + dg212*dg333))* - pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + - ginv22*(ddg3323*ginv33 + ginv23* - (2.*ddg2323 + ddg3322 - ginv33* - (2.*(dg233*dg323 + (dg223 + dg322)*dg333) + 6.*pow2(dg323))) - - (6.*dg223*dg323 + dg322*(2.*dg233 + 6.*dg323) + 2.*dg222*dg333)* - pow2(ginv23) - 2.*dg323*dg333*pow2(ginv33)) + - ginv23*(ddg3333*ginv33 - 2.*pow2(dg333)*pow2(ginv33)) - - ((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* - pow3(ginv12) - 2.*(dg222*dg322*pow3(ginv22) + - (dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow3(ginv23)) -; - -dGfromgdu33 -= --((2.*dg111*dg311*ginv13 + (dg112*dg311 + dg111*dg312)*ginv23 + - (dg113*dg311 + dg111*dg313)*ginv33)*pow2(ginv11)) - - (((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* - ginv13 + (dg222*dg311 + dg211*dg322 + - 2.*((dg122 + dg212)*dg312 + dg112*dg322))*ginv23 + - (dg223*dg311 + (dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + - dg113*dg322 + (dg112 + dg211)*dg323)*ginv33)*pow2(ginv12) + - (ddg1313 + ddg3311 - ((2.*dg213 + 8.*dg312)*dg313 + - dg311*(dg233 + 4.*dg323) + dg211*dg333 + - 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + dg112*dg333))*ginv23 \ -- ginv22*(dg223*dg311 + (dg123 + dg213)*dg312 + dg212*dg313 + - (dg112 + dg211)*dg323 + 2.*pow2(dg312)) - - ginv33*(4.*dg311*dg333 + 3.*(dg133*dg313 + dg113*dg333) + - 6.*pow2(dg313)))*pow2(ginv13) - - (2.*dg222*dg322*ginv23 + (dg223*dg322 + dg222*dg323)*ginv33)* - pow2(ginv22) + (ddg2323 + ddg3322 - - ginv33*(4.*dg322*dg333 + 3.*(dg233*dg323 + dg223*dg333) + - 6.*pow2(dg323)))*pow2(ginv23) + ddg3333*pow2(ginv33) + - ginv13*((ddg1333 + 2.*ddg3313)*ginv33 + - ginv22*(ddg2312 - (dg222*dg313 + (dg123 + dg213)*dg322 + - dg122*dg323 + 4.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 \ -- (dg312*(dg233 + 4.*dg323) + 2.*(dg223*dg313 + (dg123 + dg213)*dg323) + - dg212*dg333)*ginv33) + - ginv23*(ddg1323 + ddg2313 + 2.*ddg3312 - - (12.*dg313*dg323 + (3.*dg213 + 8.*dg312)*dg333 + - 3.*(dg233*dg313 + dg133*dg323 + dg123*dg333))*ginv33) - - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - - ((dg133 + 4.*dg313)*dg322 + (2.*dg213 + 8.*dg312)*dg323 + - dg122*dg333 + 2.*(dg233*dg312 + dg223*dg313 + dg123*dg323 + - dg212*dg333))*pow2(ginv23) - - (2.*dg133 + 8.*dg313)*dg333*pow2(ginv33)) + - ginv23*((ddg2333 + 2.*ddg3323)*ginv33 - - (2.*dg233 + 8.*dg323)*dg333*pow2(ginv33)) + - ginv12*((ddg1323 + ddg2313)*ginv33 - - ginv22*((2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))*ginv23 + - (dg222*dg313 + (dg123 + dg213)*dg322 + dg122*dg323 + - 2.*(dg223*dg312 + dg212*dg323))*ginv33) + - ginv23*(ddg1322 + ddg2312 - - (dg233*dg312 + dg133*dg322 + - 4.*(dg313*(dg223 + dg322) + (dg123 + dg213 + dg312)*dg323) + - (dg122 + dg212)*dg333)*ginv33) + - ginv13*(ddg1312 + ddg2311 - - (dg222*dg311 + (dg122 + 4.*dg212)*dg312 + (dg112 + dg211)*dg322)* - ginv22 - (dg133*dg312 + dg311*(dg233 + 4.*dg323) + - 4.*((dg123 + dg213 + dg312)*dg313 + dg113*dg323) + - (dg112 + dg211)*dg333)*ginv33 - - ginv23*(2.*(dg223*dg311 + dg122*dg313 + dg113*dg322 + - dg211*dg323) + 4.* - ((dg123 + dg213)*dg312 + dg212*dg313 + dg311*dg322 + - dg112*dg323 + pow2(dg312)))) - - (4.*dg311*dg312 + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + - (dg112 + dg211)*dg313 + dg111*dg323))*pow2(ginv13) - - ((2.*dg213 + 4.*dg312)*dg322 + - 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + - (dg122 + dg212)*dg323))*pow2(ginv23) - - (dg133*dg323 + dg313*(dg233 + 4.*dg323) + (dg123 + dg213)*dg333)* - pow2(ginv33)) + ginv11*(ddg1313*ginv33 - - ginv12*(((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*ginv13 + - ((dg122 + dg212)*dg311 + (4.*dg112 + dg211)*dg312 + dg111*dg322)* - ginv23 + ((dg123 + dg213)*dg311 + dg211*dg313 + - 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv33) - - ginv22*(((dg122 + 2.*dg212)*dg312 + dg112*dg322)*ginv23 + - ((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323)*ginv33) + - ginv13*(ddg1311 - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - - ((dg123 + dg213)*dg311 + 4.*(dg113 + dg311)*dg312 + - (4.*dg112 + dg211)*dg313 + dg111*dg323)*ginv23 - - (6.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)*ginv33) + - ginv23*(ddg1312 - (dg312*(dg133 + 4.*dg313) + - 2.*((dg123 + dg213)*dg313 + dg113*dg323) + dg112*dg333)*ginv33) \ -- (3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))*pow2(ginv13) - - ((dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + - dg112*dg323 + 2.*pow2(dg312))*pow2(ginv23) - - (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))*pow2(ginv33)) + - ginv22*(ddg2323*ginv33 + ginv23* - (ddg2322 - (6.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* - ginv33) - (3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))* - pow2(ginv23) - (dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))* - pow2(ginv33)) - (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + - dg111*dg333)*pow3(ginv13) - - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)*pow3(ginv23) - - 2.*pow2(dg333)*pow3(ginv33) -; - -R11 -= -gammado111*Gfromg1 + gammado112*Gfromg2 + gammado113*Gfromg3 + - (-0.5*ddg1111 + 3.*gamma111*gammado111 + - 2.*(gamma211*gammado112 + gamma311*gammado113) + - gamma211*gammado211 + gamma311*gammado311)*ginv11 + - (-ddg1211 + 3.*(gamma112*gammado111 + gamma111*gammado112) + - 2.*(gamma212*gammado112 + gamma312*gammado113 + - gamma211*gammado122 + gamma311*gammado123) + gamma212*gammado211 + - gamma211*gammado212 + gamma312*gammado311 + gamma311*gammado312)*ginv12 \ -+ (-ddg1311 + 3.*(gamma113*gammado111 + gamma111*gammado113) + - 2.*(gamma213*gammado112 + gamma313*gammado113 + - gamma211*gammado123 + gamma311*gammado133) + gamma213*gammado211 + - gamma211*gammado213 + gamma313*gammado311 + gamma311*gammado313)*ginv13 \ -+ (-0.5*ddg2211 + 3.*gamma112*gammado112 + - 2.*(gamma212*gammado122 + gamma312*gammado123) + - gamma212*gammado212 + gamma312*gammado312)*ginv22 + - (-ddg2311 + 3.*(gamma113*gammado112 + gamma112*gammado113) + - 2.*(gamma213*gammado122 + (gamma212 + gamma313)*gammado123 + - gamma312*gammado133) + gamma213*gammado212 + gamma212*gammado213 + - gamma313*gammado312 + gamma312*gammado313)*ginv23 + - (-0.5*ddg3311 + 3.*gamma113*gammado113 + - 2.*(gamma213*gammado123 + gamma313*gammado133) + - gamma213*gammado213 + gamma313*gammado313)*ginv33 + dG11*g11 + - dG12*g12 + dG13*g13 -; - -R12 -= -(-0.5*ddg1112 + gamma112*gammado111 + (gamma111 + gamma212)*gammado112 + - gamma312*gammado113 + gamma111*gammado211 + 2.*gamma211*gammado212 + - gamma311*(gammado213 + gammado312))*ginv11 + - (-ddg1212 + gamma122*gammado111 + (2.*gamma112 + gamma222)*gammado112 + - gamma322*gammado113 + (gamma111 + gamma212)*gammado122 + - gamma112*gammado211 + (gamma111 + 2.*gamma212)*gammado212 + - 2.*gamma211*gammado222 + gamma312* - (gammado123 + gammado213 + gammado312) + - gamma311*(gammado223 + gammado322))*ginv12 + - (-ddg1312 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + - (gamma112 + gamma323)*gammado113 + (gamma111 + gamma212)*gammado123 + - gamma312*gammado133 + gamma113*gammado211 + - (gamma111 + gamma313)*gammado213 + - 2.*(gamma213*gammado212 + gamma211*gammado223) + - gamma313*gammado312 + gamma311*(gammado233 + gammado323))*ginv13 + - (-0.5*ddg2212 + gamma122*gammado112 + (gamma112 + gamma222)*gammado122 + - gamma322*gammado123 + gamma112*gammado212 + 2.*gamma212*gammado222 + - gamma312*(gammado223 + gammado322))*ginv22 + - (-ddg2312 + gamma123*gammado112 + gamma122*gammado113 + - (gamma113 + gamma223)*gammado122 + - (gamma112 + gamma222 + gamma323)*gammado123 + gamma322*gammado133 + - gamma113*gammado212 + gamma112*gammado213 + - 2.*(gamma213*gammado222 + gamma212*gammado223) + - gamma313*(gammado223 + gammado322) + - gamma312*(gammado233 + gammado323))*ginv23 + - (-0.5*ddg3312 + gamma123*gammado113 + (gamma113 + gamma223)*gammado123 + - gamma323*gammado133 + gamma113*gammado213 + 2.*gamma213*gammado223 + - gamma313*(gammado233 + gammado323))*ginv33 + - 0.5*((gammado112 + gammado211)*Gfromg1 + - (gammado122 + gammado212)*Gfromg2 + (gammado123 + gammado213)*Gfromg3 + - dG21*g11 + (dG11 + dG22)*g12 + dG23*g13 + - dG12*g22 + dG13*g23) -; - -R13 -= -(-0.5*ddg1113 + gamma113*gammado111 + gamma213*gammado112 + - (gamma111 + gamma313)*gammado113 + gamma111*gammado311 + - gamma211*(gammado213 + gammado312) + 2.*gamma311*gammado313)*ginv11 + - (-ddg1213 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + - (gamma112 + gamma323)*gammado113 + gamma213*gammado122 + - (gamma111 + gamma313)*gammado123 + gamma112*gammado311 + - gamma111*gammado312 + gamma212*(gammado213 + gammado312) + - gamma211*(gammado223 + gammado322) + - 2.*(gamma312*gammado313 + gamma311*gammado323))*ginv12 + - (-ddg1313 + gamma133*gammado111 + gamma233*gammado112 + - (2.*gamma113 + gamma333)*gammado113 + - (gamma111 + gamma313)*gammado133 + gamma113*gammado311 + - gamma213*(gammado123 + gammado213 + gammado312) + - (gamma111 + 2.*gamma313)*gammado313 + - gamma211*(gammado233 + gammado323) + 2.*gamma311*gammado333)*ginv13 + - (-0.5*ddg2213 + gamma123*gammado112 + gamma223*gammado122 + - (gamma112 + gamma323)*gammado123 + gamma112*gammado312 + - gamma212*(gammado223 + gammado322) + 2.*gamma312*gammado323)*ginv22 + - (-ddg2313 + gamma133*gammado112 + gamma123*gammado113 + - gamma233*gammado122 + (gamma113 + gamma223 + gamma333)*gammado123 + - (gamma112 + gamma323)*gammado133 + gamma113*gammado312 + - gamma112*gammado313 + gamma213*(gammado223 + gammado322) + - gamma212*(gammado233 + gammado323) + - 2.*(gamma313*gammado323 + gamma312*gammado333))*ginv23 + - (-0.5*ddg3313 + gamma133*gammado113 + gamma233*gammado123 + - (gamma113 + gamma333)*gammado133 + gamma113*gammado313 + - gamma213*(gammado233 + gammado323) + 2.*gamma313*gammado333)*ginv33 + - 0.5*((gammado113 + gammado311)*Gfromg1 + - (gammado123 + gammado312)*Gfromg2 + (gammado133 + gammado313)*Gfromg3 + - dG31*g11 + dG32*g12 + (dG11 + dG33)*g13 + - dG12*g23 + dG13*g33) -; - -R22 -= -gammado212*Gfromg1 + gammado222*Gfromg2 + gammado223*Gfromg3 + - (-0.5*ddg1122 + gamma112*(gammado112 + 2.*gammado211) + - 3.*gamma212*gammado212 + gamma312*(2.*gammado213 + gammado312))*ginv11 \ -+ (-ddg1222 + gamma122*(gammado112 + 2.*gammado211) + - gamma112*(gammado122 + 2.*gammado212) + - 3.*(gamma222*gammado212 + gamma212*gammado222) + - 2.*(gamma322*gammado213 + gamma312*gammado223) + - gamma322*gammado312 + gamma312*gammado322)*ginv12 + - (-ddg1322 + gamma123*(gammado112 + 2.*gammado211) + - gamma112*(gammado123 + 2.*gammado213) + - 3.*(gamma223*gammado212 + gamma212*gammado223) + - 2.*(gamma323*gammado213 + gamma312*gammado233) + - gamma323*gammado312 + gamma312*gammado323)*ginv13 + - (-0.5*ddg2222 + gamma122*(gammado122 + 2.*gammado212) + - 3.*gamma222*gammado222 + gamma322*(2.*gammado223 + gammado322))*ginv22 \ -+ (-ddg2322 + gamma123*(gammado122 + 2.*gammado212) + - gamma122*(gammado123 + 2.*gammado213) + - 3.*(gamma223*gammado222 + gamma222*gammado223) + - 2.*(gamma323*gammado223 + gamma322*gammado233) + - gamma323*gammado322 + gamma322*gammado323)*ginv23 + - (-0.5*ddg3322 + gamma123*(gammado123 + 2.*gammado213) + - 3.*gamma223*gammado223 + gamma323*(2.*gammado233 + gammado323))*ginv33 \ -+ dG21*g12 + dG22*g22 + dG23*g23 -; - -R23 -= -(-0.5*ddg1123 + gamma113*gammado211 + gamma213*gammado212 + - (gamma212 + gamma313)*gammado213 + - gamma112*(gammado113 + gammado311) + gamma212*gammado312 + - 2.*gamma312*gammado313)*ginv11 + - (-ddg1223 + gamma123*gammado211 + (gamma113 + gamma223)*gammado212 + - (gamma222 + gamma323)*gammado213 + gamma213*gammado222 + - (gamma212 + gamma313)*gammado223 + - gamma122*(gammado113 + gammado311) + gamma222*gammado312 + - gamma112*(gammado123 + gammado312) + gamma212*gammado322 + - 2.*(gamma322*gammado313 + gamma312*gammado323))*ginv12 + - (-ddg1323 + gamma133*gammado211 + gamma233*gammado212 + - (gamma113 + gamma223 + gamma333)*gammado213 + gamma213*gammado223 + - (gamma212 + gamma313)*gammado233 + - gamma123*(gammado113 + gammado311) + gamma223*gammado312 + - gamma112*(gammado133 + gammado313) + gamma212*gammado323 + - 2.*(gamma323*gammado313 + gamma312*gammado333))*ginv13 + - (-0.5*ddg2223 + gamma123*gammado212 + gamma223*gammado222 + - (gamma222 + gamma323)*gammado223 + - gamma122*(gammado123 + gammado312) + gamma222*gammado322 + - 2.*gamma322*gammado323)*ginv22 + - (-ddg2323 + gamma133*gammado212 + gamma233*gammado222 + - (2.*gamma223 + gamma333)*gammado223 + - (gamma222 + gamma323)*gammado233 + - gamma123*(gammado123 + gammado213 + gammado312) + - gamma122*(gammado133 + gammado313) + gamma223*gammado322 + - (gamma222 + 2.*gamma323)*gammado323 + 2.*gamma322*gammado333)*ginv23 + - (-0.5*ddg3323 + gamma133*gammado213 + gamma233*gammado223 + - (gamma223 + gamma333)*gammado233 + - gamma123*(gammado133 + gammado313) + gamma223*gammado323 + - 2.*gamma323*gammado333)*ginv33 + - 0.5*((gammado213 + gammado312)*Gfromg1 + - (gammado223 + gammado322)*Gfromg2 + (gammado233 + gammado323)*Gfromg3 + - dG31*g12 + dG21*g13 + dG32*g22 + - (dG22 + dG33)*g23 + dG23*g33) -; - -R33 -= -gammado313*Gfromg1 + gammado323*Gfromg2 + gammado333*Gfromg3 + - (-0.5*ddg1133 + gamma113*(gammado113 + 2.*gammado311) + - gamma213*(gammado213 + 2.*gammado312) + 3.*gamma313*gammado313)*ginv11 \ -+ (-ddg1233 + gamma123*(gammado113 + 2.*gammado311) + - gamma113*(gammado123 + 2.*gammado312) + - gamma223*(gammado213 + 2.*gammado312) + - gamma213*(gammado223 + 2.*gammado322) + - 3.*(gamma323*gammado313 + gamma313*gammado323))*ginv12 + - (-ddg1333 + gamma133*(gammado113 + 2.*gammado311) + - gamma233*(gammado213 + 2.*gammado312) + - gamma113*(gammado133 + 2.*gammado313) + - gamma213*(gammado233 + 2.*gammado323) + - 3.*(gamma333*gammado313 + gamma313*gammado333))*ginv13 + - (-0.5*ddg2233 + gamma123*(gammado123 + 2.*gammado312) + - gamma223*(gammado223 + 2.*gammado322) + 3.*gamma323*gammado323)*ginv22 \ -+ (-ddg2333 + gamma133*(gammado123 + 2.*gammado312) + - gamma123*(gammado133 + 2.*gammado313) + - gamma233*(gammado223 + 2.*gammado322) + - gamma223*(gammado233 + 2.*gammado323) + - 3.*(gamma333*gammado323 + gamma323*gammado333))*ginv23 + - (-0.5*ddg3333 + gamma133*(gammado133 + 2.*gammado313) + - gamma233*(gammado233 + 2.*gammado323) + 3.*gamma333*gammado333)*ginv33 \ -+ dG31*g13 + dG32*g23 + dG33*g33 -; - -ff -= -chi -; - -oochipsipower -= -1/chipsipower -; - -f -= -oochipsipower*log(ff) -; - -psim4 -= -exp(-4.*f) -; - -df1 -= -(dchi1*oochipsipower)/chi -; - -df2 -= -(dchi2*oochipsipower)/chi -; - -df3 -= -(dchi3*oochipsipower)/chi -; - -ddf11 -= -(ddchi11*oochipsipower)/chi - chipsipower*pow2(df1) -; - -ddf12 -= --(chipsipower*df1*df2) + (ddchi12*oochipsipower)/chi -; - -ddf13 -= --(chipsipower*df1*df3) + (ddchi13*oochipsipower)/chi -; - -ddf22 -= -(ddchi22*oochipsipower)/chi - chipsipower*pow2(df2) -; - -ddf23 -= --(chipsipower*df2*df3) + (ddchi23*oochipsipower)/chi -; - -ddf33 -= -(ddchi33*oochipsipower)/chi - chipsipower*pow2(df3) -; - -cddf11 -= -ddf11 - df1*gamma111 - df2*gamma211 - df3*gamma311 -; - -cddf12 -= -ddf12 - df1*gamma112 - df2*gamma212 - df3*gamma312 -; - -cddf13 -= -ddf13 - df1*gamma113 - df2*gamma213 - df3*gamma313 -; - -cddf22 -= -ddf22 - df1*gamma122 - df2*gamma222 - df3*gamma322 -; - -cddf23 -= -ddf23 - df1*gamma123 - df2*gamma223 - df3*gamma323 -; - -cddf33 -= -ddf33 - df1*gamma133 - df2*gamma233 - df3*gamma333 -; - -trcddf -= -cddf11*ginv11 + cddf22*ginv22 + - 2.*(cddf12*ginv12 + cddf13*ginv13 + cddf23*ginv23) + cddf33*ginv33 -; - -Rphi11 -= --2.*(cddf11 + trcddf*g11) + (4. - 4.*ginv11*g11)*pow2(df1) - - g11*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi12 -= -df1*df2*(4. - 8.*ginv12*g12) - 2.*(cddf12 + trcddf*g12) - - g12*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi13 -= -df1*(4.*df3 - 8.*df2*ginv12*g13) - 2.*(cddf13 + trcddf*g13) - - g13*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi22 -= --2.*(cddf22 + trcddf*g22) + (4. - 4.*ginv22*g22)*pow2(df2) - - g22*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv11*pow2(df1) + ginv33*pow2(df3))) -; - -Rphi23 -= -df2*(4.*df3 - 8.*df1*ginv12*g23) - 2.*(cddf23 + trcddf*g23) - - g23*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi33 -= --2.*(cddf33 + trcddf*g33) - - g33*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2))) + - (4. - 4.*ginv33*g33)*pow2(df3) -; - -Rf11 -= -R11 + Rphi11 -; - -Rf12 -= -R12 + Rphi12 -; - -Rf13 -= -R13 + Rphi13 -; - -Rf22 -= -R22 + Rphi22 -; - -Rf23 -= -R23 + Rphi23 -; - -Rf33 -= -R33 + Rphi33 -; - -Rhat -= -psim4*(ginv11*Rf11 + ginv22*Rf22 + - 2.*(ginv12*Rf12 + ginv13*Rf13 + ginv23*Rf23) + ginv33*Rf33) -; - -cdda11 -= -dda11 - da2*gamma211 - da3*gamma311 + - 2.*((da2*df1 + da1*df2)*ginv12 + (da3*df1 + da1*df3)*ginv13 + - da2*df2*ginv22 + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g11 \ -+ da1*(-4.*df1 - gamma111 + 2.*df1*ginv11*g11) -; - -cdda12 -= -dda12 - 2.*(da2*df1 + da1*df2) - da1*gamma112 - da2*gamma212 - - da3*gamma312 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g12 -; - -cdda13 -= -dda13 - 2.*(da3*df1 + da1*df3) - da1*gamma113 - da2*gamma213 - - da3*gamma313 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g13 -; - -cdda22 -= -dda22 - da1*gamma122 - da3*gamma322 + - 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + (da3*df2 + da2*df3)*ginv23 + - da3*df3*ginv33)*g22 + - da2*(-4.*df2 - gamma222 + 2.*df2*ginv22*g22) -; - -cdda23 -= -dda23 - 2.*(da3*df2 + da2*df3) - da1*gamma123 - da2*gamma223 - - da3*gamma323 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g23 -; - -cdda33 -= -dda33 - da1*gamma133 - da2*gamma233 + - 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23)*g33 + - da3*(-4.*df3 - gamma333 + 2.*df3*ginv33*g33) -; - -dda12 -= -dda12 - 2.*(da2*df1 + da1*df2) - da1*gamma112 - da2*gamma212 - - da3*gamma312 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g12 -; - -dda13 -= -dda13 - 2.*(da3*df1 + da1*df3) - da1*gamma113 - da2*gamma213 - - da3*gamma313 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g13 -; - -dda23 -= -dda23 - 2.*(da3*df2 + da2*df3) - da1*gamma123 - da2*gamma223 - - da3*gamma323 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g23 -; - -trcdda -= -(cdda11*ginv11 + (cdda12 + dda12)*ginv12 + (cdda13 + dda13)*ginv13 + - cdda22*ginv22 + (cdda23 + dda23)*ginv23 + cdda33*ginv33)*psim4 -; - -AA11 -= -2.*(ginv23*A12*A13 + - A11*(ginv12*A12 + ginv13*A13)) + ginv11*pow2(A11) + - ginv22*pow2(A12) + ginv33*pow2(A13) -; - -AA12 -= -A12*(ginv11*A11 + ginv22*A22) + ginv33*A13*A23 + - ginv13*(A12*A13 + A11*A23) + - ginv23*(A13*A22 + A12*A23) + - ginv12*(A11*A22 + pow2(A12)) -; - -AA13 -= -ginv22*A12*A23 + ginv12*(A12*A13 + A11*A23) + - A13*(ginv11*A11 + ginv33*A33) + - ginv23*(A13*A23 + A12*A33) + - ginv13*(A11*A33 + pow2(A13)) -; - -AA21 -= -A12*(ginv11*A11 + ginv22*A22) + ginv33*A13*A23 + - ginv13*(A12*A13 + A11*A23) + - ginv23*(A13*A22 + A12*A23) + - ginv12*(A11*A22 + pow2(A12)) -; - -AA22 -= -2.*(ginv23*A22*A23 + - A12*(ginv12*A22 + ginv13*A23)) + ginv11*pow2(A12) + - ginv22*pow2(A22) + ginv33*pow2(A23) -; - -AA23 -= -ginv11*A12*A13 + ginv12*(A13*A22 + A12*A23) + - A23*(ginv22*A22 + ginv33*A33) + - ginv13*(A13*A23 + A12*A33) + - ginv23*(A22*A33 + pow2(A23)) -; - -AA31 -= -ginv22*A12*A23 + ginv12*(A12*A13 + A11*A23) + - A13*(ginv11*A11 + ginv33*A33) + - ginv23*(A13*A23 + A12*A33) + - ginv13*(A11*A33 + pow2(A13)) -; - -AA32 -= -ginv11*A12*A13 + ginv12*(A13*A22 + A12*A23) + - A23*(ginv22*A22 + ginv33*A33) + - ginv13*(A13*A23 + A12*A33) + - ginv23*(A22*A33 + pow2(A23)) -; - -AA33 -= -2.*(ginv23*A23*A33 + - A13*(ginv12*A23 + ginv13*A33)) + ginv11*pow2(A13) + - ginv22*pow2(A23) + ginv33*pow2(A33) -; - -Ainv11 -= -2.*(ginv11*(ginv12*A12 + ginv13*A13) + ginv12*ginv13*A23) + - A11*pow2(ginv11) + A22*pow2(ginv12) + A33*pow2(ginv13) -; - -Ainv12 -= -ginv11*(ginv12*A11 + ginv22*A12 + ginv23*A13) + - ginv12*(ginv13*A13 + ginv22*A22 + ginv23*A23) + - ginv13*(ginv22*A23 + ginv23*A33) + A12*pow2(ginv12) -; - -Ainv13 -= -ginv11*(ginv13*A11 + ginv23*A12 + ginv33*A13) + - ginv12*(ginv13*A12 + ginv23*A22 + ginv33*A23) + - ginv13*(ginv23*A23 + ginv33*A33) + A13*pow2(ginv13) -; - -Ainv22 -= -2.*(ginv12*(ginv22*A12 + ginv23*A13) + ginv22*ginv23*A23) + - A11*pow2(ginv12) + A22*pow2(ginv22) + A33*pow2(ginv23) -; - -Ainv23 -= -ginv13*(ginv22*A12 + ginv23*A13) + - ginv12*(ginv13*A11 + ginv23*A12 + ginv33*A13) + - ginv22*(ginv23*A22 + ginv33*A23) + ginv23*ginv33*A33 + - A23*pow2(ginv23) -; - -Ainv33 -= -2.*(ginv13*(ginv23*A12 + ginv33*A13) + ginv23*ginv33*A23) + - A11*pow2(ginv13) + A22*pow2(ginv23) + A33*pow2(ginv33) -; - -cdA111 -= -dA111 - 2.*(gamma111*A11 + gamma211*A12 + gamma311*A13) -; - -cdA112 -= -dA112 - gamma112*A11 - (gamma111 + gamma212)*A12 - - gamma312*A13 - gamma211*A22 - gamma311*A23 -; - -cdA113 -= -dA113 - gamma113*A11 - gamma213*A12 - - (gamma111 + gamma313)*A13 - gamma211*A23 - gamma311*A33 -; - -cdA122 -= -dA122 - 2.*(gamma112*A12 + gamma212*A22 + gamma312*A23) -; - -cdA123 -= -dA123 - gamma113*A12 - gamma112*A13 - gamma213*A22 - - (gamma212 + gamma313)*A23 - gamma312*A33 -; - -cdA133 -= -dA133 - 2.*(gamma113*A13 + gamma213*A23 + gamma313*A33) -; - -cdA211 -= -dA211 - 2.*(gamma112*A11 + gamma212*A12 + gamma312*A13) -; - -cdA212 -= -dA212 - gamma122*A11 - (gamma112 + gamma222)*A12 - - gamma322*A13 - gamma212*A22 - gamma312*A23 -; - -cdA213 -= -dA213 - gamma123*A11 - gamma223*A12 - - (gamma112 + gamma323)*A13 - gamma212*A23 - gamma312*A33 -; - -cdA222 -= -dA222 - 2.*(gamma122*A12 + gamma222*A22 + gamma322*A23) -; - -cdA223 -= -dA223 - gamma123*A12 - gamma122*A13 - gamma223*A22 - - (gamma222 + gamma323)*A23 - gamma322*A33 -; - -cdA233 -= -dA233 - 2.*(gamma123*A13 + gamma223*A23 + gamma323*A33) -; - -cdA311 -= -dA311 - 2.*(gamma113*A11 + gamma213*A12 + gamma313*A13) -; - -cdA312 -= -dA312 - gamma123*A11 - (gamma113 + gamma223)*A12 - - gamma323*A13 - gamma213*A22 - gamma313*A23 -; - -cdA313 -= -dA313 - gamma133*A11 - gamma233*A12 - - (gamma113 + gamma333)*A13 - gamma213*A23 - gamma313*A33 -; - -cdA322 -= -dA322 - 2.*(gamma123*A12 + gamma223*A22 + gamma323*A23) -; - -cdA323 -= -dA323 - gamma133*A12 - gamma123*A13 - gamma233*A22 - - (gamma223 + gamma333)*A23 - gamma323*A33 -; - -cdA333 -= -dA333 - 2.*(gamma133*A13 + gamma233*A23 + gamma333*A33) -; - -divbeta -= -db11 + db22 + db33 -; - -totdivbeta -= -0.66666666666666666667*divbeta -; - -lieg11 -= -dg111*beta1 + dg211*beta2 + dg311*beta3 + - (2.*db11 - totdivbeta)*g11 + 2.*(db12*g12 + db13*g13) -; - -lieg12 -= -dg112*beta1 + dg212*beta2 + dg312*beta3 + db21*g11 + - (db11 + db22 - totdivbeta)*g12 + db23*g13 + db12*g22 + - db13*g23 -; - -lieg13 -= -dg113*beta1 + dg213*beta2 + dg313*beta3 + db31*g11 + - db32*g12 + (db11 + db33 - totdivbeta)*g13 + db12*g23 + - db13*g33 -; - -lieg22 -= -dg122*beta1 + dg222*beta2 + dg322*beta3 - - totdivbeta*g22 + 2.*(db21*g12 + db22*g22 + db23*g23) -; - -lieg23 -= -dg123*beta1 + dg223*beta2 + dg323*beta3 + db31*g12 + - db21*g13 + db32*g22 + (db22 + db33 - totdivbeta)*g23 + - db23*g33 -; - -lieg33 -= -dg133*beta1 + dg233*beta2 + dg333*beta3 - - totdivbeta*g33 + 2.*(db31*g13 + db32*g23 + db33*g33) -; - -lieA11 -= -(2.*db11 - totdivbeta)*A11 + 2.*(db12*A12 + db13*A13) + - dA111*beta1 + dA211*beta2 + dA311*beta3 -; - -lieA12 -= -db21*A11 + (db11 + db22 - totdivbeta)*A12 + db23*A13 + - db12*A22 + db13*A23 + dA112*beta1 + dA212*beta2 + - dA312*beta3 -; - -lieA13 -= -db31*A11 + db32*A12 + (db11 + db33 - totdivbeta)*A13 + - db12*A23 + db13*A33 + dA113*beta1 + dA213*beta2 + - dA313*beta3 -; - -lieA22 -= --(totdivbeta*A22) + 2.*(db21*A12 + db22*A22 + - db23*A23) + dA122*beta1 + dA222*beta2 + dA322*beta3 -; - -lieA23 -= -db31*A12 + db21*A13 + db32*A22 + - (db22 + db33 - totdivbeta)*A23 + db23*A33 + dA123*beta1 + - dA223*beta2 + dA323*beta3 -; - -lieA33 -= --(totdivbeta*A33) + 2.*(db31*A13 + db32*A23 + - db33*A33) + dA133*beta1 + dA233*beta2 + dA333*beta3 -; - -betas -= -sdown1*beta1 + sdown2*beta2 + sdown3*beta3 -; - -Dbetas -= -(db11*sdown1 + db12*sdown2 + db13*sdown3)*sup1 + - (db21*sdown1 + db22*sdown2 + db23*sdown3)*sup2 + - (db31*sdown1 + db32*sdown2 + db33*sdown3)*sup3 -; - -Dalpha -= -da1*sup1 + da2*sup2 + da3*sup3 -; - -DKhat -= -dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3 -; - -DK -= -dK1*sup1 + dK2*sup2 + dK3*sup3 -; - -DTheta -= -dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 -; - -Gams -= -sdown1*G1 + sdown2*G2 + sdown3*G3 -; - -DGams -= -(dG11*sdown1 + dG12*sdown2 + dG13*sdown3)*sup1 + - (dG21*sdown1 + dG22*sdown2 + dG23*sdown3)*sup2 + - (dG31*sdown1 + dG32*sdown2 + dG33*sdown3)*sup3 -; - -GamA1 -= -qud11*G1 + qud12*G2 + qud13*G3 -; - -GamA2 -= -qud21*G1 + qud22*G2 + qud23*G3 -; - -GamA3 -= -qud31*G1 + qud32*G2 + qud33*G3 -; - -DGamA1 -= -(dG11*qud11 + dG12*qud12 + dG13*qud13)*sup1 + - (dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + - (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3 -; - -DGamA2 -= -(dG11*qud21 + dG12*qud22 + dG13*qud23)*sup1 + - (dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + - (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3 -; - -DGamA3 -= -(dG11*qud31 + dG12*qud32 + dG13*qud33)*sup1 + - (dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + - (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3 -; - -betaA1 -= -qud11*beta1 + qud12*beta2 + qud13*beta3 -; - -betaA2 -= -qud21*beta1 + qud22*beta2 + qud23*beta3 -; - -betaA3 -= -qud31*beta1 + qud32*beta2 + qud33*beta3 -; - -DbetaA1 -= -(db11*qud11 + db12*qud12 + db13*qud13)*sup1 + - (db21*qud11 + db22*qud12 + db23*qud13)*sup2 + - (db31*qud11 + db32*qud12 + db33*qud13)*sup3 -; - -DbetaA2 -= -(db11*qud21 + db12*qud22 + db13*qud23)*sup1 + - (db21*qud21 + db22*qud22 + db23*qud23)*sup2 + - (db31*qud21 + db32*qud22 + db33*qud23)*sup3 -; - -DbetaA3 -= -(db11*qud31 + db12*qud32 + db13*qud33)*sup1 + - (db21*qud31 + db22*qud32 + db23*qud33)*sup2 + - (db31*qud31 + db32*qud32 + db33*qud33)*sup3 -; - -lienKhat -= --((DKhat + Khat/r)*sqrt(muL)) -; - -lienTheta -= --DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta -; - -lienK -= -lienKhat + 2.*lienTheta -; - -rKhat -= -lienKhat*alpha + dKhat1*beta1 + dKhat2*beta2 + - dKhat3*beta3 -; - -rGams -= --(((db11*sdown1 + db12*sdown2)*beta1 + - (db21*sdown1 + db22*sdown2 + db23*sdown3)*beta2 + - db31*sdown1*beta3)*pow2(shiftdriver)) + - beta3*(2.*ddb231*sdown1*shiftdriver*beta2 + - sdown2*(2.*ddb132*shiftdriver*beta1 - db32*pow2(shiftdriver)) + - sdown3*(shiftdriver*(dG33 + 2.*ddb133*beta1) - - db33*pow2(shiftdriver))) + - sdown3*(db13*(db21*shiftdriver*beta2 - - beta1*pow2(shiftdriver)) + - shiftdriver*((db12*db23 + db13*(db11 + db33) + dG13)*beta1 + - (db23*db33 + dG23)*beta2 + - beta3*(db13*db31 + db23*db32 + pow2(db33)) + - ddb113*pow2(beta1))) + - shiftdriver*((dG22*sdown2 + db22*(db21*sdown1 + db23*sdown3) + - 2.*ddb123*sdown3*beta1)*beta2 + - 2.*((ddb232*sdown2 + ddb233*sdown3)*beta2*beta3 + - beta1*((ddb121*sdown1 + ddb122*sdown2)*beta2 + - ddb131*sdown1*beta3)) + - sdown2*((db13*db32 + dG12)*beta1 + - (db32*(db22 + db33) + dG32)*beta3 + - db12*((db11 + db22)*beta1 + db31*beta3) + - beta2*(db12*db21 + db23*db32 + pow2(db22))) + - (ddb111*sdown1 + ddb112*sdown2)*pow2(beta1) + - (ddb221*sdown1 + ddb222*sdown2 + ddb223*sdown3)*pow2(beta2) + - (ddb332*sdown2 + ddb333*sdown3)*pow2(beta3) + - sdown1*((db11*db21 + db23*db31 + dG21)*beta2 + - (db21*db32 + db31*(db11 + db33) + dG31)*beta3 + - beta1*(db12*db21 + db13*db31 + dG11 + pow2(db11)) + - ddb331*pow2(beta3))) -; - -rTheta -= -lienTheta*alpha + dTheta1*beta1 + dTheta2*beta2 + - dTheta3*beta3 -; - -rACss -= -sup1*(2.*lieA13*sup3 + 1.3333333333333333333*dK1*alpha*chi + - sup2*(-(cdda12*psim4) + 2.*(lieA12 - AA12*alpha) + - 0.66666666666666666667*trcdda*g12)) + - sup3*(2.*((psim4*Rf13*sup1 - AA23*sup2)*alpha + - sup2*(lieA23 + (-AA32 + psim4*Rf23)*alpha)) + - 1.3333333333333333333*dK3*alpha*chi + - sup1*(-(dda13*psim4) - 2.*AA13*alpha + - 0.66666666666666666667*trcdda*g13)) + - (lieA11 - cdda11*psim4 - 2.*AA11*alpha + - 0.33333333333333333333*trcdda*g11)*pow2(sup1) + - (lieA22 - 2.*AA22*alpha + 0.33333333333333333333*trcdda*g22)* - pow2(sup2) - psim4*((cdda23 + dda23)*sup2*sup3 + - sup1*(dda12*sup2 + cdda13*sup3) + cdda22*pow2(sup2)) + - (lieA33 - cdda33*psim4 - 2.*AA33*alpha + - 0.33333333333333333333*trcdda*g33)*pow2(sup3) - - alpha*(sup2*(2.*AA21*sup1 + - 0.66666666666666666667*Rhat*sup3*g23) + - 0.33333333333333333333*(Rhat*g11*pow2(sup1) + - dGfromgdu11*qud11*pow2(chi))) + - alpha*(1.3333333333333333333*dK2*sup2*chi + - 2.*(sup1*(-(AA31*sup3) + K*sup2*A12) + K*sup2*sup3*A23 - - DTheta*chi) + ginv11* - (3.*dchi1*(sup1*A11 + sup2*A12 + sup3*A13) - - 2.*(cdA111*sup1 + cdA112*sup2 + cdA113*sup3)*chi) + - ginv12*(3.*(sup1*(dchi2*A11 + dchi1*A12) + - dchi2*(sup2*A12 + sup3*A13) + - dchi1*(sup2*A22 + sup3*A23)) - - 2.*((cdA112 + cdA211)*sup1 + (cdA122 + cdA212)*sup2 + - (cdA123 + cdA213)*sup3)*chi) + - ginv22*(3.*dchi2*(sup1*A12 + sup2*A22 + sup3*A23) - - 2.*(cdA212*sup1 + cdA222*sup2 + cdA223*sup3)*chi) + - ginv13*(3.*(dchi3*(sup1*A11 + sup2*A12) + - (dchi1*sup1 + dchi3*sup3)*A13 + - dchi1*(sup2*A23 + sup3*A33)) - - 2.*((cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 + cdA313)*sup3)*chi) + - ginv23*(3.*(sup1*(dchi3*A12 + dchi2*A13) + - sup2*(dchi3*A22 + dchi2*A23) + - sup3*(dchi3*A23 + dchi2*A33)) - - 2.*((cdA213 + cdA312)*sup1 + (cdA223 + cdA322)*sup2 + - (cdA233 + cdA323)*sup3)*chi) + - ginv33*(3.*dchi3*(sup1*A13 + sup2*A23 + sup3*A33) - - 2.*(cdA313*sup1 + cdA323*sup2 + cdA333*sup3)*chi) - - 0.66666666666666666667*Rhat*sup1*sup3*g13 + - psim4*(2.*Rf12*sup1*sup2 + Rf11*pow2(sup1) + Rf22*pow2(sup2) + - Rf33*pow2(sup3)) + K*(2.*sup1*sup3*A13 + - A11*pow2(sup1) + A22*pow2(sup2) + A33*pow2(sup3)) + - (0.33333333333333333333*dG11*qud11 - - sdown3*(Gfromg3*kappa1 + 0.66666666666666666667*dG33*sup3) + - sdown1*(0.66666666666666666667*dGfromgdu11*sup1 + - kappa1*G1) + kappa1* - (-(Gfromg1*sdown1) - Gfromg2*sdown2 + sdown2*G2 + - sdown3*G3))*pow2(chi) + - 0.33333333333333333333*(-(Rhat* - (g22*pow2(sup2) + g33*pow2(sup3))) + - ((dG12 - dGfromgdu12)*qud12 + (dG13 - dGfromgdu13)*qud13 + - (dG21 - dGfromgdu21)*qud21 + (dG22 - dGfromgdu22)*qud22 + - (dG23 - dGfromgdu23)*qud23 + (dG31 - dGfromgdu31)*qud31 + - (dG32 - dGfromgdu32)*qud32 + (dG33 - dGfromgdu33)*qud33)* - pow2(chi))) + 0.66666666666666666667* - (sup2*(sup3*trcdda*g23 + - (-(dG21*sdown1) - dG22*sdown2 + dGfromgdu22*sdown2 + - dGfromgdu23*sdown3)*alpha*pow2(chi)) + - alpha*((-(sdown3*(dG13*sup1 + dG23*sup2)) + - (-(dG31*sdown1) - dG32*sdown2 + dGfromgdu32*sdown2 + - dGfromgdu33*sdown3)*sup3 + - sdown1*(dGfromgdu21*sup2 + dGfromgdu31*sup3))*pow2(chi) + - sup1*(-(Rhat*sup2*g12) + - (-(dG11*sdown1) - dG12*sdown2 + dGfromgdu12*sdown2 + - dGfromgdu13*sdown3)*pow2(chi)))) -; - -rACqq -= --rACss + (Ainv22*lieg22 + 2.*(Ainv12*lieg12 + Ainv13*lieg13 + - Ainv23*lieg23) - (2.*Ainv22*A22 + - 4.*(Ainv12*A12 + Ainv13*A13 + Ainv23*A23))* - alpha + Ainv11*(lieg11 - 2.*A11*alpha) + - Ainv33*(lieg33 - 2.*A33*alpha))*chi -; - -rGamA1 -= --(((dG11*qud11 + dG12*qud12 + dG13*qud13)*sup1 + - (dG22*qud12 + dG23*qud13)*sup2 + (dG32*qud12 + dG33*qud13)*sup3 + - qud11*(dG21*sup2 + dG31*sup3))*vbetaA) + - (dG11*qud11 + dG12*qud12 + dG13*qud13)*beta1 + - (dG21*qud11 + dG22*qud12 + dG23*qud13)*beta2 + - (dG31*qud11 + dG32*qud12 + dG33*qud13)*beta3 - - ((((db11*quu11 + db21*quu12 + db31*quu13)*sdown1 + - (db12*quu11 + db22*quu12 + db32*quu13)*sdown2 + - (db13*quu11 + db23*quu12)*sdown3)*shiftdriver)/vbetaA + - (0.66666666666666666667*dTheta1*quu11 + - (1.3333333333333333333*dKhat2 + 0.66666666666666666667*dTheta2)* - quu12)*alpha + quu13* - ((db33*sdown3*shiftdriver)/vbetaA + - 1.3333333333333333333*dKhat3*alpha))/chi + - (2.3333333333333333333*((ddb121*qud11 + ddb122*qud12 + ddb123*qud13)* - quu12 + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13)*quu13) + - 0.33333333333333333333*((ddb122*qud22 + ddb123*qud23 + - ddb131*qud31 + ddb132*qud32)*quu11 + - (ddb221*qud21 + ddb222*qud22 + ddb223*qud23 + ddb231*qud31 + - ddb232*qud32 + ddb233*qud33)*quu12 + - (ddb231*qud21 + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + - ddb332*qud32 + ddb333*qud33)*quu13) + - (ddb221*qud11 + ddb222*qud12 + ddb223*qud13)*quu22 + - 2.*(ddb231*qud11 + ddb232*qud12 + ddb233*qud13)*quu23 + - (ddb331*qud11 + ddb332*qud12 + ddb333*qud13)*quu33 + - 1.3333333333333333333*((ddb111*qud11 + ddb112*qud12)*quu11 + - (ddb132*quu13*sdown2 + ddb113*quu11*sdown3)*sup1 + - (ddb232*quu13*sdown2 + ddb123*quu11*sdown3)*sup2 + - (ddb332*quu13*sdown2 + ddb133*quu11*sdown3)*sup3 + - sdown2*((ddb112*quu11 + ddb122*quu12)*sup1 + - (ddb122*quu11 + ddb222*quu12)*sup2 + - (ddb132*quu11 + ddb232*quu12)*sup3) + - sdown1*((ddb121*quu12 + ddb131*quu13)*sup1 + - (ddb221*quu12 + ddb231*quu13)*sup2 + - (ddb231*quu12 + ddb331*quu13)*sup3) + - sdown3*((ddb123*quu12 + ddb133*quu13)*sup1 + - (ddb223*quu12 + ddb233*quu13)*sup2 + - (ddb233*quu12 + ddb333*quu13)*sup3)) + - (shiftdriver*((db11*qud11 + db12*qud12 + db13*qud13)*sup1 + - (db21*qud11 + db22*qud12 + db23*qud13)*sup2 + - (db31*qud11 + db32*qud12 + db33*qud13)*sup3))/vbetaA + - ((dG21*quu12 + dG31*quu13)*sdown1 + - (dG12*quu11 + dG22*quu12 + dG32*quu13)*sdown2 + - (dG13*quu11 + dG23*quu12 + dG33*quu13)*sdown3)*vbetaA - - 0.66666666666666666667*dTheta3*quu13*alpha + - quu11*(0.33333333333333333333*(ddb121*qud21 + ddb133*qud33) + - dG11*sdown1*vbetaA + 1.3333333333333333333* - (ddb113*qud13 + sdown1*(ddb111*sup1 + ddb121*sup2 + ddb131*sup3) - - dKhat1*alpha)))/chi -; - -rGamA2 -= --(((dG11*qud21 + dG12*qud22 + dG13*qud23)*sup1 + - (dG22*qud22 + dG23*qud23)*sup2 + (dG32*qud22 + dG33*qud23)*sup3 + - qud21*(dG21*sup2 + dG31*sup3))*vbetaA) + - (dG11*qud21 + dG12*qud22 + dG13*qud23)*beta1 + - (dG21*qud21 + dG22*qud22 + dG23*qud23)*beta2 + - (dG31*qud21 + dG32*qud22 + dG33*qud23)*beta3 - - ((((db11*quu12 + db21*quu22 + db31*quu23)*sdown1 + - (db12*quu12 + db22*quu22 + db32*quu23)*sdown2 + - (db13*quu12 + db23*quu22)*sdown3)*shiftdriver)/vbetaA + - (0.66666666666666666667*dTheta1*quu12 + - (1.3333333333333333333*dKhat2 + 0.66666666666666666667*dTheta2)* - quu22)*alpha + quu23* - ((db33*sdown3*shiftdriver)/vbetaA + - 1.3333333333333333333*dKhat3*alpha))/chi + - ((ddb111*qud21 + ddb112*qud22)*quu11 + - 2.*(ddb131*qud21 + ddb132*qud22 + ddb133*qud23)*quu13 + - (1.3333333333333333333*ddb223*qud23 + - 0.33333333333333333333*(ddb121*qud11 + ddb231*qud31))*quu22 + - 2.3333333333333333333*((ddb121*qud21 + ddb122*qud22)*quu12 + - (ddb231*qud21 + ddb232*qud22)*quu23) + - 0.33333333333333333333*((ddb112*qud12 + ddb113*qud13 + - ddb132*qud32 + ddb133*qud33)*quu12 + - (ddb122*qud12 + ddb123*qud13 + ddb232*qud32 + ddb233*qud33)* - quu22 + (ddb132*qud12 + ddb133*qud13 + ddb332*qud32 + - ddb333*qud33)*quu23) + - (ddb331*qud21 + ddb332*qud22 + ddb333*qud23)*quu33 + - 1.3333333333333333333*((ddb221*qud21 + ddb222*qud22)*quu22 + - (ddb132*quu23*sdown2 + ddb113*quu12*sdown3)*sup1 + - (ddb232*quu23*sdown2 + ddb123*quu12*sdown3)*sup2 + - (ddb332*quu23*sdown2 + ddb133*quu12*sdown3)*sup3 + - sdown2*((ddb112*quu12 + ddb122*quu22)*sup1 + - (ddb122*quu12 + ddb222*quu22)*sup2 + - (ddb132*quu12 + ddb232*quu22)*sup3) + - sdown1*((ddb121*quu22 + ddb131*quu23)*sup1 + - (ddb221*quu22 + ddb231*quu23)*sup2 + - (ddb231*quu22 + ddb331*quu23)*sup3) + - sdown3*((ddb123*quu22 + ddb133*quu23)*sup1 + - (ddb223*quu22 + ddb233*quu23)*sup2 + - (ddb233*quu22 + ddb333*quu23)*sup3)) + - qud23*(ddb113*quu11 + (db33*shiftdriver*sup3)/vbetaA) + - (shiftdriver*((db11*qud21 + db12*qud22 + db13*qud23)*sup1 + - (db21*qud21 + db22*qud22 + db23*qud23)*sup2 + - (db31*qud21 + db32*qud22)*sup3))/vbetaA + - ((dG21*quu22 + dG31*quu23)*sdown1 + - (dG12*quu12 + dG22*quu22 + dG32*quu23)*sdown2 + - (dG13*quu12 + dG23*quu22 + dG33*quu23)*sdown3)*vbetaA + - quu23*(2.3333333333333333333*ddb233*qud23 + - 0.33333333333333333333*(ddb131*qud11 + ddb331*qud31) - - 0.66666666666666666667*dTheta3*alpha) + - quu12*(2.3333333333333333333*ddb123*qud23 + - 0.33333333333333333333*(ddb111*qud11 + ddb131*qud31) + - dG11*sdown1*vbetaA + 1.3333333333333333333* - (sdown1*(ddb111*sup1 + ddb121*sup2 + ddb131*sup3) - - dKhat1*alpha)))/chi -; - -rGamA3 -= --(((dG11*qud31 + dG12*qud32 + dG13*qud33)*sup1 + - (dG22*qud32 + dG23*qud33)*sup2 + (dG32*qud32 + dG33*qud33)*sup3 + - qud31*(dG21*sup2 + dG31*sup3))*vbetaA) + - (dG11*qud31 + dG12*qud32 + dG13*qud33)*beta1 + - (dG21*qud31 + dG22*qud32 + dG23*qud33)*beta2 + - (dG31*qud31 + dG32*qud32 + dG33*qud33)*beta3 - - ((((db11*quu13 + db21*quu23 + db31*quu33)*sdown1 + - (db12*quu13 + db22*quu23 + db32*quu33)*sdown2 + - (db13*quu13 + db23*quu23)*sdown3)*shiftdriver)/vbetaA + - (0.66666666666666666667*dTheta1*quu13 + - (1.3333333333333333333*dKhat2 + 0.66666666666666666667*dTheta2)* - quu23)*alpha + quu33* - ((db33*sdown3*shiftdriver)/vbetaA + - 1.3333333333333333333*dKhat3*alpha))/chi + - ((ddb111*qud31 + ddb112*qud32)*quu11 + - 2.*(ddb122*qud32 + ddb123*qud33)*quu12 + - (ddb222*qud32 + ddb223*qud33)*quu22 + - qud31*(2.*ddb121*quu12 + ddb221*quu22) + - (0.33333333333333333333*(ddb121*qud11 + ddb223*qud23) + - 2.3333333333333333333*ddb231*qud31)*quu23 + - 2.3333333333333333333*((ddb132*qud32 + ddb133*qud33)*quu13 + - (ddb232*qud32 + ddb233*qud33)*quu23) + - 0.33333333333333333333*((ddb112*qud12 + ddb113*qud13 + - ddb121*qud21 + ddb122*qud22)*quu13 + - (ddb122*qud12 + ddb123*qud13 + ddb221*qud21 + ddb222*qud22)* - quu23 + (ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + - ddb232*qud22)*quu33) + - 1.3333333333333333333*((ddb332*qud32 + ddb333*qud33)*quu33 + - (ddb132*quu33*sdown2 + ddb113*quu13*sdown3)*sup1 + - (ddb232*quu33*sdown2 + ddb123*quu13*sdown3)*sup2 + - (ddb332*quu33*sdown2 + ddb133*quu13*sdown3)*sup3 + - sdown2*((ddb112*quu13 + ddb122*quu23)*sup1 + - (ddb122*quu13 + ddb222*quu23)*sup2 + - (ddb132*quu13 + ddb232*quu23)*sup3) + - sdown1*((ddb121*quu23 + ddb131*quu33)*sup1 + - (ddb221*quu23 + ddb231*quu33)*sup2 + - (ddb231*quu23 + ddb331*quu33)*sup3) + - sdown3*((ddb123*quu23 + ddb133*quu33)*sup1 + - (ddb223*quu23 + ddb233*quu33)*sup2 + - (ddb233*quu23 + ddb333*quu33)*sup3)) + - qud33*(ddb113*quu11 + (db33*shiftdriver*sup3)/vbetaA) + - (shiftdriver*((db11*qud31 + db12*qud32 + db13*qud33)*sup1 + - (db21*qud31 + db22*qud32 + db23*qud33)*sup2 + - (db31*qud31 + db32*qud32)*sup3))/vbetaA + - ((dG21*quu23 + dG31*quu33)*sdown1 + - (dG12*quu13 + dG22*quu23 + dG32*quu33)*sdown2 + - (dG13*quu13 + dG23*quu23 + dG33*quu33)*sdown3)*vbetaA + - quu33*(0.33333333333333333333*(ddb131*qud11 + ddb233*qud23) + - 1.3333333333333333333*ddb331*qud31 - - 0.66666666666666666667*dTheta3*alpha) + - quu13*(0.33333333333333333333*(ddb111*qud11 + ddb123*qud23) + - ddb131*(2.3333333333333333333*qud31 + - 1.3333333333333333333*sdown1*sup3) + dG11*sdown1*vbetaA + - 1.3333333333333333333*(sdown1*(ddb111*sup1 + ddb121*sup2) - - dKhat1*alpha)))/chi -; - -rACsA1 -= --2.*((AA12*qud21 + AA13*qud31)*sup1 + (AA22*qud21 + AA23*qud31)*sup2 + - (AA32*qud21 + AA33*qud31)*sup3)*alpha - - ((cdda12*qud21 + cdda13*qud31)*sup1 + - (cdda22*qud21 + cdda23*qud31)*sup2 + dda23*qud21*sup3)*chi + - (-(cdda33*qud31*sup3) + 0.66666666666666666667*dK1*qud11*alpha)* - chi + sup1*(qud11*(lieA11 - 2.*AA11*alpha - cdda11*chi) + - qud21*(lieA12 + Rf12*alpha*chi) + - qud31*(lieA13 + Rf13*alpha*chi)) + - sup2*(lieA23*qud31 + qud11*(lieA12 - 2.*AA21*alpha - - dda12*chi + Rf12*alpha*chi) + - qud21*(lieA22 + Rf22*alpha*chi)) + - sup3*(qud11*(lieA13 - 2.*AA31*alpha - dda13*chi) + - qud21*(lieA23 + Rf23*alpha*chi) + - qud31*(lieA33 + alpha*(K*A33 + Rf33*chi)) - - 0.5*dG33*qdd13*alpha*pow2(chi)) + - alpha*(K*(sup1*(qud11*A11 + qud21*A12 + qud31*A13) + - qud11*(sup2*A12 + sup3*A13) + qud21*sup3*A23 + - sup2*(qud21*A22 + qud31*A23)) + - (-(dTheta1*qud11) - dTheta2*qud21 - dTheta3*qud31 + - 0.66666666666666666667*(dK2*qud21 + dK3*qud31) + qud31*Rf23*sup2 + - qud11*(Rf11*sup1 + Rf13*sup3))*chi + - ginv11*(1.5*dchi1*(qud11*A11 + qud21*A12 + qud31*A13) - - (cdA111*qud11 + cdA112*qud21 + cdA113*qud31)*chi) + - ginv12*(1.5*(qud11*(dchi2*A11 + dchi1*A12) + - dchi2*(qud21*A12 + qud31*A13) + - dchi1*(qud21*A22 + qud31*A23)) - - ((cdA112 + cdA211)*qud11 + (cdA122 + cdA212)*qud21 + - (cdA123 + cdA213)*qud31)*chi) + - ginv22*(1.5*dchi2*(qud11*A12 + qud21*A22 + qud31*A23) - - (cdA212*qud11 + cdA222*qud21 + cdA223*qud31)*chi) + - ginv13*(1.5*(dchi3*(qud11*A11 + qud21*A12) + - (dchi1*qud11 + dchi3*qud31)*A13 + - dchi1*(qud21*A23 + qud31*A33)) - - ((cdA113 + cdA311)*qud11 + (cdA123 + cdA312)*qud21 + - (cdA133 + cdA313)*qud31)*chi) + - ginv23*(1.5*(qud11*(dchi3*A12 + dchi2*A13) + - qud21*(dchi3*A22 + dchi2*A23) + - qud31*(dchi3*A23 + dchi2*A33)) - - ((cdA213 + cdA312)*qud11 + (cdA223 + cdA322)*qud21 + - (cdA233 + cdA323)*qud31)*chi) + - ginv33*(1.5*dchi3*(qud11*A13 + qud21*A23 + qud31*A33) - - (cdA313*qud11 + cdA323*qud21 + cdA333*qud31)*chi) + - 0.5*((-(dG11*qdd11) - dG12*qdd12 + dGfromgdu12*qdd12 + - dGfromgdu13*qdd13)*sup1 + - (-(dG21*qdd11) - dG22*qdd12 + dGfromgdu22*qdd12 + - dGfromgdu23*qdd13)*sup2 - - qdd13*(Gfromg3*kappa1 + dG13*sup1 + dG23*sup2) + - (-(dG31*qdd11) - dG32*qdd12 + dGfromgdu32*qdd12 + - dGfromgdu33*qdd13)*sup3 + - qdd11*(dGfromgdu11*sup1 + dGfromgdu21*sup2 + dGfromgdu31*sup3) + - kappa1*(-(Gfromg1*qdd11) - Gfromg2*qdd12 + qdd11*G1 + - qdd12*G2 + qdd13*G3))*pow2(chi)) -; - -rACsA2 -= --2.*((AA12*qud22 + AA13*qud32)*sup1 + (AA22*qud22 + AA23*qud32)*sup2 + - (AA32*qud22 + AA33*qud32)*sup3)*alpha - - ((cdda12*qud22 + cdda13*qud32)*sup1 + - (cdda22*qud22 + cdda23*qud32)*sup2 + dda23*qud22*sup3)*chi + - (-(cdda33*qud32*sup3) + 0.66666666666666666667*dK1*qud12*alpha)* - chi + sup1*(qud12*(lieA11 - 2.*AA11*alpha - cdda11*chi) + - qud22*(lieA12 + Rf12*alpha*chi) + - qud32*(lieA13 + Rf13*alpha*chi)) + - sup2*(lieA23*qud32 + qud12*(lieA12 - 2.*AA21*alpha - - dda12*chi + Rf12*alpha*chi) + - qud22*(lieA22 + Rf22*alpha*chi)) + - sup3*(qud12*(lieA13 - 2.*AA31*alpha - dda13*chi) + - qud22*(lieA23 + Rf23*alpha*chi) + - qud32*(lieA33 + alpha*(K*A33 + Rf33*chi)) - - 0.5*dG33*qdd23*alpha*pow2(chi)) + - alpha*(K*(sup1*(qud12*A11 + qud22*A12 + qud32*A13) + - qud12*(sup2*A12 + sup3*A13) + qud22*sup3*A23 + - sup2*(qud22*A22 + qud32*A23)) + - (-(dTheta1*qud12) - dTheta2*qud22 - dTheta3*qud32 + - 0.66666666666666666667*(dK2*qud22 + dK3*qud32) + qud32*Rf23*sup2 + - qud12*(Rf11*sup1 + Rf13*sup3))*chi + - ginv11*(1.5*dchi1*(qud12*A11 + qud22*A12 + qud32*A13) - - (cdA111*qud12 + cdA112*qud22 + cdA113*qud32)*chi) + - ginv12*(1.5*(qud12*(dchi2*A11 + dchi1*A12) + - dchi2*(qud22*A12 + qud32*A13) + - dchi1*(qud22*A22 + qud32*A23)) - - ((cdA112 + cdA211)*qud12 + (cdA122 + cdA212)*qud22 + - (cdA123 + cdA213)*qud32)*chi) + - ginv22*(1.5*dchi2*(qud12*A12 + qud22*A22 + qud32*A23) - - (cdA212*qud12 + cdA222*qud22 + cdA223*qud32)*chi) + - ginv13*(1.5*(dchi3*(qud12*A11 + qud22*A12) + - (dchi1*qud12 + dchi3*qud32)*A13 + - dchi1*(qud22*A23 + qud32*A33)) - - ((cdA113 + cdA311)*qud12 + (cdA123 + cdA312)*qud22 + - (cdA133 + cdA313)*qud32)*chi) + - ginv23*(1.5*(qud12*(dchi3*A12 + dchi2*A13) + - qud22*(dchi3*A22 + dchi2*A23) + - qud32*(dchi3*A23 + dchi2*A33)) - - ((cdA213 + cdA312)*qud12 + (cdA223 + cdA322)*qud22 + - (cdA233 + cdA323)*qud32)*chi) + - ginv33*(1.5*dchi3*(qud12*A13 + qud22*A23 + qud32*A33) - - (cdA313*qud12 + cdA323*qud22 + cdA333*qud32)*chi) + - 0.5*((-(dG11*qdd12) - dG12*qdd22 + dGfromgdu12*qdd22 + - dGfromgdu13*qdd23)*sup1 + - (-(dG21*qdd12) - dG22*qdd22 + dGfromgdu22*qdd22 + - dGfromgdu23*qdd23)*sup2 - - qdd23*(Gfromg3*kappa1 + dG13*sup1 + dG23*sup2) + - (-(dG31*qdd12) - dG32*qdd22 + dGfromgdu32*qdd22 + - dGfromgdu33*qdd23)*sup3 + - qdd12*(dGfromgdu11*sup1 + dGfromgdu21*sup2 + dGfromgdu31*sup3) + - kappa1*(-(Gfromg1*qdd12) - Gfromg2*qdd22 + qdd12*G1 + - qdd22*G2 + qdd23*G3))*pow2(chi)) -; - -rACsA3 -= --2.*((AA12*qud23 + AA13*qud33)*sup1 + (AA22*qud23 + AA23*qud33)*sup2 + - (AA32*qud23 + AA33*qud33)*sup3)*alpha - - ((cdda12*qud23 + cdda13*qud33)*sup1 + - (cdda22*qud23 + cdda23*qud33)*sup2 + dda23*qud23*sup3)*chi + - (-(cdda33*qud33*sup3) + 0.66666666666666666667*dK1*qud13*alpha)* - chi + sup1*(qud13*(lieA11 - 2.*AA11*alpha - cdda11*chi) + - qud23*(lieA12 + Rf12*alpha*chi) + - qud33*(lieA13 + Rf13*alpha*chi)) + - sup2*(lieA23*qud33 + qud13*(lieA12 - 2.*AA21*alpha - - dda12*chi + Rf12*alpha*chi) + - qud23*(lieA22 + Rf22*alpha*chi)) + - sup3*(qud13*(lieA13 - 2.*AA31*alpha - dda13*chi) + - qud23*(lieA23 + Rf23*alpha*chi) + - qud33*(lieA33 + alpha*(K*A33 + Rf33*chi)) - - 0.5*dG33*qdd33*alpha*pow2(chi)) + - alpha*(K*(sup1*(qud13*A11 + qud23*A12 + qud33*A13) + - qud13*(sup2*A12 + sup3*A13) + qud23*sup3*A23 + - sup2*(qud23*A22 + qud33*A23)) + - (-(dTheta1*qud13) - dTheta2*qud23 - dTheta3*qud33 + - 0.66666666666666666667*(dK2*qud23 + dK3*qud33) + qud33*Rf23*sup2 + - qud13*(Rf11*sup1 + Rf13*sup3))*chi + - ginv11*(1.5*dchi1*(qud13*A11 + qud23*A12 + qud33*A13) - - (cdA111*qud13 + cdA112*qud23 + cdA113*qud33)*chi) + - ginv12*(1.5*(qud13*(dchi2*A11 + dchi1*A12) + - dchi2*(qud23*A12 + qud33*A13) + - dchi1*(qud23*A22 + qud33*A23)) - - ((cdA112 + cdA211)*qud13 + (cdA122 + cdA212)*qud23 + - (cdA123 + cdA213)*qud33)*chi) + - ginv22*(1.5*dchi2*(qud13*A12 + qud23*A22 + qud33*A23) - - (cdA212*qud13 + cdA222*qud23 + cdA223*qud33)*chi) + - ginv13*(1.5*(dchi3*(qud13*A11 + qud23*A12) + - (dchi1*qud13 + dchi3*qud33)*A13 + - dchi1*(qud23*A23 + qud33*A33)) - - ((cdA113 + cdA311)*qud13 + (cdA123 + cdA312)*qud23 + - (cdA133 + cdA313)*qud33)*chi) + - ginv23*(1.5*(qud13*(dchi3*A12 + dchi2*A13) + - qud23*(dchi3*A22 + dchi2*A23) + - qud33*(dchi3*A23 + dchi2*A33)) - - ((cdA213 + cdA312)*qud13 + (cdA223 + cdA322)*qud23 + - (cdA233 + cdA323)*qud33)*chi) + - ginv33*(1.5*dchi3*(qud13*A13 + qud23*A23 + qud33*A33) - - (cdA313*qud13 + cdA323*qud23 + cdA333*qud33)*chi) + - 0.5*((-(dG11*qdd13) - dG12*qdd23 + dGfromgdu12*qdd23 + - dGfromgdu13*qdd33)*sup1 + - (-(dG21*qdd13) - dG22*qdd23 + dGfromgdu22*qdd23 + - dGfromgdu23*qdd33)*sup2 - - qdd33*(Gfromg3*kappa1 + dG13*sup1 + dG23*sup2) + - (-(dG31*qdd13) - dG32*qdd23 + dGfromgdu32*qdd23 + - dGfromgdu33*qdd33)*sup3 + - qdd13*(dGfromgdu11*sup1 + dGfromgdu21*sup2 + dGfromgdu31*sup3) + - kappa1*(-(Gfromg1*qdd13) - Gfromg2*qdd23 + qdd13*G1 + - qdd23*G2 + qdd33*G3))*pow2(chi)) -; - -rACABTF11 -= -2.*(lieA12*qPhysuudd1211 + lieA13*qPhysuudd1311 + - qPhysuudd2311*(lieA23 - cdA123*sup1*alpha)) + - qPhysuudd1111*(lieA11 + alpha* - (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ -+ alpha*(qPhysuudd1111*(cdA113*sup3 + - 0.66666666666666666667*K*A11) + - 1.3333333333333333333*K*(qPhysuudd1211*A12 + - qPhysuudd1311*A13 + qPhysuudd2311*A23) + - qPhysuudd3311*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + - sup3*(cdA123*qPhysuudd1211 + - qPhysuudd1111*(-cdA311 + (0.5*dchi3*A11)/chi)) + - qPhysuudd2211*A22*(0.66666666666666666667*K + - (0.5*dchi3*sup3)/chi) + - sup2*(-2.*cdA213*qPhysuudd1311 - cdA223*qPhysuudd2311 + - cdA322*qPhysuudd2311 + cdA323*qPhysuudd3311 + - (0.5*dchi2*qPhysuudd1111*A11)/chi) + - (dchi3*(-0.5*qPhysuudd1311*sup2 + qPhysuudd1211*sup3)*A12 + - (-0.5*dchi3*qPhysuudd3311*sup1 + dchi2*qPhysuudd1311*sup2)* - A13 + sup1*(-0.5*dchi2*qPhysuudd1211*A11 + - dchi1*qPhysuudd2311*A23) + - 0.5*((-(dchi3*qPhysuudd2311*sup1) + dchi2*qPhysuudd1211*sup2)* - A12 + dchi3*qPhysuudd1311*sup3*A13 - - (dchi1*qPhysuudd1211 + dchi3*qPhysuudd2311)*sup2*A22 + - sup1*((dchi1*qPhysuudd1211 - dchi2*qPhysuudd2211)*A12 + - (dchi1*qPhysuudd1311 - dchi2*qPhysuudd2311)*A13 + - dchi1*qPhysuudd2211*A22) - - (dchi3*qPhysuudd3311*sup2 + dchi1*qPhysuudd1211*sup3)* - A23 + ((-(dchi1*qPhysuudd1311) + dchi2*qPhysuudd2311)* - sup2 + (-(dchi2*qPhysuudd2211) + dchi3*qPhysuudd2311)*sup3\ -)*A23 + qPhysuudd3311*(dchi1*sup1 + dchi2*sup2)*A33 - - sup3*((dchi1*qPhysuudd1111 + dchi2*qPhysuudd1211)*A13 + - (dchi1*qPhysuudd1311 + dchi2*qPhysuudd2311)*A33)))/ - chi) - cdda11*qPhysuudd1111*chi + - qPhysuudd1211*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + - (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + - qPhysuudd1311*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + - qPhysuudd2211*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + - cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + - qPhysuudd2311*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* - alpha - cdda23*chi) + - qPhysuudd3311*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - - cdda33*chi) - qPhysuudd1211* - ((AA12 + AA21)*alpha + dda12*chi) - - qPhysuudd1311*(alpha*(AA13 + AA31 + - (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - - qPhysuudd2311*((AA23 + AA32)*alpha + dda23*chi) -; - -rACABTF12 -= -2.*(lieA12*qPhysuudd1212 + lieA13*qPhysuudd1312 + - qPhysuudd2312*(lieA23 - cdA123*sup1*alpha)) + - qPhysuudd1112*(lieA11 + alpha* - (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ -+ alpha*(qPhysuudd1112*(cdA113*sup3 + - 0.66666666666666666667*K*A11) + - 1.3333333333333333333*K*(qPhysuudd1212*A12 + - qPhysuudd1312*A13 + qPhysuudd2312*A23) + - qPhysuudd3312*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + - sup3*(cdA123*qPhysuudd1212 + - qPhysuudd1112*(-cdA311 + (0.5*dchi3*A11)/chi)) + - qPhysuudd2212*A22*(0.66666666666666666667*K + - (0.5*dchi3*sup3)/chi) + - sup2*(-2.*cdA213*qPhysuudd1312 - cdA223*qPhysuudd2312 + - cdA322*qPhysuudd2312 + cdA323*qPhysuudd3312 + - (0.5*dchi2*qPhysuudd1112*A11)/chi) + - (dchi3*(-0.5*qPhysuudd1312*sup2 + qPhysuudd1212*sup3)*A12 + - (-0.5*dchi3*qPhysuudd3312*sup1 + dchi2*qPhysuudd1312*sup2)* - A13 + sup1*(-0.5*dchi2*qPhysuudd1212*A11 + - dchi1*qPhysuudd2312*A23) + - 0.5*((-(dchi3*qPhysuudd2312*sup1) + dchi2*qPhysuudd1212*sup2)* - A12 + dchi3*qPhysuudd1312*sup3*A13 - - (dchi1*qPhysuudd1212 + dchi3*qPhysuudd2312)*sup2*A22 + - sup1*((dchi1*qPhysuudd1212 - dchi2*qPhysuudd2212)*A12 + - (dchi1*qPhysuudd1312 - dchi2*qPhysuudd2312)*A13 + - dchi1*qPhysuudd2212*A22) - - (dchi3*qPhysuudd3312*sup2 + dchi1*qPhysuudd1212*sup3)* - A23 + ((-(dchi1*qPhysuudd1312) + dchi2*qPhysuudd2312)* - sup2 + (-(dchi2*qPhysuudd2212) + dchi3*qPhysuudd2312)*sup3\ -)*A23 + qPhysuudd3312*(dchi1*sup1 + dchi2*sup2)*A33 - - sup3*((dchi1*qPhysuudd1112 + dchi2*qPhysuudd1212)*A13 + - (dchi1*qPhysuudd1312 + dchi2*qPhysuudd2312)*A33)))/ - chi) - cdda11*qPhysuudd1112*chi + - qPhysuudd1212*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + - (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + - qPhysuudd1312*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + - qPhysuudd2212*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + - cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + - qPhysuudd2312*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* - alpha - cdda23*chi) + - qPhysuudd3312*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - - cdda33*chi) - qPhysuudd1212* - ((AA12 + AA21)*alpha + dda12*chi) - - qPhysuudd1312*(alpha*(AA13 + AA31 + - (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - - qPhysuudd2312*((AA23 + AA32)*alpha + dda23*chi) -; - -rACABTF13 -= -2.*(lieA12*qPhysuudd1213 + lieA13*qPhysuudd1313 + - qPhysuudd2313*(lieA23 - cdA123*sup1*alpha)) + - qPhysuudd1113*(lieA11 + alpha* - (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ -+ alpha*(qPhysuudd1113*(cdA113*sup3 + - 0.66666666666666666667*K*A11) + - 1.3333333333333333333*K*(qPhysuudd1213*A12 + - qPhysuudd1313*A13 + qPhysuudd2313*A23) + - qPhysuudd3313*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + - sup3*(cdA123*qPhysuudd1213 + - qPhysuudd1113*(-cdA311 + (0.5*dchi3*A11)/chi)) + - qPhysuudd2213*A22*(0.66666666666666666667*K + - (0.5*dchi3*sup3)/chi) + - sup2*(-2.*cdA213*qPhysuudd1313 - cdA223*qPhysuudd2313 + - cdA322*qPhysuudd2313 + cdA323*qPhysuudd3313 + - (0.5*dchi2*qPhysuudd1113*A11)/chi) + - (dchi3*(-0.5*qPhysuudd1313*sup2 + qPhysuudd1213*sup3)*A12 + - (-0.5*dchi3*qPhysuudd3313*sup1 + dchi2*qPhysuudd1313*sup2)* - A13 + sup1*(-0.5*dchi2*qPhysuudd1213*A11 + - dchi1*qPhysuudd2313*A23) + - 0.5*((-(dchi3*qPhysuudd2313*sup1) + dchi2*qPhysuudd1213*sup2)* - A12 + dchi3*qPhysuudd1313*sup3*A13 - - (dchi1*qPhysuudd1213 + dchi3*qPhysuudd2313)*sup2*A22 + - sup1*((dchi1*qPhysuudd1213 - dchi2*qPhysuudd2213)*A12 + - (dchi1*qPhysuudd1313 - dchi2*qPhysuudd2313)*A13 + - dchi1*qPhysuudd2213*A22) - - (dchi3*qPhysuudd3313*sup2 + dchi1*qPhysuudd1213*sup3)* - A23 + ((-(dchi1*qPhysuudd1313) + dchi2*qPhysuudd2313)* - sup2 + (-(dchi2*qPhysuudd2213) + dchi3*qPhysuudd2313)*sup3\ -)*A23 + qPhysuudd3313*(dchi1*sup1 + dchi2*sup2)*A33 - - sup3*((dchi1*qPhysuudd1113 + dchi2*qPhysuudd1213)*A13 + - (dchi1*qPhysuudd1313 + dchi2*qPhysuudd2313)*A33)))/ - chi) - cdda11*qPhysuudd1113*chi + - qPhysuudd1213*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + - (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + - qPhysuudd1313*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + - qPhysuudd2213*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + - cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + - qPhysuudd2313*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* - alpha - cdda23*chi) + - qPhysuudd3313*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - - cdda33*chi) - qPhysuudd1213* - ((AA12 + AA21)*alpha + dda12*chi) - - qPhysuudd1313*(alpha*(AA13 + AA31 + - (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - - qPhysuudd2313*((AA23 + AA32)*alpha + dda23*chi) -; - -rACABTF22 -= -2.*(lieA12*qPhysuudd1222 + lieA13*qPhysuudd1322 + - qPhysuudd2322*(lieA23 - cdA123*sup1*alpha)) + - qPhysuudd1122*(lieA11 + alpha* - (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ -+ alpha*(qPhysuudd1122*(cdA113*sup3 + - 0.66666666666666666667*K*A11) + - 1.3333333333333333333*K*(qPhysuudd1222*A12 + - qPhysuudd1322*A13 + qPhysuudd2322*A23) + - qPhysuudd3322*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + - sup3*(cdA123*qPhysuudd1222 + - qPhysuudd1122*(-cdA311 + (0.5*dchi3*A11)/chi)) + - qPhysuudd2222*A22*(0.66666666666666666667*K + - (0.5*dchi3*sup3)/chi) + - sup2*(-2.*cdA213*qPhysuudd1322 - cdA223*qPhysuudd2322 + - cdA322*qPhysuudd2322 + cdA323*qPhysuudd3322 + - (0.5*dchi2*qPhysuudd1122*A11)/chi) + - (dchi3*(-0.5*qPhysuudd1322*sup2 + qPhysuudd1222*sup3)*A12 + - (-0.5*dchi3*qPhysuudd3322*sup1 + dchi2*qPhysuudd1322*sup2)* - A13 + sup1*(-0.5*dchi2*qPhysuudd1222*A11 + - dchi1*qPhysuudd2322*A23) + - 0.5*((-(dchi3*qPhysuudd2322*sup1) + dchi2*qPhysuudd1222*sup2)* - A12 + dchi3*qPhysuudd1322*sup3*A13 - - (dchi1*qPhysuudd1222 + dchi3*qPhysuudd2322)*sup2*A22 + - sup1*((dchi1*qPhysuudd1222 - dchi2*qPhysuudd2222)*A12 + - (dchi1*qPhysuudd1322 - dchi2*qPhysuudd2322)*A13 + - dchi1*qPhysuudd2222*A22) - - (dchi3*qPhysuudd3322*sup2 + dchi1*qPhysuudd1222*sup3)* - A23 + ((-(dchi1*qPhysuudd1322) + dchi2*qPhysuudd2322)* - sup2 + (-(dchi2*qPhysuudd2222) + dchi3*qPhysuudd2322)*sup3\ -)*A23 + qPhysuudd3322*(dchi1*sup1 + dchi2*sup2)*A33 - - sup3*((dchi1*qPhysuudd1122 + dchi2*qPhysuudd1222)*A13 + - (dchi1*qPhysuudd1322 + dchi2*qPhysuudd2322)*A33)))/ - chi) - cdda11*qPhysuudd1122*chi + - qPhysuudd1222*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + - (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + - qPhysuudd1322*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + - qPhysuudd2222*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + - cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + - qPhysuudd2322*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* - alpha - cdda23*chi) + - qPhysuudd3322*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - - cdda33*chi) - qPhysuudd1222* - ((AA12 + AA21)*alpha + dda12*chi) - - qPhysuudd1322*(alpha*(AA13 + AA31 + - (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - - qPhysuudd2322*((AA23 + AA32)*alpha + dda23*chi) -; - -rACABTF23 -= -2.*(lieA12*qPhysuudd1223 + lieA13*qPhysuudd1323 + - qPhysuudd2323*(lieA23 - cdA123*sup1*alpha)) + - qPhysuudd1123*(lieA11 + alpha* - (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ -+ alpha*(qPhysuudd1123*(cdA113*sup3 + - 0.66666666666666666667*K*A11) + - 1.3333333333333333333*K*(qPhysuudd1223*A12 + - qPhysuudd1323*A13 + qPhysuudd2323*A23) + - qPhysuudd3323*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + - sup3*(cdA123*qPhysuudd1223 + - qPhysuudd1123*(-cdA311 + (0.5*dchi3*A11)/chi)) + - qPhysuudd2223*A22*(0.66666666666666666667*K + - (0.5*dchi3*sup3)/chi) + - sup2*(-2.*cdA213*qPhysuudd1323 - cdA223*qPhysuudd2323 + - cdA322*qPhysuudd2323 + cdA323*qPhysuudd3323 + - (0.5*dchi2*qPhysuudd1123*A11)/chi) + - (dchi3*(-0.5*qPhysuudd1323*sup2 + qPhysuudd1223*sup3)*A12 + - (-0.5*dchi3*qPhysuudd3323*sup1 + dchi2*qPhysuudd1323*sup2)* - A13 + sup1*(-0.5*dchi2*qPhysuudd1223*A11 + - dchi1*qPhysuudd2323*A23) + - 0.5*((-(dchi3*qPhysuudd2323*sup1) + dchi2*qPhysuudd1223*sup2)* - A12 + dchi3*qPhysuudd1323*sup3*A13 - - (dchi1*qPhysuudd1223 + dchi3*qPhysuudd2323)*sup2*A22 + - sup1*((dchi1*qPhysuudd1223 - dchi2*qPhysuudd2223)*A12 + - (dchi1*qPhysuudd1323 - dchi2*qPhysuudd2323)*A13 + - dchi1*qPhysuudd2223*A22) - - (dchi3*qPhysuudd3323*sup2 + dchi1*qPhysuudd1223*sup3)* - A23 + ((-(dchi1*qPhysuudd1323) + dchi2*qPhysuudd2323)* - sup2 + (-(dchi2*qPhysuudd2223) + dchi3*qPhysuudd2323)*sup3\ -)*A23 + qPhysuudd3323*(dchi1*sup1 + dchi2*sup2)*A33 - - sup3*((dchi1*qPhysuudd1123 + dchi2*qPhysuudd1223)*A13 + - (dchi1*qPhysuudd1323 + dchi2*qPhysuudd2323)*A33)))/ - chi) - cdda11*qPhysuudd1123*chi + - qPhysuudd1223*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + - (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + - qPhysuudd1323*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + - qPhysuudd2223*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + - cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + - qPhysuudd2323*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* - alpha - cdda23*chi) + - qPhysuudd3323*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - - cdda33*chi) - qPhysuudd1223* - ((AA12 + AA21)*alpha + dda12*chi) - - qPhysuudd1323*(alpha*(AA13 + AA31 + - (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - - qPhysuudd2323*((AA23 + AA32)*alpha + dda23*chi) -; - -rACABTF33 -= -2.*(lieA12*qPhysuudd1233 + lieA13*qPhysuudd1333 + - qPhysuudd2333*(lieA23 - cdA123*sup1*alpha)) + - qPhysuudd1133*(lieA11 + alpha* - (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ -+ alpha*(qPhysuudd1133*(cdA113*sup3 + - 0.66666666666666666667*K*A11) + - 1.3333333333333333333*K*(qPhysuudd1233*A12 + - qPhysuudd1333*A13 + qPhysuudd2333*A23) + - qPhysuudd3333*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + - sup3*(cdA123*qPhysuudd1233 + - qPhysuudd1133*(-cdA311 + (0.5*dchi3*A11)/chi)) + - qPhysuudd2233*A22*(0.66666666666666666667*K + - (0.5*dchi3*sup3)/chi) + - sup2*(-2.*cdA213*qPhysuudd1333 - cdA223*qPhysuudd2333 + - cdA322*qPhysuudd2333 + cdA323*qPhysuudd3333 + - (0.5*dchi2*qPhysuudd1133*A11)/chi) + - (dchi3*(-0.5*qPhysuudd1333*sup2 + qPhysuudd1233*sup3)*A12 + - (-0.5*dchi3*qPhysuudd3333*sup1 + dchi2*qPhysuudd1333*sup2)* - A13 + sup1*(-0.5*dchi2*qPhysuudd1233*A11 + - dchi1*qPhysuudd2333*A23) + - 0.5*((-(dchi3*qPhysuudd2333*sup1) + dchi2*qPhysuudd1233*sup2)* - A12 + dchi3*qPhysuudd1333*sup3*A13 - - (dchi1*qPhysuudd1233 + dchi3*qPhysuudd2333)*sup2*A22 + - sup1*((dchi1*qPhysuudd1233 - dchi2*qPhysuudd2233)*A12 + - (dchi1*qPhysuudd1333 - dchi2*qPhysuudd2333)*A13 + - dchi1*qPhysuudd2233*A22) - - (dchi3*qPhysuudd3333*sup2 + dchi1*qPhysuudd1233*sup3)* - A23 + ((-(dchi1*qPhysuudd1333) + dchi2*qPhysuudd2333)* - sup2 + (-(dchi2*qPhysuudd2233) + dchi3*qPhysuudd2333)*sup3\ -)*A23 + qPhysuudd3333*(dchi1*sup1 + dchi2*sup2)*A33 - - sup3*((dchi1*qPhysuudd1133 + dchi2*qPhysuudd1233)*A13 + - (dchi1*qPhysuudd1333 + dchi2*qPhysuudd2333)*A33)))/ - chi) - cdda11*qPhysuudd1133*chi + - qPhysuudd1233*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + - (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + - qPhysuudd1333*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + - (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + - qPhysuudd2233*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + - cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + - qPhysuudd2333*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* - alpha - cdda23*chi) + - qPhysuudd3333*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - - cdda33*chi) - qPhysuudd1233* - ((AA12 + AA21)*alpha + dda12*chi) - - qPhysuudd1333*(alpha*(AA13 + AA31 + - (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - - qPhysuudd2333*((AA23 + AA32)*alpha + dda23*chi) -; - - -if (givehPsi0) { - -gADM11 -= -g11/chi -; - -gADM12 -= -g12/chi -; - -gADM13 -= -g13/chi -; - -gADM21 -= -g12/chi -; - -gADM22 -= -g22/chi -; - -gADM23 -= -g23/chi -; - -gADM31 -= -g13/chi -; - -gADM32 -= -g23/chi -; - -gADM33 -= -g33/chi -; - -vu1 -= --yp -; - -vu2 -= -xp -; - -vu3 -= -0 -; - -wu1 -= -((-(ADMginv13*sup2) + ADMginv12*sup3)*vu1 + - (ADMginv13*sup1 - ADMginv11*sup3)*vu2 + - (-(ADMginv12*sup1) + ADMginv11*sup2)*vu3)/Power(chi,1.5) -; - -wu2 -= -((-(ADMginv23*sup2) + ADMginv22*sup3)*vu1 + - (ADMginv23*sup1 - ADMginv12*sup3)*vu2 + - (-(ADMginv22*sup1) + ADMginv12*sup2)*vu3)/Power(chi,1.5) -; - -wu3 -= -((-(ADMginv33*sup2) + ADMginv23*sup3)*vu1 + - (ADMginv33*sup1 - ADMginv13*sup3)*vu2 + - (-(ADMginv23*sup1) + ADMginv13*sup2)*vu3)/Power(chi,1.5) -; - -sdotv -= -(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*vu1 + - (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*vu2 + - (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*vu3 -; - -vu1 -= --(sdotv*sup1) + vu1 -; - -vu2 -= --(sdotv*sup2) + vu2 -; - -vu3 -= --(sdotv*sup3) + vu3 -; - -vdotv -= -(gADM31*vu1 + (gADM23 + gADM32)*vu2)*vu3 + - vu1*((gADM12 + gADM21)*vu2 + gADM13*vu3) + gADM11*pow2(vu1) + - gADM22*pow2(vu2) + gADM33*pow2(vu3) -; - -vu1 -= -vu1/Sqrt(vdotv) -; - -vu2 -= -vu2/Sqrt(vdotv) -; - -vu3 -= -vu3/Sqrt(vdotv) -; - -sdotw -= -(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*wu1 + - (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*wu2 + - (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*wu3 -; - -vdotw -= -(gADM11*vu1 + gADM21*vu2 + gADM31*vu3)*wu1 + - (gADM12*vu1 + gADM22*vu2 + gADM32*vu3)*wu2 + - (gADM13*vu1 + gADM23*vu2 + gADM33*vu3)*wu3 -; - -wu1 -= --(sdotw*sup1) - vdotw*vu1 + wu1 -; - -wu2 -= --(sdotw*sup2) - vdotw*vu2 + wu2 -; - -wu3 -= --(sdotw*sup3) - vdotw*vu3 + wu3 -; - -wdotw -= -(gADM31*wu1 + (gADM23 + gADM32)*wu2)*wu3 + - wu1*((gADM12 + gADM21)*wu2 + gADM13*wu3) + gADM11*pow2(wu1) + - gADM22*pow2(wu2) + gADM33*pow2(wu3) -; - -wu1 -= -wu1/Sqrt(wdotw) -; - -wu2 -= -wu2/Sqrt(wdotw) -; - -wu3 -= -wu3/Sqrt(wdotw) -; - -vd1 -= -gADM11*vu1 + gADM12*vu2 + gADM13*vu3 -; - -vd2 -= -gADM21*vu1 + gADM22*vu2 + gADM23*vu3 -; - -vd3 -= -gADM31*vu1 + gADM32*vu2 + gADM33*vu3 -; - -wd1 -= -gADM11*wu1 + gADM12*wu2 + gADM13*wu3 -; - -wd2 -= -gADM21*wu1 + gADM22*wu2 + gADM23*wu3 -; - -wd3 -= -gADM31*wu1 + gADM32*wu2 + gADM33*wu3 -; - -RehPsi0 -= -Power(2.7182818284590452354,pow2(hPsi0parb)* - (2.*hPsi0parc*time - pow2(hPsi0parc) - pow2(time)))*hPsi0para -; - -ImhPsi0 -= -0 -; - -rACABTF11 -= -rACABTF11 + alpha*chi* - (2.*ImhPsi0*vd1*wd1 + RehPsi0*(pow2(vd1) - pow2(wd1))) -; - -rACABTF12 -= -rACABTF12 + (vd2*(RehPsi0*vd1 + ImhPsi0*wd1) + - (ImhPsi0*vd1 - RehPsi0*wd1)*wd2)*alpha*chi -; - -rACABTF13 -= -rACABTF13 + (vd3*(RehPsi0*vd1 + ImhPsi0*wd1) + - (ImhPsi0*vd1 - RehPsi0*wd1)*wd3)*alpha*chi -; - -rACABTF22 -= -rACABTF22 + alpha*chi* - (2.*ImhPsi0*vd2*wd2 + RehPsi0*(pow2(vd2) - pow2(wd2))) -; - -rACABTF23 -= -rACABTF23 + (vd3*(RehPsi0*vd2 + ImhPsi0*wd2) + - (ImhPsi0*vd2 - RehPsi0*wd2)*wd3)*alpha*chi -; - -rACABTF33 -= -rACABTF33 + alpha*chi* - (2.*ImhPsi0*vd3*wd3 + RehPsi0*(pow2(vd3) - pow2(wd3))) -; - - - } - -rA11 -= -rACABTF11 + 0.5*qdd11*rACqq + 2.* - (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)*sdown1 + rACss*pow2(sdown1) -; - -rA12 -= -rACABTF12 + 0.5*qdd12*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* - sdown2 + sdown1*(qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3 + - rACss*sdown2) -; - -rA13 -= -rACABTF13 + 0.5*qdd13*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* - sdown3 + sdown1*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + - rACss*sdown3) -; - -rA22 -= -rACABTF22 + 0.5*qdd22*rACqq + 2.* - (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)*sdown2 + rACss*pow2(sdown2) -; - -rA23 -= -rACABTF23 + 0.5*qdd23*rACqq + (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)* - sdown3 + sdown2*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + - rACss*sdown3) -; - -rA33 -= -rACABTF33 + 0.5*qdd33*rACqq + 2.* - (qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3)*sdown3 + rACss*pow2(sdown3) -; - -rG1 -= -qud11*rGamA1 + qud12*rGamA2 + qud13*rGamA3 + rGams*sup1 -; - -rG2 -= -qud21*rGamA1 + qud22*rGamA2 + qud23*rGamA3 + rGams*sup2 -; - -rG3 -= -qud31*rGamA1 + qud32*rGamA2 + qud33*rGamA3 + rGams*sup3 -; - -#if 0 -rG1 -= kappa1*(G1-Gfromg1); -rG2 -= kappa1*(G2-Gfromg2); -rG3 -= kappa1*(G3-Gfromg3); - -rA11 -= kappa1*A11/r; -rA12 -= kappa1*A12/r; -rA13 -= kappa1*A13/r; -rA22 -= kappa1*A22/r; -rA23 -= kappa1*A23/r; -rA33 -= kappa1*A33/r; -#endif - -#endif -} /* function */ -// f and tof are uper index -#ifdef fortran1 -void decompose2p1_1 -#endif -#ifdef fortran2 -void DECOMPOSE2P1_1 -#endif -#ifdef fortran3 -void decompose2p1_1_ -#endif -(double & r,double & xp,double & yp,double & zp,double & chi, - double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, - double & f1,double & f2,double & f3,double & tofs,double & tof1,double & tof2,double & tof3) -{ -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double modshatARG; -double oomodshat; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -tofs -= -f1*sdown1 + f2*sdown2 + f3*sdown3 -; - -tof1 -= -f1*qud11 + f2*qud12 + f3*qud13 -; - -tof2 -= -f1*qud21 + f2*qud22 + f3*qud23 -; - -tof3 -= -f1*qud31 + f2*qud32 + f3*qud33 -; -} /* function */ -// f and tof are lower index -#ifdef fortran1 -void decompose2p1_2 -#endif -#ifdef fortran2 -void DECOMPOSE2P1_2 -#endif -#ifdef fortran3 -void decompose2p1_2_ -#endif -(double & r,double & xp,double & yp,double & zp,double & chi, - double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, - double & f11,double & f12,double & f13,double & f22,double & f23,double & f33, - double & tofqq,double & tofss,double & tofs1,double & tofs2,double & tofs3, - double & tof11,double & tof12,double & tof13,double & tof22,double & tof23,double & tof33) -{ -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double modshatARG; -double oomodshat; -double qdd11; -double qdd12; -double qdd13; -double qdd22; -double qdd23; -double qdd33; -double qPhysuudd1111; -double qPhysuudd1112; -double qPhysuudd1113; -double qPhysuudd1122; -double qPhysuudd1123; -double qPhysuudd1133; -double qPhysuudd1211; -double qPhysuudd1212; -double qPhysuudd1213; -double qPhysuudd1222; -double qPhysuudd1223; -double qPhysuudd1233; -double qPhysuudd1311; -double qPhysuudd1312; -double qPhysuudd1313; -double qPhysuudd1322; -double qPhysuudd1323; -double qPhysuudd1333; -double qPhysuudd2211; -double qPhysuudd2212; -double qPhysuudd2213; -double qPhysuudd2222; -double qPhysuudd2223; -double qPhysuudd2233; -double qPhysuudd2311; -double qPhysuudd2312; -double qPhysuudd2313; -double qPhysuudd2322; -double qPhysuudd2323; -double qPhysuudd2333; -double qPhysuudd3311; -double qPhysuudd3312; -double qPhysuudd3313; -double qPhysuudd3322; -double qPhysuudd3323; -double qPhysuudd3333; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double quu11; -double quu12; -double quu13; -double quu22; -double quu23; -double quu33; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -qdd11 -= -g11/chi - pow2(sdown1) -; - -qdd12 -= -g12/chi - sdown1*sdown2 -; - -qdd13 -= -g13/chi - sdown1*sdown3 -; - -qdd22 -= -g22/chi - pow2(sdown2) -; - -qdd23 -= -g23/chi - sdown2*sdown3 -; - -qdd33 -= -g33/chi - pow2(sdown3) -; - -quu11 -= -ADMginv11 - pow2(sup1) -; - -quu12 -= -ADMginv12 - sup1*sup2 -; - -quu13 -= -ADMginv13 - sup1*sup3 -; - -quu22 -= -ADMginv22 - pow2(sup2) -; - -quu23 -= -ADMginv23 - sup2*sup3 -; - -quu33 -= -ADMginv33 - pow2(sup3) -; - -qPhysuudd1111 -= --0.5*qdd11*quu11 + pow2(qud11) -; - -qPhysuudd1112 -= -qud11*qud12 - 0.5*qdd12*quu11 -; - -qPhysuudd1113 -= -qud11*qud13 - 0.5*qdd13*quu11 -; - -qPhysuudd1122 -= --0.5*qdd22*quu11 + pow2(qud12) -; - -qPhysuudd1123 -= -qud12*qud13 - 0.5*qdd23*quu11 -; - -qPhysuudd1133 -= --0.5*qdd33*quu11 + pow2(qud13) -; - -qPhysuudd1211 -= -qud11*qud21 - 0.5*qdd11*quu12 -; - -qPhysuudd1212 -= -0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) -; - -qPhysuudd1213 -= -0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) -; - -qPhysuudd1222 -= -qud12*qud22 - 0.5*qdd22*quu12 -; - -qPhysuudd1223 -= -0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) -; - -qPhysuudd1233 -= -qud13*qud23 - 0.5*qdd33*quu12 -; - -qPhysuudd1311 -= -qud11*qud31 - 0.5*qdd11*quu13 -; - -qPhysuudd1312 -= -0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) -; - -qPhysuudd1313 -= -0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) -; - -qPhysuudd1322 -= -qud12*qud32 - 0.5*qdd22*quu13 -; - -qPhysuudd1323 -= -0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) -; - -qPhysuudd1333 -= -qud13*qud33 - 0.5*qdd33*quu13 -; - -qPhysuudd2211 -= --0.5*qdd11*quu22 + pow2(qud21) -; - -qPhysuudd2212 -= -qud21*qud22 - 0.5*qdd12*quu22 -; - -qPhysuudd2213 -= -qud21*qud23 - 0.5*qdd13*quu22 -; - -qPhysuudd2222 -= --0.5*qdd22*quu22 + pow2(qud22) -; - -qPhysuudd2223 -= -qud22*qud23 - 0.5*qdd23*quu22 -; - -qPhysuudd2233 -= --0.5*qdd33*quu22 + pow2(qud23) -; - -qPhysuudd2311 -= -qud21*qud31 - 0.5*qdd11*quu23 -; - -qPhysuudd2312 -= -0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) -; - -qPhysuudd2313 -= -0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) -; - -qPhysuudd2322 -= -qud22*qud32 - 0.5*qdd22*quu23 -; - -qPhysuudd2323 -= -0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) -; - -qPhysuudd2333 -= -qud23*qud33 - 0.5*qdd33*quu23 -; - -qPhysuudd3311 -= --0.5*qdd11*quu33 + pow2(qud31) -; - -qPhysuudd3312 -= -qud31*qud32 - 0.5*qdd12*quu33 -; - -qPhysuudd3313 -= -qud31*qud33 - 0.5*qdd13*quu33 -; - -qPhysuudd3322 -= --0.5*qdd22*quu33 + pow2(qud32) -; - -qPhysuudd3323 -= -qud32*qud33 - 0.5*qdd23*quu33 -; - -qPhysuudd3333 -= --0.5*qdd33*quu33 + pow2(qud33) -; - -tofss -= -2.*(f23*sup2*sup3 + sup1*(f12*sup2 + f13*sup3)) + f11*pow2(sup1) + - f22*pow2(sup2) + f33*pow2(sup3) -; - -tofqq -= -f12*quu12 + f13*quu13 + f23*quu23 + 0.5*(f11*quu11 + f22*quu22 + f33*quu33) -; - -tofs1 -= -(f11*qud11 + f12*qud21 + f13*qud31)*sup1 + - (f12*qud11 + f22*qud21 + f23*qud31)*sup2 + - (f13*qud11 + f23*qud21 + f33*qud31)*sup3 -; - -tofs2 -= -(f11*qud12 + f12*qud22 + f13*qud32)*sup1 + - (f12*qud12 + f22*qud22 + f23*qud32)*sup2 + - (f13*qud12 + f23*qud22 + f33*qud32)*sup3 -; - -tofs3 -= -(f11*qud13 + f12*qud23 + f13*qud33)*sup1 + - (f12*qud13 + f22*qud23 + f23*qud33)*sup2 + - (f13*qud13 + f23*qud23 + f33*qud33)*sup3 -; - -tof11 -= -f11*qPhysuudd1111 + f22*qPhysuudd2211 + - 2.*(f12*qPhysuudd1211 + f13*qPhysuudd1311 + f23*qPhysuudd2311) + - f33*qPhysuudd3311 -; - -tof12 -= -f11*qPhysuudd1112 + f22*qPhysuudd2212 + - 2.*(f12*qPhysuudd1212 + f13*qPhysuudd1312 + f23*qPhysuudd2312) + - f33*qPhysuudd3312 -; - -tof13 -= -f11*qPhysuudd1113 + f22*qPhysuudd2213 + - 2.*(f12*qPhysuudd1213 + f13*qPhysuudd1313 + f23*qPhysuudd2313) + - f33*qPhysuudd3313 -; - -tof22 -= -f11*qPhysuudd1122 + f22*qPhysuudd2222 + - 2.*(f12*qPhysuudd1222 + f13*qPhysuudd1322 + f23*qPhysuudd2322) + - f33*qPhysuudd3322 -; - -tof23 -= -f11*qPhysuudd1123 + f22*qPhysuudd2223 + - 2.*(f12*qPhysuudd1223 + f13*qPhysuudd1323 + f23*qPhysuudd2323) + - f33*qPhysuudd3323 -; - -tof33 -= -f11*qPhysuudd1133 + f22*qPhysuudd2233 + - 2.*(f12*qPhysuudd1233 + f13*qPhysuudd1333 + f23*qPhysuudd2333) + - f33*qPhysuudd3333 -; -} /*function */ -// f and tof are uper index -#ifdef fortran1 -void compose2p1_1 -#endif -#ifdef fortran2 -void COMPOSE2P1_1 -#endif -#ifdef fortran3 -void compose2p1_1_ -#endif -(double & r,double & xp,double & yp,double & zp,double & chi, - double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, - double & f1,double & f2,double & f3,double & tofs,double & tof1,double & tof2,double & tof3) -{ -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double modshatARG; -double oomodshat; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -f1 -= -qud11*tof1 + qud12*tof2 + qud13*tof3 + sup1*tofs -; - -f2 -= -qud21*tof1 + qud22*tof2 + qud23*tof3 + sup2*tofs -; - -f3 -= -qud31*tof1 + qud32*tof2 + qud33*tof3 + sup3*tofs -; -} /* function */ -// f and tof are lower index -#ifdef fortran1 -void compose2p1_2 -#endif -#ifdef fortran2 -void COMPOSE2P1_2 -#endif -#ifdef fortran3 -void compose2p1_2_ -#endif -(double & r,double & xp,double & yp,double & zp,double & chi, - double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, - double & f11,double & f12,double & f13,double & f22,double & f23,double & f33, - double & tofqq,double & tofss,double & tofs1,double & tofs2,double & tofs3, - double & tof11,double & tof12,double & tof13,double & tof22,double & tof23,double & tof33) -{ -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double modshatARG; -double oomodshat; -double qdd11; -double qdd12; -double qdd13; -double qdd22; -double qdd23; -double qdd33; -double qPhysuudd1111; -double qPhysuudd1112; -double qPhysuudd1113; -double qPhysuudd1122; -double qPhysuudd1123; -double qPhysuudd1133; -double qPhysuudd1211; -double qPhysuudd1212; -double qPhysuudd1213; -double qPhysuudd1222; -double qPhysuudd1223; -double qPhysuudd1233; -double qPhysuudd1311; -double qPhysuudd1312; -double qPhysuudd1313; -double qPhysuudd1322; -double qPhysuudd1323; -double qPhysuudd1333; -double qPhysuudd2211; -double qPhysuudd2212; -double qPhysuudd2213; -double qPhysuudd2222; -double qPhysuudd2223; -double qPhysuudd2233; -double qPhysuudd2311; -double qPhysuudd2312; -double qPhysuudd2313; -double qPhysuudd2322; -double qPhysuudd2323; -double qPhysuudd2333; -double qPhysuudd3311; -double qPhysuudd3312; -double qPhysuudd3313; -double qPhysuudd3322; -double qPhysuudd3323; -double qPhysuudd3333; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double quu11; -double quu12; -double quu13; -double quu22; -double quu23; -double quu33; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; - - - -shat1 -= -0 -; - -shat2 -= -0 -; - -shat3 -= -0 -; - - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -qdd11 -= -g11/chi - pow2(sdown1) -; - -qdd12 -= -g12/chi - sdown1*sdown2 -; - -qdd13 -= -g13/chi - sdown1*sdown3 -; - -qdd22 -= -g22/chi - pow2(sdown2) -; - -qdd23 -= -g23/chi - sdown2*sdown3 -; - -qdd33 -= -g33/chi - pow2(sdown3) -; - -quu11 -= -ADMginv11 - pow2(sup1) -; - -quu12 -= -ADMginv12 - sup1*sup2 -; - -quu13 -= -ADMginv13 - sup1*sup3 -; - -quu22 -= -ADMginv22 - pow2(sup2) -; - -quu23 -= -ADMginv23 - sup2*sup3 -; - -quu33 -= -ADMginv33 - pow2(sup3) -; - -qPhysuudd1111 -= --0.5*qdd11*quu11 + pow2(qud11) -; - -qPhysuudd1112 -= -qud11*qud12 - 0.5*qdd12*quu11 -; - -qPhysuudd1113 -= -qud11*qud13 - 0.5*qdd13*quu11 -; - -qPhysuudd1122 -= --0.5*qdd22*quu11 + pow2(qud12) -; - -qPhysuudd1123 -= -qud12*qud13 - 0.5*qdd23*quu11 -; - -qPhysuudd1133 -= --0.5*qdd33*quu11 + pow2(qud13) -; - -qPhysuudd1211 -= -qud11*qud21 - 0.5*qdd11*quu12 -; - -qPhysuudd1212 -= -0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) -; - -qPhysuudd1213 -= -0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) -; - -qPhysuudd1222 -= -qud12*qud22 - 0.5*qdd22*quu12 -; - -qPhysuudd1223 -= -0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) -; - -qPhysuudd1233 -= -qud13*qud23 - 0.5*qdd33*quu12 -; - -qPhysuudd1311 -= -qud11*qud31 - 0.5*qdd11*quu13 -; - -qPhysuudd1312 -= -0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) -; - -qPhysuudd1313 -= -0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) -; - -qPhysuudd1322 -= -qud12*qud32 - 0.5*qdd22*quu13 -; - -qPhysuudd1323 -= -0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) -; - -qPhysuudd1333 -= -qud13*qud33 - 0.5*qdd33*quu13 -; - -qPhysuudd2211 -= --0.5*qdd11*quu22 + pow2(qud21) -; - -qPhysuudd2212 -= -qud21*qud22 - 0.5*qdd12*quu22 -; - -qPhysuudd2213 -= -qud21*qud23 - 0.5*qdd13*quu22 -; - -qPhysuudd2222 -= --0.5*qdd22*quu22 + pow2(qud22) -; - -qPhysuudd2223 -= -qud22*qud23 - 0.5*qdd23*quu22 -; - -qPhysuudd2233 -= --0.5*qdd33*quu22 + pow2(qud23) -; - -qPhysuudd2311 -= -qud21*qud31 - 0.5*qdd11*quu23 -; - -qPhysuudd2312 -= -0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) -; - -qPhysuudd2313 -= -0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) -; - -qPhysuudd2322 -= -qud22*qud32 - 0.5*qdd22*quu23 -; - -qPhysuudd2323 -= -0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) -; - -qPhysuudd2333 -= -qud23*qud33 - 0.5*qdd33*quu23 -; - -qPhysuudd3311 -= --0.5*qdd11*quu33 + pow2(qud31) -; - -qPhysuudd3312 -= -qud31*qud32 - 0.5*qdd12*quu33 -; - -qPhysuudd3313 -= -qud31*qud33 - 0.5*qdd13*quu33 -; - -qPhysuudd3322 -= --0.5*qdd22*quu33 + pow2(qud32) -; - -qPhysuudd3323 -= -qud32*qud33 - 0.5*qdd23*quu33 -; - -qPhysuudd3333 -= --0.5*qdd33*quu33 + pow2(qud33) -; - -// my equations -#if 0 -f11 -= -qPhysuudd1111*tof11 + qPhysuudd2211*tof22 + - 2.*(qPhysuudd1211*tof12 + qPhysuudd1311*tof13 + qPhysuudd2311*tof23) + - qPhysuudd3311*tof33 + qdd11*tofqq + - 1.*sdown1*(qud11*tofs1 + qud21*tofs2 + qud31*tofs3) + tofss*pow2(sdown1) -; - -f12 -= -qPhysuudd1112*tof11 + qPhysuudd2212*tof22 + - 2.*(qPhysuudd1212*tof12 + qPhysuudd1312*tof13 + qPhysuudd2312*tof23) + - qPhysuudd3312*tof33 + qdd12*tofqq + - 0.5*((qud12*sdown1 + qud11*sdown2)*tofs1 + - (qud22*sdown1 + qud21*sdown2)*tofs2 + - (qud32*sdown1 + qud31*sdown2)*tofs3) + sdown1*sdown2*tofss -; - -f13 -= -qPhysuudd1113*tof11 + qPhysuudd2213*tof22 + - 2.*(qPhysuudd1213*tof12 + qPhysuudd1313*tof13 + qPhysuudd2313*tof23) + - qPhysuudd3313*tof33 + qdd13*tofqq + - 0.5*((qud13*sdown1 + qud11*sdown3)*tofs1 + - (qud23*sdown1 + qud21*sdown3)*tofs2 + - (qud33*sdown1 + qud31*sdown3)*tofs3) + sdown1*sdown3*tofss -; - -f22 -= -qPhysuudd1122*tof11 + qPhysuudd2222*tof22 + - 2.*(qPhysuudd1222*tof12 + qPhysuudd1322*tof13 + qPhysuudd2322*tof23) + - qPhysuudd3322*tof33 + qdd22*tofqq + - 1.*sdown2*(qud12*tofs1 + qud22*tofs2 + qud32*tofs3) + tofss*pow2(sdown2) -; - -f23 -= -qPhysuudd1123*tof11 + qPhysuudd2223*tof22 + - 2.*(qPhysuudd1223*tof12 + qPhysuudd1323*tof13 + qPhysuudd2323*tof23) + - qPhysuudd3323*tof33 + qdd23*tofqq + - 0.5*((qud13*sdown2 + qud12*sdown3)*tofs1 + - (qud23*sdown2 + qud22*sdown3)*tofs2 + - (qud33*sdown2 + qud32*sdown3)*tofs3) + sdown2*sdown3*tofss -; - -f33 -= -qPhysuudd1133*tof11 + qPhysuudd2233*tof22 + - 2.*(qPhysuudd1233*tof12 + qPhysuudd1333*tof13 + qPhysuudd2333*tof23) + - qPhysuudd3333*tof33 + qdd33*tofqq + - 1.*sdown3*(qud13*tofs1 + qud23*tofs2 + qud33*tofs3) + tofss*pow2(sdown3) -; -// David's equations -#else -f11 -= -tof11 + 0.5*qdd11*tofqq + 2.*sdown1* - (qud11*tofs1 + qud21*tofs2 + qud31*tofs3) + tofss*pow2(sdown1) -; - -f12 -= -tof12 + 0.5*qdd12*tofqq + (qud12*sdown1 + qud11*sdown2)*tofs1 + - (qud22*sdown1 + qud21*sdown2)*tofs2 + - (qud32*sdown1 + qud31*sdown2)*tofs3 + sdown1*sdown2*tofss -; - -f13 -= -tof13 + 0.5*qdd13*tofqq + (qud13*sdown1 + qud11*sdown3)*tofs1 + - (qud23*sdown1 + qud21*sdown3)*tofs2 + - (qud33*sdown1 + qud31*sdown3)*tofs3 + sdown1*sdown3*tofss -; - -f22 -= -tof22 + 0.5*qdd22*tofqq + 2.*sdown2* - (qud12*tofs1 + qud22*tofs2 + qud32*tofs3) + tofss*pow2(sdown2) -; - -f23 -= -tof23 + 0.5*qdd23*tofqq + (qud13*sdown2 + qud12*sdown3)*tofs1 + - (qud23*sdown2 + qud22*sdown3)*tofs2 + - (qud33*sdown2 + qud32*sdown3)*tofs3 + sdown2*sdown3*tofss -; - -f33 -= -tof33 + 0.5*qdd33*tofqq + 2.*sdown3* - (qud13*tofs1 + qud23*tofs2 + qud33*tofs3) + tofss*pow2(sdown3) -; -#endif - -} /* function */ -#ifdef fortran1 -void racqq_point -#endif -#ifdef fortran2 -void RACQQ_POINT -#endif -#ifdef fortran3 -void racqq_point_ -#endif -(double &A11, -double &A12, -double &A13, -double &A22, -double &A23, -double &A33, -double &alpha, -double &beta1, -double &beta2, -double &beta3, -double &chi, -double &db11, -double &db12, -double &db13, -double &db21, -double &db22, -double &db23, -double &db31, -double &db32, -double &db33, -double &dg111, -double &dg112, -double &dg113, -double &dg122, -double &dg123, -double &dg133, -double &dg211, -double &dg212, -double &dg213, -double &dg222, -double &dg223, -double &dg233, -double &dg311, -double &dg312, -double &dg313, -double &dg322, -double &dg323, -double &dg333, -double &g11, -double &g12, -double &g13, -double &g22, -double &g23, -double &g33, -double &rACqq, -double &rACss) -{ - -double Ainv11; -double Ainv12; -double Ainv13; -double Ainv22; -double Ainv23; -double Ainv33; -double detginv; -double divbeta; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double lieg11; -double lieg12; -double lieg13; -double lieg22; -double lieg23; -double lieg33; -double totdivbeta; - - - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -divbeta -= -db11 + db22 + db33 -; - -totdivbeta -= -0.66666666666666666667*divbeta -; - -Ainv11 -= -2.*(A23*ginv12*ginv13 + ginv11*(A12*ginv12 + A13*ginv13)) + - A11*pow2(ginv11) + A22*pow2(ginv12) + A33*pow2(ginv13) -; - -Ainv12 -= -ginv11*(A11*ginv12 + A12*ginv22 + A13*ginv23) + - ginv12*(A13*ginv13 + A22*ginv22 + A23*ginv23) + - ginv13*(A23*ginv22 + A33*ginv23) + A12*pow2(ginv12) -; - -Ainv13 -= -ginv11*(A11*ginv13 + A12*ginv23 + A13*ginv33) + - ginv12*(A12*ginv13 + A22*ginv23 + A23*ginv33) + - ginv13*(A23*ginv23 + A33*ginv33) + A13*pow2(ginv13) -; - -Ainv22 -= -2.*(A23*ginv22*ginv23 + ginv12*(A12*ginv22 + A13*ginv23)) + - A11*pow2(ginv12) + A22*pow2(ginv22) + A33*pow2(ginv23) -; - -Ainv23 -= -ginv13*(A12*ginv22 + A13*ginv23) + A33*ginv23*ginv33 + - ginv12*(A11*ginv13 + A12*ginv23 + A13*ginv33) + - ginv22*(A22*ginv23 + A23*ginv33) + A23*pow2(ginv23) -; - -Ainv33 -= -2.*(A23*ginv23*ginv33 + ginv13*(A12*ginv23 + A13*ginv33)) + - A11*pow2(ginv13) + A22*pow2(ginv23) + A33*pow2(ginv33) -; - -lieg11 -= -beta1*dg111 + beta2*dg211 + beta3*dg311 + - 2.*(db11*g11 + db12*g12 + db13*g13) - g11*totdivbeta -; - -lieg12 -= -beta1*dg112 + beta2*dg212 + beta3*dg312 + db21*g11 + db23*g13 + db12*g22 + - db13*g23 + g12*(db11 + db22 - totdivbeta) -; - -lieg13 -= -beta1*dg113 + beta2*dg213 + beta3*dg313 + db31*g11 + db32*g12 + db12*g23 + - db13*g33 + g13*(db11 + db33 - totdivbeta) -; - -lieg22 -= -beta1*dg122 + beta2*dg222 + beta3*dg322 + - 2.*(db21*g12 + db22*g22 + db23*g23) - g22*totdivbeta -; - -lieg23 -= -beta1*dg123 + beta2*dg223 + beta3*dg323 + db31*g12 + db21*g13 + db32*g22 + - db23*g33 + g23*(db22 + db33 - totdivbeta) -; - -lieg33 -= -beta1*dg133 + beta2*dg233 + beta3*dg333 + - 2.*(db31*g13 + db32*g23 + db33*g33) - g33*totdivbeta -; - -rACqq -= -chi*(-((4.*(A12*Ainv12 + A13*Ainv13 + A23*Ainv23) + - 2.*(A11*Ainv11 + A22*Ainv22 + A33*Ainv33))*alpha) + - Ainv11*lieg11 + Ainv22*lieg22 + - 2.*(Ainv12*lieg12 + Ainv13*lieg13 + Ainv23*lieg23) + Ainv33*lieg33) - - rACss -; - -} /* function */ -#ifdef fortran1 -void rkhat_point -#endif -#ifdef fortran2 -void RKHAT_POINT -#endif -#ifdef fortran3 -void rkhat_point_ -#endif -(double &alpha, -double &beta1, -double &beta2, -double &beta3, -double &chi, -double &dKhat1, -double &dKhat2, -double &dKhat3, -double &dTheta1, -double &dTheta2, -double &dTheta3, -double &g11, -double &g12, -double &g13, -double &g22, -double &g23, -double &g33, -double &kappa1, -double &kappa2, -double &Khat, -double &r, -double &rKhat, -double &Theta, -double &xp, -double &yp, -double &zp) -{ - -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double DKhat; -double DTheta; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double lienK; -double lienKhat; -double lienTheta; -double modshatARG; -double muL; -double oomodshat; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -muL -= -2./alpha -; - -DKhat -= -dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3 -; - -DTheta -= -dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 -; - -lienKhat -= --((DKhat + Khat/r)*sqrt(muL)) -; - -lienTheta -= --DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta -; - -lienK -= -lienKhat + 2.*lienTheta -; - -rKhat -= -beta1*dKhat1 + beta2*dKhat2 + beta3*dKhat3 + alpha*lienKhat -; - -} /* function */ -#ifdef fortran1 -void rtheta_point -#endif -#ifdef fortran2 -void RTHETA_POINT -#endif -#ifdef fortran3 -void rtheta_point_ -#endif -(double &alpha, -double &beta1, -double &beta2, -double &beta3, -double &chi, -double &dTheta1, -double &dTheta2, -double &dTheta3, -double &g11, -double &g12, -double &g13, -double &g22, -double &g23, -double &g33, -double &kappa1, -double &kappa2, -double &r, -double &rTheta, -double &Theta, -double &xp, -double &yp, -double &zp) -{ - -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double DTheta; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double lienTheta; -double modshatARG; -double oomodshat; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; - - - -shat1 -= -0 -; - -shat2 -= -0 -; - -shat3 -= -0 -; - - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -DTheta -= -dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 -; - -lienTheta -= --DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta -; - -rTheta -= -beta1*dTheta1 + beta2*dTheta2 + beta3*dTheta3 + alpha*lienTheta -; - -} /* function */ - -#ifdef fortran1 -void rgam_point -#endif -#ifdef fortran2 -void RGAM_POINT -#endif -#ifdef fortran3 -void rgam_point_ -#endif -(double &alpha, -double &beta1, -double &beta2, -double &beta3, -double &chi, -double &db11, -double &db12, -double &db13, -double &db21, -double &db22, -double &db23, -double &db31, -double &db32, -double &db33, -double &ddb111, -double &ddb112, -double &ddb113, -double &ddb121, -double &ddb122, -double &ddb123, -double &ddb131, -double &ddb132, -double &ddb133, -double &ddb221, -double &ddb222, -double &ddb223, -double &ddb231, -double &ddb232, -double &ddb233, -double &ddb331, -double &ddb332, -double &ddb333, -double &dG11, -double &dG12, -double &dG13, -double &dG21, -double &dG22, -double &dG23, -double &dG31, -double &dG32, -double &dG33, -double &dKhat1, -double &dKhat2, -double &dKhat3, -double &dTheta1, -double &dTheta2, -double &dTheta3, -double &g11, -double &g12, -double &g13, -double &g22, -double &g23, -double &g33, -double &r, -double &rGamA1, -double &rGamA2, -double &rGamA3, -double &rGams, -double &shiftdriver, -double &xp, -double &yp, -double &zp) -{ - -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double detginv; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double modshatARG; -double muL; -double muStilde; -double oomodshat; -double qdd11; -double qdd12; -double qdd13; -double qdd22; -double qdd23; -double qdd33; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double quu11; -double quu12; -double quu13; -double quu22; -double quu23; -double quu33; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; -double vbetaA; -double vbetas; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -qdd11 -= -g11/chi - pow2(sdown1) -; - -qdd12 -= -g12/chi - sdown1*sdown2 -; - -qdd13 -= -g13/chi - sdown1*sdown3 -; - -qdd22 -= -g22/chi - pow2(sdown2) -; - -qdd23 -= -g23/chi - sdown2*sdown3 -; - -qdd33 -= -g33/chi - pow2(sdown3) -; - -quu11 -= -ADMginv11 - pow2(sup1) -; - -quu12 -= -ADMginv12 - sup1*sup2 -; - -quu13 -= -ADMginv13 - sup1*sup3 -; - -quu22 -= -ADMginv22 - pow2(sup2) -; - -quu23 -= -ADMginv23 - sup2*sup3 -; - -quu33 -= -ADMginv33 - pow2(sup3) -; - -muL -= -2./alpha -; - -muStilde -= -1/chi -; - -vbetas -= -2.*sqrt(0.33333333333333333333*muStilde) -; - -vbetaA -= -sqrt(muStilde) -; - -rGams -= -(beta1*dG11 + beta2*dG21 + beta3*dG31 + - (ddb111*quu11 + ddb221*quu22 + - 2.*(ddb121*quu12 + ddb131*quu13 + ddb231*quu23) + ddb331*quu33)/chi\ -)*sdown1 + (beta1*dG12 + beta2*dG22 + beta3*dG32 + - (ddb112*quu11 + ddb222*quu22 + - 2.*(ddb122*quu12 + ddb132*quu13 + ddb232*quu23) + ddb332*quu33)/chi\ -)*sdown2 + (beta1*dG13 + beta2*dG23 + beta3*dG33 + - (ddb113*quu11 + ddb223*quu22 + - 2.*(ddb123*quu12 + ddb133*quu13 + ddb233*quu23) + ddb333*quu33)/chi\ -)*sdown3 - ((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + ddb121*qud21 + - ddb122*qud22 + ddb123*qud23 + ddb131*qud31 + ddb132*qud32 + - ddb133*qud33)*sup1 + (ddb121*qud11 + ddb122*qud12 + - ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + ddb223*qud23 + - ddb231*qud31 + ddb232*qud32 + ddb233*qud33)*sup2 + - (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + - ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + ddb332*qud32 + - ddb333*qud33)*sup3)/chi - (dG11 + dG22 + dG33)*vbetas + - 2.*((0.33333333333333333333*alpha* - (dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3))/(chi + chi*vbetas) + - ((db11 + db22 + db33)*shiftdriver)/(vbetaA*sqrt(3.))) + - (1.3333333333333333333*alpha*(dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3)* - sqrt(muL))/(chi*(vbetas + sqrt(muL))) -; - -rGamA1 -= --(((dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + - (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3)*vbetaA) + - qud11*(beta2*dG21 + beta3*dG31 + - (1.3333333333333333333*ddb111*quu11 + - 2.3333333333333333333*(ddb121*quu12 + ddb131*quu13) + - ddb221*quu22 + ddb331*quu33 + - (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + - dG11*(beta1 - sup1*vbetaA)) + - qud12*(beta2*dG22 + beta3*dG32 + - (1.3333333333333333333*ddb112*quu11 + - 2.3333333333333333333*(ddb122*quu12 + ddb132*quu13) + - ddb222*quu22 + 2.*ddb232*quu23 + ddb332*quu33 + - (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + - dG12*(beta1 - sup1*vbetaA)) + - qud13*(beta2*dG23 + beta3*dG33 + - (1.3333333333333333333*ddb113*quu11 + - 2.3333333333333333333*(ddb123*quu12 + ddb133*quu13) + - ddb223*quu22 + 2.*ddb233*quu23 + ddb333*quu33 + - (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + - dG13*(beta1 - sup1*vbetaA)) + - (0.33333333333333333333*((ddb121*qud21 + ddb122*qud22 + ddb123*qud23 + - ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu11 + - (ddb221*qud21 + ddb223*qud23 + ddb231*qud31 + ddb232*qud32 + - ddb233*qud33)*quu12 + - (ddb231*qud21 + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + - ddb332*qud32)*quu13) - - alpha*((1.3333333333333333333*dKhat1 + - 0.66666666666666666667*dTheta1)*quu11 + - 1.3333333333333333333*(dKhat2*quu12 + dKhat3*quu13)) + - 1.3333333333333333333*((ddb132*quu13*sdown2 + ddb113*quu11*sdown3)* - sup1 + (quu13*(ddb231*sdown1 + ddb232*sdown2) + - quu12*(ddb222*sdown2 + ddb223*sdown3))*sup2 + - (quu12*(ddb232*sdown2 + ddb233*sdown3) + - quu13*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + - sdown1*((ddb121*quu12 + ddb131*quu13)*sup1 + ddb221*quu12*sup2 + - ddb131*quu11*sup3) + - sdown2*((ddb112*quu11 + ddb122*quu12)*sup1 + - quu11*(ddb122*sup2 + ddb132*sup3)) + - sdown3*((ddb123*quu12 + ddb133*quu13)*sup1 + - quu11*(ddb123*sup2 + ddb133*sup3))) + - qud11*(2.*ddb231*quu23 + (db21*shiftdriver*sup2)/vbetaA) - - (((db11*quu11 + db21*quu12)*sdown1 + - (db12*quu11 + db22*quu12 + db32*quu13)*sdown2 + - (db13*quu11 + db23*quu12 + db33*quu13)*sdown3)*shiftdriver)/ - vbetaA + ((dG22*quu12 + dG32*quu13)*sdown2 + - (dG13*quu11 + dG23*quu12)*sdown3)*vbetaA + - quu11*(1.3333333333333333333*sdown1*(ddb111*sup1 + ddb121*sup2) + - (dG11*sdown1 + dG12*sdown2)*vbetaA) + - quu12*(-0.66666666666666666667*alpha*dTheta2 + - 0.33333333333333333333*ddb222*qud22 + - sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + - quu13*(-0.66666666666666666667*alpha*dTheta3 + - 0.33333333333333333333*ddb333*qud33 - - (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + - sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi -; - -rGamA2 -= --(((dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + - (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3)*vbetaA) + - qud21*(beta2*dG21 + beta3*dG31 + - (ddb111*quu11 + 2.*ddb131*quu13 + - 1.3333333333333333333*ddb221*quu22 + - 2.3333333333333333333*(ddb121*quu12 + ddb231*quu23) + - ddb331*quu33 + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + - dG11*(beta1 - sup1*vbetaA)) + - qud22*(beta2*dG22 + beta3*dG32 + - (ddb112*quu11 + 2.*ddb132*quu13 + - 1.3333333333333333333*ddb222*quu22 + - 2.3333333333333333333*(ddb122*quu12 + ddb232*quu23) + - ddb332*quu33 + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/ - vbetaA)/chi + dG12*(beta1 - sup1*vbetaA)) + - qud23*(beta2*dG23 + beta3*dG33 + - (ddb113*quu11 + 2.*ddb133*quu13 + - 1.3333333333333333333*ddb223*quu22 + - 2.3333333333333333333*(ddb123*quu12 + ddb233*quu23) + - ddb333*quu33 + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/ - vbetaA)/chi + dG13*(beta1 - sup1*vbetaA)) + - (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + - ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu12 + - (ddb121*qud11 + ddb123*qud13 + ddb231*qud31 + ddb232*qud32 + - ddb233*qud33)*quu22 + - (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb331*qud31 + - ddb332*qud32)*quu23) - - alpha*((1.3333333333333333333*dKhat1 + - 0.66666666666666666667*dTheta1)*quu12 + - 1.3333333333333333333*(dKhat2*quu22 + dKhat3*quu23)) + - 1.3333333333333333333*((ddb132*quu23*sdown2 + ddb113*quu12*sdown3)* - sup1 + (quu23*(ddb231*sdown1 + ddb232*sdown2) + - quu22*(ddb222*sdown2 + ddb223*sdown3))*sup2 + - (quu22*(ddb232*sdown2 + ddb233*sdown3) + - quu23*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + - sdown1*((ddb121*quu22 + ddb131*quu23)*sup1 + ddb221*quu22*sup2 + - ddb131*quu12*sup3) + - sdown2*((ddb112*quu12 + ddb122*quu22)*sup1 + - quu12*(ddb122*sup2 + ddb132*sup3)) + - sdown3*((ddb123*quu22 + ddb133*quu23)*sup1 + - quu12*(ddb123*sup2 + ddb133*sup3))) - - (((db11*quu12 + db21*quu22)*sdown1 + - (db12*quu12 + db22*quu22 + db32*quu23)*sdown2 + - (db13*quu12 + db23*quu22 + db33*quu23)*sdown3)*shiftdriver)/ - vbetaA + (db21*qud21*shiftdriver*sup2)/vbetaA + - ((dG22*quu22 + dG32*quu23)*sdown2 + (dG13*quu12 + dG23*quu22)*sdown3)* - vbetaA + quu12*(1.3333333333333333333*sdown1* - (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ -+ quu22*(-0.66666666666666666667*alpha*dTheta2 + - 0.33333333333333333333*ddb122*qud12 + - sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + - quu23*(-0.66666666666666666667*alpha*dTheta3 + - 0.33333333333333333333*ddb333*qud33 - - (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + - sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi -; - -rGamA3 -= --(((dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + - (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3)*vbetaA) + - qud31*(beta2*dG21 + beta3*dG31 + - (ddb111*quu11 + 2.*ddb121*quu12 + ddb221*quu22 + - 2.3333333333333333333*(ddb131*quu13 + ddb231*quu23) + - 1.3333333333333333333*ddb331*quu33 + - (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + - dG11*(beta1 - sup1*vbetaA)) + - qud32*(beta2*dG22 + beta3*dG32 + - (ddb112*quu11 + 2.*ddb122*quu12 + ddb222*quu22 + - 2.3333333333333333333*(ddb132*quu13 + ddb232*quu23) + - 1.3333333333333333333*ddb332*quu33 + - (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + - dG12*(beta1 - sup1*vbetaA)) + - qud33*(beta2*dG23 + beta3*dG33 + - (ddb113*quu11 + 2.*ddb123*quu12 + ddb223*quu22 + - 2.3333333333333333333*(ddb133*quu13 + ddb233*quu23) + - 1.3333333333333333333*ddb333*quu33 + - (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + - dG13*(beta1 - sup1*vbetaA)) + - (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + - ddb121*qud21 + ddb122*qud22 + ddb123*qud23)*quu13 + - (ddb121*qud11 + ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + - ddb223*qud23)*quu23 + - (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + - ddb232*qud22)*quu33) - - alpha*((1.3333333333333333333*dKhat1 + - 0.66666666666666666667*dTheta1)*quu13 + - 1.3333333333333333333*(dKhat2*quu23 + dKhat3*quu33)) + - 1.3333333333333333333*((ddb132*quu33*sdown2 + ddb113*quu13*sdown3)* - sup1 + (quu33*(ddb231*sdown1 + ddb232*sdown2) + - quu23*(ddb222*sdown2 + ddb223*sdown3))*sup2 + - (quu23*(ddb232*sdown2 + ddb233*sdown3) + - quu33*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + - sdown1*((ddb121*quu23 + ddb131*quu33)*sup1 + ddb221*quu23*sup2 + - ddb131*quu13*sup3) + - sdown2*((ddb112*quu13 + ddb122*quu23)*sup1 + - quu13*(ddb122*sup2 + ddb132*sup3)) + - sdown3*((ddb123*quu23 + ddb133*quu33)*sup1 + - quu13*(ddb123*sup2 + ddb133*sup3))) - - (((db11*quu13 + db21*quu23)*sdown1 + - (db12*quu13 + db22*quu23 + db32*quu33)*sdown2 + - (db13*quu13 + db23*quu23 + db33*quu33)*sdown3)*shiftdriver)/ - vbetaA + (db21*qud31*shiftdriver*sup2)/vbetaA + - ((dG22*quu23 + dG32*quu33)*sdown2 + (dG13*quu13 + dG23*quu23)*sdown3)* - vbetaA + quu13*(1.3333333333333333333*sdown1* - (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ -+ quu33*(-0.66666666666666666667*alpha*dTheta3 + - ddb233*(0.33333333333333333333*qud23 + - 1.3333333333333333333*sdown3*sup2) - - (db31*sdown1*shiftdriver)/vbetaA + - (dG31*sdown1 + dG33*sdown3)*vbetaA) + - quu23*(-0.66666666666666666667*alpha*dTheta2 + - 0.33333333333333333333*ddb122*qud12 + - sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)))/chi -; - -} /* function */ -#ifdef fortran1 -void ra_point -#endif -#ifdef fortran2 -void RA_POINT -#endif -#ifdef fortran3 -void ra_point_ -#endif -(double &A11, -double &A12, -double &A13, -double &A22, -double &A23, -double &A33, -double &alpha, -double &beta1, -double &beta2, -double &beta3, -double &chi, -double &da1, -double &dA111, -double &dA112, -double &dA113, -double &dA122, -double &dA123, -double &dA133, -double &da2, -double &dA211, -double &dA212, -double &dA213, -double &dA222, -double &dA223, -double &dA233, -double &da3, -double &dA311, -double &dA312, -double &dA313, -double &dA322, -double &dA323, -double &dA333, -double &db11, -double &db12, -double &db13, -double &db21, -double &db22, -double &db23, -double &db31, -double &db32, -double &db33, -double &dchi1, -double &dchi2, -double &dchi3, -double &dda11, -double &dda12, -double &dda13, -double &dda22, -double &dda23, -double &dda33, -double &ddb111, -double &ddb112, -double &ddb113, -double &ddb121, -double &ddb122, -double &ddb123, -double &ddb131, -double &ddb132, -double &ddb133, -double &ddb221, -double &ddb222, -double &ddb223, -double &ddb231, -double &ddb232, -double &ddb233, -double &ddb331, -double &ddb332, -double &ddb333, -double &ddchi11, -double &ddchi12, -double &ddchi13, -double &ddchi22, -double &ddchi23, -double &ddchi33, -double &ddg1111, -double &ddg1112, -double &ddg1113, -double &ddg1122, -double &ddg1123, -double &ddg1133, -double &ddg1211, -double &ddg1212, -double &ddg1213, -double &ddg1222, -double &ddg1223, -double &ddg1233, -double &ddg1311, -double &ddg1312, -double &ddg1313, -double &ddg1322, -double &ddg1323, -double &ddg1333, -double &ddg2211, -double &ddg2212, -double &ddg2213, -double &ddg2222, -double &ddg2223, -double &ddg2233, -double &ddg2311, -double &ddg2312, -double &ddg2313, -double &ddg2322, -double &ddg2323, -double &ddg2333, -double &ddg3311, -double &ddg3312, -double &ddg3313, -double &ddg3322, -double &ddg3323, -double &ddg3333, -double &dG11, -double &dg111, -double &dg112, -double &dg113, -double &dG12, -double &dg122, -double &dg123, -double &dG13, -double &dg133, -double &dG21, -double &dg211, -double &dg212, -double &dg213, -double &dG22, -double &dg222, -double &dg223, -double &dG23, -double &dg233, -double &dG31, -double &dg311, -double &dg312, -double &dg313, -double &dG32, -double &dg322, -double &dg323, -double &dG33, -double &dg333, -double &dKhat1, -double &dKhat2, -double &dKhat3, -double &dTheta1, -double &dTheta2, -double &dTheta3, -double &G1, -double &g11, -double &g12, -double &g13, -double &G2, -double &g22, -double &g23, -double &G3, -double &g33, -double &kappa1, -double &Khat, -double &r, -double &rACABTF11, -double &rACABTF12, -double &rACABTF13, -double &rACABTF22, -double &rACABTF23, -double &rACABTF33, -double &rACsA1, -double &rACsA2, -double &rACsA3, -double &rACss, -double &Theta, -double &xp, -double &yp, -double &zp) -{ - -double AA11; -double AA12; -double AA13; -double AA21; -double AA22; -double AA23; -double AA31; -double AA32; -double AA33; -double ADMginv11; -double ADMginv12; -double ADMginv13; -double ADMginv22; -double ADMginv23; -double ADMginv33; -double cdA111; -double cdA112; -double cdA113; -double cdA122; -double cdA123; -double cdA133; -double cdA211; -double cdA212; -double cdA213; -double cdA222; -double cdA223; -double cdA233; -double cdA311; -double cdA312; -double cdA313; -double cdA322; -double cdA323; -double cdA333; -double cdda11; -double cdda12; -double cdda13; -double cdda22; -double cdda23; -double cdda33; -double cddf11; -double cddf12; -double cddf13; -double cddf22; -double cddf23; -double cddf33; -double chipsipower; -double ddf11; -double ddf12; -double ddf13; -double ddf22; -double ddf23; -double ddf33; -double detginv; -double df1; -double df2; -double df3; -double dGfromgdu11; -double dGfromgdu12; -double dGfromgdu13; -double dGfromgdu21; -double dGfromgdu22; -double dGfromgdu23; -double dGfromgdu31; -double dGfromgdu32; -double dGfromgdu33; -double divbeta; -double dK1; -double dK2; -double dK3; -double DTheta; -double f; -double ff; -double gamma111; -double gamma112; -double gamma113; -double gamma122; -double gamma123; -double gamma133; -double gamma211; -double gamma212; -double gamma213; -double gamma222; -double gamma223; -double gamma233; -double gamma311; -double gamma312; -double gamma313; -double gamma322; -double gamma323; -double gamma333; -double gammado111; -double gammado112; -double gammado113; -double gammado122; -double gammado123; -double gammado133; -double gammado211; -double gammado212; -double gammado213; -double gammado222; -double gammado223; -double gammado233; -double gammado311; -double gammado312; -double gammado313; -double gammado322; -double gammado323; -double gammado333; -double Gfromg1; -double Gfromg2; -double Gfromg3; -double ginv11; -double ginv12; -double ginv13; -double ginv22; -double ginv23; -double ginv33; -double K; -double lieA11; -double lieA12; -double lieA13; -double lieA22; -double lieA23; -double lieA33; -double modshatARG; -double oochipsipower; -double oomodshat; -double psim4; -double qdd11; -double qdd12; -double qdd13; -double qdd22; -double qdd23; -double qdd33; -double qPhysuudd1111; -double qPhysuudd1112; -double qPhysuudd1113; -double qPhysuudd1122; -double qPhysuudd1123; -double qPhysuudd1133; -double qPhysuudd1211; -double qPhysuudd1212; -double qPhysuudd1213; -double qPhysuudd1222; -double qPhysuudd1223; -double qPhysuudd1233; -double qPhysuudd1311; -double qPhysuudd1312; -double qPhysuudd1313; -double qPhysuudd1322; -double qPhysuudd1323; -double qPhysuudd1333; -double qPhysuudd2211; -double qPhysuudd2212; -double qPhysuudd2213; -double qPhysuudd2222; -double qPhysuudd2223; -double qPhysuudd2233; -double qPhysuudd2311; -double qPhysuudd2312; -double qPhysuudd2313; -double qPhysuudd2322; -double qPhysuudd2323; -double qPhysuudd2333; -double qPhysuudd3311; -double qPhysuudd3312; -double qPhysuudd3313; -double qPhysuudd3322; -double qPhysuudd3323; -double qPhysuudd3333; -double qud11; -double qud12; -double qud13; -double qud21; -double qud22; -double qud23; -double qud31; -double qud32; -double qud33; -double quu11; -double quu12; -double quu13; -double quu22; -double quu23; -double quu33; -double R11; -double R12; -double R13; -double R22; -double R23; -double R33; -double Rf11; -double Rf12; -double Rf13; -double Rf22; -double Rf23; -double Rf33; -double Rhat; -double Rphi11; -double Rphi12; -double Rphi13; -double Rphi22; -double Rphi23; -double Rphi33; -double sdown1; -double sdown2; -double sdown3; -double shat1; -double shat2; -double shat3; -double sup1; -double sup2; -double sup3; -double totdivbeta; -double trcdda; -double trcddf; - - - -chipsipower -= --4. -; - -shat1=xp/r;shat2=yp/r;shat3=zp/r; - -detginv -= -1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - - g11*pow2(g23)) -; - -ginv11 -= -detginv*(g22*g33 - pow2(g23)) -; - -ginv12 -= -detginv*(g13*g23 - g12*g33) -; - -ginv13 -= -detginv*(-(g13*g22) + g12*g23) -; - -ginv22 -= -detginv*(g11*g33 - pow2(g13)) -; - -ginv23 -= -detginv*(g12*g13 - g11*g23) -; - -ginv33 -= -detginv*(g11*g22 - pow2(g12)) -; - -ADMginv11 -= -chi*ginv11 -; - -ADMginv12 -= -chi*ginv12 -; - -ADMginv13 -= -chi*ginv13 -; - -ADMginv22 -= -chi*ginv22 -; - -ADMginv23 -= -chi*ginv23 -; - -ADMginv33 -= -chi*ginv33 -; - -modshatARG -= -2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + - ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) -; - - -if (modshatARG<0.00001) { - printf("modshat is wrong (%e)\n",modshatARG); - modshatARG = 0.00001; - }oomodshat -= -1/sqrt(modshatARG) -; - -sdown1 -= -oomodshat*shat1 -; - -sdown2 -= -oomodshat*shat2 -; - -sdown3 -= -oomodshat*shat3 -; - -sup1 -= -ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 -; - -sup2 -= -ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 -; - -sup3 -= -ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 -; - -qud11 -= -1. - sdown1*sup1 -; - -qud12 -= --(sdown2*sup1) -; - -qud13 -= --(sdown3*sup1) -; - -qud21 -= --(sdown1*sup2) -; - -qud22 -= -1. - sdown2*sup2 -; - -qud23 -= --(sdown3*sup2) -; - -qud31 -= --(sdown1*sup3) -; - -qud32 -= --(sdown2*sup3) -; - -qud33 -= -1. - sdown3*sup3 -; - -qdd11 -= -g11/chi - pow2(sdown1) -; - -qdd12 -= -g12/chi - sdown1*sdown2 -; - -qdd13 -= -g13/chi - sdown1*sdown3 -; - -qdd22 -= -g22/chi - pow2(sdown2) -; - -qdd23 -= -g23/chi - sdown2*sdown3 -; - -qdd33 -= -g33/chi - pow2(sdown3) -; - -quu11 -= -ADMginv11 - pow2(sup1) -; - -quu12 -= -ADMginv12 - sup1*sup2 -; - -quu13 -= -ADMginv13 - sup1*sup3 -; - -quu22 -= -ADMginv22 - pow2(sup2) -; - -quu23 -= -ADMginv23 - sup2*sup3 -; - -quu33 -= -ADMginv33 - pow2(sup3) -; - -qPhysuudd1111 -= --0.5*qdd11*quu11 + pow2(qud11) -; - -qPhysuudd1112 -= -qud11*qud12 - 0.5*qdd12*quu11 -; - -qPhysuudd1113 -= -qud11*qud13 - 0.5*qdd13*quu11 -; - -qPhysuudd1122 -= --0.5*qdd22*quu11 + pow2(qud12) -; - -qPhysuudd1123 -= -qud12*qud13 - 0.5*qdd23*quu11 -; - -qPhysuudd1133 -= --0.5*qdd33*quu11 + pow2(qud13) -; - -qPhysuudd1211 -= -qud11*qud21 - 0.5*qdd11*quu12 -; - -qPhysuudd1212 -= -0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) -; - -qPhysuudd1213 -= -0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) -; - -qPhysuudd1222 -= -qud12*qud22 - 0.5*qdd22*quu12 -; - -qPhysuudd1223 -= -0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) -; - -qPhysuudd1233 -= -qud13*qud23 - 0.5*qdd33*quu12 -; - -qPhysuudd1311 -= -qud11*qud31 - 0.5*qdd11*quu13 -; - -qPhysuudd1312 -= -0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) -; - -qPhysuudd1313 -= -0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) -; - -qPhysuudd1322 -= -qud12*qud32 - 0.5*qdd22*quu13 -; - -qPhysuudd1323 -= -0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) -; - -qPhysuudd1333 -= -qud13*qud33 - 0.5*qdd33*quu13 -; - -qPhysuudd2211 -= --0.5*qdd11*quu22 + pow2(qud21) -; - -qPhysuudd2212 -= -qud21*qud22 - 0.5*qdd12*quu22 -; - -qPhysuudd2213 -= -qud21*qud23 - 0.5*qdd13*quu22 -; - -qPhysuudd2222 -= --0.5*qdd22*quu22 + pow2(qud22) -; - -qPhysuudd2223 -= -qud22*qud23 - 0.5*qdd23*quu22 -; - -qPhysuudd2233 -= --0.5*qdd33*quu22 + pow2(qud23) -; - -qPhysuudd2311 -= -qud21*qud31 - 0.5*qdd11*quu23 -; - -qPhysuudd2312 -= -0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) -; - -qPhysuudd2313 -= -0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) -; - -qPhysuudd2322 -= -qud22*qud32 - 0.5*qdd22*quu23 -; - -qPhysuudd2323 -= -0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) -; - -qPhysuudd2333 -= -qud23*qud33 - 0.5*qdd33*quu23 -; - -qPhysuudd3311 -= --0.5*qdd11*quu33 + pow2(qud31) -; - -qPhysuudd3312 -= -qud31*qud32 - 0.5*qdd12*quu33 -; - -qPhysuudd3313 -= -qud31*qud33 - 0.5*qdd13*quu33 -; - -qPhysuudd3322 -= --0.5*qdd22*quu33 + pow2(qud32) -; - -qPhysuudd3323 -= -qud32*qud33 - 0.5*qdd23*quu33 -; - -qPhysuudd3333 -= --0.5*qdd33*quu33 + pow2(qud33) -; - -K -= -Khat + 2.*Theta -; - -dK1 -= -dKhat1 + 2.*dTheta1 -; - -dK2 -= -dKhat2 + 2.*dTheta2 -; - -dK3 -= -dKhat3 + 2.*dTheta3 -; - -gammado111 -= -0.5*dg111 -; - -gammado112 -= -0.5*dg211 -; - -gammado113 -= -0.5*dg311 -; - -gammado122 -= --0.5*dg122 + dg212 -; - -gammado123 -= -0.5*(-dg123 + dg213 + dg312) -; - -gammado133 -= --0.5*dg133 + dg313 -; - -gammado211 -= -dg112 - 0.5*dg211 -; - -gammado212 -= -0.5*dg122 -; - -gammado213 -= -0.5*(dg123 - dg213 + dg312) -; - -gammado222 -= -0.5*dg222 -; - -gammado223 -= -0.5*dg322 -; - -gammado233 -= --0.5*dg233 + dg323 -; - -gammado311 -= -dg113 - 0.5*dg311 -; - -gammado312 -= -0.5*(dg123 + dg213 - dg312) -; - -gammado313 -= -0.5*dg133 -; - -gammado322 -= -dg223 - 0.5*dg322 -; - -gammado323 -= -0.5*dg233 -; - -gammado333 -= -0.5*dg333 -; - -gamma111 -= -gammado111*ginv11 + gammado211*ginv12 + gammado311*ginv13 -; - -gamma112 -= -gammado112*ginv11 + gammado212*ginv12 + gammado312*ginv13 -; - -gamma113 -= -gammado113*ginv11 + gammado213*ginv12 + gammado313*ginv13 -; - -gamma122 -= -gammado122*ginv11 + gammado222*ginv12 + gammado322*ginv13 -; - -gamma123 -= -gammado123*ginv11 + gammado223*ginv12 + gammado323*ginv13 -; - -gamma133 -= -gammado133*ginv11 + gammado233*ginv12 + gammado333*ginv13 -; - -gamma211 -= -gammado111*ginv12 + gammado211*ginv22 + gammado311*ginv23 -; - -gamma212 -= -gammado112*ginv12 + gammado212*ginv22 + gammado312*ginv23 -; - -gamma213 -= -gammado113*ginv12 + gammado213*ginv22 + gammado313*ginv23 -; - -gamma222 -= -gammado122*ginv12 + gammado222*ginv22 + gammado322*ginv23 -; - -gamma223 -= -gammado123*ginv12 + gammado223*ginv22 + gammado323*ginv23 -; - -gamma233 -= -gammado133*ginv12 + gammado233*ginv22 + gammado333*ginv23 -; - -gamma311 -= -gammado111*ginv13 + gammado211*ginv23 + gammado311*ginv33 -; - -gamma312 -= -gammado112*ginv13 + gammado212*ginv23 + gammado312*ginv33 -; - -gamma313 -= -gammado113*ginv13 + gammado213*ginv23 + gammado313*ginv33 -; - -gamma322 -= -gammado122*ginv13 + gammado222*ginv23 + gammado322*ginv33 -; - -gamma323 -= -gammado123*ginv13 + gammado223*ginv23 + gammado323*ginv33 -; - -gamma333 -= -gammado133*ginv13 + gammado233*ginv23 + gammado333*ginv33 -; - -Gfromg1 -= -gamma111*ginv11 + gamma122*ginv22 + - 2.*(gamma112*ginv12 + gamma113*ginv13 + gamma123*ginv23) + gamma133*ginv33 -; - -Gfromg2 -= -gamma211*ginv11 + gamma222*ginv22 + - 2.*(gamma212*ginv12 + gamma213*ginv13 + gamma223*ginv23) + gamma233*ginv33 -; - -Gfromg3 -= -gamma311*ginv11 + gamma322*ginv22 + - 2.*(gamma312*ginv12 + gamma313*ginv13 + gamma323*ginv23) + gamma333*ginv33 -; - -dGfromgdu11 -= --((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)* - Power(ginv12,3)) - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + - dg111*dg333)*Power(ginv13,3) - 2.*Power(ginv11,3)*pow2(dg111) + - (ddg1111 - dg111*((8.*dg112 + 2.*dg211)*ginv12 + - (8.*dg113 + 2.*dg311)*ginv13) - - (dg113*(4.*dg112 + dg211) + dg112*dg311 + dg111*(dg213 + dg312))* - ginv23 - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - - ginv33*(dg113*dg311 + dg111*dg313 + 2.*pow2(dg113)))*pow2(ginv11) + - (ddg1122 + ddg1212 - (dg123*(8.*dg112 + 2.*dg211) + - dg113*(4.*dg122 + 2.*dg212) + dg122*dg311 + - 2.*(dg111*dg223 + dg112*(dg213 + dg312)) + dg111*dg322)*ginv13 - - (dg123*(4.*dg122 + 2.*dg212) + - 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* - ginv23 - ginv22*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122)) - - ginv33*(dg123*(dg213 + dg312) + dg122*dg313 + dg113*(dg223 + dg322) + - dg112*dg323 + 2.*pow2(dg123)))*pow2(ginv12) + - (ddg1133 + ddg1313 - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*ginv23 - - ginv22*(dg133*dg212 + dg113*dg223 + dg123*(dg213 + dg312) + - dg112*(dg233 + dg323) + 2.*pow2(dg123)) - - ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133)))*pow2(ginv13) \ -+ ginv13*(ddg1333*ginv33 + ginv22* - (ddg1223 - (dg133*dg222 + dg123*(4.*dg223 + dg322) + - dg122*(dg233 + dg323))*ginv23 - - (dg133*dg223 + dg123*(dg233 + 2.*dg323))*ginv33) + - ginv23*(ddg1233 + ddg1323 - - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)*ginv33) - - (dg123*dg222 + dg122*dg223)*pow2(ginv22) - - (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + - dg122*dg333)*pow2(ginv23) - 2.*dg133*dg333*pow2(ginv33)) + - ginv11*(ddg1313*ginv33 + ginv12* - (2.*ddg1112 + ddg1211 - - (dg113*(12.*dg112 + 3.*dg211) + 3.*dg112*dg311 + - dg111*(8.*dg123 + 3.*(dg213 + dg312)))*ginv13 - - (dg122*(4.*dg112 + dg211) + 6.*dg112*dg212 + dg111*dg222)*ginv22 - - (dg123*dg211 + dg122*dg311 + - 4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213 + dg312)) + - dg111*(dg223 + dg322))*ginv23 - - (dg123*dg311 + dg113*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*dg112*dg313 + dg111*dg323)*ginv33) + - ginv22*(ddg1212 - (dg113*dg222 + 2.*(dg123*dg212 + dg112*dg223) + - dg122*(dg213 + dg312) + dg112*dg322)*ginv23 - - (dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323)*ginv33) + - ginv13*(2.*ddg1113 + ddg1311 - - (dg123*(4.*dg112 + dg211) + dg111*dg223 + - 2.*(dg113*dg212 + dg112*(dg213 + dg312)))*ginv22 - - (dg133*dg211 + dg123*dg311 + - 4.*(dg113*(dg123 + dg213 + dg312) + dg112*(dg133 + dg313)) + - dg111*(dg233 + dg323))*ginv23 - - (dg133*(4.*dg113 + dg311) + 6.*dg113*dg313 + dg111*dg333)*ginv33) + - ginv23*(ddg1213 + ddg1312 - - (dg133*(dg213 + dg312) + 2.*dg123*dg313 + - dg113*(dg233 + 2.*dg323) + dg112*dg333)*ginv33) - - (3.*dg112*dg211 + dg111*(4.*dg122 + 3.*dg212) + 6.*pow2(dg112))* - pow2(ginv12) - (3.*dg113*dg311 + dg111*(4.*dg133 + 3.*dg313) + - 6.*pow2(dg113))*pow2(ginv13) - - (dg122*dg212 + dg112*dg222)*pow2(ginv22) - - (dg133*dg212 + dg123*(dg213 + dg312) + dg122*dg313 + - dg113*(dg223 + dg322) + dg112*(dg233 + dg323))*pow2(ginv23) - - (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + - ginv12*(ddg1323*ginv33 + ginv22* - (ddg1222 - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*ginv23 - - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33) + - ginv23*(ddg1223 + ddg1322 - - (dg133*(dg223 + dg322) + dg123*(dg233 + 4.*dg323) + dg122*dg333)* - ginv33) + ginv13*(2.*ddg1123 + ddg1213 + ddg1312 - - (dg113*dg222 + 4.*(dg123*(dg122 + dg212) + dg112*dg223) + - dg122*(dg213 + dg312) + dg112*dg322)*ginv22 - - (dg133*(4.*dg123 + dg213 + dg312) + 4.*dg123*dg313 + - dg113*(dg233 + 4.*dg323) + dg112*dg333)*ginv33 - - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg122*dg313 + - dg113*dg322) + 4.* - (dg122*dg133 + dg113*dg223 + dg123*(dg213 + dg312) + - dg112*dg323 + pow2(dg123)))) - - (dg133*(4.*dg112 + dg211) + dg113*(8.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* - pow2(ginv13) - 2.*dg122*dg222*pow2(ginv22) - - (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* - pow2(ginv23) - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) -; - -dGfromgdu12 -= --((dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + dg122*dg333)* - Power(ginv23,3)) - 2.*(dg122*dg222*Power(ginv22,3) + - Power(ginv12,3)*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)) + - (dg111*(dg112*ginv22 + dg113*ginv23) + ginv12*pow2(dg111))*pow2(ginv11)\ -) + (ddg1112 + ddg1211 - (4.*(dg112*dg113 + dg111*dg123) + - 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))*ginv13 - - (dg122*(6.*dg112 + 2.*dg211) + 6.*dg112*dg212 + 2.*dg111*dg222)* - ginv22 - (4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213)) + - dg122*dg311 + 2.*(dg123*dg211 + dg111*dg223 + dg112*dg312) + - dg111*dg322)*ginv23 - - (dg123*dg311 + dg113*(2.*(dg123 + dg213) + dg312) + dg112*dg313 + - dg111*dg323)*ginv33)*pow2(ginv12) - - ((2.*(dg113*dg123 + dg112*dg133) + dg123*dg311 + dg113*dg312 + - dg112*dg313 + dg111*dg323)*ginv22 + - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*ginv23)* - pow2(ginv13) + (ddg1222 - (4.*(dg123*dg222 + dg122*dg223) + - 2.*dg122*dg322)*ginv23 - - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33)*pow2(ginv22) + - (ddg1233 + ddg1323 - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)* - ginv33)*pow2(ginv23) + ginv11* - (ginv23*(ddg1113 - 2.*dg113*(dg133 + dg313)*ginv33) + - ginv22*(ddg1112 - (dg112*(4.*dg123 + 2.*dg213) + - 2.*(dg113*(dg122 + dg212) + dg112*dg312))*ginv23 - - (dg113*(2.*dg123 + dg312) + dg112*dg313)*ginv33) + - ginv12*(ddg1111 - dg111*(6.*dg113 + 2.*dg311)*ginv13 - - (dg113*(8.*dg112 + 2.*dg211) + dg112*dg311 + - dg111*(2.*(dg123 + dg213) + dg312))*ginv23 - - ginv22*(2.*(dg112*dg211 + dg111*(dg122 + dg212)) + - 6.*pow2(dg112)) - ginv33* - (dg113*dg311 + dg111*dg313 + 2.*pow2(dg113))) - - ginv13*((dg112*(4.*dg113 + dg311) + dg111*(2.*dg123 + dg312))* - ginv22 + ginv23*(dg113*dg311 + dg111*(2.*dg133 + dg313) + - 4.*pow2(dg113))) - dg111*(6.*dg112 + 2.*dg211)*pow2(ginv12) - - 2.*dg112*(dg122 + dg212)*pow2(ginv22) - - (2.*(dg112*dg133 + dg113*(dg123 + dg213)) + dg113*dg312 + dg112*dg313)* - pow2(ginv23)) + ginv13*(ginv22* - (ddg1123 + ddg1312 - (dg133*(2.*dg123 + dg312) + - 2.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33 - - ginv23*(2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg113*dg223 + - dg112*dg233) + dg122*dg313 + dg113*dg322 + - 4.*(dg123*dg312 + dg112*dg323 + pow2(dg123)))) + - ginv23*(ddg1133 + ddg1313 - - ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))) - - (2.*(dg123*(dg122 + dg212) + dg112*dg223) + dg122*dg312 + - dg112*dg322)*pow2(ginv22) - - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + - 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*pow2(ginv23)\ -) + ginv23*(ddg1333*ginv33 - 2.*dg133*dg333*pow2(ginv33)) + - ginv12*(ddg1313*ginv33 + ginv13* - (ddg1113 + ddg1311 - (2.* - (dg123*dg211 + dg113*(dg122 + dg212) + dg111*dg223) + - dg122*dg311 + dg112*(8.*dg123 + 2.*dg213 + 4.*dg312) + - dg111*dg322)*ginv22 - - (dg133*(4.*dg112 + 2.*dg211) + - dg113*(8.*dg123 + 4.*(dg213 + dg312)) + 4.*dg112*dg313 + - 2.*(dg123*dg311 + dg111*(dg233 + dg323)))*ginv23 - - (dg133*(2.*dg113 + dg311) + 4.*dg113*dg313 + dg111*dg333)*ginv33) + - ginv23*(ddg1123 + 2.*ddg1213 + ddg1312 - - (2.*(dg133*(dg123 + dg213) + dg113*dg233) + dg133*dg312 + - 4.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33) + - ginv22*(ddg1122 + 2.*ddg1212 - - (4.*(dg122*dg213 + dg113*dg222) + - 6.*(dg123*(dg122 + dg212) + dg112*dg223) + - 3.*(dg122*dg312 + dg112*dg322))*ginv23 - - ginv33*(dg122*dg313 + dg113*dg322 + - 2.*(dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323 + - pow2(dg123)))) - - 2.*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow2(ginv13) - - (4.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))*pow2(ginv22) - - (4.*(dg123*dg213 + dg113*dg223) + - 2.*(dg133*(dg122 + dg212) + dg123*dg312 + dg122*dg313 + - dg113*dg322 + dg112*(dg233 + dg323) + pow2(dg123)))*pow2(ginv23) \ -- (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + - ginv22*(ddg1323*ginv33 + ginv23* - (2.*ddg1223 + ddg1322 - (2.*(dg133*dg223 + dg123*dg233) + - dg133*dg322 + 6.*dg123*dg323 + dg122*dg333)*ginv33) - - (2.*(dg133*dg222 + dg122*dg233) + dg123*(6.*dg223 + 3.*dg322) + - 3.*dg122*dg323)*pow2(ginv23) - - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) -; - -dGfromgdu13 -= --((dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* - Power(ginv23,3)) - 2.*(dg133*dg333*Power(ginv33,3) + - Power(ginv13,3)*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113)) + - (dg111*(dg112*ginv23 + dg113*ginv33) + ginv13*pow2(dg111))*pow2(ginv11)\ -) - ((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*ginv23 + - (2.*(dg113*dg122 + dg112*dg123) + dg123*dg211 + dg113*dg212 + - dg112*dg213 + dg111*dg223)*ginv33 + - 2.*ginv13*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)))* - pow2(ginv12) + (ddg1113 + ddg1311 - - (dg123*(2.*dg112 + dg211) + dg113*dg212 + dg111*dg223 + - dg112*(dg213 + 2.*dg312))*ginv22 - - (dg133*dg211 + 2.*(dg113*dg213 + dg123*dg311) + - 4.*(dg113*(dg123 + dg312) + dg112*(dg133 + dg313)) + - dg111*(dg233 + 2.*dg323))*ginv23 - - (dg133*(6.*dg113 + 2.*dg311) + 6.*dg113*dg313 + 2.*dg111*dg333)*ginv33\ -)*pow2(ginv13) - (2.*dg122*dg222*ginv23 + - (dg123*dg222 + dg122*dg223)*ginv33)*pow2(ginv22) + - (ddg1223 + ddg1322 - (3.*(dg133*dg223 + dg123*dg233) + 6.*dg123*dg323 + - 2.*(dg133*dg322 + dg122*dg333))*ginv33)*pow2(ginv23) + - ddg1333*pow2(ginv33) + ginv11* - (ddg1113*ginv33 - ginv22*(2.*dg112*(dg122 + dg212)*ginv23 + - (dg113*dg212 + dg112*(2.*dg123 + dg213))*ginv33) + - ginv23*(ddg1112 - (dg113*(4.*dg123 + 2.*dg213) + - 2.*(dg113*dg312 + dg112*(dg133 + dg313)))*ginv33) - - ginv12*(dg111*(6.*dg112 + 2.*dg211)*ginv13 + - (dg113*(4.*dg112 + dg211) + dg111*(2.*dg123 + dg213))*ginv33 + - ginv23*(dg112*dg211 + dg111*(2.*dg122 + dg212) + 4.*pow2(dg112))) + - ginv13*(ddg1111 - (dg113*(8.*dg112 + dg211) + 2.*dg112*dg311 + - dg111*(dg213 + 2.*(dg123 + dg312)))*ginv23 - - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - - ginv33*(2.*(dg113*dg311 + dg111*(dg133 + dg313)) + 6.*pow2(dg113))) \ -- dg111*(6.*dg113 + 2.*dg311)*pow2(ginv13) - - (dg113*dg212 + dg112*dg213 + - 2.*(dg113*dg122 + dg112*(dg123 + dg312)))*pow2(ginv23) - - 2.*dg113*(dg133 + dg313)*pow2(ginv33)) + - ginv12*((ddg1123 + ddg1213)*ginv33 + - ginv13*(ddg1112 + ddg1211 - - (dg122*(2.*dg112 + dg211) + 4.*dg112*dg212 + dg111*dg222)*ginv22 - - (dg123*(8.*dg112 + 2.*dg211) + - 4.*(dg113*(dg122 + dg212) + dg112*(dg213 + dg312)) + - 2.*(dg122*dg311 + dg111*(dg223 + dg322)))*ginv23 - - (dg133*(2.*dg112 + dg211) + - dg113*(8.*dg123 + 4.*dg213 + 2.*dg312) + - 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* - ginv33) - ginv22*((dg122*dg213 + dg113*dg222 + - 2.*(dg123*(dg122 + dg212) + dg112*dg223))*ginv33 + - ginv23*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))) + - ginv23*(ddg1122 + ddg1212 - - ginv33*(dg133*(2.*dg122 + dg212) + - 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322) + - dg112*(dg233 + 2.*dg323) + - 4.*(dg123*dg213 + dg113*dg223 + pow2(dg123)))) - - (4.*(dg112*dg113 + dg111*dg123) + - 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))* - pow2(ginv13) - (dg123*(4.*dg122 + 2.*dg212) + - 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* - pow2(ginv23) - (dg133*(2.*dg123 + dg213) + 2.*dg123*dg313 + - dg113*(dg233 + 2.*dg323))*pow2(ginv33)) + - ginv22*(ddg1223*ginv33 + ginv23* - (ddg1222 - (dg133*dg222 + dg123*(6.*dg223 + 2.*dg322) + - dg122*(dg233 + 2.*dg323))*ginv33) - - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*pow2(ginv23) - - (dg133*dg223 + dg123*(dg233 + 2.*dg323))*pow2(ginv33)) + - ginv23*((ddg1233 + 2.*ddg1323)*ginv33 - - (dg133*(2.*dg233 + 4.*dg323) + 4.*dg123*dg333)*pow2(ginv33)) + - ginv13*((ddg1133 + 2.*ddg1313)*ginv33 + - ginv23*(ddg1123 + ddg1213 + 2.*ddg1312 - - (dg133*(6.*dg123 + 3.*dg213 + 4.*dg312) + 6.*dg123*dg313 + - dg113*(3.*dg233 + 6.*dg323) + 4.*dg112*dg333)*ginv33) + - ginv22*(ddg1212 - (dg123*(2.*dg122 + 4.*dg212) + dg113*dg222 + - dg122*(dg213 + 2.*dg312) + dg112*(4.*dg223 + 2.*dg322))*ginv23 - - ginv33*(dg133*dg212 + dg112*(dg233 + 2.*dg323) + - 2.*(dg113*dg223 + dg123*(dg213 + dg312) + pow2(dg123)))) - - (dg122*dg212 + dg112*dg222)*pow2(ginv22) - - (4.*(dg123*dg312 + dg112*dg323) + - 2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg112*dg233 + - dg122*dg313 + dg113*(dg223 + dg322) + pow2(dg123)))*pow2(ginv23) \ -- (4.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))*pow2(ginv33)) -; - -dGfromgdu21 -= --((dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + dg211*dg333)* - Power(ginv13,3)) - 2.*(dg111*dg211*Power(ginv11,3) + - Power(ginv12,3)*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212))) + - (ddg1211 - (4.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - - 2.*(dg112 + dg211)*dg212*ginv22 - - (2.*(dg113*dg212 + (dg112 + dg211)*dg213) + dg212*dg311 + - dg211*dg312)*ginv23 - - (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33 - - ginv12*(4.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211)))*pow2(ginv11) \ -+ (ddg1222 + ddg2212 - (4.*(dg212*(dg123 + dg213) + - (dg112 + dg211)*dg223) + dg222*dg311 + - 2.*(dg122*dg213 + dg113*dg222 + dg212*dg312) + dg211*dg322)*ginv13 \ -- (2.*dg122 + 6.*dg212)*dg222*ginv22 - - ((2.*dg122 + 4.*dg212)*dg223 + - dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)*ginv23 - - (dg223*(2.*(dg123 + dg213) + dg312) + dg222*dg313 + dg213*dg322 + - dg212*dg323)*ginv33)*pow2(ginv12) + - (ddg1233 + ddg2313 - (2.*((dg123 + dg213)*dg223 + dg212*dg233) + - dg223*dg312 + dg212*dg323)*ginv22 - - (dg233*(4.*dg213 + 2.*dg312) + - 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + - dg212*dg333))*ginv23 - - (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33)*pow2(ginv13) + - ginv11*(ddg2313*ginv33 + ginv22* - (ddg2212 - (dg222*(2.*dg213 + dg312) + dg212*(4.*dg223 + dg322))* - ginv23 - (dg223*(2.*dg213 + dg312) + dg212*dg323)*ginv33) + - ginv23*(ddg2213 + ddg2312 - - (dg233*(2.*dg213 + dg312) + 2.*(dg223*dg313 + dg213*dg323) + - dg212*dg333)*ginv33) + - ginv13*(2.*ddg1213 + ddg2311 - - (2.*(dg112 + dg211)*dg223 + - dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv22 - - (2.*(dg133*dg213 + dg113*dg233) + dg233*dg311 + 6.*dg213*dg313 + - dg211*dg333)*ginv33 - - ginv23*(2.*(dg133*dg212 + dg123*dg213 + dg113*dg223 + - (dg112 + dg211)*dg233) + dg223*dg311 + dg211*dg323 + - 4.*(dg213*dg312 + dg212*dg313 + pow2(dg213)))) + - ginv12*(2.*ddg1212 + ddg2211 - - (6.*(dg113*dg212 + dg112*dg213) + 4.*dg111*dg223 + - 3.*dg212*dg311 + dg211*(4.*dg123 + 6.*dg213 + 3.*dg312))*ginv13 \ -- (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + - (dg112 + dg211)*dg223) + dg222*dg311 + - dg212*(8.*dg213 + 4.*dg312) + dg211*dg322)*ginv23 - - ginv22*(2.*(dg122*dg212 + (dg112 + dg211)*dg222) + - 6.*pow2(dg212)) - ginv33* - (dg223*dg311 + dg211*dg323 + - 2.*(dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313 + - pow2(dg213)))) - - (6.*dg112*dg212 + dg211*(2.*dg122 + 6.*dg212) + 2.*dg111*dg222)* - pow2(ginv12) - (2.*(dg133*dg211 + dg111*dg233) + - dg213*(6.*dg113 + 3.*dg311) + 3.*dg211*dg313)*pow2(ginv13) - - 2.*dg212*dg222*pow2(ginv22) - - (2.*(dg213*dg223 + dg212*dg233) + dg223*dg312 + dg222*dg313 + - dg213*dg322 + dg212*dg323)*pow2(ginv23) - - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + - ginv12*(ddg2323*ginv33 + ginv13* - (2.*ddg1223 + ddg2213 + ddg2312 - - (2.*((dg123 + dg213)*dg222 + dg122*dg223) + dg222*dg312 + - dg212*(8.*dg223 + dg322))*ginv22 - - (dg223*(8.*dg213 + 4.*(dg123 + dg312)) + - 2.*(dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322) + - 4.*dg212*(dg233 + dg323))*ginv23 - - (2.*(dg133*dg223 + (dg123 + dg213)*dg233) + dg233*dg312 + - 4.*(dg223*dg313 + dg213*dg323) + dg212*dg333)*ginv33) + - ginv23*(ddg2223 + ddg2322 - - (dg233*(2.*dg223 + dg322) + 4.*dg223*dg323 + dg222*dg333)*ginv33) + - ginv22*(ddg2222 - dg222*(6.*dg223 + 2.*dg322)*ginv23 - - ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223))) - - (4.*(dg123*dg213 + dg113*dg223) + - 2.*((dg112 + dg211)*dg233 + dg223*dg311 + dg213*dg312 + - dg212*(dg133 + dg313) + dg211*dg323 + pow2(dg213)))*pow2(ginv13) \ -- 2.*(pow2(dg222)*pow2(ginv22) + - (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))*pow2(ginv23)) - - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) + - ginv13*(ddg2333*ginv33 + ginv22* - (ddg2223 - 2.*dg223*(dg233 + dg323)*ginv33 - - ginv23*(dg223*dg322 + dg222*(2.*dg233 + dg323) + 4.*pow2(dg223))) + - ginv23*(ddg2233 + ddg2323 - - ginv33*(3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))) - - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)* - pow2(ginv23) - 2.*(dg222*dg223*pow2(ginv22) + dg233*dg333*pow2(ginv33))\ -) -; - -dGfromgdu22 -= --((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)* - Power(ginv12,3)) - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + - dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv22,3)*pow2(dg222) - - (2.*dg111*dg211*ginv12 + (dg112*dg211 + dg111*dg212)*ginv22 + - (dg113*dg211 + dg111*dg213)*ginv23)*pow2(ginv11) + - (ddg1212 + ddg2211 - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + - dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))*ginv13 - - (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + dg112*dg223) + - dg222*dg311 + dg212*(8.*dg213 + 2.*dg312) + - dg211*(4.*dg223 + dg322))*ginv23 - - ginv22*(4.*dg211*dg222 + 3.*(dg122*dg212 + dg112*dg222) + - 6.*pow2(dg212)) - ginv33* - (dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + dg212*dg313 + - dg211*dg323 + 2.*pow2(dg213)))*pow2(ginv12) - - ((dg112*dg233 + dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + - dg212*(dg133 + dg313) + dg211*dg323)*ginv22 + - (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + - dg211*dg333)*ginv23)*pow2(ginv13) + - (ddg2222 - dg222*(8.*dg223 + 2.*dg322)*ginv23 - - ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223)))*pow2(ginv22) + - (ddg2233 + ddg2323 - ginv33* - (3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233)))*pow2(ginv23) + - ginv13*(ginv22*(ddg1223 + ddg2312 - - (dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322 + - 4.*(dg223*(dg123 + dg213 + dg312) + dg212*(dg233 + dg323)))* - ginv23 - (dg233*(dg123 + dg312) + dg223*(dg133 + 2.*dg313) + - 2.*dg213*dg323 + dg212*dg333)*ginv33) + - ginv23*(ddg1233 + ddg2313 - - (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33) - - ((dg122 + 4.*dg212)*dg223 + dg222*(dg123 + dg312) + dg212*dg322)* - pow2(ginv22) - (dg233*(4.*dg213 + 2.*dg312) + - 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + - dg212*dg333))*pow2(ginv23)) + - ginv11*(-(ginv13*((2.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + - dg212*dg311 + dg211*(dg123 + dg312))*ginv22 + - (dg111*dg233 + dg213*(4.*dg113 + dg311) + dg211*(dg133 + dg313))* - ginv23)) + ginv12*(ddg1211 - - (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - - (6.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv22 - - (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + dg212*dg311 + - dg211*(dg123 + 4.*dg213 + dg312))*ginv23 - - (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33) + - ginv22*(ddg1212 - (dg122*dg213 + dg113*dg222 + 2.*dg112*dg223 + - dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv23 - - (dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313)*ginv33) + - ginv23*(ddg1213 - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*ginv33) - - (3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))*pow2(ginv12) - - (dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))*pow2(ginv22) - - (dg113*dg223 + dg112*dg233 + dg213*(dg123 + dg312) + - dg212*(dg133 + dg313) + 2.*pow2(dg213))*pow2(ginv23)) + - ginv23*(ddg2333*ginv33 - 2.*dg233*dg333*pow2(ginv33)) + - ginv12*(ddg2313*ginv33 + ginv22* - (ddg1222 + 2.*ddg2212 - - ((3.*dg122 + 12.*dg212)*dg223 + - dg222*(8.*dg213 + 3.*(dg123 + dg312)) + 3.*dg212*dg322)*ginv23 \ -- (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + dg222*dg313 + dg213*dg322 + - 2.*dg212*dg323)*ginv33) + - ginv23*(ddg1223 + 2.*ddg2213 + ddg2312 - - (dg233*(dg123 + 4.*dg213 + dg312) + dg223*(dg133 + 4.*dg313) + - 4.*dg213*dg323 + dg212*dg333)*ginv33) + - ginv13*(ddg1213 + ddg2311 - - (dg122*dg213 + dg222*(dg113 + dg311) + - 4.*((dg112 + dg211)*dg223 + dg212*(dg123 + dg213 + dg312)) + - dg211*dg322)*ginv22 - - (dg233*(dg113 + dg311) + dg213*(dg133 + 4.*dg313) + dg211*dg333)* - ginv33 - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg223*dg311 + - dg211*dg323) + 4.* - (dg113*dg223 + dg211*dg233 + dg213*(dg123 + dg312) + - dg212*dg313 + pow2(dg213)))) - - (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* - pow2(ginv13) - (2.*dg122 + 8.*dg212)*dg222*pow2(ginv22) - - ((dg122 + 4.*dg212)*dg233 + dg223*(8.*dg213 + 2.*(dg123 + dg312)) + - dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* - pow2(ginv23) - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + - ginv22*(ddg2323*ginv33 + ginv23* - (2.*ddg2223 + ddg2322 - (dg233*(4.*dg223 + dg322) + 6.*dg223*dg323 + - dg222*dg333)*ginv33) - - (3.*dg223*dg322 + dg222*(4.*dg233 + 3.*dg323) + 6.*pow2(dg223))* - pow2(ginv23) - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) -; - -dGfromgdu23 -= --((dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* - Power(ginv13,3)) - (2.*dg111*dg211*ginv13 + - (dg112*dg211 + dg111*dg212)*ginv23 + - (dg113*dg211 + dg111*dg213)*ginv33)*pow2(ginv11) - - ((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv13 + - (dg122*dg213 + dg212*(dg123 + 2.*dg213) + dg113*dg222 + - (dg112 + 2.*dg211)*dg223)*ginv33 + - 2.*ginv23*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212)))* - pow2(ginv12) + (ddg1213 + ddg2311 - - ((dg112 + 2.*dg211)*dg223 + dg212*(dg123 + 2.*(dg213 + dg312)))* - ginv22 - (3.*(dg133*dg213 + dg113*dg233) + 6.*dg213*dg313 + - 2.*(dg233*dg311 + dg211*dg333))*ginv33 - - ginv23*(4.*(dg213*dg312 + dg212*dg313) + - 2.*(dg133*dg212 + dg123*dg213 + (dg112 + dg211)*dg233 + - dg223*(dg113 + dg311) + dg211*dg323 + pow2(dg213))))*pow2(ginv13) \ -- 2.*(dg233*dg333*Power(ginv33,3) + - Power(ginv23,3)*(dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223)) + - (dg222*dg223*ginv33 + ginv23*pow2(dg222))*pow2(ginv22)) + - (ddg2223 + ddg2322 - (dg233*(6.*dg223 + 2.*dg322) + 6.*dg223*dg323 + - 2.*dg222*dg333)*ginv33)*pow2(ginv23) + ddg2333*pow2(ginv33) + - ginv11*(ddg1213*ginv33 + ginv13* - (ddg1211 - 2.*(dg112 + dg211)*dg212*ginv22 - - (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + 2.*dg212*dg311 + - dg211*(dg123 + 2.*(dg213 + dg312)))*ginv23 - - (dg111*dg233 + dg213*(6.*dg113 + 2.*dg311) + - dg211*(dg133 + 2.*dg313))*ginv33) - - ginv12*((4.*dg112*dg212 + dg211*(dg122 + 2.*dg212) + dg111*dg222)* - ginv23 + (dg211*(dg123 + 2.*dg213) + - 2.*(dg113*dg212 + dg112*dg213) + dg111*dg223)*ginv33 + - ginv13*(3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))) - - ginv22*((dg212*(dg123 + 2.*dg213) + dg112*dg223)*ginv33 + - ginv23*(dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))) + - ginv23*(ddg1212 - ginv33* - (dg112*dg233 + dg212*(dg133 + 2.*dg313) + - 2.*(dg113*dg223 + dg213*(dg123 + dg312) + pow2(dg213)))) - - (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*pow2(ginv13) - - (dg122*dg213 + dg113*dg222 + dg112*dg223 + - dg212*(dg123 + 2.*(dg213 + dg312)))*pow2(ginv23) - - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*pow2(ginv33)) + - ginv22*(ddg2223*ginv33 + ginv23* - (ddg2222 - ginv33*(2.*(dg223*dg322 + dg222*(dg233 + dg323)) + - 6.*pow2(dg223))) - dg222*(6.*dg223 + 2.*dg322)*pow2(ginv23) - - 2.*dg223*(dg233 + dg323)*pow2(ginv33)) + - ginv12*((ddg1223 + ddg2213)*ginv33 - - ginv22*((2.*dg122 + 6.*dg212)*dg222*ginv23 + - ((dg123 + 2.*dg213)*dg222 + (dg122 + 4.*dg212)*dg223)*ginv33) + - ginv23*(ddg1222 + ddg2212 - - ((dg122 + 2.*dg212)*dg233 + - dg223*(4.*dg123 + 8.*dg213 + 2.*dg312) + - dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* - ginv33) + ginv13*(ddg1212 + ddg2211 - - (4.*(dg112 + dg211)*dg223 + - dg212*(8.*dg213 + 4.*(dg123 + dg312)) + - 2.*(dg122*dg213 + dg222*(dg113 + dg311) + dg211*dg322))*ginv23 \ -- ginv22*(dg122*dg212 + (dg112 + 2.*dg211)*dg222 + 4.*pow2(dg212)) - - ginv33*((dg112 + 2.*dg211)*dg233 + dg212*(dg133 + 2.*dg313) + - 2.*(dg223*dg311 + dg213*dg312 + dg211*dg323) + - 4.*(dg123*dg213 + dg113*dg223 + pow2(dg213)))) - - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + - dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))* - pow2(ginv13) - ((2.*dg122 + 4.*dg212)*dg223 + - dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)* - pow2(ginv23) - ((dg123 + 2.*dg213)*dg233 + - dg223*(dg133 + 2.*dg313) + 2.*dg213*dg323)*pow2(ginv33)) + - ginv13*((ddg1233 + 2.*ddg2313)*ginv33 + - ginv22*(ddg2212 - ((dg122 + 8.*dg212)*dg223 + - dg222*(dg123 + 2.*(dg213 + dg312)) + 2.*dg212*dg322)*ginv23 - - (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*(dg233 + dg323))* - ginv33) + ginv23*(ddg1223 + ddg2213 + 2.*ddg2312 - - (3.*(dg133*dg223 + dg123*dg233) + dg233*(6.*dg213 + 4.*dg312) + - 6.*(dg223*dg313 + dg213*dg323) + 4.*dg212*dg333)*ginv33) - - 2.*dg212*dg222*pow2(ginv22) - - ((dg122 + 4.*dg212)*dg233 + dg223*(2.*dg123 + 4.*(dg213 + dg312)) + - dg222*(dg133 + 2.*dg313) + 2.*dg213*dg322 + 4.*dg212*dg323)* - pow2(ginv23) - (dg233*(2.*dg133 + 4.*dg313) + 4.*dg213*dg333)* - pow2(ginv33)) + ginv23*((ddg2233 + 2.*ddg2323)*ginv33 - - (4.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))*pow2(ginv33)) -; - -dGfromgdu31 -= --((dg222*dg311 + dg211*dg322 + 2.*((dg122 + dg212)*dg312 + dg112*dg322))* - Power(ginv12,3)) - 2.*(dg111*dg311*Power(ginv11,3) + - Power(ginv13,3)*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313))) + - (ddg1311 - ((4.*dg112 + 2.*dg211)*dg311 + 4.*dg111*dg312)*ginv12 - - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - - (dg311*(dg213 + 2.*dg312) + dg211*dg313 + - 2.*(dg113*dg312 + dg112*dg313))*ginv23 - - 2.*(dg113 + dg311)*dg313*ginv33 - - ginv13*(4.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311)))*pow2(ginv11) \ -+ (ddg1322 + ddg2312 - (2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))* - ginv22 - ((2.*dg213 + 4.*dg312)*dg322 + - 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + - (dg122 + dg212)*dg323))*ginv23 - - (dg313*(dg223 + 2.*dg322) + (dg213 + 2.*(dg123 + dg312))*dg323)* - ginv33 - ginv13*(4.*(dg123*dg312 + dg112*dg323) + - 2.*(dg213*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + - dg311*(dg223 + dg322) + dg211*dg323 + pow2(dg312))))*pow2(ginv12) \ -+ (ddg1333 + ddg3313 - (dg233*dg312 + dg223*dg313 + - (dg213 + 2.*(dg123 + dg312))*dg323 + dg212*dg333)*ginv22 - - (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + - 4.*(dg313*dg323 + dg312*dg333))*ginv23 - - (2.*dg133 + 6.*dg313)*dg333*ginv33)*pow2(ginv13) + - ginv11*(ddg3313*ginv33 + ginv22* - (ddg2312 - (dg222*dg313 + dg213*dg322 + - 2.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - - (dg223*dg313 + (dg213 + 2.*dg312)*dg323)*ginv33) + - ginv23*(ddg2313 + ddg3312 - - (dg313*(dg233 + 4.*dg323) + (dg213 + 2.*dg312)*dg333)*ginv33) + - ginv12*(2.*ddg1312 + ddg2311 - - (dg311*(4.*dg123 + 3.*dg213 + 6.*dg312) + 3.*dg211*dg313 + - 6.*(dg113*dg312 + dg112*dg313) + 4.*dg111*dg323)*ginv13 - - (dg222*dg311 + (2.*dg122 + 6.*dg212)*dg312 + - (2.*dg112 + dg211)*dg322)*ginv22 - - (4.*dg312*dg313 + 2.*((dg123 + dg213)*dg313 + - (dg113 + dg311)*dg323))*ginv33 - - ginv23*((2.*dg123 + 4.*dg213)*dg312 + dg311*(dg223 + 2.*dg322) + - dg211*dg323 + 2.*(dg122*dg313 + dg113*dg322 + dg112*dg323) + - 4.*(dg212*dg313 + pow2(dg312)))) + - ginv13*(2.*ddg1313 + ddg3311 - - ((4.*dg213 + 8.*dg312)*dg313 + dg311*(dg233 + 2.*dg323) + - dg211*dg333 + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + - dg112*dg333))*ginv23 - - ginv22*(dg223*dg311 + dg211*dg323 + - 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + - pow2(dg312))) - - ginv33*(2.*(dg133*dg313 + (dg113 + dg311)*dg333) + 6.*pow2(dg313))) \ -- ((2.*dg122 + 3.*dg212)*dg311 + (6.*dg112 + 3.*dg211)*dg312 + - 2.*dg111*dg322)*pow2(ginv12) - - (6.*dg113*dg313 + dg311*(2.*dg133 + 6.*dg313) + 2.*dg111*dg333)* - pow2(ginv13) - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - - (dg313*(dg223 + 2.*dg322) + dg213*dg323 + dg312*(dg233 + 2.*dg323) + - dg212*dg333)*pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + - ginv12*(ddg3323*ginv33 + ginv13* - (2.*ddg1323 + ddg2313 + ddg3312 - - (dg222*dg313 + (2.*dg123 + dg213)*dg322 + - dg312*(4.*dg223 + 2.*dg322) + (2.*dg122 + 4.*dg212)*dg323)* - ginv22 - ((4.*dg213 + 8.*dg312)*dg323 + - 4.*(dg313*(dg223 + dg322) + dg123*dg323) + - 2.*(dg233*dg312 + dg133*dg322 + (dg122 + dg212)*dg333))*ginv23 \ -- (dg313*(dg233 + 8.*dg323) + (dg213 + 2.*dg312)*dg333 + - 2.*(dg133*dg323 + dg123*dg333))*ginv33) + - ginv22*(ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - - ginv23*(3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))) + - ginv23*(ddg2323 + ddg3322 - - ginv33*(dg233*dg323 + (dg223 + 2.*dg322)*dg333 + 4.*pow2(dg323))) - - (dg311*(dg233 + 4.*dg323) + - 4.*((dg123 + dg312)*dg313 + dg113*dg323) + dg211*dg333 + - 2.*(dg133*dg312 + dg213*dg313 + dg112*dg333))*pow2(ginv13) - - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* - pow2(ginv23) - 2.*(dg222*dg322*pow2(ginv22) + - dg323*dg333*pow2(ginv33))) + - ginv13*(ddg3333*ginv33 + ginv23* - (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33) + - ginv22*(ddg2323 - (4.*dg223*dg323 + dg322*(dg233 + 2.*dg323) + - dg222*dg333)*ginv23 - - ginv33*(dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))) - - (dg223*dg322 + dg222*dg323)*pow2(ginv22) - - 2.*((dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow2(ginv23) + - pow2(dg333)*pow2(ginv33))) -; - -dGfromgdu32 -= --(((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* - Power(ginv12,3)) - 2.*(dg222*dg322*Power(ginv22,3) + - Power(ginv23,3)*(dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))) - - (2.*dg111*dg311*ginv12 + (dg112*dg311 + dg111*dg312)*ginv22 + - (dg113*dg311 + dg111*dg313)*ginv23)*pow2(ginv11) + - (ddg1312 + ddg2311 - (4.*dg311*dg312 + - 2.*((dg123 + dg213)*dg311 + dg113*dg312 + - (dg112 + dg211)*dg313 + dg111*dg323))*ginv13 - - ((3.*dg122 + 6.*dg212)*dg312 + 3.*dg112*dg322 + - 2.*(dg222*dg311 + dg211*dg322))*ginv22 - - ((dg123 + 2.*(dg213 + dg312))*dg313 + (dg113 + 2.*dg311)*dg323)* - ginv33 - ginv23*(4.*(dg213*dg312 + dg212*dg313) + - 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322 + - dg311*(dg223 + dg322) + (dg112 + dg211)*dg323 + pow2(dg312))))* - pow2(ginv12) - ((dg123*dg313 + dg312*(dg133 + 2.*dg313) + - (dg113 + 2.*dg311)*dg323 + dg112*dg333)*ginv22 + - 2.*ginv23*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313)))* - pow2(ginv13) + (ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - - ginv23*(4.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322)))*pow2(ginv22) \ -+ (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33)*pow2(ginv23) + - ginv11*(-(ginv13*((dg311*(dg123 + 2.*dg312) + - 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv22 + - (4.*dg113*dg313 + dg311*(dg133 + 2.*dg313) + dg111*dg333)*ginv23)\ -) + ginv12*(ddg1311 - ((dg122 + 2.*dg212)*dg311 + - (6.*dg112 + 2.*dg211)*dg312 + dg111*dg322)*ginv22 - - (dg311*(dg123 + 2.*(dg213 + dg312)) + 2.*dg211*dg313 + - 4.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv23 - - 2.*(dg113 + dg311)*dg313*ginv33 - - ginv13*(3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))) + - ginv22*(ddg1312 - ((dg123 + 2.*dg312)*dg313 + dg113*dg323)*ginv33 - - ginv23*(dg122*dg313 + dg113*dg322 + - 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + - pow2(dg312)))) + - ginv23*(ddg1313 - ginv33* - (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))) - - ((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*pow2(ginv12) - - ((dg122 + 2.*dg212)*dg312 + dg112*dg322)*pow2(ginv22) - - (dg133*dg312 + (dg123 + 2.*(dg213 + dg312))*dg313 + dg113*dg323 + - dg112*dg333)*pow2(ginv23)) + - ginv13*(ginv23*(ddg1333 + ddg3313 - (2.*dg133 + 6.*dg313)*dg333*ginv33) + - ginv22*(ddg1323 + ddg3312 - - (dg133*dg322 + (4.*dg123 + 2.*dg213 + 8.*dg312)*dg323 + - dg122*dg333 + 2.*(dg233*dg312 + dg313*(dg223 + dg322) + - dg212*dg333))*ginv23 - - ((dg133 + 4.*dg313)*dg323 + (dg123 + 2.*dg312)*dg333)*ginv33) - - (dg123*dg322 + dg122*dg323 + - 2.*(dg312*(dg223 + dg322) + dg212*dg323))*pow2(ginv22) - - (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + - 4.*(dg313*dg323 + dg312*dg333))*pow2(ginv23)) + - ginv12*(ddg3313*ginv33 + ginv22* - (ddg1322 + 2.*ddg2312 - - (4.*(dg222*dg313 + dg213*dg322) + - 3.*(dg123*dg322 + dg122*dg323) + - 6.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - - ((2.*dg213 + 4.*dg312)*dg323 + - 2.*(dg313*(dg223 + dg322) + dg123*dg323))*ginv33) + - ginv23*(ddg1323 + 2.*ddg2313 + ddg3312 - - (dg133*dg323 + dg313*(2.*dg233 + 8.*dg323) + - (dg123 + 2.*(dg213 + dg312))*dg333)*ginv33) + - ginv13*(ddg1313 + ddg3311 - - (8.*dg312*dg313 + 4.* - ((dg123 + dg213)*dg313 + (dg113 + dg311)*dg323) + - 2.*(dg233*dg311 + dg133*dg312 + (dg112 + dg211)*dg333))*ginv23 \ -- ginv22*(dg122*dg313 + dg113*dg322 + - 2.*(dg213*dg312 + dg212*dg313 + dg311*(dg223 + dg322) + - dg211*dg323) + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg312))) \ -- ginv33*(dg133*dg313 + (dg113 + 2.*dg311)*dg333 + 4.*pow2(dg313))) - - (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* - pow2(ginv13) - (2.*dg122*dg322 + 4.*(dg222*dg312 + dg212*dg322))* - pow2(ginv22) - (dg133*dg322 + - 4.*(dg313*(dg223 + dg322) + (dg213 + dg312)*dg323) + - dg122*dg333 + 2.*(dg233*dg312 + dg123*dg323 + dg212*dg333))* - pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + - ginv22*(ddg3323*ginv33 + ginv23* - (2.*ddg2323 + ddg3322 - - ginv33*(2.*(dg233*dg323 + (dg223 + dg322)*dg333) + 6.*pow2(dg323))) \ -- (6.*dg223*dg323 + dg322*(2.*dg233 + 6.*dg323) + 2.*dg222*dg333)* - pow2(ginv23) - 2.*dg323*dg333*pow2(ginv33)) + - ginv23*(ddg3333*ginv33 - 2.*pow2(dg333)*pow2(ginv33)) -; - -dGfromgdu33 -= --((2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* - Power(ginv13,3)) - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + - dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv33,3)*pow2(dg333) - - (2.*dg111*dg311*ginv13 + (dg112*dg311 + dg111*dg312)*ginv23 + - (dg113*dg311 + dg111*dg313)*ginv33)*pow2(ginv11) - - (((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* - ginv13 + (dg222*dg311 + dg211*dg322 + - 2.*((dg122 + dg212)*dg312 + dg112*dg322))*ginv23 + - (dg223*dg311 + (dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + - dg113*dg322 + (dg112 + dg211)*dg323)*ginv33)*pow2(ginv12) + - (ddg1313 + ddg3311 - ((2.*dg213 + 8.*dg312)*dg313 + - dg311*(dg233 + 4.*dg323) + dg211*dg333 + - 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + dg112*dg333))*ginv23 \ -- ginv22*(dg223*dg311 + (dg123 + dg213)*dg312 + dg212*dg313 + - (dg112 + dg211)*dg323 + 2.*pow2(dg312)) - - ginv33*(4.*dg311*dg333 + 3.*(dg133*dg313 + dg113*dg333) + - 6.*pow2(dg313)))*pow2(ginv13) - - (2.*dg222*dg322*ginv23 + (dg223*dg322 + dg222*dg323)*ginv33)* - pow2(ginv22) + (ddg2323 + ddg3322 - - ginv33*(4.*dg322*dg333 + 3.*(dg233*dg323 + dg223*dg333) + - 6.*pow2(dg323)))*pow2(ginv23) + ddg3333*pow2(ginv33) + - ginv13*((ddg1333 + 2.*ddg3313)*ginv33 + - ginv22*(ddg2312 - (dg222*dg313 + (dg123 + dg213)*dg322 + - dg122*dg323 + 4.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 \ -- (dg312*(dg233 + 4.*dg323) + 2.*(dg223*dg313 + (dg123 + dg213)*dg323) + - dg212*dg333)*ginv33) + - ginv23*(ddg1323 + ddg2313 + 2.*ddg3312 - - (12.*dg313*dg323 + (3.*dg213 + 8.*dg312)*dg333 + - 3.*(dg233*dg313 + dg133*dg323 + dg123*dg333))*ginv33) - - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - - ((dg133 + 4.*dg313)*dg322 + (2.*dg213 + 8.*dg312)*dg323 + - dg122*dg333 + 2.*(dg233*dg312 + dg223*dg313 + dg123*dg323 + - dg212*dg333))*pow2(ginv23) - - (2.*dg133 + 8.*dg313)*dg333*pow2(ginv33)) + - ginv23*((ddg2333 + 2.*ddg3323)*ginv33 - - (2.*dg233 + 8.*dg323)*dg333*pow2(ginv33)) + - ginv12*((ddg1323 + ddg2313)*ginv33 - - ginv22*((2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))*ginv23 + - (dg222*dg313 + (dg123 + dg213)*dg322 + dg122*dg323 + - 2.*(dg223*dg312 + dg212*dg323))*ginv33) + - ginv23*(ddg1322 + ddg2312 - - (dg233*dg312 + dg133*dg322 + - 4.*(dg313*(dg223 + dg322) + (dg123 + dg213 + dg312)*dg323) + - (dg122 + dg212)*dg333)*ginv33) + - ginv13*(ddg1312 + ddg2311 - - (dg222*dg311 + (dg122 + 4.*dg212)*dg312 + (dg112 + dg211)*dg322)* - ginv22 - (dg133*dg312 + dg311*(dg233 + 4.*dg323) + - 4.*((dg123 + dg213 + dg312)*dg313 + dg113*dg323) + - (dg112 + dg211)*dg333)*ginv33 - - ginv23*(2.*(dg223*dg311 + dg122*dg313 + dg113*dg322 + - dg211*dg323) + 4.* - ((dg123 + dg213)*dg312 + dg212*dg313 + dg311*dg322 + - dg112*dg323 + pow2(dg312)))) - - (4.*dg311*dg312 + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + - (dg112 + dg211)*dg313 + dg111*dg323))*pow2(ginv13) - - ((2.*dg213 + 4.*dg312)*dg322 + - 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + - (dg122 + dg212)*dg323))*pow2(ginv23) - - (dg133*dg323 + dg313*(dg233 + 4.*dg323) + (dg123 + dg213)*dg333)* - pow2(ginv33)) + ginv11*(ddg1313*ginv33 - - ginv12*(((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*ginv13 + - ((dg122 + dg212)*dg311 + (4.*dg112 + dg211)*dg312 + dg111*dg322)* - ginv23 + ((dg123 + dg213)*dg311 + dg211*dg313 + - 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv33) - - ginv22*(((dg122 + 2.*dg212)*dg312 + dg112*dg322)*ginv23 + - ((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323)*ginv33) + - ginv13*(ddg1311 - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - - ((dg123 + dg213)*dg311 + 4.*(dg113 + dg311)*dg312 + - (4.*dg112 + dg211)*dg313 + dg111*dg323)*ginv23 - - (6.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)*ginv33) + - ginv23*(ddg1312 - (dg312*(dg133 + 4.*dg313) + - 2.*((dg123 + dg213)*dg313 + dg113*dg323) + dg112*dg333)*ginv33) \ -- (3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))*pow2(ginv13) - - ((dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + - dg112*dg323 + 2.*pow2(dg312))*pow2(ginv23) - - (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))*pow2(ginv33)) + - ginv22*(ddg2323*ginv33 + ginv23* - (ddg2322 - (6.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* - ginv33) - (3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))* - pow2(ginv23) - (dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))* - pow2(ginv33)) -; - -R11 -= -dG11*g11 + dG12*g12 + dG13*g13 + gammado111*Gfromg1 + gammado112*Gfromg2 + - gammado113*Gfromg3 + (-0.5*ddg1111 + 3.*gamma111*gammado111 + - 2.*(gamma211*gammado112 + gamma311*gammado113) + - gamma211*gammado211 + gamma311*gammado311)*ginv11 + - (-ddg1211 + 3.*(gamma112*gammado111 + gamma111*gammado112) + - 2.*(gamma212*gammado112 + gamma312*gammado113 + - gamma211*gammado122 + gamma311*gammado123) + gamma212*gammado211 + - gamma211*gammado212 + gamma312*gammado311 + gamma311*gammado312)*ginv12 \ -+ (-ddg1311 + 3.*(gamma113*gammado111 + gamma111*gammado113) + - 2.*(gamma213*gammado112 + gamma313*gammado113 + - gamma211*gammado123 + gamma311*gammado133) + gamma213*gammado211 + - gamma211*gammado213 + gamma313*gammado311 + gamma311*gammado313)*ginv13 \ -+ (-0.5*ddg2211 + 3.*gamma112*gammado112 + - 2.*(gamma212*gammado122 + gamma312*gammado123) + - gamma212*gammado212 + gamma312*gammado312)*ginv22 + - (-ddg2311 + 3.*(gamma113*gammado112 + gamma112*gammado113) + - 2.*(gamma213*gammado122 + (gamma212 + gamma313)*gammado123 + - gamma312*gammado133) + gamma213*gammado212 + gamma212*gammado213 + - gamma313*gammado312 + gamma312*gammado313)*ginv23 + - (-0.5*ddg3311 + 3.*gamma113*gammado113 + - 2.*(gamma213*gammado123 + gamma313*gammado133) + gamma213*gammado213 + - gamma313*gammado313)*ginv33 -; - -R12 -= -0.5*(dG21*g11 + (dG11 + dG22)*g12 + dG23*g13 + dG12*g22 + dG13*g23 + - (gammado112 + gammado211)*Gfromg1 + - (gammado122 + gammado212)*Gfromg2 + (gammado123 + gammado213)*Gfromg3) \ -+ (-0.5*ddg1112 + gamma112*gammado111 + (gamma111 + gamma212)*gammado112 + - gamma312*gammado113 + gamma111*gammado211 + 2.*gamma211*gammado212 + - gamma311*(gammado213 + gammado312))*ginv11 + - (-ddg1212 + gamma122*gammado111 + (2.*gamma112 + gamma222)*gammado112 + - gamma322*gammado113 + (gamma111 + gamma212)*gammado122 + - gamma112*gammado211 + (gamma111 + 2.*gamma212)*gammado212 + - 2.*gamma211*gammado222 + - gamma312*(gammado123 + gammado213 + gammado312) + - gamma311*(gammado223 + gammado322))*ginv12 + - (-ddg1312 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + - (gamma112 + gamma323)*gammado113 + (gamma111 + gamma212)*gammado123 + - gamma312*gammado133 + gamma113*gammado211 + - (gamma111 + gamma313)*gammado213 + - 2.*(gamma213*gammado212 + gamma211*gammado223) + - gamma313*gammado312 + gamma311*(gammado233 + gammado323))*ginv13 + - (-0.5*ddg2212 + gamma122*gammado112 + (gamma112 + gamma222)*gammado122 + - gamma322*gammado123 + gamma112*gammado212 + 2.*gamma212*gammado222 + - gamma312*(gammado223 + gammado322))*ginv22 + - (-ddg2312 + gamma123*gammado112 + gamma122*gammado113 + - (gamma113 + gamma223)*gammado122 + - (gamma112 + gamma222 + gamma323)*gammado123 + gamma322*gammado133 + - gamma113*gammado212 + gamma112*gammado213 + - 2.*(gamma213*gammado222 + gamma212*gammado223) + - gamma313*(gammado223 + gammado322) + - gamma312*(gammado233 + gammado323))*ginv23 + - (-0.5*ddg3312 + gamma123*gammado113 + (gamma113 + gamma223)*gammado123 + - gamma323*gammado133 + gamma113*gammado213 + 2.*gamma213*gammado223 + - gamma313*(gammado233 + gammado323))*ginv33 -; - -R13 -= -0.5*(dG31*g11 + dG32*g12 + (dG11 + dG33)*g13 + dG12*g23 + dG13*g33 + - (gammado113 + gammado311)*Gfromg1 + - (gammado123 + gammado312)*Gfromg2 + (gammado133 + gammado313)*Gfromg3) \ -+ (-0.5*ddg1113 + gamma113*gammado111 + gamma213*gammado112 + - (gamma111 + gamma313)*gammado113 + gamma111*gammado311 + - gamma211*(gammado213 + gammado312) + 2.*gamma311*gammado313)*ginv11 + - (-ddg1213 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + - (gamma112 + gamma323)*gammado113 + gamma213*gammado122 + - (gamma111 + gamma313)*gammado123 + gamma112*gammado311 + - gamma111*gammado312 + gamma212*(gammado213 + gammado312) + - gamma211*(gammado223 + gammado322) + - 2.*(gamma312*gammado313 + gamma311*gammado323))*ginv12 + - (-ddg1313 + gamma133*gammado111 + gamma233*gammado112 + - (2.*gamma113 + gamma333)*gammado113 + - (gamma111 + gamma313)*gammado133 + gamma113*gammado311 + - gamma213*(gammado123 + gammado213 + gammado312) + - (gamma111 + 2.*gamma313)*gammado313 + - gamma211*(gammado233 + gammado323) + 2.*gamma311*gammado333)*ginv13 + - (-0.5*ddg2213 + gamma123*gammado112 + gamma223*gammado122 + - (gamma112 + gamma323)*gammado123 + gamma112*gammado312 + - gamma212*(gammado223 + gammado322) + 2.*gamma312*gammado323)*ginv22 + - (-ddg2313 + gamma133*gammado112 + gamma123*gammado113 + - gamma233*gammado122 + (gamma113 + gamma223 + gamma333)*gammado123 + - (gamma112 + gamma323)*gammado133 + gamma113*gammado312 + - gamma112*gammado313 + gamma213*(gammado223 + gammado322) + - gamma212*(gammado233 + gammado323) + - 2.*(gamma313*gammado323 + gamma312*gammado333))*ginv23 + - (-0.5*ddg3313 + gamma133*gammado113 + gamma233*gammado123 + - (gamma113 + gamma333)*gammado133 + gamma113*gammado313 + - gamma213*(gammado233 + gammado323) + 2.*gamma313*gammado333)*ginv33 -; - -R22 -= -dG21*g12 + dG22*g22 + dG23*g23 + gammado212*Gfromg1 + gammado222*Gfromg2 + - gammado223*Gfromg3 + (-0.5*ddg1122 + - gamma112*(gammado112 + 2.*gammado211) + 3.*gamma212*gammado212 + - gamma312*(2.*gammado213 + gammado312))*ginv11 + - (-ddg1222 + gamma122*(gammado112 + 2.*gammado211) + - gamma112*(gammado122 + 2.*gammado212) + - 3.*(gamma222*gammado212 + gamma212*gammado222) + - 2.*(gamma322*gammado213 + gamma312*gammado223) + - gamma322*gammado312 + gamma312*gammado322)*ginv12 + - (-ddg1322 + gamma123*(gammado112 + 2.*gammado211) + - gamma112*(gammado123 + 2.*gammado213) + - 3.*(gamma223*gammado212 + gamma212*gammado223) + - 2.*(gamma323*gammado213 + gamma312*gammado233) + - gamma323*gammado312 + gamma312*gammado323)*ginv13 + - (-0.5*ddg2222 + gamma122*(gammado122 + 2.*gammado212) + - 3.*gamma222*gammado222 + gamma322*(2.*gammado223 + gammado322))*ginv22 \ -+ (-ddg2322 + gamma123*(gammado122 + 2.*gammado212) + - gamma122*(gammado123 + 2.*gammado213) + - 3.*(gamma223*gammado222 + gamma222*gammado223) + - 2.*(gamma323*gammado223 + gamma322*gammado233) + - gamma323*gammado322 + gamma322*gammado323)*ginv23 + - (-0.5*ddg3322 + gamma123*(gammado123 + 2.*gammado213) + - 3.*gamma223*gammado223 + gamma323*(2.*gammado233 + gammado323))*ginv33 -; - -R23 -= -0.5*(dG31*g12 + dG21*g13 + dG32*g22 + (dG22 + dG33)*g23 + dG23*g33 + - (gammado213 + gammado312)*Gfromg1 + - (gammado223 + gammado322)*Gfromg2 + (gammado233 + gammado323)*Gfromg3) \ -+ (-0.5*ddg1123 + gamma113*gammado211 + gamma213*gammado212 + - (gamma212 + gamma313)*gammado213 + - gamma112*(gammado113 + gammado311) + gamma212*gammado312 + - 2.*gamma312*gammado313)*ginv11 + - (-ddg1223 + gamma123*gammado211 + (gamma113 + gamma223)*gammado212 + - (gamma222 + gamma323)*gammado213 + gamma213*gammado222 + - (gamma212 + gamma313)*gammado223 + - gamma122*(gammado113 + gammado311) + gamma222*gammado312 + - gamma112*(gammado123 + gammado312) + gamma212*gammado322 + - 2.*(gamma322*gammado313 + gamma312*gammado323))*ginv12 + - (-ddg1323 + gamma133*gammado211 + gamma233*gammado212 + - (gamma113 + gamma223 + gamma333)*gammado213 + gamma213*gammado223 + - (gamma212 + gamma313)*gammado233 + - gamma123*(gammado113 + gammado311) + gamma223*gammado312 + - gamma112*(gammado133 + gammado313) + gamma212*gammado323 + - 2.*(gamma323*gammado313 + gamma312*gammado333))*ginv13 + - (-0.5*ddg2223 + gamma123*gammado212 + gamma223*gammado222 + - (gamma222 + gamma323)*gammado223 + - gamma122*(gammado123 + gammado312) + gamma222*gammado322 + - 2.*gamma322*gammado323)*ginv22 + - (-ddg2323 + gamma133*gammado212 + gamma233*gammado222 + - (2.*gamma223 + gamma333)*gammado223 + - (gamma222 + gamma323)*gammado233 + - gamma123*(gammado123 + gammado213 + gammado312) + - gamma122*(gammado133 + gammado313) + gamma223*gammado322 + - (gamma222 + 2.*gamma323)*gammado323 + 2.*gamma322*gammado333)*ginv23 + - (-0.5*ddg3323 + gamma133*gammado213 + gamma233*gammado223 + - (gamma223 + gamma333)*gammado233 + - gamma123*(gammado133 + gammado313) + gamma223*gammado323 + - 2.*gamma323*gammado333)*ginv33 -; - -R33 -= -dG31*g13 + dG32*g23 + dG33*g33 + gammado313*Gfromg1 + gammado323*Gfromg2 + - gammado333*Gfromg3 + (-0.5*ddg1133 + - gamma113*(gammado113 + 2.*gammado311) + - gamma213*(gammado213 + 2.*gammado312) + 3.*gamma313*gammado313)*ginv11 \ -+ (-ddg1233 + gamma123*(gammado113 + 2.*gammado311) + - gamma113*(gammado123 + 2.*gammado312) + - gamma223*(gammado213 + 2.*gammado312) + - gamma213*(gammado223 + 2.*gammado322) + - 3.*(gamma323*gammado313 + gamma313*gammado323))*ginv12 + - (-ddg1333 + gamma133*(gammado113 + 2.*gammado311) + - gamma233*(gammado213 + 2.*gammado312) + - gamma113*(gammado133 + 2.*gammado313) + - gamma213*(gammado233 + 2.*gammado323) + - 3.*(gamma333*gammado313 + gamma313*gammado333))*ginv13 + - (-0.5*ddg2233 + gamma123*(gammado123 + 2.*gammado312) + - gamma223*(gammado223 + 2.*gammado322) + 3.*gamma323*gammado323)*ginv22 \ -+ (-ddg2333 + gamma133*(gammado123 + 2.*gammado312) + - gamma123*(gammado133 + 2.*gammado313) + - gamma233*(gammado223 + 2.*gammado322) + - gamma223*(gammado233 + 2.*gammado323) + - 3.*(gamma333*gammado323 + gamma323*gammado333))*ginv23 + - (-0.5*ddg3333 + gamma133*(gammado133 + 2.*gammado313) + - gamma233*(gammado233 + 2.*gammado323) + 3.*gamma333*gammado333)*ginv33 -; - -ff -= -chi -; - -oochipsipower -= -1/chipsipower -; - -f -= -oochipsipower*log(ff) -; - -psim4 -= -exp(-4.*f) -; - -df1 -= -(dchi1*oochipsipower)/chi -; - -df2 -= -(dchi2*oochipsipower)/chi -; - -df3 -= -(dchi3*oochipsipower)/chi -; - -ddf11 -= -(ddchi11*oochipsipower)/chi - chipsipower*pow2(df1) -; - -ddf12 -= --(chipsipower*df1*df2) + (ddchi12*oochipsipower)/chi -; - -ddf13 -= --(chipsipower*df1*df3) + (ddchi13*oochipsipower)/chi -; - -ddf22 -= -(ddchi22*oochipsipower)/chi - chipsipower*pow2(df2) -; - -ddf23 -= --(chipsipower*df2*df3) + (ddchi23*oochipsipower)/chi -; - -ddf33 -= -(ddchi33*oochipsipower)/chi - chipsipower*pow2(df3) -; - -cddf11 -= -ddf11 - df1*gamma111 - df2*gamma211 - df3*gamma311 -; - -cddf12 -= -ddf12 - df1*gamma112 - df2*gamma212 - df3*gamma312 -; - -cddf13 -= -ddf13 - df1*gamma113 - df2*gamma213 - df3*gamma313 -; - -cddf22 -= -ddf22 - df1*gamma122 - df2*gamma222 - df3*gamma322 -; - -cddf23 -= -ddf23 - df1*gamma123 - df2*gamma223 - df3*gamma323 -; - -cddf33 -= -ddf33 - df1*gamma133 - df2*gamma233 - df3*gamma333 -; - -trcddf -= -cddf11*ginv11 + cddf22*ginv22 + - 2.*(cddf12*ginv12 + cddf13*ginv13 + cddf23*ginv23) + cddf33*ginv33 -; - -Rphi11 -= --2.*(cddf11 + g11*trcddf) + (4. - 4.*g11*ginv11)*pow2(df1) - - g11*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi12 -= -df1*df2*(4. - 8.*g12*ginv12) - 2.*(cddf12 + g12*trcddf) - - g12*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi13 -= -df1*(4.*df3 - 8.*df2*g13*ginv12) - 2.*(cddf13 + g13*trcddf) - - g13*(8.*df3*(df1*ginv13 + df2*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) -; - -Rphi22 -= --2.*(cddf22 + g22*trcddf) + (4. - 4.*g22*ginv22)*pow2(df2) - - g22*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv11*pow2(df1) + ginv33*pow2(df3))) -; - -Rphi23 -= -df2*(-8.*df1*g23*ginv12 + df3*(4. - 8.*g23*ginv23)) - - 2.*(cddf23 + g23*trcddf) - g23* - (8.*df1*df3*ginv13 + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + - ginv33*pow2(df3))) -; - -Rphi33 -= --2.*(cddf33 + g33*trcddf) - g33* - (8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + - 4.*(ginv11*pow2(df1) + ginv22*pow2(df2))) + - (4. - 4.*g33*ginv33)*pow2(df3) -; - -Rf11 -= -R11 + Rphi11 -; - -Rf12 -= -R12 + Rphi12 -; - -Rf13 -= -R13 + Rphi13 -; - -Rf22 -= -R22 + Rphi22 -; - -Rf23 -= -R23 + Rphi23 -; - -Rf33 -= -R33 + Rphi33 -; - -Rhat -= -psim4*(ginv11*Rf11 + ginv22*Rf22 + - 2.*(ginv12*Rf12 + ginv13*Rf13 + ginv23*Rf23) + ginv33*Rf33) -; - -cdda11 -= -dda11 - da2*gamma211 - da3*gamma311 + - da1*(-gamma111 + df1*(-4. + 2.*g11*ginv11)) + - 2.*g11*((da2*df1 + da1*df2)*ginv12 + (da3*df1 + da1*df3)*ginv13 + - da2*df2*ginv22 + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) -; - -cdda12 -= -dda12 - da1*gamma112 - da2*gamma212 - da3*gamma312 + - 2.*(-(da2*df1) - da1*df2 + g12* - (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) -; - -cdda13 -= -dda13 - da1*gamma113 - da2*gamma213 - da3*gamma313 + - 2.*(-(da3*df1) - da1*df3 + g13* - (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) -; - -cdda22 -= -dda22 - da1*gamma122 - da2*(4.*df2 + gamma222) - da3*gamma322 + - 2.*g22*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) -; - -cdda23 -= -dda23 - da1*gamma123 - da2*gamma223 - da3*gamma323 + - 2.*(-(da3*df2) - da2*df3 + g23* - (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) -; - -cdda33 -= -dda33 - da1*gamma133 - da2*gamma233 - da3*(4.*df3 + gamma333) + - 2.*g33*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + - (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + - (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) -; - -trcdda -= -(cdda11*ginv11 + cdda22*ginv22 + - 2.*(cdda12*ginv12 + cdda13*ginv13 + cdda23*ginv23) + cdda33*ginv33)*psim4 -; - -AA11 -= -2.*(A11*(A12*ginv12 + A13*ginv13) + A12*A13*ginv23) + ginv11*pow2(A11) + - ginv22*pow2(A12) + ginv33*pow2(A13) -; - -AA12 -= -(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + - (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) -; - -AA13 -= -(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + - A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) -; - -AA21 -= -(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + - (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) -; - -AA22 -= -2.*(A12*(A22*ginv12 + A23*ginv13) + A22*A23*ginv23) + ginv11*pow2(A12) + - ginv22*pow2(A22) + ginv33*pow2(A23) -; - -AA23 -= -A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + - A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) -; - -AA31 -= -(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + - A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) -; - -AA32 -= -A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + - A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) -; - -AA33 -= -2.*(A13*(A23*ginv12 + A33*ginv13) + A23*A33*ginv23) + ginv11*pow2(A13) + - ginv22*pow2(A23) + ginv33*pow2(A33) -; - -cdA111 -= -dA111 - 2.*(A11*gamma111 + A12*gamma211 + A13*gamma311) -; - -cdA112 -= -dA112 - A11*gamma112 - A22*gamma211 - A12*(gamma111 + gamma212) - - A23*gamma311 - A13*gamma312 -; - -cdA113 -= -dA113 - A11*gamma113 - A23*gamma211 - A12*gamma213 - A33*gamma311 - - A13*(gamma111 + gamma313) -; - -cdA122 -= -dA122 - 2.*(A12*gamma112 + A22*gamma212 + A23*gamma312) -; - -cdA123 -= -dA123 - A13*gamma112 - A12*gamma113 - A22*gamma213 - A33*gamma312 - - A23*(gamma212 + gamma313) -; - -cdA133 -= -dA133 - 2.*(A13*gamma113 + A23*gamma213 + A33*gamma313) -; - -cdA211 -= -dA211 - 2.*(A11*gamma112 + A12*gamma212 + A13*gamma312) -; - -cdA212 -= -dA212 - A11*gamma122 - A22*gamma212 - A12*(gamma112 + gamma222) - - A23*gamma312 - A13*gamma322 -; - -cdA213 -= -dA213 - A11*gamma123 - A23*gamma212 - A12*gamma223 - A33*gamma312 - - A13*(gamma112 + gamma323) -; - -cdA222 -= -dA222 - 2.*(A12*gamma122 + A22*gamma222 + A23*gamma322) -; - -cdA223 -= -dA223 - A13*gamma122 - A12*gamma123 - A22*gamma223 - A33*gamma322 - - A23*(gamma222 + gamma323) -; - -cdA233 -= -dA233 - 2.*(A13*gamma123 + A23*gamma223 + A33*gamma323) -; - -cdA311 -= -dA311 - 2.*(A11*gamma113 + A12*gamma213 + A13*gamma313) -; - -cdA312 -= -dA312 - A11*gamma123 - A22*gamma213 - A12*(gamma113 + gamma223) - - A23*gamma313 - A13*gamma323 -; - -cdA313 -= -dA313 - A11*gamma133 - A23*gamma213 - A12*gamma233 - A33*gamma313 - - A13*(gamma113 + gamma333) -; - -cdA322 -= -dA322 - 2.*(A12*gamma123 + A22*gamma223 + A23*gamma323) -; - -cdA323 -= -dA323 - A13*gamma123 - A12*gamma133 - A22*gamma233 - A33*gamma323 - - A23*(gamma223 + gamma333) -; - -cdA333 -= -dA333 - 2.*(A13*gamma133 + A23*gamma233 + A33*gamma333) -; - -divbeta -= -db11 + db22 + db33 -; - -totdivbeta -= -0.66666666666666666667*divbeta -; - -lieA11 -= -beta1*dA111 + beta2*dA211 + beta3*dA311 + - 2.*(A11*db11 + A12*db12 + A13*db13) - A11*totdivbeta -; - -lieA12 -= -beta1*dA112 + beta2*dA212 + beta3*dA312 + A22*db12 + A23*db13 + A11*db21 + - A13*db23 + A12*(db11 + db22 - totdivbeta) -; - -lieA13 -= -beta1*dA113 + beta2*dA213 + beta3*dA313 + A23*db12 + A33*db13 + A11*db31 + - A12*db32 + A13*(db11 + db33 - totdivbeta) -; - -lieA22 -= -beta1*dA122 + beta2*dA222 + beta3*dA322 + - 2.*(A12*db21 + A22*db22 + A23*db23) - A22*totdivbeta -; - -lieA23 -= -beta1*dA123 + beta2*dA223 + beta3*dA323 + A13*db21 + A33*db23 + A12*db31 + - A22*db32 + A23*(db22 + db33 - totdivbeta) -; - -lieA33 -= -beta1*dA133 + beta2*dA233 + beta3*dA333 + - 2.*(A13*db31 + A23*db32 + A33*db33) - A33*totdivbeta -; - -DTheta -= -dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 -; - -rACss -= -2.*((A23*alpha*K + lieA23)*sup2*sup3 + - sup1*((A12*alpha*K + lieA12)*sup2 + A13*alpha*K*sup3) + - psim4*((-cdda23 + alpha*Rf23)*sup2*sup3 + - sup1*((-cdda12 + alpha*Rf12)*sup2 - cdda13*sup3))) + - 0.66666666666666666667*(g13*sup1 + g23*sup2)*sup3*trcdda + - sup1*(2.*(-(AA31*alpha) + lieA13)*sup3 + - 0.66666666666666666667*g12*sup2*trcdda) + - (lieA11 + psim4*(-cdda11 + alpha*Rf11) + - 0.33333333333333333333*g11*(-(alpha*Rhat) + trcdda))*pow2(sup1) + - (lieA22 - cdda22*psim4 + alpha* - (A22*K + psim4*Rf22 - 0.33333333333333333333*g22*Rhat) + - 0.33333333333333333333*g22*trcdda)*pow2(sup2) + - (lieA33 - cdda33*psim4 + alpha* - (A33*K + psim4*Rf33 - 0.33333333333333333333*g33*Rhat) + - 0.33333333333333333333*g33*trcdda)*pow2(sup3) + - alpha*(ginv11*((-2.*cdA111*chi + 3.*A11*dchi1)*sup1 + - (-2.*cdA112*chi + 3.*A12*dchi1)*sup2 + - (-2.*cdA113*chi + 3.*A13*dchi1)*sup3) + - ginv22*((-2.*cdA212*chi + 3.*A12*dchi2)*sup1 + - (-2.*cdA222*chi + 3.*A22*dchi2)*sup2 + - (-2.*cdA223*chi + 3.*A23*dchi2)*sup3) + - ginv33*((-2.*cdA313*chi + 3.*A13*dchi3)*sup1 + - (-2.*cdA323*chi + 3.*A23*dchi3)*sup2 + - (-2.*cdA333*chi + 3.*A33*dchi3)*sup3) + - chi*(-2.*DTheta + 1.3333333333333333333* - (dK1*sup1 + dK2*sup2 + dK3*sup3)) + - ginv12*((-2.*cdA212*chi + 3.*A12*dchi2)*sup2 + - (-2.*cdA213*chi + 3.*A13*dchi2)*sup3 - - 2.*chi*((cdA112 + cdA211)*sup1 + cdA122*sup2 + cdA123*sup3) + - 3.*((A12*dchi1 + A11*dchi2)*sup1 + dchi1*(A22*sup2 + A23*sup3))) + - ginv13*((-2.*cdA312*chi + 3.*A12*dchi3)*sup2 + - (-2.*cdA313*chi + 3.*A13*dchi3)*sup3 - - 2.*chi*((cdA113 + cdA311)*sup1 + cdA123*sup2 + cdA133*sup3) + - 3.*((A13*dchi1 + A11*dchi3)*sup1 + dchi1*(A23*sup2 + A33*sup3))) + - ginv23*((-2.*cdA322*chi + 3.*A22*dchi3)*sup2 + - (-2.*cdA323*chi + 3.*A23*dchi3)*sup3 - - 2.*chi*((cdA213 + cdA312)*sup1 + cdA223*sup2 + cdA233*sup3) + - 3.*((A13*dchi2 + A12*dchi3)*sup1 + dchi2*(A23*sup2 + A33*sup3))) + - (0.33333333333333333333*((dG11 - dGfromgdu11)*qud11 + - (dG12 - dGfromgdu12)*qud12 + (dG13 - dGfromgdu13)*qud13 + - (dG21 - dGfromgdu21)*qud21 + (dG22 - dGfromgdu22)*qud22 + - (dG23 - dGfromgdu23)*qud23 + (dG31 - dGfromgdu31)*qud31 + - (dG32 - dGfromgdu32)*qud32 + (dG33 - dGfromgdu33)*qud33) + - kappa1*((G1 - Gfromg1)*sdown1 + (G2 - Gfromg2)*sdown2 + - (G3 - Gfromg3)*sdown3) + - 0.66666666666666666667* - ((dGfromgdu21*sdown1 + dGfromgdu22*sdown2)*sup2 + - sdown3*((-dG13 + dGfromgdu13)*sup1 - dG23*sup2 - dG33*sup3) + - sdown1*((-dG11 + dGfromgdu11)*sup1 - dG21*sup2 - dG31*sup3 + - dGfromgdu31*sup3) + - sdown2*((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3 + - dGfromgdu32*sup3)))*pow2(chi) + - 0.66666666666666666667*sup2* - (-(Rhat*(g12*sup1 + g23*sup3)) + dGfromgdu23*sdown3*pow2(chi)) + - sup3*((2.*psim4*Rf13 - 0.66666666666666666667*g13*Rhat)*sup1 + - 0.66666666666666666667*dGfromgdu33*sdown3*pow2(chi)) + - (-2.*AA11 + A11*K)*pow2(sup1) - - 2.*((AA23 + AA32)*sup2*sup3 + sup1*((AA12 + AA21)*sup2 + AA13*sup3) + - AA22*pow2(sup2) + AA33*pow2(sup3))) -; - -rACsA1 -= -(qud11*(lieA11 + alpha*chi*Rf11) + - qud21*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + - qud31*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + - qud11*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + - (A13*alpha*K + lieA13)*sup3 + - alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + - qud21*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + - (A23*alpha*K + lieA23)*sup3 + - alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + - qud31*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + - (A33*alpha*K + lieA33)*sup3 + - alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + - alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud11 + - (-(cdA112*chi) + 1.5*A12*dchi1)*qud21 + - (-(cdA113*chi) + 1.5*A13*dchi1)*qud31) + - ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud11 + - (-(cdA222*chi) + 1.5*A22*dchi2)*qud21 + - (-(cdA223*chi) + 1.5*A23*dchi2)*qud31) + - ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud11 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud21 + - (-(cdA333*chi) + 1.5*A33*dchi3)*qud31) + - chi*((0.66666666666666666667*dK1 - dTheta1)*qud11 + - (0.66666666666666666667*dK2 - dTheta2)*qud21 + - (0.66666666666666666667*dK3 - dTheta3)*qud31) + - ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud21 + - (-(cdA213*chi) + 1.5*A13*dchi2)*qud31 - - chi*((cdA112 + cdA211)*qud11 + cdA122*qud21 + cdA123*qud31) + - 1.5*((A12*dchi1 + A11*dchi2)*qud11 + dchi1*(A22*qud21 + A23*qud31))\ -) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud21 + - (-(cdA313*chi) + 1.5*A13*dchi3)*qud31 - - chi*((cdA113 + cdA311)*qud11 + cdA123*qud21 + cdA133*qud31) + - 1.5*((A13*dchi1 + A11*dchi3)*qud11 + dchi1*(A23*qud21 + A33*qud31))\ -) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud21 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud31 - - chi*((cdA213 + cdA312)*qud11 + cdA223*qud21 + cdA233*qud31) + - 1.5*((A13*dchi2 + A12*dchi3)*qud11 + dchi2*(A23*qud21 + A33*qud31))\ -) + 0.5*(kappa1*((G1 - Gfromg1)*qdd11 + (G2 - Gfromg2)*qdd12 + - (G3 - Gfromg3)*qdd13) - dG13*qdd13*sup1 - dG21*qdd11*sup2 + - (dGfromgdu22*qdd12 - dG23*qdd13)*sup2 + - (dGfromgdu31*qdd11 + dGfromgdu32*qdd12 - dG33*qdd13)*sup3 + - qdd11*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - - dG31*sup3) + qdd12* - ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + - sup1*(-2.*AA11*qud11 + 0.5*dGfromgdu13*qdd13*pow2(chi))) + - sup2*(chi*(-(cdda12*qud11) - cdda22*qud21 - cdda23*qud31 + - alpha*qud21*Rf22) + alpha* - (chi*(qud11*Rf12 + qud31*Rf23) + 0.5*dGfromgdu23*qdd13*pow2(chi))) + - sup3*(chi*(-(cdda13*qud11) - cdda23*qud21 - cdda33*qud31 + - alpha*qud21*Rf23) + alpha* - (chi*(qud11*Rf13 + qud31*Rf33) + 0.5*dGfromgdu33*qdd13*pow2(chi))) -; - -rACsA2 -= -(qud12*(lieA11 + alpha*chi*Rf11) + - qud22*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + - qud32*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + - qud12*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + - (A13*alpha*K + lieA13)*sup3 + - alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + - qud22*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + - (A23*alpha*K + lieA23)*sup3 + - alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + - qud32*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + - (A33*alpha*K + lieA33)*sup3 + - alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + - alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud12 + - (-(cdA112*chi) + 1.5*A12*dchi1)*qud22 + - (-(cdA113*chi) + 1.5*A13*dchi1)*qud32) + - ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud12 + - (-(cdA222*chi) + 1.5*A22*dchi2)*qud22 + - (-(cdA223*chi) + 1.5*A23*dchi2)*qud32) + - ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud12 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud22 + - (-(cdA333*chi) + 1.5*A33*dchi3)*qud32) + - chi*((0.66666666666666666667*dK1 - dTheta1)*qud12 + - (0.66666666666666666667*dK2 - dTheta2)*qud22 + - (0.66666666666666666667*dK3 - dTheta3)*qud32) + - ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud22 + - (-(cdA213*chi) + 1.5*A13*dchi2)*qud32 - - chi*((cdA112 + cdA211)*qud12 + cdA122*qud22 + cdA123*qud32) + - 1.5*((A12*dchi1 + A11*dchi2)*qud12 + dchi1*(A22*qud22 + A23*qud32))\ -) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud22 + - (-(cdA313*chi) + 1.5*A13*dchi3)*qud32 - - chi*((cdA113 + cdA311)*qud12 + cdA123*qud22 + cdA133*qud32) + - 1.5*((A13*dchi1 + A11*dchi3)*qud12 + dchi1*(A23*qud22 + A33*qud32))\ -) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud22 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud32 - - chi*((cdA213 + cdA312)*qud12 + cdA223*qud22 + cdA233*qud32) + - 1.5*((A13*dchi2 + A12*dchi3)*qud12 + dchi2*(A23*qud22 + A33*qud32))\ -) + 0.5*(kappa1*((G1 - Gfromg1)*qdd12 + (G2 - Gfromg2)*qdd22 + - (G3 - Gfromg3)*qdd23) - dG13*qdd23*sup1 - dG21*qdd12*sup2 + - (dGfromgdu22*qdd22 - dG23*qdd23)*sup2 + - (dGfromgdu31*qdd12 + dGfromgdu32*qdd22 - dG33*qdd23)*sup3 + - qdd12*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - - dG31*sup3) + qdd22* - ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + - sup1*(-2.*AA11*qud12 + 0.5*dGfromgdu13*qdd23*pow2(chi))) + - sup2*(chi*(-(cdda12*qud12) - cdda22*qud22 - cdda23*qud32 + - alpha*qud22*Rf22) + alpha* - (chi*(qud12*Rf12 + qud32*Rf23) + 0.5*dGfromgdu23*qdd23*pow2(chi))) + - sup3*(chi*(-(cdda13*qud12) - cdda23*qud22 - cdda33*qud32 + - alpha*qud22*Rf23) + alpha* - (chi*(qud12*Rf13 + qud32*Rf33) + 0.5*dGfromgdu33*qdd23*pow2(chi))) -; - -rACsA3 -= -(qud13*(lieA11 + alpha*chi*Rf11) + - qud23*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + - qud33*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + - qud13*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + - (A13*alpha*K + lieA13)*sup3 + - alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + - qud23*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + - (A23*alpha*K + lieA23)*sup3 + - alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + - qud33*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + - (A33*alpha*K + lieA33)*sup3 + - alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + - alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud13 + - (-(cdA112*chi) + 1.5*A12*dchi1)*qud23 + - (-(cdA113*chi) + 1.5*A13*dchi1)*qud33) + - ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud13 + - (-(cdA222*chi) + 1.5*A22*dchi2)*qud23 + - (-(cdA223*chi) + 1.5*A23*dchi2)*qud33) + - ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud13 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud23 + - (-(cdA333*chi) + 1.5*A33*dchi3)*qud33) + - chi*((0.66666666666666666667*dK1 - dTheta1)*qud13 + - (0.66666666666666666667*dK2 - dTheta2)*qud23 + - (0.66666666666666666667*dK3 - dTheta3)*qud33) + - ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud23 + - (-(cdA213*chi) + 1.5*A13*dchi2)*qud33 - - chi*((cdA112 + cdA211)*qud13 + cdA122*qud23 + cdA123*qud33) + - 1.5*((A12*dchi1 + A11*dchi2)*qud13 + dchi1*(A22*qud23 + A23*qud33))\ -) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud23 + - (-(cdA313*chi) + 1.5*A13*dchi3)*qud33 - - chi*((cdA113 + cdA311)*qud13 + cdA123*qud23 + cdA133*qud33) + - 1.5*((A13*dchi1 + A11*dchi3)*qud13 + dchi1*(A23*qud23 + A33*qud33))\ -) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud23 + - (-(cdA323*chi) + 1.5*A23*dchi3)*qud33 - - chi*((cdA213 + cdA312)*qud13 + cdA223*qud23 + cdA233*qud33) + - 1.5*((A13*dchi2 + A12*dchi3)*qud13 + dchi2*(A23*qud23 + A33*qud33))\ -) + 0.5*(kappa1*((G1 - Gfromg1)*qdd13 + (G2 - Gfromg2)*qdd23 + - (G3 - Gfromg3)*qdd33) - dG13*qdd33*sup1 - dG21*qdd13*sup2 + - (dGfromgdu22*qdd23 - dG23*qdd33)*sup2 + - (dGfromgdu31*qdd13 + dGfromgdu32*qdd23 - dG33*qdd33)*sup3 + - qdd13*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - - dG31*sup3) + qdd23* - ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + - sup1*(-2.*AA11*qud13 + 0.5*dGfromgdu13*qdd33*pow2(chi))) + - sup2*(chi*(-(cdda12*qud13) - cdda22*qud23 - cdda23*qud33 + - alpha*qud23*Rf22) + alpha* - (chi*(qud13*Rf12 + qud33*Rf23) + 0.5*dGfromgdu23*qdd33*pow2(chi))) + - sup3*(chi*(-(cdda13*qud13) - cdda23*qud23 - cdda33*qud33 + - alpha*qud23*Rf23) + alpha* - (chi*(qud13*Rf13 + qud33*Rf33) + 0.5*dGfromgdu33*qdd33*pow2(chi))) -; - -rACABTF11 -= --(qPhysuudd1211*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3311*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1111*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1211* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1311*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2211*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2311*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1311 + AA22*qPhysuudd2211 + AA23*qPhysuudd2311 + - AA33*qPhysuudd3311 + qPhysuudd1111*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1311 + - (0.5*(A12*dchi1*qPhysuudd1111 + A23*dchi3*qPhysuudd3311))/chi)* - sup2) - qPhysuudd3311*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1211*sup3 + - qPhysuudd1211*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1311*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2211* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2311*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2311*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1211 + A13*dchi2*qPhysuudd1311)*sup2 + - (A12*dchi3*qPhysuudd1211 - - 0.5*dchi1*(A13*qPhysuudd1111 + A23*qPhysuudd1211))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1211 - - dchi3*(A11*qPhysuudd1311 + A12*qPhysuudd2311) + - dchi1*(A22*qPhysuudd2211 + A33*qPhysuudd3311))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1311) - - A22*dchi3*qPhysuudd2311 + - dchi2*(A11*qPhysuudd1111 + A33*qPhysuudd3311))*sup2 + - (-(A33*dchi1*qPhysuudd1311) + - A13*(-(dchi2*qPhysuudd1211) + dchi3*qPhysuudd1311) + - dchi3*(A11*qPhysuudd1111 + A22*qPhysuudd2211) + - A23*(-(dchi2*qPhysuudd2211) + dchi3*qPhysuudd2311))*sup3))/chi) -; - -rACABTF12 -= --(qPhysuudd1212*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3312*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1112*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1212* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1312*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2212*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2312*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1312 + AA22*qPhysuudd2212 + AA23*qPhysuudd2312 + - AA33*qPhysuudd3312 + qPhysuudd1112*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1312 + - (0.5*(A12*dchi1*qPhysuudd1112 + A23*dchi3*qPhysuudd3312))/chi)* - sup2) - qPhysuudd3312*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1212*sup3 + - qPhysuudd1212*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1312*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2212* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2312*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2312*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1212 + A13*dchi2*qPhysuudd1312)*sup2 + - (A12*dchi3*qPhysuudd1212 - - 0.5*dchi1*(A13*qPhysuudd1112 + A23*qPhysuudd1212))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1212 - - dchi3*(A11*qPhysuudd1312 + A12*qPhysuudd2312) + - dchi1*(A22*qPhysuudd2212 + A33*qPhysuudd3312))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1312) - - A22*dchi3*qPhysuudd2312 + - dchi2*(A11*qPhysuudd1112 + A33*qPhysuudd3312))*sup2 + - (-(A33*dchi1*qPhysuudd1312) + - A13*(-(dchi2*qPhysuudd1212) + dchi3*qPhysuudd1312) + - dchi3*(A11*qPhysuudd1112 + A22*qPhysuudd2212) + - A23*(-(dchi2*qPhysuudd2212) + dchi3*qPhysuudd2312))*sup3))/chi) -; - -rACABTF13 -= --(qPhysuudd1213*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3313*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1113*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1213* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1313*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2213*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2313*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1313 + AA22*qPhysuudd2213 + AA23*qPhysuudd2313 + - AA33*qPhysuudd3313 + qPhysuudd1113*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1313 + - (0.5*(A12*dchi1*qPhysuudd1113 + A23*dchi3*qPhysuudd3313))/chi)* - sup2) - qPhysuudd3313*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1213*sup3 + - qPhysuudd1213*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1313*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2213* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2313*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2313*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1213 + A13*dchi2*qPhysuudd1313)*sup2 + - (A12*dchi3*qPhysuudd1213 - - 0.5*dchi1*(A13*qPhysuudd1113 + A23*qPhysuudd1213))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1213 - - dchi3*(A11*qPhysuudd1313 + A12*qPhysuudd2313) + - dchi1*(A22*qPhysuudd2213 + A33*qPhysuudd3313))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1313) - - A22*dchi3*qPhysuudd2313 + - dchi2*(A11*qPhysuudd1113 + A33*qPhysuudd3313))*sup2 + - (-(A33*dchi1*qPhysuudd1313) + - A13*(-(dchi2*qPhysuudd1213) + dchi3*qPhysuudd1313) + - dchi3*(A11*qPhysuudd1113 + A22*qPhysuudd2213) + - A23*(-(dchi2*qPhysuudd2213) + dchi3*qPhysuudd2313))*sup3))/chi) -; - -rACABTF22 -= --(qPhysuudd1222*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3322*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1122*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1222* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1322*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2222*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2322*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1322 + AA22*qPhysuudd2222 + AA23*qPhysuudd2322 + - AA33*qPhysuudd3322 + qPhysuudd1122*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1322 + - (0.5*(A12*dchi1*qPhysuudd1122 + A23*dchi3*qPhysuudd3322))/chi)* - sup2) - qPhysuudd3322*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1222*sup3 + - qPhysuudd1222*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1322*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2222* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2322*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2322*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1222 + A13*dchi2*qPhysuudd1322)*sup2 + - (A12*dchi3*qPhysuudd1222 - - 0.5*dchi1*(A13*qPhysuudd1122 + A23*qPhysuudd1222))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1222 - - dchi3*(A11*qPhysuudd1322 + A12*qPhysuudd2322) + - dchi1*(A22*qPhysuudd2222 + A33*qPhysuudd3322))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1322) - - A22*dchi3*qPhysuudd2322 + - dchi2*(A11*qPhysuudd1122 + A33*qPhysuudd3322))*sup2 + - (-(A33*dchi1*qPhysuudd1322) + - A13*(-(dchi2*qPhysuudd1222) + dchi3*qPhysuudd1322) + - dchi3*(A11*qPhysuudd1122 + A22*qPhysuudd2222) + - A23*(-(dchi2*qPhysuudd2222) + dchi3*qPhysuudd2322))*sup3))/chi) -; - -rACABTF23 -= --(qPhysuudd1223*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3323*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1123*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1223* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1323*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2223*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2323*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1323 + AA22*qPhysuudd2223 + AA23*qPhysuudd2323 + - AA33*qPhysuudd3323 + qPhysuudd1123*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1323 + - (0.5*(A12*dchi1*qPhysuudd1123 + A23*dchi3*qPhysuudd3323))/chi)* - sup2) - qPhysuudd3323*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1223*sup3 + - qPhysuudd1223*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1323*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2223* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2323*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2323*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1223 + A13*dchi2*qPhysuudd1323)*sup2 + - (A12*dchi3*qPhysuudd1223 - - 0.5*dchi1*(A13*qPhysuudd1123 + A23*qPhysuudd1223))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1223 - - dchi3*(A11*qPhysuudd1323 + A12*qPhysuudd2323) + - dchi1*(A22*qPhysuudd2223 + A33*qPhysuudd3323))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1323) - - A22*dchi3*qPhysuudd2323 + - dchi2*(A11*qPhysuudd1123 + A33*qPhysuudd3323))*sup2 + - (-(A33*dchi1*qPhysuudd1323) + - A13*(-(dchi2*qPhysuudd1223) + dchi3*qPhysuudd1323) + - dchi3*(A11*qPhysuudd1123 + A22*qPhysuudd2223) + - A23*(-(dchi2*qPhysuudd2223) + dchi3*qPhysuudd2323))*sup3))/chi) -; - -rACABTF33 -= --(qPhysuudd1233*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + - qPhysuudd3333*(-(cdda33*chi) + lieA33 + - alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + - qPhysuudd1133*(-(cdda11*chi) + lieA11 + - alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + - cdA113*sup3)) + qPhysuudd1233* - (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + - cdA122*sup2 + cdA123*sup3)) + - qPhysuudd1333*(2.*(-(cdda13*chi) + lieA13) + - alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + - cdA123*sup2 + cdA133*sup3)) + - qPhysuudd2233*(-(cdda22*chi) + lieA22 + - alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + - qPhysuudd2333*(2.*(-(cdda23*chi) + lieA23) + - alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + - cdA322*sup2 + cdA233*sup3)) - - alpha*(AA13*qPhysuudd1333 + AA22*qPhysuudd2233 + AA23*qPhysuudd2333 + - AA33*qPhysuudd3333 + qPhysuudd1133*(cdA211*sup2 + cdA311*sup3)) + - alpha*(-((2.*cdA213*qPhysuudd1333 + - (0.5*(A12*dchi1*qPhysuudd1133 + A23*dchi3*qPhysuudd3333))/chi)* - sup2) - qPhysuudd3333*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + - cdA233*sup2) - 2.*cdA312*qPhysuudd1233*sup3 + - qPhysuudd1233*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + - qPhysuudd1333*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - - cdA313*sup3) - qPhysuudd2233* - ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + - qPhysuudd2333*((cdA312 + (A23*dchi1)/chi)*sup1 + - (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - - qPhysuudd2333*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + - (0.5*A33*dchi2*sup3)/chi) + - ((-0.5*A22*dchi1*qPhysuudd1233 + A13*dchi2*qPhysuudd1333)*sup2 + - (A12*dchi3*qPhysuudd1233 - - 0.5*dchi1*(A13*qPhysuudd1133 + A23*qPhysuudd1233))*sup3 + - 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1233 - - dchi3*(A11*qPhysuudd1333 + A12*qPhysuudd2333) + - dchi1*(A22*qPhysuudd2233 + A33*qPhysuudd3333))*sup1 + - (-((A23*dchi1 + A12*dchi3)*qPhysuudd1333) - - A22*dchi3*qPhysuudd2333 + - dchi2*(A11*qPhysuudd1133 + A33*qPhysuudd3333))*sup2 + - (-(A33*dchi1*qPhysuudd1333) + - A13*(-(dchi2*qPhysuudd1233) + dchi3*qPhysuudd1333) + - dchi3*(A11*qPhysuudd1133 + A22*qPhysuudd2233) + - A23*(-(dchi2*qPhysuudd2233) + dchi3*qPhysuudd2333))*sup3))/chi) -; - -} /* function */ - -} + + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + + +#define Power(x,y) (pow((double) (x), (double) (y))) +#define Sqrt(x) sqrt(x) +#define Log(x) log((double) (x)) +#define pow2(x) ((x)*(x)) +#define pow3(x) ((x)*(x)*(x)) +#define pow4(x) ((x)*(x)*(x)*(x)) +#define pow2inv(x) (1.0/((x)*(x))) + +#define Cal(x,y,z) ((x)?(y):(z)) + +#define Tan(x) tan(x) +#define ArcTan(x) atan(x) +#define Sin(x) sin(x) +#define Cos(x) cos(x) +#define Csc(x) (1./sin(x)) +#define Abs(x) (fabs(x)) +#define sqrt2 (sqrt(2)) +#define Tanh(x) tanh(x) +#define Sech(x) (1/cosh(x)) + + +extern "C" { + +#ifdef fortran1 +void cpbc_point +#endif +#ifdef fortran2 +void CPBC_POINT +#endif +#ifdef fortran3 +void cpbc_point_ +#endif +(double & r,double & xp,double & yp,double & zp, + double & Theta,double & chi,double & Khat, + double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, + double & A11,double & A12,double & A13,double & A22,double & A23,double & A33, + double & G1,double & G2,double & G3, + double & alpha,double & beta1,double & beta2,double & beta3, + double & da1,double & da2,double & da3, + double & dda11,double & dda12,double & dda13,double & dda22,double & dda23,double & dda33, + double & db11,double & db21,double & db31, + double & db12,double & db22,double & db32, + double & db13,double & db23,double & db33, + double & ddb111,double & ddb121,double & ddb131,double & ddb221,double & ddb231,double & ddb331, + double & ddb112,double & ddb122,double & ddb132,double & ddb222,double & ddb232,double & ddb332, + double & ddb113,double & ddb123,double & ddb133,double & ddb223,double & ddb233,double & ddb333, + double & dchi1,double & dchi2,double & dchi3, + double & ddchi11,double & ddchi12,double & ddchi13,double & ddchi22,double & ddchi23,double & ddchi33, + double & dg111,double & dg112,double & dg113,double & dg122,double & dg123,double & dg133, + double & dg211,double & dg212,double & dg213,double & dg222,double & dg223,double & dg233, + double & dg311,double & dg312,double & dg313,double & dg322,double & dg323,double & dg333, + double & ddg1111,double & ddg1211,double & ddg1311,double & ddg2211,double & ddg2311,double & ddg3311, + double & ddg1112,double & ddg1212,double & ddg1312,double & ddg2212,double & ddg2312,double & ddg3312, + double & ddg1113,double & ddg1213,double & ddg1313,double & ddg2213,double & ddg2313,double & ddg3313, + double & ddg1122,double & ddg1222,double & ddg1322,double & ddg2222,double & ddg2322,double & ddg3322, + double & ddg1123,double & ddg1223,double & ddg1323,double & ddg2223,double & ddg2323,double & ddg3323, + double & ddg1133,double & ddg1233,double & ddg1333,double & ddg2233,double & ddg2333,double & ddg3333, + double & dKhat1,double & dKhat2,double & dKhat3, + double & dA111,double & dA112,double & dA113,double & dA122,double & dA123,double & dA133, + double & dA211,double & dA212,double & dA213,double & dA222,double & dA223,double & dA233, + double & dA311,double & dA312,double & dA313,double & dA322,double & dA323,double & dA333, + double & dG11,double & dG21,double & dG31, + double & dG12,double & dG22,double & dG32, + double & dG13,double & dG23,double & dG33, + double & dTheta1,double & dTheta2,double & dTheta3, + double & rKhat,double & rTheta, + double & rA11,double & rA12,double & rA13,double & rA22,double & rA23,double & rA33, + double & rG1,double & rG2,double & rG3, + double &kappa1,double &kappa2,double &shiftdriver) +{ + +double AA11; +double AA12; +double AA13; +double AA21; +double AA22; +double AA23; +double AA31; +double AA32; +double AA33; +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double Ainv11; +double Ainv12; +double Ainv13; +double Ainv22; +double Ainv23; +double Ainv33; +double betaA1; +double betaA2; +double betaA3; +double betas; +double cdA111; +double cdA112; +double cdA113; +double cdA122; +double cdA123; +double cdA133; +double cdA211; +double cdA212; +double cdA213; +double cdA222; +double cdA223; +double cdA233; +double cdA311; +double cdA312; +double cdA313; +double cdA322; +double cdA323; +double cdA333; +double cdda11; +double cdda12; +double cdda13; +double cdda22; +double cdda23; +double cdda33; +double cddf11; +double cddf12; +double cddf13; +double cddf22; +double cddf23; +double cddf33; +const double chipsipower = -4; +double Dalpha; +double DbetaA1; +double DbetaA2; +double DbetaA3; +double Dbetas; +double ddf11; +double ddf12; +double ddf13; +double ddf22; +double ddf23; +double ddf33; +double detginv; +double df1; +double df2; +double df3; +double DGamA1; +double DGamA2; +double DGamA3; +double DGams; +double dGfromgdu11; +double dGfromgdu12; +double dGfromgdu13; +double dGfromgdu21; +double dGfromgdu22; +double dGfromgdu23; +double dGfromgdu31; +double dGfromgdu32; +double dGfromgdu33; +double dginv111; +double dginv112; +double dginv113; +double dginv122; +double dginv123; +double dginv133; +double dginv211; +double dginv212; +double dginv213; +double dginv222; +double dginv223; +double dginv233; +double dginv311; +double dginv312; +double dginv313; +double dginv322; +double dginv323; +double dginv333; +double divbeta; +double DK; +double dK1; +double dK2; +double dK3; +double DKhat; +double DTheta; +double f; +double ff; +double gADM11; +double gADM12; +double gADM13; +double gADM21; +double gADM22; +double gADM23; +double gADM31; +double gADM32; +double gADM33; +double GamA1; +double GamA2; +double GamA3; +double gamma111; +double gamma112; +double gamma113; +double gamma122; +double gamma123; +double gamma133; +double gamma211; +double gamma212; +double gamma213; +double gamma222; +double gamma223; +double gamma233; +double gamma311; +double gamma312; +double gamma313; +double gamma322; +double gamma323; +double gamma333; +double gammado111; +double gammado112; +double gammado113; +double gammado122; +double gammado123; +double gammado133; +double gammado211; +double gammado212; +double gammado213; +double gammado222; +double gammado223; +double gammado233; +double gammado311; +double gammado312; +double gammado313; +double gammado322; +double gammado323; +double gammado333; +double Gams; +double Gfromg1; +double Gfromg2; +double Gfromg3; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +const bool givehPsi0 = false; +const double hPsi0para = 0; +const double hPsi0parb = 0; +const double hPsi0parc = 0; +double ImhPsi0; +double K; +double lieA11; +double lieA12; +double lieA13; +double lieA22; +double lieA23; +double lieA33; +double lieg11; +double lieg12; +double lieg13; +double lieg22; +double lieg23; +double lieg33; +double lienK; +double lienKhat; +double lienTheta; +double modshatARG; +double muL; +double muStilde; +double oochipsipower; +double oomodshat; +double psim4; +double qdd11; +double qdd12; +double qdd13; +double qdd22; +double qdd23; +double qdd33; +double qPhysuudd1111; +double qPhysuudd1112; +double qPhysuudd1113; +double qPhysuudd1122; +double qPhysuudd1123; +double qPhysuudd1133; +double qPhysuudd1211; +double qPhysuudd1212; +double qPhysuudd1213; +double qPhysuudd1222; +double qPhysuudd1223; +double qPhysuudd1233; +double qPhysuudd1311; +double qPhysuudd1312; +double qPhysuudd1313; +double qPhysuudd1322; +double qPhysuudd1323; +double qPhysuudd1333; +double qPhysuudd2211; +double qPhysuudd2212; +double qPhysuudd2213; +double qPhysuudd2222; +double qPhysuudd2223; +double qPhysuudd2233; +double qPhysuudd2311; +double qPhysuudd2312; +double qPhysuudd2313; +double qPhysuudd2322; +double qPhysuudd2323; +double qPhysuudd2333; +double qPhysuudd3311; +double qPhysuudd3312; +double qPhysuudd3313; +double qPhysuudd3322; +double qPhysuudd3323; +double qPhysuudd3333; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double quu11; +double quu12; +double quu13; +double quu22; +double quu23; +double quu33; +double R11; +double R12; +double R13; +double R22; +double R23; +double R33; +double rACABTF11; +double rACABTF12; +double rACABTF13; +double rACABTF22; +double rACABTF23; +double rACABTF33; +double rACqq; +double rACsA1; +double rACsA2; +double rACsA3; +double rACss; +double RehPsi0; +double Rf11; +double Rf12; +double Rf13; +double Rf22; +double Rf23; +double Rf33; +double rGamA1; +double rGamA2; +double rGamA3; +double rGams; +double Rhat; +double Rphi11; +double Rphi12; +double Rphi13; +double Rphi22; +double Rphi23; +double Rphi33; +double sdotv; +double sdotw; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; +const double time = 0; +double totdivbeta; +double trcdda; +double trcddf; +double vbetaA; +double vbetas; +double vd1; +double vd2; +double vd3; +double vdotv; +double vdotw; +double vu1; +double vu2; +double vu3; +double wd1; +double wd2; +double wd3; +double wdotw; +double wu1; +double wu2; +double wu3; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +#if 0 +// my code +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +qdd11 += +g11/chi - pow2(sdown1) +; + +qdd12 += +g12/chi - sdown1*sdown2 +; + +qdd13 += +g13/chi - sdown1*sdown3 +; + +qdd22 += +g22/chi - pow2(sdown2) +; + +qdd23 += +g23/chi - sdown2*sdown3 +; + +qdd33 += +g33/chi - pow2(sdown3) +; + +quu11 += +ADMginv11 - pow2(sup1) +; + +quu12 += +ADMginv12 - sup1*sup2 +; + +quu13 += +ADMginv13 - sup1*sup3 +; + +quu22 += +ADMginv22 - pow2(sup2) +; + +quu23 += +ADMginv23 - sup2*sup3 +; + +quu33 += +ADMginv33 - pow2(sup3) +; + +qPhysuudd1111 += +-0.5*qdd11*quu11 + pow2(qud11) +; + +qPhysuudd1112 += +qud11*qud12 - 0.5*qdd12*quu11 +; + +qPhysuudd1113 += +qud11*qud13 - 0.5*qdd13*quu11 +; + +qPhysuudd1122 += +-0.5*qdd22*quu11 + pow2(qud12) +; + +qPhysuudd1123 += +qud12*qud13 - 0.5*qdd23*quu11 +; + +qPhysuudd1133 += +-0.5*qdd33*quu11 + pow2(qud13) +; + +qPhysuudd1211 += +qud11*qud21 - 0.5*qdd11*quu12 +; + +qPhysuudd1212 += +0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) +; + +qPhysuudd1213 += +0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) +; + +qPhysuudd1222 += +qud12*qud22 - 0.5*qdd22*quu12 +; + +qPhysuudd1223 += +0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) +; + +qPhysuudd1233 += +qud13*qud23 - 0.5*qdd33*quu12 +; + +qPhysuudd1311 += +qud11*qud31 - 0.5*qdd11*quu13 +; + +qPhysuudd1312 += +0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) +; + +qPhysuudd1313 += +0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) +; + +qPhysuudd1322 += +qud12*qud32 - 0.5*qdd22*quu13 +; + +qPhysuudd1323 += +0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) +; + +qPhysuudd1333 += +qud13*qud33 - 0.5*qdd33*quu13 +; + +qPhysuudd2211 += +-0.5*qdd11*quu22 + pow2(qud21) +; + +qPhysuudd2212 += +qud21*qud22 - 0.5*qdd12*quu22 +; + +qPhysuudd2213 += +qud21*qud23 - 0.5*qdd13*quu22 +; + +qPhysuudd2222 += +-0.5*qdd22*quu22 + pow2(qud22) +; + +qPhysuudd2223 += +qud22*qud23 - 0.5*qdd23*quu22 +; + +qPhysuudd2233 += +-0.5*qdd33*quu22 + pow2(qud23) +; + +qPhysuudd2311 += +qud21*qud31 - 0.5*qdd11*quu23 +; + +qPhysuudd2312 += +0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) +; + +qPhysuudd2313 += +0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) +; + +qPhysuudd2322 += +qud22*qud32 - 0.5*qdd22*quu23 +; + +qPhysuudd2323 += +0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) +; + +qPhysuudd2333 += +qud23*qud33 - 0.5*qdd33*quu23 +; + +qPhysuudd3311 += +-0.5*qdd11*quu33 + pow2(qud31) +; + +qPhysuudd3312 += +qud31*qud32 - 0.5*qdd12*quu33 +; + +qPhysuudd3313 += +qud31*qud33 - 0.5*qdd13*quu33 +; + +qPhysuudd3322 += +-0.5*qdd22*quu33 + pow2(qud32) +; + +qPhysuudd3323 += +qud32*qud33 - 0.5*qdd23*quu33 +; + +qPhysuudd3333 += +-0.5*qdd33*quu33 + pow2(qud33) +; + +muL += +2./alpha +; + +muStilde += +1/chi +; + +vbetas += +2.*sqrt(0.33333333333333333333*muStilde) +; + +vbetaA += +sqrt(muStilde) +; + +K += +Khat + 2.*Theta +; + +dK1 += +dKhat1 + 2.*dTheta1 +; + +dK2 += +dKhat2 + 2.*dTheta2 +; + +dK3 += +dKhat3 + 2.*dTheta3 +; + +dginv111 += +-2.*(dg123*ginv12*ginv13 + ginv11*(dg112*ginv12 + dg113*ginv13)) - + dg111*pow2(ginv11) - dg122*pow2(ginv12) - dg133*pow2(ginv13) +; + +dginv112 += +-(ginv11*(dg111*ginv12 + dg112*ginv22 + dg113*ginv23)) - + ginv12*(dg113*ginv13 + dg122*ginv22 + dg123*ginv23) - + ginv13*(dg123*ginv22 + dg133*ginv23) - dg112*pow2(ginv12) +; + +dginv113 += +-(ginv11*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33)) - + ginv12*(dg112*ginv13 + dg122*ginv23 + dg123*ginv33) - + ginv13*(dg123*ginv23 + dg133*ginv33) - dg113*pow2(ginv13) +; + +dginv122 += +-2.*(dg123*ginv22*ginv23 + ginv12*(dg112*ginv22 + dg113*ginv23)) - + dg111*pow2(ginv12) - dg122*pow2(ginv22) - dg133*pow2(ginv23) +; + +dginv123 += +-(ginv13*(dg112*ginv22 + dg113*ginv23)) - dg133*ginv23*ginv33 - + ginv12*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33) - + ginv22*(dg122*ginv23 + dg123*ginv33) - dg123*pow2(ginv23) +; + +dginv133 += +-2.*(dg123*ginv23*ginv33 + ginv13*(dg112*ginv23 + dg113*ginv33)) - + dg111*pow2(ginv13) - dg122*pow2(ginv23) - dg133*pow2(ginv33) +; + +dginv211 += +-2.*(dg223*ginv12*ginv13 + ginv11*(dg212*ginv12 + dg213*ginv13)) - + dg211*pow2(ginv11) - dg222*pow2(ginv12) - dg233*pow2(ginv13) +; + +dginv212 += +-(ginv11*(dg211*ginv12 + dg212*ginv22 + dg213*ginv23)) - + ginv12*(dg213*ginv13 + dg222*ginv22 + dg223*ginv23) - + ginv13*(dg223*ginv22 + dg233*ginv23) - dg212*pow2(ginv12) +; + +dginv213 += +-(ginv11*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33)) - + ginv12*(dg212*ginv13 + dg222*ginv23 + dg223*ginv33) - + ginv13*(dg223*ginv23 + dg233*ginv33) - dg213*pow2(ginv13) +; + +dginv222 += +-2.*(dg223*ginv22*ginv23 + ginv12*(dg212*ginv22 + dg213*ginv23)) - + dg211*pow2(ginv12) - dg222*pow2(ginv22) - dg233*pow2(ginv23) +; + +dginv223 += +-(ginv13*(dg212*ginv22 + dg213*ginv23)) - dg233*ginv23*ginv33 - + ginv12*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33) - + ginv22*(dg222*ginv23 + dg223*ginv33) - dg223*pow2(ginv23) +; + +dginv233 += +-2.*(dg223*ginv23*ginv33 + ginv13*(dg212*ginv23 + dg213*ginv33)) - + dg211*pow2(ginv13) - dg222*pow2(ginv23) - dg233*pow2(ginv33) +; + +dginv311 += +-2.*(dg323*ginv12*ginv13 + ginv11*(dg312*ginv12 + dg313*ginv13)) - + dg311*pow2(ginv11) - dg322*pow2(ginv12) - dg333*pow2(ginv13) +; + +dginv312 += +-(ginv11*(dg311*ginv12 + dg312*ginv22 + dg313*ginv23)) - + ginv12*(dg313*ginv13 + dg322*ginv22 + dg323*ginv23) - + ginv13*(dg323*ginv22 + dg333*ginv23) - dg312*pow2(ginv12) +; + +dginv313 += +-(ginv11*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33)) - + ginv12*(dg312*ginv13 + dg322*ginv23 + dg323*ginv33) - + ginv13*(dg323*ginv23 + dg333*ginv33) - dg313*pow2(ginv13) +; + +dginv322 += +-2.*(dg323*ginv22*ginv23 + ginv12*(dg312*ginv22 + dg313*ginv23)) - + dg311*pow2(ginv12) - dg322*pow2(ginv22) - dg333*pow2(ginv23) +; + +dginv323 += +-(ginv13*(dg312*ginv22 + dg313*ginv23)) - dg333*ginv23*ginv33 - + ginv12*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33) - + ginv22*(dg322*ginv23 + dg323*ginv33) - dg323*pow2(ginv23) +; + +dginv333 += +-2.*(dg323*ginv23*ginv33 + ginv13*(dg312*ginv23 + dg313*ginv33)) - + dg311*pow2(ginv13) - dg322*pow2(ginv23) - dg333*pow2(ginv33) +; + +gammado111 += +0.5*dg111 +; + +gammado112 += +0.5*dg211 +; + +gammado113 += +0.5*dg311 +; + +gammado122 += +-0.5*dg122 + dg212 +; + +gammado123 += +0.5*(-dg123 + dg213 + dg312) +; + +gammado133 += +-0.5*dg133 + dg313 +; + +gammado211 += +dg112 - 0.5*dg211 +; + +gammado212 += +0.5*dg122 +; + +gammado213 += +0.5*(dg123 - dg213 + dg312) +; + +gammado222 += +0.5*dg222 +; + +gammado223 += +0.5*dg322 +; + +gammado233 += +-0.5*dg233 + dg323 +; + +gammado311 += +dg113 - 0.5*dg311 +; + +gammado312 += +0.5*(dg123 + dg213 - dg312) +; + +gammado313 += +0.5*dg133 +; + +gammado322 += +dg223 - 0.5*dg322 +; + +gammado323 += +0.5*dg233 +; + +gammado333 += +0.5*dg333 +; + +gamma111 += +gammado111*ginv11 + gammado211*ginv12 + gammado311*ginv13 +; + +gamma112 += +gammado112*ginv11 + gammado212*ginv12 + gammado312*ginv13 +; + +gamma113 += +gammado113*ginv11 + gammado213*ginv12 + gammado313*ginv13 +; + +gamma122 += +gammado122*ginv11 + gammado222*ginv12 + gammado322*ginv13 +; + +gamma123 += +gammado123*ginv11 + gammado223*ginv12 + gammado323*ginv13 +; + +gamma133 += +gammado133*ginv11 + gammado233*ginv12 + gammado333*ginv13 +; + +gamma211 += +gammado111*ginv12 + gammado211*ginv22 + gammado311*ginv23 +; + +gamma212 += +gammado112*ginv12 + gammado212*ginv22 + gammado312*ginv23 +; + +gamma213 += +gammado113*ginv12 + gammado213*ginv22 + gammado313*ginv23 +; + +gamma222 += +gammado122*ginv12 + gammado222*ginv22 + gammado322*ginv23 +; + +gamma223 += +gammado123*ginv12 + gammado223*ginv22 + gammado323*ginv23 +; + +gamma233 += +gammado133*ginv12 + gammado233*ginv22 + gammado333*ginv23 +; + +gamma311 += +gammado111*ginv13 + gammado211*ginv23 + gammado311*ginv33 +; + +gamma312 += +gammado112*ginv13 + gammado212*ginv23 + gammado312*ginv33 +; + +gamma313 += +gammado113*ginv13 + gammado213*ginv23 + gammado313*ginv33 +; + +gamma322 += +gammado122*ginv13 + gammado222*ginv23 + gammado322*ginv33 +; + +gamma323 += +gammado123*ginv13 + gammado223*ginv23 + gammado323*ginv33 +; + +gamma333 += +gammado133*ginv13 + gammado233*ginv23 + gammado333*ginv33 +; + +Gfromg1 += +gamma111*ginv11 + gamma122*ginv22 + + 2.*(gamma112*ginv12 + gamma113*ginv13 + gamma123*ginv23) + gamma133*ginv33 +; + +Gfromg2 += +gamma211*ginv11 + gamma222*ginv22 + + 2.*(gamma212*ginv12 + gamma213*ginv13 + gamma223*ginv23) + gamma233*ginv33 +; + +Gfromg3 += +gamma311*ginv11 + gamma322*ginv22 + + 2.*(gamma312*ginv12 + gamma313*ginv13 + gamma323*ginv23) + gamma333*ginv33 +; + +dGfromgdu11 += +-((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)* + Power(ginv12,3)) - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + + dg111*dg333)*Power(ginv13,3) - 2.*Power(ginv11,3)*pow2(dg111) + + (ddg1111 - dg111*((8.*dg112 + 2.*dg211)*ginv12 + + (8.*dg113 + 2.*dg311)*ginv13) - + (dg113*(4.*dg112 + dg211) + dg112*dg311 + dg111*(dg213 + dg312))* + ginv23 - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - + ginv33*(dg113*dg311 + dg111*dg313 + 2.*pow2(dg113)))*pow2(ginv11) + + (ddg1122 + ddg1212 - (dg123*(8.*dg112 + 2.*dg211) + + dg113*(4.*dg122 + 2.*dg212) + dg122*dg311 + + 2.*(dg111*dg223 + dg112*(dg213 + dg312)) + dg111*dg322)*ginv13 - + (dg123*(4.*dg122 + 2.*dg212) + + 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* + ginv23 - ginv22*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122)) - + ginv33*(dg123*(dg213 + dg312) + dg122*dg313 + dg113*(dg223 + dg322) + + dg112*dg323 + 2.*pow2(dg123)))*pow2(ginv12) + + (ddg1133 + ddg1313 - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*ginv23 - + ginv22*(dg133*dg212 + dg113*dg223 + dg123*(dg213 + dg312) + + dg112*(dg233 + dg323) + 2.*pow2(dg123)) - + ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133)))*pow2(ginv13) \ ++ ginv13*(ddg1333*ginv33 + ginv22* + (ddg1223 - (dg133*dg222 + dg123*(4.*dg223 + dg322) + + dg122*(dg233 + dg323))*ginv23 - + (dg133*dg223 + dg123*(dg233 + 2.*dg323))*ginv33) + + ginv23*(ddg1233 + ddg1323 - + (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)*ginv33) - + (dg123*dg222 + dg122*dg223)*pow2(ginv22) - + (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + + dg122*dg333)*pow2(ginv23) - 2.*dg133*dg333*pow2(ginv33)) + + ginv11*(ddg1313*ginv33 + ginv12* + (2.*ddg1112 + ddg1211 - + (dg113*(12.*dg112 + 3.*dg211) + 3.*dg112*dg311 + + dg111*(8.*dg123 + 3.*(dg213 + dg312)))*ginv13 - + (dg122*(4.*dg112 + dg211) + 6.*dg112*dg212 + dg111*dg222)*ginv22 - + (dg123*dg211 + dg122*dg311 + + 4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213 + dg312)) + + dg111*(dg223 + dg322))*ginv23 - + (dg123*dg311 + dg113*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*dg112*dg313 + dg111*dg323)*ginv33) + + ginv22*(ddg1212 - (dg113*dg222 + 2.*(dg123*dg212 + dg112*dg223) + + dg122*(dg213 + dg312) + dg112*dg322)*ginv23 - + (dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323)*ginv33) + + ginv13*(2.*ddg1113 + ddg1311 - + (dg123*(4.*dg112 + dg211) + dg111*dg223 + + 2.*(dg113*dg212 + dg112*(dg213 + dg312)))*ginv22 - + (dg133*dg211 + dg123*dg311 + + 4.*(dg113*(dg123 + dg213 + dg312) + dg112*(dg133 + dg313)) + + dg111*(dg233 + dg323))*ginv23 - + (dg133*(4.*dg113 + dg311) + 6.*dg113*dg313 + dg111*dg333)*ginv33) + + ginv23*(ddg1213 + ddg1312 - + (dg133*(dg213 + dg312) + 2.*dg123*dg313 + + dg113*(dg233 + 2.*dg323) + dg112*dg333)*ginv33) - + (3.*dg112*dg211 + dg111*(4.*dg122 + 3.*dg212) + 6.*pow2(dg112))* + pow2(ginv12) - (3.*dg113*dg311 + dg111*(4.*dg133 + 3.*dg313) + + 6.*pow2(dg113))*pow2(ginv13) - + (dg122*dg212 + dg112*dg222)*pow2(ginv22) - + (dg133*dg212 + dg123*(dg213 + dg312) + dg122*dg313 + + dg113*(dg223 + dg322) + dg112*(dg233 + dg323))*pow2(ginv23) - + (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + + ginv12*(ddg1323*ginv33 + ginv22* + (ddg1222 - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*ginv23 - + (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33) + + ginv23*(ddg1223 + ddg1322 - + (dg133*(dg223 + dg322) + dg123*(dg233 + 4.*dg323) + dg122*dg333)* + ginv33) + ginv13*(2.*ddg1123 + ddg1213 + ddg1312 - + (dg113*dg222 + 4.*(dg123*(dg122 + dg212) + dg112*dg223) + + dg122*(dg213 + dg312) + dg112*dg322)*ginv22 - + (dg133*(4.*dg123 + dg213 + dg312) + 4.*dg123*dg313 + + dg113*(dg233 + 4.*dg323) + dg112*dg333)*ginv33 - + ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg122*dg313 + + dg113*dg322) + 4.* + (dg122*dg133 + dg113*dg223 + dg123*(dg213 + dg312) + + dg112*dg323 + pow2(dg123)))) - + (dg133*(4.*dg112 + dg211) + dg113*(8.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* + pow2(ginv13) - 2.*dg122*dg222*pow2(ginv22) - + (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* + pow2(ginv23) - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) +; + +dGfromgdu12 += +-((dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + dg122*dg333)* + Power(ginv23,3)) - 2.*(dg122*dg222*Power(ginv22,3) + + Power(ginv12,3)*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)) + + (dg111*(dg112*ginv22 + dg113*ginv23) + ginv12*pow2(dg111))*pow2(ginv11)\ +) + (ddg1112 + ddg1211 - (4.*(dg112*dg113 + dg111*dg123) + + 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))*ginv13 - + (dg122*(6.*dg112 + 2.*dg211) + 6.*dg112*dg212 + 2.*dg111*dg222)* + ginv22 - (4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213)) + + dg122*dg311 + 2.*(dg123*dg211 + dg111*dg223 + dg112*dg312) + + dg111*dg322)*ginv23 - + (dg123*dg311 + dg113*(2.*(dg123 + dg213) + dg312) + dg112*dg313 + + dg111*dg323)*ginv33)*pow2(ginv12) - + ((2.*(dg113*dg123 + dg112*dg133) + dg123*dg311 + dg113*dg312 + + dg112*dg313 + dg111*dg323)*ginv22 + + (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*ginv23)* + pow2(ginv13) + (ddg1222 - (4.*(dg123*dg222 + dg122*dg223) + + 2.*dg122*dg322)*ginv23 - + (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33)*pow2(ginv22) + + (ddg1233 + ddg1323 - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)* + ginv33)*pow2(ginv23) + ginv11* + (ginv23*(ddg1113 - 2.*dg113*(dg133 + dg313)*ginv33) + + ginv22*(ddg1112 - (dg112*(4.*dg123 + 2.*dg213) + + 2.*(dg113*(dg122 + dg212) + dg112*dg312))*ginv23 - + (dg113*(2.*dg123 + dg312) + dg112*dg313)*ginv33) + + ginv12*(ddg1111 - dg111*(6.*dg113 + 2.*dg311)*ginv13 - + (dg113*(8.*dg112 + 2.*dg211) + dg112*dg311 + + dg111*(2.*(dg123 + dg213) + dg312))*ginv23 - + ginv22*(2.*(dg112*dg211 + dg111*(dg122 + dg212)) + + 6.*pow2(dg112)) - ginv33* + (dg113*dg311 + dg111*dg313 + 2.*pow2(dg113))) - + ginv13*((dg112*(4.*dg113 + dg311) + dg111*(2.*dg123 + dg312))* + ginv22 + ginv23*(dg113*dg311 + dg111*(2.*dg133 + dg313) + + 4.*pow2(dg113))) - dg111*(6.*dg112 + 2.*dg211)*pow2(ginv12) - + 2.*dg112*(dg122 + dg212)*pow2(ginv22) - + (2.*(dg112*dg133 + dg113*(dg123 + dg213)) + dg113*dg312 + dg112*dg313)* + pow2(ginv23)) + ginv13*(ginv22* + (ddg1123 + ddg1312 - (dg133*(2.*dg123 + dg312) + + 2.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33 - + ginv23*(2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg113*dg223 + + dg112*dg233) + dg122*dg313 + dg113*dg322 + + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg123)))) + + ginv23*(ddg1133 + ddg1313 - + ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))) - + (2.*(dg123*(dg122 + dg212) + dg112*dg223) + dg122*dg312 + + dg112*dg322)*pow2(ginv22) - + (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*pow2(ginv23)\ +) + ginv23*(ddg1333*ginv33 - 2.*dg133*dg333*pow2(ginv33)) + + ginv12*(ddg1313*ginv33 + ginv13* + (ddg1113 + ddg1311 - (2.* + (dg123*dg211 + dg113*(dg122 + dg212) + dg111*dg223) + + dg122*dg311 + dg112*(8.*dg123 + 2.*dg213 + 4.*dg312) + + dg111*dg322)*ginv22 - + (dg133*(4.*dg112 + 2.*dg211) + + dg113*(8.*dg123 + 4.*(dg213 + dg312)) + 4.*dg112*dg313 + + 2.*(dg123*dg311 + dg111*(dg233 + dg323)))*ginv23 - + (dg133*(2.*dg113 + dg311) + 4.*dg113*dg313 + dg111*dg333)*ginv33) + + ginv23*(ddg1123 + 2.*ddg1213 + ddg1312 - + (2.*(dg133*(dg123 + dg213) + dg113*dg233) + dg133*dg312 + + 4.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33) + + ginv22*(ddg1122 + 2.*ddg1212 - + (4.*(dg122*dg213 + dg113*dg222) + + 6.*(dg123*(dg122 + dg212) + dg112*dg223) + + 3.*(dg122*dg312 + dg112*dg322))*ginv23 - + ginv33*(dg122*dg313 + dg113*dg322 + + 2.*(dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323 + + pow2(dg123)))) - + 2.*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow2(ginv13) - + (4.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))*pow2(ginv22) - + (4.*(dg123*dg213 + dg113*dg223) + + 2.*(dg133*(dg122 + dg212) + dg123*dg312 + dg122*dg313 + + dg113*dg322 + dg112*(dg233 + dg323) + pow2(dg123)))*pow2(ginv23) \ +- (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + + ginv22*(ddg1323*ginv33 + ginv23* + (2.*ddg1223 + ddg1322 - (2.*(dg133*dg223 + dg123*dg233) + + dg133*dg322 + 6.*dg123*dg323 + dg122*dg333)*ginv33) - + (2.*(dg133*dg222 + dg122*dg233) + dg123*(6.*dg223 + 3.*dg322) + + 3.*dg122*dg323)*pow2(ginv23) - + (dg133*dg323 + dg123*dg333)*pow2(ginv33)) +; + +dGfromgdu13 += +-((dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* + Power(ginv23,3)) - 2.*(dg133*dg333*Power(ginv33,3) + + Power(ginv13,3)*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113)) + + (dg111*(dg112*ginv23 + dg113*ginv33) + ginv13*pow2(dg111))*pow2(ginv11)\ +) - ((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*ginv23 + + (2.*(dg113*dg122 + dg112*dg123) + dg123*dg211 + dg113*dg212 + + dg112*dg213 + dg111*dg223)*ginv33 + + 2.*ginv13*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)))* + pow2(ginv12) + (ddg1113 + ddg1311 - + (dg123*(2.*dg112 + dg211) + dg113*dg212 + dg111*dg223 + + dg112*(dg213 + 2.*dg312))*ginv22 - + (dg133*dg211 + 2.*(dg113*dg213 + dg123*dg311) + + 4.*(dg113*(dg123 + dg312) + dg112*(dg133 + dg313)) + + dg111*(dg233 + 2.*dg323))*ginv23 - + (dg133*(6.*dg113 + 2.*dg311) + 6.*dg113*dg313 + 2.*dg111*dg333)*ginv33\ +)*pow2(ginv13) - (2.*dg122*dg222*ginv23 + + (dg123*dg222 + dg122*dg223)*ginv33)*pow2(ginv22) + + (ddg1223 + ddg1322 - (3.*(dg133*dg223 + dg123*dg233) + 6.*dg123*dg323 + + 2.*(dg133*dg322 + dg122*dg333))*ginv33)*pow2(ginv23) + + ddg1333*pow2(ginv33) + ginv11* + (ddg1113*ginv33 - ginv22*(2.*dg112*(dg122 + dg212)*ginv23 + + (dg113*dg212 + dg112*(2.*dg123 + dg213))*ginv33) + + ginv23*(ddg1112 - (dg113*(4.*dg123 + 2.*dg213) + + 2.*(dg113*dg312 + dg112*(dg133 + dg313)))*ginv33) - + ginv12*(dg111*(6.*dg112 + 2.*dg211)*ginv13 + + (dg113*(4.*dg112 + dg211) + dg111*(2.*dg123 + dg213))*ginv33 + + ginv23*(dg112*dg211 + dg111*(2.*dg122 + dg212) + 4.*pow2(dg112))) + + ginv13*(ddg1111 - (dg113*(8.*dg112 + dg211) + 2.*dg112*dg311 + + dg111*(dg213 + 2.*(dg123 + dg312)))*ginv23 - + ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - + ginv33*(2.*(dg113*dg311 + dg111*(dg133 + dg313)) + 6.*pow2(dg113))) \ +- dg111*(6.*dg113 + 2.*dg311)*pow2(ginv13) - + (dg113*dg212 + dg112*dg213 + + 2.*(dg113*dg122 + dg112*(dg123 + dg312)))*pow2(ginv23) - + 2.*dg113*(dg133 + dg313)*pow2(ginv33)) + + ginv12*((ddg1123 + ddg1213)*ginv33 + + ginv13*(ddg1112 + ddg1211 - + (dg122*(2.*dg112 + dg211) + 4.*dg112*dg212 + dg111*dg222)*ginv22 - + (dg123*(8.*dg112 + 2.*dg211) + + 4.*(dg113*(dg122 + dg212) + dg112*(dg213 + dg312)) + + 2.*(dg122*dg311 + dg111*(dg223 + dg322)))*ginv23 - + (dg133*(2.*dg112 + dg211) + + dg113*(8.*dg123 + 4.*dg213 + 2.*dg312) + + 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* + ginv33) - ginv22*((dg122*dg213 + dg113*dg222 + + 2.*(dg123*(dg122 + dg212) + dg112*dg223))*ginv33 + + ginv23*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))) + + ginv23*(ddg1122 + ddg1212 - + ginv33*(dg133*(2.*dg122 + dg212) + + 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322) + + dg112*(dg233 + 2.*dg323) + + 4.*(dg123*dg213 + dg113*dg223 + pow2(dg123)))) - + (4.*(dg112*dg113 + dg111*dg123) + + 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))* + pow2(ginv13) - (dg123*(4.*dg122 + 2.*dg212) + + 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* + pow2(ginv23) - (dg133*(2.*dg123 + dg213) + 2.*dg123*dg313 + + dg113*(dg233 + 2.*dg323))*pow2(ginv33)) + + ginv22*(ddg1223*ginv33 + ginv23* + (ddg1222 - (dg133*dg222 + dg123*(6.*dg223 + 2.*dg322) + + dg122*(dg233 + 2.*dg323))*ginv33) - + (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*pow2(ginv23) - + (dg133*dg223 + dg123*(dg233 + 2.*dg323))*pow2(ginv33)) + + ginv23*((ddg1233 + 2.*ddg1323)*ginv33 - + (dg133*(2.*dg233 + 4.*dg323) + 4.*dg123*dg333)*pow2(ginv33)) + + ginv13*((ddg1133 + 2.*ddg1313)*ginv33 + + ginv23*(ddg1123 + ddg1213 + 2.*ddg1312 - + (dg133*(6.*dg123 + 3.*dg213 + 4.*dg312) + 6.*dg123*dg313 + + dg113*(3.*dg233 + 6.*dg323) + 4.*dg112*dg333)*ginv33) + + ginv22*(ddg1212 - (dg123*(2.*dg122 + 4.*dg212) + dg113*dg222 + + dg122*(dg213 + 2.*dg312) + dg112*(4.*dg223 + 2.*dg322))*ginv23 - + ginv33*(dg133*dg212 + dg112*(dg233 + 2.*dg323) + + 2.*(dg113*dg223 + dg123*(dg213 + dg312) + pow2(dg123)))) - + (dg122*dg212 + dg112*dg222)*pow2(ginv22) - + (4.*(dg123*dg312 + dg112*dg323) + + 2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg112*dg233 + + dg122*dg313 + dg113*(dg223 + dg322) + pow2(dg123)))*pow2(ginv23) \ +- (4.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))*pow2(ginv33)) +; + +dGfromgdu21 += +-((dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + dg211*dg333)* + Power(ginv13,3)) - 2.*(dg111*dg211*Power(ginv11,3) + + Power(ginv12,3)*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212))) + + (ddg1211 - (4.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - + 2.*(dg112 + dg211)*dg212*ginv22 - + (2.*(dg113*dg212 + (dg112 + dg211)*dg213) + dg212*dg311 + + dg211*dg312)*ginv23 - + (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33 - + ginv12*(4.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211)))*pow2(ginv11) \ ++ (ddg1222 + ddg2212 - (4.*(dg212*(dg123 + dg213) + + (dg112 + dg211)*dg223) + dg222*dg311 + + 2.*(dg122*dg213 + dg113*dg222 + dg212*dg312) + dg211*dg322)*ginv13 \ +- (2.*dg122 + 6.*dg212)*dg222*ginv22 - + ((2.*dg122 + 4.*dg212)*dg223 + + dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)*ginv23 - + (dg223*(2.*(dg123 + dg213) + dg312) + dg222*dg313 + dg213*dg322 + + dg212*dg323)*ginv33)*pow2(ginv12) + + (ddg1233 + ddg2313 - (2.*((dg123 + dg213)*dg223 + dg212*dg233) + + dg223*dg312 + dg212*dg323)*ginv22 - + (dg233*(4.*dg213 + 2.*dg312) + + 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + + dg212*dg333))*ginv23 - + (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33)*pow2(ginv13) + + ginv11*(ddg2313*ginv33 + ginv22* + (ddg2212 - (dg222*(2.*dg213 + dg312) + dg212*(4.*dg223 + dg322))* + ginv23 - (dg223*(2.*dg213 + dg312) + dg212*dg323)*ginv33) + + ginv23*(ddg2213 + ddg2312 - + (dg233*(2.*dg213 + dg312) + 2.*(dg223*dg313 + dg213*dg323) + + dg212*dg333)*ginv33) + + ginv13*(2.*ddg1213 + ddg2311 - + (2.*(dg112 + dg211)*dg223 + + dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv22 - + (2.*(dg133*dg213 + dg113*dg233) + dg233*dg311 + 6.*dg213*dg313 + + dg211*dg333)*ginv33 - + ginv23*(2.*(dg133*dg212 + dg123*dg213 + dg113*dg223 + + (dg112 + dg211)*dg233) + dg223*dg311 + dg211*dg323 + + 4.*(dg213*dg312 + dg212*dg313 + pow2(dg213)))) + + ginv12*(2.*ddg1212 + ddg2211 - + (6.*(dg113*dg212 + dg112*dg213) + 4.*dg111*dg223 + + 3.*dg212*dg311 + dg211*(4.*dg123 + 6.*dg213 + 3.*dg312))*ginv13 \ +- (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + + (dg112 + dg211)*dg223) + dg222*dg311 + + dg212*(8.*dg213 + 4.*dg312) + dg211*dg322)*ginv23 - + ginv22*(2.*(dg122*dg212 + (dg112 + dg211)*dg222) + + 6.*pow2(dg212)) - ginv33* + (dg223*dg311 + dg211*dg323 + + 2.*(dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313 + + pow2(dg213)))) - + (6.*dg112*dg212 + dg211*(2.*dg122 + 6.*dg212) + 2.*dg111*dg222)* + pow2(ginv12) - (2.*(dg133*dg211 + dg111*dg233) + + dg213*(6.*dg113 + 3.*dg311) + 3.*dg211*dg313)*pow2(ginv13) - + 2.*dg212*dg222*pow2(ginv22) - + (2.*(dg213*dg223 + dg212*dg233) + dg223*dg312 + dg222*dg313 + + dg213*dg322 + dg212*dg323)*pow2(ginv23) - + (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + + ginv12*(ddg2323*ginv33 + ginv13* + (2.*ddg1223 + ddg2213 + ddg2312 - + (2.*((dg123 + dg213)*dg222 + dg122*dg223) + dg222*dg312 + + dg212*(8.*dg223 + dg322))*ginv22 - + (dg223*(8.*dg213 + 4.*(dg123 + dg312)) + + 2.*(dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322) + + 4.*dg212*(dg233 + dg323))*ginv23 - + (2.*(dg133*dg223 + (dg123 + dg213)*dg233) + dg233*dg312 + + 4.*(dg223*dg313 + dg213*dg323) + dg212*dg333)*ginv33) + + ginv23*(ddg2223 + ddg2322 - + (dg233*(2.*dg223 + dg322) + 4.*dg223*dg323 + dg222*dg333)*ginv33) + + ginv22*(ddg2222 - dg222*(6.*dg223 + 2.*dg322)*ginv23 - + ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223))) - + (4.*(dg123*dg213 + dg113*dg223) + + 2.*((dg112 + dg211)*dg233 + dg223*dg311 + dg213*dg312 + + dg212*(dg133 + dg313) + dg211*dg323 + pow2(dg213)))*pow2(ginv13) \ +- 2.*(pow2(dg222)*pow2(ginv22) + + (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))*pow2(ginv23)) - + (dg233*dg323 + dg223*dg333)*pow2(ginv33)) + + ginv13*(ddg2333*ginv33 + ginv22* + (ddg2223 - 2.*dg223*(dg233 + dg323)*ginv33 - + ginv23*(dg223*dg322 + dg222*(2.*dg233 + dg323) + 4.*pow2(dg223))) + + ginv23*(ddg2233 + ddg2323 - + ginv33*(3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))) - + (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)* + pow2(ginv23) - 2.*(dg222*dg223*pow2(ginv22) + dg233*dg333*pow2(ginv33))\ +) +; + +dGfromgdu22 += +-((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)* + Power(ginv12,3)) - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + + dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv22,3)*pow2(dg222) - + (2.*dg111*dg211*ginv12 + (dg112*dg211 + dg111*dg212)*ginv22 + + (dg113*dg211 + dg111*dg213)*ginv23)*pow2(ginv11) + + (ddg1212 + ddg2211 - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + + dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))*ginv13 - + (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + dg112*dg223) + + dg222*dg311 + dg212*(8.*dg213 + 2.*dg312) + + dg211*(4.*dg223 + dg322))*ginv23 - + ginv22*(4.*dg211*dg222 + 3.*(dg122*dg212 + dg112*dg222) + + 6.*pow2(dg212)) - ginv33* + (dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + dg212*dg313 + + dg211*dg323 + 2.*pow2(dg213)))*pow2(ginv12) - + ((dg112*dg233 + dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + + dg212*(dg133 + dg313) + dg211*dg323)*ginv22 + + (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + + dg211*dg333)*ginv23)*pow2(ginv13) + + (ddg2222 - dg222*(8.*dg223 + 2.*dg322)*ginv23 - + ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223)))*pow2(ginv22) + + (ddg2233 + ddg2323 - ginv33* + (3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233)))*pow2(ginv23) + + ginv13*(ginv22*(ddg1223 + ddg2312 - + (dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322 + + 4.*(dg223*(dg123 + dg213 + dg312) + dg212*(dg233 + dg323)))* + ginv23 - (dg233*(dg123 + dg312) + dg223*(dg133 + 2.*dg313) + + 2.*dg213*dg323 + dg212*dg333)*ginv33) + + ginv23*(ddg1233 + ddg2313 - + (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33) - + ((dg122 + 4.*dg212)*dg223 + dg222*(dg123 + dg312) + dg212*dg322)* + pow2(ginv22) - (dg233*(4.*dg213 + 2.*dg312) + + 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + + dg212*dg333))*pow2(ginv23)) + + ginv11*(-(ginv13*((2.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + + dg212*dg311 + dg211*(dg123 + dg312))*ginv22 + + (dg111*dg233 + dg213*(4.*dg113 + dg311) + dg211*(dg133 + dg313))* + ginv23)) + ginv12*(ddg1211 - + (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - + (6.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv22 - + (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + dg212*dg311 + + dg211*(dg123 + 4.*dg213 + dg312))*ginv23 - + (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33) + + ginv22*(ddg1212 - (dg122*dg213 + dg113*dg222 + 2.*dg112*dg223 + + dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv23 - + (dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313)*ginv33) + + ginv23*(ddg1213 - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*ginv33) - + (3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))*pow2(ginv12) - + (dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))*pow2(ginv22) - + (dg113*dg223 + dg112*dg233 + dg213*(dg123 + dg312) + + dg212*(dg133 + dg313) + 2.*pow2(dg213))*pow2(ginv23)) + + ginv23*(ddg2333*ginv33 - 2.*dg233*dg333*pow2(ginv33)) + + ginv12*(ddg2313*ginv33 + ginv22* + (ddg1222 + 2.*ddg2212 - + ((3.*dg122 + 12.*dg212)*dg223 + + dg222*(8.*dg213 + 3.*(dg123 + dg312)) + 3.*dg212*dg322)*ginv23 \ +- (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + dg222*dg313 + dg213*dg322 + + 2.*dg212*dg323)*ginv33) + + ginv23*(ddg1223 + 2.*ddg2213 + ddg2312 - + (dg233*(dg123 + 4.*dg213 + dg312) + dg223*(dg133 + 4.*dg313) + + 4.*dg213*dg323 + dg212*dg333)*ginv33) + + ginv13*(ddg1213 + ddg2311 - + (dg122*dg213 + dg222*(dg113 + dg311) + + 4.*((dg112 + dg211)*dg223 + dg212*(dg123 + dg213 + dg312)) + + dg211*dg322)*ginv22 - + (dg233*(dg113 + dg311) + dg213*(dg133 + 4.*dg313) + dg211*dg333)* + ginv33 - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg223*dg311 + + dg211*dg323) + 4.* + (dg113*dg223 + dg211*dg233 + dg213*(dg123 + dg312) + + dg212*dg313 + pow2(dg213)))) - + (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* + pow2(ginv13) - (2.*dg122 + 8.*dg212)*dg222*pow2(ginv22) - + ((dg122 + 4.*dg212)*dg233 + dg223*(8.*dg213 + 2.*(dg123 + dg312)) + + dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* + pow2(ginv23) - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + + ginv22*(ddg2323*ginv33 + ginv23* + (2.*ddg2223 + ddg2322 - (dg233*(4.*dg223 + dg322) + 6.*dg223*dg323 + + dg222*dg333)*ginv33) - + (3.*dg223*dg322 + dg222*(4.*dg233 + 3.*dg323) + 6.*pow2(dg223))* + pow2(ginv23) - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) +; + +dGfromgdu23 += +-((dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* + Power(ginv13,3)) - (2.*dg111*dg211*ginv13 + + (dg112*dg211 + dg111*dg212)*ginv23 + + (dg113*dg211 + dg111*dg213)*ginv33)*pow2(ginv11) - + ((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv13 + + (dg122*dg213 + dg212*(dg123 + 2.*dg213) + dg113*dg222 + + (dg112 + 2.*dg211)*dg223)*ginv33 + + 2.*ginv23*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212)))* + pow2(ginv12) + (ddg1213 + ddg2311 - + ((dg112 + 2.*dg211)*dg223 + dg212*(dg123 + 2.*(dg213 + dg312)))* + ginv22 - (3.*(dg133*dg213 + dg113*dg233) + 6.*dg213*dg313 + + 2.*(dg233*dg311 + dg211*dg333))*ginv33 - + ginv23*(4.*(dg213*dg312 + dg212*dg313) + + 2.*(dg133*dg212 + dg123*dg213 + (dg112 + dg211)*dg233 + + dg223*(dg113 + dg311) + dg211*dg323 + pow2(dg213))))*pow2(ginv13) \ +- 2.*(dg233*dg333*Power(ginv33,3) + + Power(ginv23,3)*(dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223)) + + (dg222*dg223*ginv33 + ginv23*pow2(dg222))*pow2(ginv22)) + + (ddg2223 + ddg2322 - (dg233*(6.*dg223 + 2.*dg322) + 6.*dg223*dg323 + + 2.*dg222*dg333)*ginv33)*pow2(ginv23) + ddg2333*pow2(ginv33) + + ginv11*(ddg1213*ginv33 + ginv13* + (ddg1211 - 2.*(dg112 + dg211)*dg212*ginv22 - + (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + 2.*dg212*dg311 + + dg211*(dg123 + 2.*(dg213 + dg312)))*ginv23 - + (dg111*dg233 + dg213*(6.*dg113 + 2.*dg311) + + dg211*(dg133 + 2.*dg313))*ginv33) - + ginv12*((4.*dg112*dg212 + dg211*(dg122 + 2.*dg212) + dg111*dg222)* + ginv23 + (dg211*(dg123 + 2.*dg213) + + 2.*(dg113*dg212 + dg112*dg213) + dg111*dg223)*ginv33 + + ginv13*(3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))) - + ginv22*((dg212*(dg123 + 2.*dg213) + dg112*dg223)*ginv33 + + ginv23*(dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))) + + ginv23*(ddg1212 - ginv33* + (dg112*dg233 + dg212*(dg133 + 2.*dg313) + + 2.*(dg113*dg223 + dg213*(dg123 + dg312) + pow2(dg213)))) - + (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*pow2(ginv13) - + (dg122*dg213 + dg113*dg222 + dg112*dg223 + + dg212*(dg123 + 2.*(dg213 + dg312)))*pow2(ginv23) - + (dg113*dg233 + dg213*(dg133 + 2.*dg313))*pow2(ginv33)) + + ginv22*(ddg2223*ginv33 + ginv23* + (ddg2222 - ginv33*(2.*(dg223*dg322 + dg222*(dg233 + dg323)) + + 6.*pow2(dg223))) - dg222*(6.*dg223 + 2.*dg322)*pow2(ginv23) - + 2.*dg223*(dg233 + dg323)*pow2(ginv33)) + + ginv12*((ddg1223 + ddg2213)*ginv33 - + ginv22*((2.*dg122 + 6.*dg212)*dg222*ginv23 + + ((dg123 + 2.*dg213)*dg222 + (dg122 + 4.*dg212)*dg223)*ginv33) + + ginv23*(ddg1222 + ddg2212 - + ((dg122 + 2.*dg212)*dg233 + + dg223*(4.*dg123 + 8.*dg213 + 2.*dg312) + + dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* + ginv33) + ginv13*(ddg1212 + ddg2211 - + (4.*(dg112 + dg211)*dg223 + + dg212*(8.*dg213 + 4.*(dg123 + dg312)) + + 2.*(dg122*dg213 + dg222*(dg113 + dg311) + dg211*dg322))*ginv23 \ +- ginv22*(dg122*dg212 + (dg112 + 2.*dg211)*dg222 + 4.*pow2(dg212)) - + ginv33*((dg112 + 2.*dg211)*dg233 + dg212*(dg133 + 2.*dg313) + + 2.*(dg223*dg311 + dg213*dg312 + dg211*dg323) + + 4.*(dg123*dg213 + dg113*dg223 + pow2(dg213)))) - + (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + + dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))* + pow2(ginv13) - ((2.*dg122 + 4.*dg212)*dg223 + + dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)* + pow2(ginv23) - ((dg123 + 2.*dg213)*dg233 + + dg223*(dg133 + 2.*dg313) + 2.*dg213*dg323)*pow2(ginv33)) + + ginv13*((ddg1233 + 2.*ddg2313)*ginv33 + + ginv22*(ddg2212 - ((dg122 + 8.*dg212)*dg223 + + dg222*(dg123 + 2.*(dg213 + dg312)) + 2.*dg212*dg322)*ginv23 - + (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*(dg233 + dg323))* + ginv33) + ginv23*(ddg1223 + ddg2213 + 2.*ddg2312 - + (3.*(dg133*dg223 + dg123*dg233) + dg233*(6.*dg213 + 4.*dg312) + + 6.*(dg223*dg313 + dg213*dg323) + 4.*dg212*dg333)*ginv33) - + 2.*dg212*dg222*pow2(ginv22) - + ((dg122 + 4.*dg212)*dg233 + dg223*(2.*dg123 + 4.*(dg213 + dg312)) + + dg222*(dg133 + 2.*dg313) + 2.*dg213*dg322 + 4.*dg212*dg323)* + pow2(ginv23) - (dg233*(2.*dg133 + 4.*dg313) + 4.*dg213*dg333)* + pow2(ginv33)) + ginv23*((ddg2233 + 2.*ddg2323)*ginv33 - + (4.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))*pow2(ginv33)) +; + +dGfromgdu31 += +-((dg222*dg311 + dg211*dg322 + 2.*((dg122 + dg212)*dg312 + dg112*dg322))* + Power(ginv12,3)) - 2.*(dg111*dg311*Power(ginv11,3) + + Power(ginv13,3)*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313))) + + (ddg1311 - ((4.*dg112 + 2.*dg211)*dg311 + 4.*dg111*dg312)*ginv12 - + (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - + (dg311*(dg213 + 2.*dg312) + dg211*dg313 + + 2.*(dg113*dg312 + dg112*dg313))*ginv23 - + 2.*(dg113 + dg311)*dg313*ginv33 - + ginv13*(4.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311)))*pow2(ginv11) \ ++ (ddg1322 + ddg2312 - (2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))* + ginv22 - ((2.*dg213 + 4.*dg312)*dg322 + + 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + + (dg122 + dg212)*dg323))*ginv23 - + (dg313*(dg223 + 2.*dg322) + (dg213 + 2.*(dg123 + dg312))*dg323)* + ginv33 - ginv13*(4.*(dg123*dg312 + dg112*dg323) + + 2.*(dg213*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + + dg311*(dg223 + dg322) + dg211*dg323 + pow2(dg312))))*pow2(ginv12) \ ++ (ddg1333 + ddg3313 - (dg233*dg312 + dg223*dg313 + + (dg213 + 2.*(dg123 + dg312))*dg323 + dg212*dg333)*ginv22 - + (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + + 4.*(dg313*dg323 + dg312*dg333))*ginv23 - + (2.*dg133 + 6.*dg313)*dg333*ginv33)*pow2(ginv13) + + ginv11*(ddg3313*ginv33 + ginv22* + (ddg2312 - (dg222*dg313 + dg213*dg322 + + 2.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - + (dg223*dg313 + (dg213 + 2.*dg312)*dg323)*ginv33) + + ginv23*(ddg2313 + ddg3312 - + (dg313*(dg233 + 4.*dg323) + (dg213 + 2.*dg312)*dg333)*ginv33) + + ginv12*(2.*ddg1312 + ddg2311 - + (dg311*(4.*dg123 + 3.*dg213 + 6.*dg312) + 3.*dg211*dg313 + + 6.*(dg113*dg312 + dg112*dg313) + 4.*dg111*dg323)*ginv13 - + (dg222*dg311 + (2.*dg122 + 6.*dg212)*dg312 + + (2.*dg112 + dg211)*dg322)*ginv22 - + (4.*dg312*dg313 + 2.*((dg123 + dg213)*dg313 + + (dg113 + dg311)*dg323))*ginv33 - + ginv23*((2.*dg123 + 4.*dg213)*dg312 + dg311*(dg223 + 2.*dg322) + + dg211*dg323 + 2.*(dg122*dg313 + dg113*dg322 + dg112*dg323) + + 4.*(dg212*dg313 + pow2(dg312)))) + + ginv13*(2.*ddg1313 + ddg3311 - + ((4.*dg213 + 8.*dg312)*dg313 + dg311*(dg233 + 2.*dg323) + + dg211*dg333 + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + + dg112*dg333))*ginv23 - + ginv22*(dg223*dg311 + dg211*dg323 + + 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + + pow2(dg312))) - + ginv33*(2.*(dg133*dg313 + (dg113 + dg311)*dg333) + 6.*pow2(dg313))) \ +- ((2.*dg122 + 3.*dg212)*dg311 + (6.*dg112 + 3.*dg211)*dg312 + + 2.*dg111*dg322)*pow2(ginv12) - + (6.*dg113*dg313 + dg311*(2.*dg133 + 6.*dg313) + 2.*dg111*dg333)* + pow2(ginv13) - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - + (dg313*(dg223 + 2.*dg322) + dg213*dg323 + dg312*(dg233 + 2.*dg323) + + dg212*dg333)*pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + + ginv12*(ddg3323*ginv33 + ginv13* + (2.*ddg1323 + ddg2313 + ddg3312 - + (dg222*dg313 + (2.*dg123 + dg213)*dg322 + + dg312*(4.*dg223 + 2.*dg322) + (2.*dg122 + 4.*dg212)*dg323)* + ginv22 - ((4.*dg213 + 8.*dg312)*dg323 + + 4.*(dg313*(dg223 + dg322) + dg123*dg323) + + 2.*(dg233*dg312 + dg133*dg322 + (dg122 + dg212)*dg333))*ginv23 \ +- (dg313*(dg233 + 8.*dg323) + (dg213 + 2.*dg312)*dg333 + + 2.*(dg133*dg323 + dg123*dg333))*ginv33) + + ginv22*(ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - + ginv23*(3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))) + + ginv23*(ddg2323 + ddg3322 - + ginv33*(dg233*dg323 + (dg223 + 2.*dg322)*dg333 + 4.*pow2(dg323))) - + (dg311*(dg233 + 4.*dg323) + + 4.*((dg123 + dg312)*dg313 + dg113*dg323) + dg211*dg333 + + 2.*(dg133*dg312 + dg213*dg313 + dg112*dg333))*pow2(ginv13) - + (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* + pow2(ginv23) - 2.*(dg222*dg322*pow2(ginv22) + + dg323*dg333*pow2(ginv33))) + + ginv13*(ddg3333*ginv33 + ginv23* + (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33) + + ginv22*(ddg2323 - (4.*dg223*dg323 + dg322*(dg233 + 2.*dg323) + + dg222*dg333)*ginv23 - + ginv33*(dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))) - + (dg223*dg322 + dg222*dg323)*pow2(ginv22) - + 2.*((dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow2(ginv23) + + pow2(dg333)*pow2(ginv33))) +; + +dGfromgdu32 += +-(((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* + Power(ginv12,3)) - 2.*(dg222*dg322*Power(ginv22,3) + + Power(ginv23,3)*(dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))) - + (2.*dg111*dg311*ginv12 + (dg112*dg311 + dg111*dg312)*ginv22 + + (dg113*dg311 + dg111*dg313)*ginv23)*pow2(ginv11) + + (ddg1312 + ddg2311 - (4.*dg311*dg312 + + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + + (dg112 + dg211)*dg313 + dg111*dg323))*ginv13 - + ((3.*dg122 + 6.*dg212)*dg312 + 3.*dg112*dg322 + + 2.*(dg222*dg311 + dg211*dg322))*ginv22 - + ((dg123 + 2.*(dg213 + dg312))*dg313 + (dg113 + 2.*dg311)*dg323)* + ginv33 - ginv23*(4.*(dg213*dg312 + dg212*dg313) + + 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322 + + dg311*(dg223 + dg322) + (dg112 + dg211)*dg323 + pow2(dg312))))* + pow2(ginv12) - ((dg123*dg313 + dg312*(dg133 + 2.*dg313) + + (dg113 + 2.*dg311)*dg323 + dg112*dg333)*ginv22 + + 2.*ginv23*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313)))* + pow2(ginv13) + (ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - + ginv23*(4.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322)))*pow2(ginv22) \ ++ (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33)*pow2(ginv23) + + ginv11*(-(ginv13*((dg311*(dg123 + 2.*dg312) + + 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv22 + + (4.*dg113*dg313 + dg311*(dg133 + 2.*dg313) + dg111*dg333)*ginv23)\ +) + ginv12*(ddg1311 - ((dg122 + 2.*dg212)*dg311 + + (6.*dg112 + 2.*dg211)*dg312 + dg111*dg322)*ginv22 - + (dg311*(dg123 + 2.*(dg213 + dg312)) + 2.*dg211*dg313 + + 4.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv23 - + 2.*(dg113 + dg311)*dg313*ginv33 - + ginv13*(3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))) + + ginv22*(ddg1312 - ((dg123 + 2.*dg312)*dg313 + dg113*dg323)*ginv33 - + ginv23*(dg122*dg313 + dg113*dg322 + + 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + + pow2(dg312)))) + + ginv23*(ddg1313 - ginv33* + (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))) - + ((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*pow2(ginv12) - + ((dg122 + 2.*dg212)*dg312 + dg112*dg322)*pow2(ginv22) - + (dg133*dg312 + (dg123 + 2.*(dg213 + dg312))*dg313 + dg113*dg323 + + dg112*dg333)*pow2(ginv23)) + + ginv13*(ginv23*(ddg1333 + ddg3313 - (2.*dg133 + 6.*dg313)*dg333*ginv33) + + ginv22*(ddg1323 + ddg3312 - + (dg133*dg322 + (4.*dg123 + 2.*dg213 + 8.*dg312)*dg323 + + dg122*dg333 + 2.*(dg233*dg312 + dg313*(dg223 + dg322) + + dg212*dg333))*ginv23 - + ((dg133 + 4.*dg313)*dg323 + (dg123 + 2.*dg312)*dg333)*ginv33) - + (dg123*dg322 + dg122*dg323 + + 2.*(dg312*(dg223 + dg322) + dg212*dg323))*pow2(ginv22) - + (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + + 4.*(dg313*dg323 + dg312*dg333))*pow2(ginv23)) + + ginv12*(ddg3313*ginv33 + ginv22* + (ddg1322 + 2.*ddg2312 - + (4.*(dg222*dg313 + dg213*dg322) + + 3.*(dg123*dg322 + dg122*dg323) + + 6.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - + ((2.*dg213 + 4.*dg312)*dg323 + + 2.*(dg313*(dg223 + dg322) + dg123*dg323))*ginv33) + + ginv23*(ddg1323 + 2.*ddg2313 + ddg3312 - + (dg133*dg323 + dg313*(2.*dg233 + 8.*dg323) + + (dg123 + 2.*(dg213 + dg312))*dg333)*ginv33) + + ginv13*(ddg1313 + ddg3311 - + (8.*dg312*dg313 + 4.* + ((dg123 + dg213)*dg313 + (dg113 + dg311)*dg323) + + 2.*(dg233*dg311 + dg133*dg312 + (dg112 + dg211)*dg333))*ginv23 \ +- ginv22*(dg122*dg313 + dg113*dg322 + + 2.*(dg213*dg312 + dg212*dg313 + dg311*(dg223 + dg322) + + dg211*dg323) + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg312))) \ +- ginv33*(dg133*dg313 + (dg113 + 2.*dg311)*dg333 + 4.*pow2(dg313))) - + (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* + pow2(ginv13) - (2.*dg122*dg322 + 4.*(dg222*dg312 + dg212*dg322))* + pow2(ginv22) - (dg133*dg322 + + 4.*(dg313*(dg223 + dg322) + (dg213 + dg312)*dg323) + + dg122*dg333 + 2.*(dg233*dg312 + dg123*dg323 + dg212*dg333))* + pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + + ginv22*(ddg3323*ginv33 + ginv23* + (2.*ddg2323 + ddg3322 - + ginv33*(2.*(dg233*dg323 + (dg223 + dg322)*dg333) + 6.*pow2(dg323))) \ +- (6.*dg223*dg323 + dg322*(2.*dg233 + 6.*dg323) + 2.*dg222*dg333)* + pow2(ginv23) - 2.*dg323*dg333*pow2(ginv33)) + + ginv23*(ddg3333*ginv33 - 2.*pow2(dg333)*pow2(ginv33)) +; + +dGfromgdu33 += +-((2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* + Power(ginv13,3)) - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + + dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv33,3)*pow2(dg333) - + (2.*dg111*dg311*ginv13 + (dg112*dg311 + dg111*dg312)*ginv23 + + (dg113*dg311 + dg111*dg313)*ginv33)*pow2(ginv11) - + (((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* + ginv13 + (dg222*dg311 + dg211*dg322 + + 2.*((dg122 + dg212)*dg312 + dg112*dg322))*ginv23 + + (dg223*dg311 + (dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + + dg113*dg322 + (dg112 + dg211)*dg323)*ginv33)*pow2(ginv12) + + (ddg1313 + ddg3311 - ((2.*dg213 + 8.*dg312)*dg313 + + dg311*(dg233 + 4.*dg323) + dg211*dg333 + + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + dg112*dg333))*ginv23 \ +- ginv22*(dg223*dg311 + (dg123 + dg213)*dg312 + dg212*dg313 + + (dg112 + dg211)*dg323 + 2.*pow2(dg312)) - + ginv33*(4.*dg311*dg333 + 3.*(dg133*dg313 + dg113*dg333) + + 6.*pow2(dg313)))*pow2(ginv13) - + (2.*dg222*dg322*ginv23 + (dg223*dg322 + dg222*dg323)*ginv33)* + pow2(ginv22) + (ddg2323 + ddg3322 - + ginv33*(4.*dg322*dg333 + 3.*(dg233*dg323 + dg223*dg333) + + 6.*pow2(dg323)))*pow2(ginv23) + ddg3333*pow2(ginv33) + + ginv13*((ddg1333 + 2.*ddg3313)*ginv33 + + ginv22*(ddg2312 - (dg222*dg313 + (dg123 + dg213)*dg322 + + dg122*dg323 + 4.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 \ +- (dg312*(dg233 + 4.*dg323) + 2.*(dg223*dg313 + (dg123 + dg213)*dg323) + + dg212*dg333)*ginv33) + + ginv23*(ddg1323 + ddg2313 + 2.*ddg3312 - + (12.*dg313*dg323 + (3.*dg213 + 8.*dg312)*dg333 + + 3.*(dg233*dg313 + dg133*dg323 + dg123*dg333))*ginv33) - + (dg222*dg312 + dg212*dg322)*pow2(ginv22) - + ((dg133 + 4.*dg313)*dg322 + (2.*dg213 + 8.*dg312)*dg323 + + dg122*dg333 + 2.*(dg233*dg312 + dg223*dg313 + dg123*dg323 + + dg212*dg333))*pow2(ginv23) - + (2.*dg133 + 8.*dg313)*dg333*pow2(ginv33)) + + ginv23*((ddg2333 + 2.*ddg3323)*ginv33 - + (2.*dg233 + 8.*dg323)*dg333*pow2(ginv33)) + + ginv12*((ddg1323 + ddg2313)*ginv33 - + ginv22*((2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))*ginv23 + + (dg222*dg313 + (dg123 + dg213)*dg322 + dg122*dg323 + + 2.*(dg223*dg312 + dg212*dg323))*ginv33) + + ginv23*(ddg1322 + ddg2312 - + (dg233*dg312 + dg133*dg322 + + 4.*(dg313*(dg223 + dg322) + (dg123 + dg213 + dg312)*dg323) + + (dg122 + dg212)*dg333)*ginv33) + + ginv13*(ddg1312 + ddg2311 - + (dg222*dg311 + (dg122 + 4.*dg212)*dg312 + (dg112 + dg211)*dg322)* + ginv22 - (dg133*dg312 + dg311*(dg233 + 4.*dg323) + + 4.*((dg123 + dg213 + dg312)*dg313 + dg113*dg323) + + (dg112 + dg211)*dg333)*ginv33 - + ginv23*(2.*(dg223*dg311 + dg122*dg313 + dg113*dg322 + + dg211*dg323) + 4.* + ((dg123 + dg213)*dg312 + dg212*dg313 + dg311*dg322 + + dg112*dg323 + pow2(dg312)))) - + (4.*dg311*dg312 + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + + (dg112 + dg211)*dg313 + dg111*dg323))*pow2(ginv13) - + ((2.*dg213 + 4.*dg312)*dg322 + + 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + + (dg122 + dg212)*dg323))*pow2(ginv23) - + (dg133*dg323 + dg313*(dg233 + 4.*dg323) + (dg123 + dg213)*dg333)* + pow2(ginv33)) + ginv11*(ddg1313*ginv33 - + ginv12*(((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*ginv13 + + ((dg122 + dg212)*dg311 + (4.*dg112 + dg211)*dg312 + dg111*dg322)* + ginv23 + ((dg123 + dg213)*dg311 + dg211*dg313 + + 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv33) - + ginv22*(((dg122 + 2.*dg212)*dg312 + dg112*dg322)*ginv23 + + ((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323)*ginv33) + + ginv13*(ddg1311 - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - + ((dg123 + dg213)*dg311 + 4.*(dg113 + dg311)*dg312 + + (4.*dg112 + dg211)*dg313 + dg111*dg323)*ginv23 - + (6.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)*ginv33) + + ginv23*(ddg1312 - (dg312*(dg133 + 4.*dg313) + + 2.*((dg123 + dg213)*dg313 + dg113*dg323) + dg112*dg333)*ginv33) \ +- (3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))*pow2(ginv13) - + ((dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + + dg112*dg323 + 2.*pow2(dg312))*pow2(ginv23) - + (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))*pow2(ginv33)) + + ginv22*(ddg2323*ginv33 + ginv23* + (ddg2322 - (6.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* + ginv33) - (3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))* + pow2(ginv23) - (dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))* + pow2(ginv33)) +; + +R11 += +dG11*g11 + dG12*g12 + dG13*g13 + gammado111*Gfromg1 + gammado112*Gfromg2 + + gammado113*Gfromg3 + (-0.5*ddg1111 + 3.*gamma111*gammado111 + + 2.*(gamma211*gammado112 + gamma311*gammado113) + + gamma211*gammado211 + gamma311*gammado311)*ginv11 + + (-ddg1211 + 3.*(gamma112*gammado111 + gamma111*gammado112) + + 2.*(gamma212*gammado112 + gamma312*gammado113 + + gamma211*gammado122 + gamma311*gammado123) + gamma212*gammado211 + + gamma211*gammado212 + gamma312*gammado311 + gamma311*gammado312)*ginv12 \ ++ (-ddg1311 + 3.*(gamma113*gammado111 + gamma111*gammado113) + + 2.*(gamma213*gammado112 + gamma313*gammado113 + + gamma211*gammado123 + gamma311*gammado133) + gamma213*gammado211 + + gamma211*gammado213 + gamma313*gammado311 + gamma311*gammado313)*ginv13 \ ++ (-0.5*ddg2211 + 3.*gamma112*gammado112 + + 2.*(gamma212*gammado122 + gamma312*gammado123) + + gamma212*gammado212 + gamma312*gammado312)*ginv22 + + (-ddg2311 + 3.*(gamma113*gammado112 + gamma112*gammado113) + + 2.*(gamma213*gammado122 + (gamma212 + gamma313)*gammado123 + + gamma312*gammado133) + gamma213*gammado212 + gamma212*gammado213 + + gamma313*gammado312 + gamma312*gammado313)*ginv23 + + (-0.5*ddg3311 + 3.*gamma113*gammado113 + + 2.*(gamma213*gammado123 + gamma313*gammado133) + gamma213*gammado213 + + gamma313*gammado313)*ginv33 +; + +R12 += +0.5*(dG21*g11 + (dG11 + dG22)*g12 + dG23*g13 + dG12*g22 + dG13*g23 + + (gammado112 + gammado211)*Gfromg1 + + (gammado122 + gammado212)*Gfromg2 + (gammado123 + gammado213)*Gfromg3) \ ++ (-0.5*ddg1112 + gamma112*gammado111 + (gamma111 + gamma212)*gammado112 + + gamma312*gammado113 + gamma111*gammado211 + 2.*gamma211*gammado212 + + gamma311*(gammado213 + gammado312))*ginv11 + + (-ddg1212 + gamma122*gammado111 + (2.*gamma112 + gamma222)*gammado112 + + gamma322*gammado113 + (gamma111 + gamma212)*gammado122 + + gamma112*gammado211 + (gamma111 + 2.*gamma212)*gammado212 + + 2.*gamma211*gammado222 + + gamma312*(gammado123 + gammado213 + gammado312) + + gamma311*(gammado223 + gammado322))*ginv12 + + (-ddg1312 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + + (gamma112 + gamma323)*gammado113 + (gamma111 + gamma212)*gammado123 + + gamma312*gammado133 + gamma113*gammado211 + + (gamma111 + gamma313)*gammado213 + + 2.*(gamma213*gammado212 + gamma211*gammado223) + + gamma313*gammado312 + gamma311*(gammado233 + gammado323))*ginv13 + + (-0.5*ddg2212 + gamma122*gammado112 + (gamma112 + gamma222)*gammado122 + + gamma322*gammado123 + gamma112*gammado212 + 2.*gamma212*gammado222 + + gamma312*(gammado223 + gammado322))*ginv22 + + (-ddg2312 + gamma123*gammado112 + gamma122*gammado113 + + (gamma113 + gamma223)*gammado122 + + (gamma112 + gamma222 + gamma323)*gammado123 + gamma322*gammado133 + + gamma113*gammado212 + gamma112*gammado213 + + 2.*(gamma213*gammado222 + gamma212*gammado223) + + gamma313*(gammado223 + gammado322) + + gamma312*(gammado233 + gammado323))*ginv23 + + (-0.5*ddg3312 + gamma123*gammado113 + (gamma113 + gamma223)*gammado123 + + gamma323*gammado133 + gamma113*gammado213 + 2.*gamma213*gammado223 + + gamma313*(gammado233 + gammado323))*ginv33 +; + +R13 += +0.5*(dG31*g11 + dG32*g12 + (dG11 + dG33)*g13 + dG12*g23 + dG13*g33 + + (gammado113 + gammado311)*Gfromg1 + + (gammado123 + gammado312)*Gfromg2 + (gammado133 + gammado313)*Gfromg3) \ ++ (-0.5*ddg1113 + gamma113*gammado111 + gamma213*gammado112 + + (gamma111 + gamma313)*gammado113 + gamma111*gammado311 + + gamma211*(gammado213 + gammado312) + 2.*gamma311*gammado313)*ginv11 + + (-ddg1213 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + + (gamma112 + gamma323)*gammado113 + gamma213*gammado122 + + (gamma111 + gamma313)*gammado123 + gamma112*gammado311 + + gamma111*gammado312 + gamma212*(gammado213 + gammado312) + + gamma211*(gammado223 + gammado322) + + 2.*(gamma312*gammado313 + gamma311*gammado323))*ginv12 + + (-ddg1313 + gamma133*gammado111 + gamma233*gammado112 + + (2.*gamma113 + gamma333)*gammado113 + + (gamma111 + gamma313)*gammado133 + gamma113*gammado311 + + gamma213*(gammado123 + gammado213 + gammado312) + + (gamma111 + 2.*gamma313)*gammado313 + + gamma211*(gammado233 + gammado323) + 2.*gamma311*gammado333)*ginv13 + + (-0.5*ddg2213 + gamma123*gammado112 + gamma223*gammado122 + + (gamma112 + gamma323)*gammado123 + gamma112*gammado312 + + gamma212*(gammado223 + gammado322) + 2.*gamma312*gammado323)*ginv22 + + (-ddg2313 + gamma133*gammado112 + gamma123*gammado113 + + gamma233*gammado122 + (gamma113 + gamma223 + gamma333)*gammado123 + + (gamma112 + gamma323)*gammado133 + gamma113*gammado312 + + gamma112*gammado313 + gamma213*(gammado223 + gammado322) + + gamma212*(gammado233 + gammado323) + + 2.*(gamma313*gammado323 + gamma312*gammado333))*ginv23 + + (-0.5*ddg3313 + gamma133*gammado113 + gamma233*gammado123 + + (gamma113 + gamma333)*gammado133 + gamma113*gammado313 + + gamma213*(gammado233 + gammado323) + 2.*gamma313*gammado333)*ginv33 +; + +R22 += +dG21*g12 + dG22*g22 + dG23*g23 + gammado212*Gfromg1 + gammado222*Gfromg2 + + gammado223*Gfromg3 + (-0.5*ddg1122 + + gamma112*(gammado112 + 2.*gammado211) + 3.*gamma212*gammado212 + + gamma312*(2.*gammado213 + gammado312))*ginv11 + + (-ddg1222 + gamma122*(gammado112 + 2.*gammado211) + + gamma112*(gammado122 + 2.*gammado212) + + 3.*(gamma222*gammado212 + gamma212*gammado222) + + 2.*(gamma322*gammado213 + gamma312*gammado223) + + gamma322*gammado312 + gamma312*gammado322)*ginv12 + + (-ddg1322 + gamma123*(gammado112 + 2.*gammado211) + + gamma112*(gammado123 + 2.*gammado213) + + 3.*(gamma223*gammado212 + gamma212*gammado223) + + 2.*(gamma323*gammado213 + gamma312*gammado233) + + gamma323*gammado312 + gamma312*gammado323)*ginv13 + + (-0.5*ddg2222 + gamma122*(gammado122 + 2.*gammado212) + + 3.*gamma222*gammado222 + gamma322*(2.*gammado223 + gammado322))*ginv22 \ ++ (-ddg2322 + gamma123*(gammado122 + 2.*gammado212) + + gamma122*(gammado123 + 2.*gammado213) + + 3.*(gamma223*gammado222 + gamma222*gammado223) + + 2.*(gamma323*gammado223 + gamma322*gammado233) + + gamma323*gammado322 + gamma322*gammado323)*ginv23 + + (-0.5*ddg3322 + gamma123*(gammado123 + 2.*gammado213) + + 3.*gamma223*gammado223 + gamma323*(2.*gammado233 + gammado323))*ginv33 +; + +R23 += +0.5*(dG31*g12 + dG21*g13 + dG32*g22 + (dG22 + dG33)*g23 + dG23*g33 + + (gammado213 + gammado312)*Gfromg1 + + (gammado223 + gammado322)*Gfromg2 + (gammado233 + gammado323)*Gfromg3) \ ++ (-0.5*ddg1123 + gamma113*gammado211 + gamma213*gammado212 + + (gamma212 + gamma313)*gammado213 + + gamma112*(gammado113 + gammado311) + gamma212*gammado312 + + 2.*gamma312*gammado313)*ginv11 + + (-ddg1223 + gamma123*gammado211 + (gamma113 + gamma223)*gammado212 + + (gamma222 + gamma323)*gammado213 + gamma213*gammado222 + + (gamma212 + gamma313)*gammado223 + + gamma122*(gammado113 + gammado311) + gamma222*gammado312 + + gamma112*(gammado123 + gammado312) + gamma212*gammado322 + + 2.*(gamma322*gammado313 + gamma312*gammado323))*ginv12 + + (-ddg1323 + gamma133*gammado211 + gamma233*gammado212 + + (gamma113 + gamma223 + gamma333)*gammado213 + gamma213*gammado223 + + (gamma212 + gamma313)*gammado233 + + gamma123*(gammado113 + gammado311) + gamma223*gammado312 + + gamma112*(gammado133 + gammado313) + gamma212*gammado323 + + 2.*(gamma323*gammado313 + gamma312*gammado333))*ginv13 + + (-0.5*ddg2223 + gamma123*gammado212 + gamma223*gammado222 + + (gamma222 + gamma323)*gammado223 + + gamma122*(gammado123 + gammado312) + gamma222*gammado322 + + 2.*gamma322*gammado323)*ginv22 + + (-ddg2323 + gamma133*gammado212 + gamma233*gammado222 + + (2.*gamma223 + gamma333)*gammado223 + + (gamma222 + gamma323)*gammado233 + + gamma123*(gammado123 + gammado213 + gammado312) + + gamma122*(gammado133 + gammado313) + gamma223*gammado322 + + (gamma222 + 2.*gamma323)*gammado323 + 2.*gamma322*gammado333)*ginv23 + + (-0.5*ddg3323 + gamma133*gammado213 + gamma233*gammado223 + + (gamma223 + gamma333)*gammado233 + + gamma123*(gammado133 + gammado313) + gamma223*gammado323 + + 2.*gamma323*gammado333)*ginv33 +; + +R33 += +dG31*g13 + dG32*g23 + dG33*g33 + gammado313*Gfromg1 + gammado323*Gfromg2 + + gammado333*Gfromg3 + (-0.5*ddg1133 + + gamma113*(gammado113 + 2.*gammado311) + + gamma213*(gammado213 + 2.*gammado312) + 3.*gamma313*gammado313)*ginv11 \ ++ (-ddg1233 + gamma123*(gammado113 + 2.*gammado311) + + gamma113*(gammado123 + 2.*gammado312) + + gamma223*(gammado213 + 2.*gammado312) + + gamma213*(gammado223 + 2.*gammado322) + + 3.*(gamma323*gammado313 + gamma313*gammado323))*ginv12 + + (-ddg1333 + gamma133*(gammado113 + 2.*gammado311) + + gamma233*(gammado213 + 2.*gammado312) + + gamma113*(gammado133 + 2.*gammado313) + + gamma213*(gammado233 + 2.*gammado323) + + 3.*(gamma333*gammado313 + gamma313*gammado333))*ginv13 + + (-0.5*ddg2233 + gamma123*(gammado123 + 2.*gammado312) + + gamma223*(gammado223 + 2.*gammado322) + 3.*gamma323*gammado323)*ginv22 \ ++ (-ddg2333 + gamma133*(gammado123 + 2.*gammado312) + + gamma123*(gammado133 + 2.*gammado313) + + gamma233*(gammado223 + 2.*gammado322) + + gamma223*(gammado233 + 2.*gammado323) + + 3.*(gamma333*gammado323 + gamma323*gammado333))*ginv23 + + (-0.5*ddg3333 + gamma133*(gammado133 + 2.*gammado313) + + gamma233*(gammado233 + 2.*gammado323) + 3.*gamma333*gammado333)*ginv33 +; + +ff += +chi +; + +oochipsipower += +1/chipsipower +; + +f += +oochipsipower*log(ff) +; + +psim4 += +exp(-4.*f) +; + +df1 += +(dchi1*oochipsipower)/chi +; + +df2 += +(dchi2*oochipsipower)/chi +; + +df3 += +(dchi3*oochipsipower)/chi +; + +ddf11 += +(ddchi11*oochipsipower)/chi - chipsipower*pow2(df1) +; + +ddf12 += +-(chipsipower*df1*df2) + (ddchi12*oochipsipower)/chi +; + +ddf13 += +-(chipsipower*df1*df3) + (ddchi13*oochipsipower)/chi +; + +ddf22 += +(ddchi22*oochipsipower)/chi - chipsipower*pow2(df2) +; + +ddf23 += +-(chipsipower*df2*df3) + (ddchi23*oochipsipower)/chi +; + +ddf33 += +(ddchi33*oochipsipower)/chi - chipsipower*pow2(df3) +; + +cddf11 += +ddf11 - df1*gamma111 - df2*gamma211 - df3*gamma311 +; + +cddf12 += +ddf12 - df1*gamma112 - df2*gamma212 - df3*gamma312 +; + +cddf13 += +ddf13 - df1*gamma113 - df2*gamma213 - df3*gamma313 +; + +cddf22 += +ddf22 - df1*gamma122 - df2*gamma222 - df3*gamma322 +; + +cddf23 += +ddf23 - df1*gamma123 - df2*gamma223 - df3*gamma323 +; + +cddf33 += +ddf33 - df1*gamma133 - df2*gamma233 - df3*gamma333 +; + +trcddf += +cddf11*ginv11 + cddf22*ginv22 + + 2.*(cddf12*ginv12 + cddf13*ginv13 + cddf23*ginv23) + cddf33*ginv33 +; + +Rphi11 += +-2.*(cddf11 + g11*trcddf) + (4. - 4.*g11*ginv11)*pow2(df1) - + g11*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi12 += +df1*df2*(4. - 8.*g12*ginv12) - 2.*(cddf12 + g12*trcddf) - + g12*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi13 += +df1*(4.*df3 - 8.*df2*g13*ginv12) - 2.*(cddf13 + g13*trcddf) - + g13*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi22 += +-2.*(cddf22 + g22*trcddf) + (4. - 4.*g22*ginv22)*pow2(df2) - + g22*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv11*pow2(df1) + ginv33*pow2(df3))) +; + +Rphi23 += +df2*(-8.*df1*g23*ginv12 + df3*(4. - 8.*g23*ginv23)) - + 2.*(cddf23 + g23*trcddf) - g23* + (8.*df1*df3*ginv13 + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + + ginv33*pow2(df3))) +; + +Rphi33 += +-2.*(cddf33 + g33*trcddf) - g33* + (8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2))) + + (4. - 4.*g33*ginv33)*pow2(df3) +; + +Rf11 += +R11 + Rphi11 +; + +Rf12 += +R12 + Rphi12 +; + +Rf13 += +R13 + Rphi13 +; + +Rf22 += +R22 + Rphi22 +; + +Rf23 += +R23 + Rphi23 +; + +Rf33 += +R33 + Rphi33 +; + +Rhat += +psim4*(ginv11*Rf11 + ginv22*Rf22 + + 2.*(ginv12*Rf12 + ginv13*Rf13 + ginv23*Rf23) + ginv33*Rf33) +; + +cdda11 += +dda11 - da2*gamma211 - da3*gamma311 + + da1*(-gamma111 + df1*(-4. + 2.*g11*ginv11)) + + 2.*g11*((da2*df1 + da1*df2)*ginv12 + (da3*df1 + da1*df3)*ginv13 + + da2*df2*ginv22 + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) +; + +cdda12 += +dda12 - da1*gamma112 - da2*gamma212 - da3*gamma312 + + 2.*(-(da2*df1) - da1*df2 + g12* + (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) +; + +cdda13 += +dda13 - da1*gamma113 - da2*gamma213 - da3*gamma313 + + 2.*(-(da3*df1) - da1*df3 + g13* + (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) +; + +cdda22 += +dda22 - da1*gamma122 - da2*(4.*df2 + gamma222) - da3*gamma322 + + 2.*g22*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) +; + +cdda23 += +dda23 - da1*gamma123 - da2*gamma223 - da3*gamma323 + + 2.*(-(da3*df2) - da2*df3 + g23* + (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) +; + +cdda33 += +dda33 - da1*gamma133 - da2*gamma233 - da3*(4.*df3 + gamma333) + + 2.*g33*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) +; + +trcdda += +(cdda11*ginv11 + cdda22*ginv22 + + 2.*(cdda12*ginv12 + cdda13*ginv13 + cdda23*ginv23) + cdda33*ginv33)*psim4 +; + +AA11 += +2.*(A11*(A12*ginv12 + A13*ginv13) + A12*A13*ginv23) + ginv11*pow2(A11) + + ginv22*pow2(A12) + ginv33*pow2(A13) +; + +AA12 += +(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + + (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) +; + +AA13 += +(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + + A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) +; + +AA21 += +(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + + (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) +; + +AA22 += +2.*(A12*(A22*ginv12 + A23*ginv13) + A22*A23*ginv23) + ginv11*pow2(A12) + + ginv22*pow2(A22) + ginv33*pow2(A23) +; + +AA23 += +A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + + A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) +; + +AA31 += +(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + + A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) +; + +AA32 += +A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + + A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) +; + +AA33 += +2.*(A13*(A23*ginv12 + A33*ginv13) + A23*A33*ginv23) + ginv11*pow2(A13) + + ginv22*pow2(A23) + ginv33*pow2(A33) +; + +Ainv11 += +2.*(A23*ginv12*ginv13 + ginv11*(A12*ginv12 + A13*ginv13)) + + A11*pow2(ginv11) + A22*pow2(ginv12) + A33*pow2(ginv13) +; + +Ainv12 += +ginv11*(A11*ginv12 + A12*ginv22 + A13*ginv23) + + ginv12*(A13*ginv13 + A22*ginv22 + A23*ginv23) + + ginv13*(A23*ginv22 + A33*ginv23) + A12*pow2(ginv12) +; + +Ainv13 += +ginv11*(A11*ginv13 + A12*ginv23 + A13*ginv33) + + ginv12*(A12*ginv13 + A22*ginv23 + A23*ginv33) + + ginv13*(A23*ginv23 + A33*ginv33) + A13*pow2(ginv13) +; + +Ainv22 += +2.*(A23*ginv22*ginv23 + ginv12*(A12*ginv22 + A13*ginv23)) + + A11*pow2(ginv12) + A22*pow2(ginv22) + A33*pow2(ginv23) +; + +Ainv23 += +ginv13*(A12*ginv22 + A13*ginv23) + A33*ginv23*ginv33 + + ginv12*(A11*ginv13 + A12*ginv23 + A13*ginv33) + + ginv22*(A22*ginv23 + A23*ginv33) + A23*pow2(ginv23) +; + +Ainv33 += +2.*(A23*ginv23*ginv33 + ginv13*(A12*ginv23 + A13*ginv33)) + + A11*pow2(ginv13) + A22*pow2(ginv23) + A33*pow2(ginv33) +; + +cdA111 += +dA111 - 2.*(A11*gamma111 + A12*gamma211 + A13*gamma311) +; + +cdA112 += +dA112 - A11*gamma112 - A22*gamma211 - A12*(gamma111 + gamma212) - + A23*gamma311 - A13*gamma312 +; + +cdA113 += +dA113 - A11*gamma113 - A23*gamma211 - A12*gamma213 - A33*gamma311 - + A13*(gamma111 + gamma313) +; + +cdA122 += +dA122 - 2.*(A12*gamma112 + A22*gamma212 + A23*gamma312) +; + +cdA123 += +dA123 - A13*gamma112 - A12*gamma113 - A22*gamma213 - A33*gamma312 - + A23*(gamma212 + gamma313) +; + +cdA133 += +dA133 - 2.*(A13*gamma113 + A23*gamma213 + A33*gamma313) +; + +cdA211 += +dA211 - 2.*(A11*gamma112 + A12*gamma212 + A13*gamma312) +; + +cdA212 += +dA212 - A11*gamma122 - A22*gamma212 - A12*(gamma112 + gamma222) - + A23*gamma312 - A13*gamma322 +; + +cdA213 += +dA213 - A11*gamma123 - A23*gamma212 - A12*gamma223 - A33*gamma312 - + A13*(gamma112 + gamma323) +; + +cdA222 += +dA222 - 2.*(A12*gamma122 + A22*gamma222 + A23*gamma322) +; + +cdA223 += +dA223 - A13*gamma122 - A12*gamma123 - A22*gamma223 - A33*gamma322 - + A23*(gamma222 + gamma323) +; + +cdA233 += +dA233 - 2.*(A13*gamma123 + A23*gamma223 + A33*gamma323) +; + +cdA311 += +dA311 - 2.*(A11*gamma113 + A12*gamma213 + A13*gamma313) +; + +cdA312 += +dA312 - A11*gamma123 - A22*gamma213 - A12*(gamma113 + gamma223) - + A23*gamma313 - A13*gamma323 +; + +cdA313 += +dA313 - A11*gamma133 - A23*gamma213 - A12*gamma233 - A33*gamma313 - + A13*(gamma113 + gamma333) +; + +cdA322 += +dA322 - 2.*(A12*gamma123 + A22*gamma223 + A23*gamma323) +; + +cdA323 += +dA323 - A13*gamma123 - A12*gamma133 - A22*gamma233 - A33*gamma323 - + A23*(gamma223 + gamma333) +; + +cdA333 += +dA333 - 2.*(A13*gamma133 + A23*gamma233 + A33*gamma333) +; + +divbeta += +db11 + db22 + db33 +; + +totdivbeta += +0.66666666666666666667*divbeta +; + +lieg11 += +beta1*dg111 + beta2*dg211 + beta3*dg311 + + 2.*(db11*g11 + db12*g12 + db13*g13) - g11*totdivbeta +; + +lieg12 += +beta1*dg112 + beta2*dg212 + beta3*dg312 + db21*g11 + db23*g13 + db12*g22 + + db13*g23 + g12*(db11 + db22 - totdivbeta) +; + +lieg13 += +beta1*dg113 + beta2*dg213 + beta3*dg313 + db31*g11 + db32*g12 + db12*g23 + + db13*g33 + g13*(db11 + db33 - totdivbeta) +; + +lieg22 += +beta1*dg122 + beta2*dg222 + beta3*dg322 + + 2.*(db21*g12 + db22*g22 + db23*g23) - g22*totdivbeta +; + +lieg23 += +beta1*dg123 + beta2*dg223 + beta3*dg323 + db31*g12 + db21*g13 + db32*g22 + + db23*g33 + g23*(db22 + db33 - totdivbeta) +; + +lieg33 += +beta1*dg133 + beta2*dg233 + beta3*dg333 + + 2.*(db31*g13 + db32*g23 + db33*g33) - g33*totdivbeta +; + +lieA11 += +beta1*dA111 + beta2*dA211 + beta3*dA311 + + 2.*(A11*db11 + A12*db12 + A13*db13) - A11*totdivbeta +; + +lieA12 += +beta1*dA112 + beta2*dA212 + beta3*dA312 + A22*db12 + A23*db13 + A11*db21 + + A13*db23 + A12*(db11 + db22 - totdivbeta) +; + +lieA13 += +beta1*dA113 + beta2*dA213 + beta3*dA313 + A23*db12 + A33*db13 + A11*db31 + + A12*db32 + A13*(db11 + db33 - totdivbeta) +; + +lieA22 += +beta1*dA122 + beta2*dA222 + beta3*dA322 + + 2.*(A12*db21 + A22*db22 + A23*db23) - A22*totdivbeta +; + +lieA23 += +beta1*dA123 + beta2*dA223 + beta3*dA323 + A13*db21 + A33*db23 + A12*db31 + + A22*db32 + A23*(db22 + db33 - totdivbeta) +; + +lieA33 += +beta1*dA133 + beta2*dA233 + beta3*dA333 + + 2.*(A13*db31 + A23*db32 + A33*db33) - A33*totdivbeta +; + +betas += +beta1*sdown1 + beta2*sdown2 + beta3*sdown3 +; + +Dbetas += +(db11*sdown1 + db12*sdown2 + db13*sdown3)*sup1 + + (db21*sdown1 + db22*sdown2 + db23*sdown3)*sup2 + + (db31*sdown1 + db32*sdown2 + db33*sdown3)*sup3 +; + +Dalpha += +da1*sup1 + da2*sup2 + da3*sup3 +; + +DKhat += +dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3 +; + +DK += +dK1*sup1 + dK2*sup2 + dK3*sup3 +; + +DTheta += +dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 +; + +Gams += +G1*sdown1 + G2*sdown2 + G3*sdown3 +; + +DGams += +(dG11*sdown1 + dG12*sdown2 + dG13*sdown3)*sup1 + + (dG21*sdown1 + dG22*sdown2 + dG23*sdown3)*sup2 + + (dG31*sdown1 + dG32*sdown2 + dG33*sdown3)*sup3 +; + +GamA1 += +G1*qud11 + G2*qud12 + G3*qud13 +; + +GamA2 += +G1*qud21 + G2*qud22 + G3*qud23 +; + +GamA3 += +G1*qud31 + G2*qud32 + G3*qud33 +; + +DGamA1 += +(dG11*qud11 + dG12*qud12 + dG13*qud13)*sup1 + + (dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + + (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3 +; + +DGamA2 += +(dG11*qud21 + dG12*qud22 + dG13*qud23)*sup1 + + (dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + + (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3 +; + +DGamA3 += +(dG11*qud31 + dG12*qud32 + dG13*qud33)*sup1 + + (dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + + (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3 +; + +betaA1 += +beta1*qud11 + beta2*qud12 + beta3*qud13 +; + +betaA2 += +beta1*qud21 + beta2*qud22 + beta3*qud23 +; + +betaA3 += +beta1*qud31 + beta2*qud32 + beta3*qud33 +; + +DbetaA1 += +(db11*qud11 + db12*qud12 + db13*qud13)*sup1 + + (db21*qud11 + db22*qud12 + db23*qud13)*sup2 + + (db31*qud11 + db32*qud12 + db33*qud13)*sup3 +; + +DbetaA2 += +(db11*qud21 + db12*qud22 + db13*qud23)*sup1 + + (db21*qud21 + db22*qud22 + db23*qud23)*sup2 + + (db31*qud21 + db32*qud22 + db33*qud23)*sup3 +; + +DbetaA3 += +(db11*qud31 + db12*qud32 + db13*qud33)*sup1 + + (db21*qud31 + db22*qud32 + db23*qud33)*sup2 + + (db31*qud31 + db32*qud32 + db33*qud33)*sup3 +; + +lienKhat += +-((DKhat + Khat/r)*sqrt(muL)) +; + +lienTheta += +-DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta +; + +lienK += +lienKhat + 2.*lienTheta +; + +rKhat += +beta1*dKhat1 + beta2*dKhat2 + beta3*dKhat3 + alpha*lienKhat +; + +#if 0 +// David's new version +rGams += +(beta1*dG11 + beta2*dG21 + beta3*dG31 + + (ddb111*quu11 + ddb221*quu22 + + 2.*(ddb121*quu12 + ddb131*quu13 + ddb231*quu23) + ddb331*quu33)/chi\ +)*sdown1 + (beta1*dG12 + beta2*dG22 + beta3*dG32 + + (ddb112*quu11 + ddb222*quu22 + + 2.*(ddb122*quu12 + ddb132*quu13 + ddb232*quu23) + ddb332*quu33)/chi\ +)*sdown2 + (beta1*dG13 + beta2*dG23 + beta3*dG33 + + (ddb113*quu11 + ddb223*quu22 + + 2.*(ddb123*quu12 + ddb133*quu13 + ddb233*quu23) + ddb333*quu33)/chi\ +)*sdown3 - ((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + ddb121*qud21 + + ddb122*qud22 + ddb123*qud23 + ddb131*qud31 + ddb132*qud32 + + ddb133*qud33)*sup1 + (ddb121*qud11 + ddb122*qud12 + + ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + ddb223*qud23 + + ddb231*qud31 + ddb232*qud32 + ddb233*qud33)*sup2 + + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + ddb332*qud32 + + ddb333*qud33)*sup3)/chi - (dG11 + dG22 + dG33)*vbetas + + 2.*((0.33333333333333333333*alpha* + (dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3))/(chi + chi*vbetas) + + ((db11 + db22 + db33)*shiftdriver)/(vbetaA*sqrt(3.))) + + (1.3333333333333333333*alpha*(dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3)* + sqrt(muL))/(chi*(vbetas + sqrt(muL))) +; +#else +//David's old version +rGams += +shiftdriver*((beta1*db11 + beta2*db21)*(db12*sdown2 + db13*sdown3) + + 2.*beta1*((beta2*ddb121 + beta3*ddb131)*sdown1 + + (beta2*ddb122 + beta3*ddb132)*sdown2 + + (beta2*ddb123 + beta3*ddb133)*sdown3) + + sdown1*(db21*(beta1*db12 + beta2*(db11 + db22) + beta3*db32) + + db31*(beta1*db13 + beta2*db23 + beta3*(db11 + db33)) + + beta2*(2.*beta3*ddb231 + dG21) + beta3*dG31 + ddb111*pow2(beta1) + + ddb221*pow2(beta2) + ddb331*pow2(beta3) + beta1*(dG11 + pow2(db11))\ +) + sdown2*(db12*(beta1*db22 + beta3*db31) + + db32*(beta1*db13 + beta2*db23 + beta3*(db22 + db33)) + beta1*dG12 + + beta3*dG32 + ddb112*pow2(beta1) + ddb222*pow2(beta2) + + ddb332*pow2(beta3) + beta2*(2.*beta3*ddb232 + dG22 + pow2(db22)))) - + ((beta1*db11 + beta2*db21 + beta3*db31)*sdown1 + + (beta2*db22 + beta3*db32)*sdown2 + beta2*db23*sdown3 + + beta1*(db12*sdown2 + db13*sdown3))*pow2(shiftdriver) + + sdown3*(shiftdriver*((beta1*db12 + beta2*db22)*db23 + beta1*dG13 + + beta2*dG23 + ddb113*pow2(beta1) + ddb223*pow2(beta2) + + ddb333*pow2(beta3) + beta3* + (db13*db31 + db23*db32 + 2.*beta2*ddb233 + dG33 + pow2(db33))) + + db33*((beta1*db13 + beta2*db23)*shiftdriver - beta3*pow2(shiftdriver))) +; +#endif + +rTheta += +beta1*dTheta1 + beta2*dTheta2 + beta3*dTheta3 + alpha*lienTheta +; + +rACss += +2.*((A23*alpha*K + lieA23)*sup2*sup3 + + sup1*((A12*alpha*K + lieA12)*sup2 + A13*alpha*K*sup3) + + psim4*((-cdda23 + alpha*Rf23)*sup2*sup3 + + sup1*((-cdda12 + alpha*Rf12)*sup2 - cdda13*sup3))) + + 0.66666666666666666667*(g13*sup1 + g23*sup2)*sup3*trcdda + + sup1*(2.*(-(AA31*alpha) + lieA13)*sup3 + + 0.66666666666666666667*g12*sup2*trcdda) + + (lieA11 + psim4*(-cdda11 + alpha*Rf11) + + 0.33333333333333333333*g11*(-(alpha*Rhat) + trcdda))*pow2(sup1) + + (lieA22 - cdda22*psim4 + alpha* + (A22*K + psim4*Rf22 - 0.33333333333333333333*g22*Rhat) + + 0.33333333333333333333*g22*trcdda)*pow2(sup2) + + (lieA33 - cdda33*psim4 + alpha* + (A33*K + psim4*Rf33 - 0.33333333333333333333*g33*Rhat) + + 0.33333333333333333333*g33*trcdda)*pow2(sup3) + + alpha*(ginv11*((-2.*cdA111*chi + 3.*A11*dchi1)*sup1 + + (-2.*cdA112*chi + 3.*A12*dchi1)*sup2 + + (-2.*cdA113*chi + 3.*A13*dchi1)*sup3) + + ginv22*((-2.*cdA212*chi + 3.*A12*dchi2)*sup1 + + (-2.*cdA222*chi + 3.*A22*dchi2)*sup2 + + (-2.*cdA223*chi + 3.*A23*dchi2)*sup3) + + ginv33*((-2.*cdA313*chi + 3.*A13*dchi3)*sup1 + + (-2.*cdA323*chi + 3.*A23*dchi3)*sup2 + + (-2.*cdA333*chi + 3.*A33*dchi3)*sup3) + + chi*(-2.*DTheta + 1.3333333333333333333* + (dK1*sup1 + dK2*sup2 + dK3*sup3)) + + ginv12*((-2.*cdA212*chi + 3.*A12*dchi2)*sup2 + + (-2.*cdA213*chi + 3.*A13*dchi2)*sup3 - + 2.*chi*((cdA112 + cdA211)*sup1 + cdA122*sup2 + cdA123*sup3) + + 3.*((A12*dchi1 + A11*dchi2)*sup1 + dchi1*(A22*sup2 + A23*sup3))) + + ginv13*((-2.*cdA312*chi + 3.*A12*dchi3)*sup2 + + (-2.*cdA313*chi + 3.*A13*dchi3)*sup3 - + 2.*chi*((cdA113 + cdA311)*sup1 + cdA123*sup2 + cdA133*sup3) + + 3.*((A13*dchi1 + A11*dchi3)*sup1 + dchi1*(A23*sup2 + A33*sup3))) + + ginv23*((-2.*cdA322*chi + 3.*A22*dchi3)*sup2 + + (-2.*cdA323*chi + 3.*A23*dchi3)*sup3 - + 2.*chi*((cdA213 + cdA312)*sup1 + cdA223*sup2 + cdA233*sup3) + + 3.*((A13*dchi2 + A12*dchi3)*sup1 + dchi2*(A23*sup2 + A33*sup3))) + + (0.33333333333333333333*((dG11 - dGfromgdu11)*qud11 + + (dG12 - dGfromgdu12)*qud12 + (dG13 - dGfromgdu13)*qud13 + + (dG21 - dGfromgdu21)*qud21 + (dG22 - dGfromgdu22)*qud22 + + (dG23 - dGfromgdu23)*qud23 + (dG31 - dGfromgdu31)*qud31 + + (dG32 - dGfromgdu32)*qud32 + (dG33 - dGfromgdu33)*qud33) + + kappa1*((G1 - Gfromg1)*sdown1 + (G2 - Gfromg2)*sdown2 + + (G3 - Gfromg3)*sdown3) + + 0.66666666666666666667* + ((dGfromgdu21*sdown1 + dGfromgdu22*sdown2)*sup2 + + sdown3*((-dG13 + dGfromgdu13)*sup1 - dG23*sup2 - dG33*sup3) + + sdown1*((-dG11 + dGfromgdu11)*sup1 - dG21*sup2 - dG31*sup3 + + dGfromgdu31*sup3) + + sdown2*((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3 + + dGfromgdu32*sup3)))*pow2(chi) + + 0.66666666666666666667*sup2* + (-(Rhat*(g12*sup1 + g23*sup3)) + dGfromgdu23*sdown3*pow2(chi)) + + sup3*((2.*psim4*Rf13 - 0.66666666666666666667*g13*Rhat)*sup1 + + 0.66666666666666666667*dGfromgdu33*sdown3*pow2(chi)) + + (-2.*AA11 + A11*K)*pow2(sup1) - + 2.*((AA23 + AA32)*sup2*sup3 + sup1*((AA12 + AA21)*sup2 + AA13*sup3) + + AA22*pow2(sup2) + AA33*pow2(sup3))) +; + +rACqq += +chi*(-((4.*(A12*Ainv12 + A13*Ainv13 + A23*Ainv23) + + 2.*(A11*Ainv11 + A22*Ainv22 + A33*Ainv33))*alpha) + + Ainv11*lieg11 + Ainv22*lieg22 + + 2.*(Ainv12*lieg12 + Ainv13*lieg13 + Ainv23*lieg23) + Ainv33*lieg33) - + rACss +; + +rGamA1 += +-(((dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + + (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3)*vbetaA) + + qud11*(beta2*dG21 + beta3*dG31 + + (1.3333333333333333333*ddb111*quu11 + + 2.3333333333333333333*(ddb121*quu12 + ddb131*quu13) + + ddb221*quu22 + ddb331*quu33 + + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + + dG11*(beta1 - sup1*vbetaA)) + + qud12*(beta2*dG22 + beta3*dG32 + + (1.3333333333333333333*ddb112*quu11 + + 2.3333333333333333333*(ddb122*quu12 + ddb132*quu13) + + ddb222*quu22 + 2.*ddb232*quu23 + ddb332*quu33 + + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + + dG12*(beta1 - sup1*vbetaA)) + + qud13*(beta2*dG23 + beta3*dG33 + + (1.3333333333333333333*ddb113*quu11 + + 2.3333333333333333333*(ddb123*quu12 + ddb133*quu13) + + ddb223*quu22 + 2.*ddb233*quu23 + ddb333*quu33 + + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + + dG13*(beta1 - sup1*vbetaA)) + + (0.33333333333333333333*((ddb121*qud21 + ddb122*qud22 + ddb123*qud23 + + ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu11 + + (ddb221*qud21 + ddb223*qud23 + ddb231*qud31 + ddb232*qud32 + + ddb233*qud33)*quu12 + + (ddb231*qud21 + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + + ddb332*qud32)*quu13) - + alpha*((1.3333333333333333333*dKhat1 + + 0.66666666666666666667*dTheta1)*quu11 + + 1.3333333333333333333*(dKhat2*quu12 + dKhat3*quu13)) + + 1.3333333333333333333*((ddb132*quu13*sdown2 + ddb113*quu11*sdown3)* + sup1 + (quu13*(ddb231*sdown1 + ddb232*sdown2) + + quu12*(ddb222*sdown2 + ddb223*sdown3))*sup2 + + (quu12*(ddb232*sdown2 + ddb233*sdown3) + + quu13*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + + sdown1*((ddb121*quu12 + ddb131*quu13)*sup1 + ddb221*quu12*sup2 + + ddb131*quu11*sup3) + + sdown2*((ddb112*quu11 + ddb122*quu12)*sup1 + + quu11*(ddb122*sup2 + ddb132*sup3)) + + sdown3*((ddb123*quu12 + ddb133*quu13)*sup1 + + quu11*(ddb123*sup2 + ddb133*sup3))) + + qud11*(2.*ddb231*quu23 + (db21*shiftdriver*sup2)/vbetaA) - + (((db11*quu11 + db21*quu12)*sdown1 + + (db12*quu11 + db22*quu12 + db32*quu13)*sdown2 + + (db13*quu11 + db23*quu12 + db33*quu13)*sdown3)*shiftdriver)/ + vbetaA + ((dG22*quu12 + dG32*quu13)*sdown2 + + (dG13*quu11 + dG23*quu12)*sdown3)*vbetaA + + quu11*(1.3333333333333333333*sdown1*(ddb111*sup1 + ddb121*sup2) + + (dG11*sdown1 + dG12*sdown2)*vbetaA) + + quu12*(-0.66666666666666666667*alpha*dTheta2 + + 0.33333333333333333333*ddb222*qud22 + + sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + + quu13*(-0.66666666666666666667*alpha*dTheta3 + + 0.33333333333333333333*ddb333*qud33 - + (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + + sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi +; + +rGamA2 += +-(((dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + + (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3)*vbetaA) + + qud21*(beta2*dG21 + beta3*dG31 + + (ddb111*quu11 + 2.*ddb131*quu13 + + 1.3333333333333333333*ddb221*quu22 + + 2.3333333333333333333*(ddb121*quu12 + ddb231*quu23) + + ddb331*quu33 + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + + dG11*(beta1 - sup1*vbetaA)) + + qud22*(beta2*dG22 + beta3*dG32 + + (ddb112*quu11 + 2.*ddb132*quu13 + + 1.3333333333333333333*ddb222*quu22 + + 2.3333333333333333333*(ddb122*quu12 + ddb232*quu23) + + ddb332*quu33 + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/ + vbetaA)/chi + dG12*(beta1 - sup1*vbetaA)) + + qud23*(beta2*dG23 + beta3*dG33 + + (ddb113*quu11 + 2.*ddb133*quu13 + + 1.3333333333333333333*ddb223*quu22 + + 2.3333333333333333333*(ddb123*quu12 + ddb233*quu23) + + ddb333*quu33 + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/ + vbetaA)/chi + dG13*(beta1 - sup1*vbetaA)) + + (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + + ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu12 + + (ddb121*qud11 + ddb123*qud13 + ddb231*qud31 + ddb232*qud32 + + ddb233*qud33)*quu22 + + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb331*qud31 + + ddb332*qud32)*quu23) - + alpha*((1.3333333333333333333*dKhat1 + + 0.66666666666666666667*dTheta1)*quu12 + + 1.3333333333333333333*(dKhat2*quu22 + dKhat3*quu23)) + + 1.3333333333333333333*((ddb132*quu23*sdown2 + ddb113*quu12*sdown3)* + sup1 + (quu23*(ddb231*sdown1 + ddb232*sdown2) + + quu22*(ddb222*sdown2 + ddb223*sdown3))*sup2 + + (quu22*(ddb232*sdown2 + ddb233*sdown3) + + quu23*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + + sdown1*((ddb121*quu22 + ddb131*quu23)*sup1 + ddb221*quu22*sup2 + + ddb131*quu12*sup3) + + sdown2*((ddb112*quu12 + ddb122*quu22)*sup1 + + quu12*(ddb122*sup2 + ddb132*sup3)) + + sdown3*((ddb123*quu22 + ddb133*quu23)*sup1 + + quu12*(ddb123*sup2 + ddb133*sup3))) - + (((db11*quu12 + db21*quu22)*sdown1 + + (db12*quu12 + db22*quu22 + db32*quu23)*sdown2 + + (db13*quu12 + db23*quu22 + db33*quu23)*sdown3)*shiftdriver)/ + vbetaA + (db21*qud21*shiftdriver*sup2)/vbetaA + + ((dG22*quu22 + dG32*quu23)*sdown2 + (dG13*quu12 + dG23*quu22)*sdown3)* + vbetaA + quu12*(1.3333333333333333333*sdown1* + (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ ++ quu22*(-0.66666666666666666667*alpha*dTheta2 + + 0.33333333333333333333*ddb122*qud12 + + sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + + quu23*(-0.66666666666666666667*alpha*dTheta3 + + 0.33333333333333333333*ddb333*qud33 - + (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + + sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi +; + +rGamA3 += +-(((dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + + (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3)*vbetaA) + + qud31*(beta2*dG21 + beta3*dG31 + + (ddb111*quu11 + 2.*ddb121*quu12 + ddb221*quu22 + + 2.3333333333333333333*(ddb131*quu13 + ddb231*quu23) + + 1.3333333333333333333*ddb331*quu33 + + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + + dG11*(beta1 - sup1*vbetaA)) + + qud32*(beta2*dG22 + beta3*dG32 + + (ddb112*quu11 + 2.*ddb122*quu12 + ddb222*quu22 + + 2.3333333333333333333*(ddb132*quu13 + ddb232*quu23) + + 1.3333333333333333333*ddb332*quu33 + + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + + dG12*(beta1 - sup1*vbetaA)) + + qud33*(beta2*dG23 + beta3*dG33 + + (ddb113*quu11 + 2.*ddb123*quu12 + ddb223*quu22 + + 2.3333333333333333333*(ddb133*quu13 + ddb233*quu23) + + 1.3333333333333333333*ddb333*quu33 + + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + + dG13*(beta1 - sup1*vbetaA)) + + (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + + ddb121*qud21 + ddb122*qud22 + ddb123*qud23)*quu13 + + (ddb121*qud11 + ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + + ddb223*qud23)*quu23 + + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + + ddb232*qud22)*quu33) - + alpha*((1.3333333333333333333*dKhat1 + + 0.66666666666666666667*dTheta1)*quu13 + + 1.3333333333333333333*(dKhat2*quu23 + dKhat3*quu33)) + + 1.3333333333333333333*((ddb132*quu33*sdown2 + ddb113*quu13*sdown3)* + sup1 + (quu33*(ddb231*sdown1 + ddb232*sdown2) + + quu23*(ddb222*sdown2 + ddb223*sdown3))*sup2 + + (quu23*(ddb232*sdown2 + ddb233*sdown3) + + quu33*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + + sdown1*((ddb121*quu23 + ddb131*quu33)*sup1 + ddb221*quu23*sup2 + + ddb131*quu13*sup3) + + sdown2*((ddb112*quu13 + ddb122*quu23)*sup1 + + quu13*(ddb122*sup2 + ddb132*sup3)) + + sdown3*((ddb123*quu23 + ddb133*quu33)*sup1 + + quu13*(ddb123*sup2 + ddb133*sup3))) - + (((db11*quu13 + db21*quu23)*sdown1 + + (db12*quu13 + db22*quu23 + db32*quu33)*sdown2 + + (db13*quu13 + db23*quu23 + db33*quu33)*sdown3)*shiftdriver)/ + vbetaA + (db21*qud31*shiftdriver*sup2)/vbetaA + + ((dG22*quu23 + dG32*quu33)*sdown2 + (dG13*quu13 + dG23*quu23)*sdown3)* + vbetaA + quu13*(1.3333333333333333333*sdown1* + (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ ++ quu33*(-0.66666666666666666667*alpha*dTheta3 + + ddb233*(0.33333333333333333333*qud23 + + 1.3333333333333333333*sdown3*sup2) - + (db31*sdown1*shiftdriver)/vbetaA + + (dG31*sdown1 + dG33*sdown3)*vbetaA) + + quu23*(-0.66666666666666666667*alpha*dTheta2 + + 0.33333333333333333333*ddb122*qud12 + + sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)))/chi +; + +rACsA1 += +(qud11*(lieA11 + alpha*chi*Rf11) + + qud21*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + + qud31*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + + qud11*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + + (A13*alpha*K + lieA13)*sup3 + + alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + + qud21*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + + (A23*alpha*K + lieA23)*sup3 + + alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + + qud31*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + + (A33*alpha*K + lieA33)*sup3 + + alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + + alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud11 + + (-(cdA112*chi) + 1.5*A12*dchi1)*qud21 + + (-(cdA113*chi) + 1.5*A13*dchi1)*qud31) + + ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud11 + + (-(cdA222*chi) + 1.5*A22*dchi2)*qud21 + + (-(cdA223*chi) + 1.5*A23*dchi2)*qud31) + + ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud11 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud21 + + (-(cdA333*chi) + 1.5*A33*dchi3)*qud31) + + chi*((0.66666666666666666667*dK1 - dTheta1)*qud11 + + (0.66666666666666666667*dK2 - dTheta2)*qud21 + + (0.66666666666666666667*dK3 - dTheta3)*qud31) + + ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud21 + + (-(cdA213*chi) + 1.5*A13*dchi2)*qud31 - + chi*((cdA112 + cdA211)*qud11 + cdA122*qud21 + cdA123*qud31) + + 1.5*((A12*dchi1 + A11*dchi2)*qud11 + dchi1*(A22*qud21 + A23*qud31))\ +) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud21 + + (-(cdA313*chi) + 1.5*A13*dchi3)*qud31 - + chi*((cdA113 + cdA311)*qud11 + cdA123*qud21 + cdA133*qud31) + + 1.5*((A13*dchi1 + A11*dchi3)*qud11 + dchi1*(A23*qud21 + A33*qud31))\ +) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud21 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud31 - + chi*((cdA213 + cdA312)*qud11 + cdA223*qud21 + cdA233*qud31) + + 1.5*((A13*dchi2 + A12*dchi3)*qud11 + dchi2*(A23*qud21 + A33*qud31))\ +) + 0.5*(kappa1*((G1 - Gfromg1)*qdd11 + (G2 - Gfromg2)*qdd12 + + (G3 - Gfromg3)*qdd13) - dG13*qdd13*sup1 - dG21*qdd11*sup2 + + (dGfromgdu22*qdd12 - dG23*qdd13)*sup2 + + (dGfromgdu31*qdd11 + dGfromgdu32*qdd12 - dG33*qdd13)*sup3 + + qdd11*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - + dG31*sup3) + qdd12* + ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + + sup1*(-2.*AA11*qud11 + 0.5*dGfromgdu13*qdd13*pow2(chi))) + + sup2*(chi*(-(cdda12*qud11) - cdda22*qud21 - cdda23*qud31 + + alpha*qud21*Rf22) + alpha* + (chi*(qud11*Rf12 + qud31*Rf23) + 0.5*dGfromgdu23*qdd13*pow2(chi))) + + sup3*(chi*(-(cdda13*qud11) - cdda23*qud21 - cdda33*qud31 + + alpha*qud21*Rf23) + alpha* + (chi*(qud11*Rf13 + qud31*Rf33) + 0.5*dGfromgdu33*qdd13*pow2(chi))) +; + +rACsA2 += +(qud12*(lieA11 + alpha*chi*Rf11) + + qud22*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + + qud32*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + + qud12*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + + (A13*alpha*K + lieA13)*sup3 + + alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + + qud22*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + + (A23*alpha*K + lieA23)*sup3 + + alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + + qud32*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + + (A33*alpha*K + lieA33)*sup3 + + alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + + alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud12 + + (-(cdA112*chi) + 1.5*A12*dchi1)*qud22 + + (-(cdA113*chi) + 1.5*A13*dchi1)*qud32) + + ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud12 + + (-(cdA222*chi) + 1.5*A22*dchi2)*qud22 + + (-(cdA223*chi) + 1.5*A23*dchi2)*qud32) + + ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud12 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud22 + + (-(cdA333*chi) + 1.5*A33*dchi3)*qud32) + + chi*((0.66666666666666666667*dK1 - dTheta1)*qud12 + + (0.66666666666666666667*dK2 - dTheta2)*qud22 + + (0.66666666666666666667*dK3 - dTheta3)*qud32) + + ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud22 + + (-(cdA213*chi) + 1.5*A13*dchi2)*qud32 - + chi*((cdA112 + cdA211)*qud12 + cdA122*qud22 + cdA123*qud32) + + 1.5*((A12*dchi1 + A11*dchi2)*qud12 + dchi1*(A22*qud22 + A23*qud32))\ +) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud22 + + (-(cdA313*chi) + 1.5*A13*dchi3)*qud32 - + chi*((cdA113 + cdA311)*qud12 + cdA123*qud22 + cdA133*qud32) + + 1.5*((A13*dchi1 + A11*dchi3)*qud12 + dchi1*(A23*qud22 + A33*qud32))\ +) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud22 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud32 - + chi*((cdA213 + cdA312)*qud12 + cdA223*qud22 + cdA233*qud32) + + 1.5*((A13*dchi2 + A12*dchi3)*qud12 + dchi2*(A23*qud22 + A33*qud32))\ +) + 0.5*(kappa1*((G1 - Gfromg1)*qdd12 + (G2 - Gfromg2)*qdd22 + + (G3 - Gfromg3)*qdd23) - dG13*qdd23*sup1 - dG21*qdd12*sup2 + + (dGfromgdu22*qdd22 - dG23*qdd23)*sup2 + + (dGfromgdu31*qdd12 + dGfromgdu32*qdd22 - dG33*qdd23)*sup3 + + qdd12*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - + dG31*sup3) + qdd22* + ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + + sup1*(-2.*AA11*qud12 + 0.5*dGfromgdu13*qdd23*pow2(chi))) + + sup2*(chi*(-(cdda12*qud12) - cdda22*qud22 - cdda23*qud32 + + alpha*qud22*Rf22) + alpha* + (chi*(qud12*Rf12 + qud32*Rf23) + 0.5*dGfromgdu23*qdd23*pow2(chi))) + + sup3*(chi*(-(cdda13*qud12) - cdda23*qud22 - cdda33*qud32 + + alpha*qud22*Rf23) + alpha* + (chi*(qud12*Rf13 + qud32*Rf33) + 0.5*dGfromgdu33*qdd23*pow2(chi))) +; + +rACsA3 += +(qud13*(lieA11 + alpha*chi*Rf11) + + qud23*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + + qud33*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + + qud13*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + + (A13*alpha*K + lieA13)*sup3 + + alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + + qud23*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + + (A23*alpha*K + lieA23)*sup3 + + alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + + qud33*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + + (A33*alpha*K + lieA33)*sup3 + + alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + + alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud13 + + (-(cdA112*chi) + 1.5*A12*dchi1)*qud23 + + (-(cdA113*chi) + 1.5*A13*dchi1)*qud33) + + ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud13 + + (-(cdA222*chi) + 1.5*A22*dchi2)*qud23 + + (-(cdA223*chi) + 1.5*A23*dchi2)*qud33) + + ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud13 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud23 + + (-(cdA333*chi) + 1.5*A33*dchi3)*qud33) + + chi*((0.66666666666666666667*dK1 - dTheta1)*qud13 + + (0.66666666666666666667*dK2 - dTheta2)*qud23 + + (0.66666666666666666667*dK3 - dTheta3)*qud33) + + ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud23 + + (-(cdA213*chi) + 1.5*A13*dchi2)*qud33 - + chi*((cdA112 + cdA211)*qud13 + cdA122*qud23 + cdA123*qud33) + + 1.5*((A12*dchi1 + A11*dchi2)*qud13 + dchi1*(A22*qud23 + A23*qud33))\ +) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud23 + + (-(cdA313*chi) + 1.5*A13*dchi3)*qud33 - + chi*((cdA113 + cdA311)*qud13 + cdA123*qud23 + cdA133*qud33) + + 1.5*((A13*dchi1 + A11*dchi3)*qud13 + dchi1*(A23*qud23 + A33*qud33))\ +) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud23 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud33 - + chi*((cdA213 + cdA312)*qud13 + cdA223*qud23 + cdA233*qud33) + + 1.5*((A13*dchi2 + A12*dchi3)*qud13 + dchi2*(A23*qud23 + A33*qud33))\ +) + 0.5*(kappa1*((G1 - Gfromg1)*qdd13 + (G2 - Gfromg2)*qdd23 + + (G3 - Gfromg3)*qdd33) - dG13*qdd33*sup1 - dG21*qdd13*sup2 + + (dGfromgdu22*qdd23 - dG23*qdd33)*sup2 + + (dGfromgdu31*qdd13 + dGfromgdu32*qdd23 - dG33*qdd33)*sup3 + + qdd13*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - + dG31*sup3) + qdd23* + ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + + sup1*(-2.*AA11*qud13 + 0.5*dGfromgdu13*qdd33*pow2(chi))) + + sup2*(chi*(-(cdda12*qud13) - cdda22*qud23 - cdda23*qud33 + + alpha*qud23*Rf22) + alpha* + (chi*(qud13*Rf12 + qud33*Rf23) + 0.5*dGfromgdu23*qdd33*pow2(chi))) + + sup3*(chi*(-(cdda13*qud13) - cdda23*qud23 - cdda33*qud33 + + alpha*qud23*Rf23) + alpha* + (chi*(qud13*Rf13 + qud33*Rf33) + 0.5*dGfromgdu33*qdd33*pow2(chi))) +; + +rACABTF11 += +-(qPhysuudd1211*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3311*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1111*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1211* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1311*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2211*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2311*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1311 + AA22*qPhysuudd2211 + AA23*qPhysuudd2311 + + AA33*qPhysuudd3311 + qPhysuudd1111*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1311 + + (0.5*(A12*dchi1*qPhysuudd1111 + A23*dchi3*qPhysuudd3311))/chi)* + sup2) - qPhysuudd3311*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1211*sup3 + + qPhysuudd1211*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1311*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2211* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2311*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2311*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1211 + A13*dchi2*qPhysuudd1311)*sup2 + + (A12*dchi3*qPhysuudd1211 - + 0.5*dchi1*(A13*qPhysuudd1111 + A23*qPhysuudd1211))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1211 - + dchi3*(A11*qPhysuudd1311 + A12*qPhysuudd2311) + + dchi1*(A22*qPhysuudd2211 + A33*qPhysuudd3311))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1311) - + A22*dchi3*qPhysuudd2311 + + dchi2*(A11*qPhysuudd1111 + A33*qPhysuudd3311))*sup2 + + (-(A33*dchi1*qPhysuudd1311) + + A13*(-(dchi2*qPhysuudd1211) + dchi3*qPhysuudd1311) + + dchi3*(A11*qPhysuudd1111 + A22*qPhysuudd2211) + + A23*(-(dchi2*qPhysuudd2211) + dchi3*qPhysuudd2311))*sup3))/chi) +; + +rACABTF12 += +-(qPhysuudd1212*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3312*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1112*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1212* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1312*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2212*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2312*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1312 + AA22*qPhysuudd2212 + AA23*qPhysuudd2312 + + AA33*qPhysuudd3312 + qPhysuudd1112*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1312 + + (0.5*(A12*dchi1*qPhysuudd1112 + A23*dchi3*qPhysuudd3312))/chi)* + sup2) - qPhysuudd3312*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1212*sup3 + + qPhysuudd1212*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1312*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2212* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2312*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2312*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1212 + A13*dchi2*qPhysuudd1312)*sup2 + + (A12*dchi3*qPhysuudd1212 - + 0.5*dchi1*(A13*qPhysuudd1112 + A23*qPhysuudd1212))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1212 - + dchi3*(A11*qPhysuudd1312 + A12*qPhysuudd2312) + + dchi1*(A22*qPhysuudd2212 + A33*qPhysuudd3312))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1312) - + A22*dchi3*qPhysuudd2312 + + dchi2*(A11*qPhysuudd1112 + A33*qPhysuudd3312))*sup2 + + (-(A33*dchi1*qPhysuudd1312) + + A13*(-(dchi2*qPhysuudd1212) + dchi3*qPhysuudd1312) + + dchi3*(A11*qPhysuudd1112 + A22*qPhysuudd2212) + + A23*(-(dchi2*qPhysuudd2212) + dchi3*qPhysuudd2312))*sup3))/chi) +; + +rACABTF13 += +-(qPhysuudd1213*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3313*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1113*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1213* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1313*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2213*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2313*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1313 + AA22*qPhysuudd2213 + AA23*qPhysuudd2313 + + AA33*qPhysuudd3313 + qPhysuudd1113*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1313 + + (0.5*(A12*dchi1*qPhysuudd1113 + A23*dchi3*qPhysuudd3313))/chi)* + sup2) - qPhysuudd3313*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1213*sup3 + + qPhysuudd1213*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1313*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2213* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2313*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2313*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1213 + A13*dchi2*qPhysuudd1313)*sup2 + + (A12*dchi3*qPhysuudd1213 - + 0.5*dchi1*(A13*qPhysuudd1113 + A23*qPhysuudd1213))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1213 - + dchi3*(A11*qPhysuudd1313 + A12*qPhysuudd2313) + + dchi1*(A22*qPhysuudd2213 + A33*qPhysuudd3313))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1313) - + A22*dchi3*qPhysuudd2313 + + dchi2*(A11*qPhysuudd1113 + A33*qPhysuudd3313))*sup2 + + (-(A33*dchi1*qPhysuudd1313) + + A13*(-(dchi2*qPhysuudd1213) + dchi3*qPhysuudd1313) + + dchi3*(A11*qPhysuudd1113 + A22*qPhysuudd2213) + + A23*(-(dchi2*qPhysuudd2213) + dchi3*qPhysuudd2313))*sup3))/chi) +; + +rACABTF22 += +-(qPhysuudd1222*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3322*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1122*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1222* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1322*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2222*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2322*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1322 + AA22*qPhysuudd2222 + AA23*qPhysuudd2322 + + AA33*qPhysuudd3322 + qPhysuudd1122*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1322 + + (0.5*(A12*dchi1*qPhysuudd1122 + A23*dchi3*qPhysuudd3322))/chi)* + sup2) - qPhysuudd3322*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1222*sup3 + + qPhysuudd1222*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1322*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2222* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2322*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2322*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1222 + A13*dchi2*qPhysuudd1322)*sup2 + + (A12*dchi3*qPhysuudd1222 - + 0.5*dchi1*(A13*qPhysuudd1122 + A23*qPhysuudd1222))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1222 - + dchi3*(A11*qPhysuudd1322 + A12*qPhysuudd2322) + + dchi1*(A22*qPhysuudd2222 + A33*qPhysuudd3322))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1322) - + A22*dchi3*qPhysuudd2322 + + dchi2*(A11*qPhysuudd1122 + A33*qPhysuudd3322))*sup2 + + (-(A33*dchi1*qPhysuudd1322) + + A13*(-(dchi2*qPhysuudd1222) + dchi3*qPhysuudd1322) + + dchi3*(A11*qPhysuudd1122 + A22*qPhysuudd2222) + + A23*(-(dchi2*qPhysuudd2222) + dchi3*qPhysuudd2322))*sup3))/chi) +; + +rACABTF23 += +-(qPhysuudd1223*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3323*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1123*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1223* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1323*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2223*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2323*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1323 + AA22*qPhysuudd2223 + AA23*qPhysuudd2323 + + AA33*qPhysuudd3323 + qPhysuudd1123*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1323 + + (0.5*(A12*dchi1*qPhysuudd1123 + A23*dchi3*qPhysuudd3323))/chi)* + sup2) - qPhysuudd3323*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1223*sup3 + + qPhysuudd1223*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1323*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2223* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2323*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2323*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1223 + A13*dchi2*qPhysuudd1323)*sup2 + + (A12*dchi3*qPhysuudd1223 - + 0.5*dchi1*(A13*qPhysuudd1123 + A23*qPhysuudd1223))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1223 - + dchi3*(A11*qPhysuudd1323 + A12*qPhysuudd2323) + + dchi1*(A22*qPhysuudd2223 + A33*qPhysuudd3323))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1323) - + A22*dchi3*qPhysuudd2323 + + dchi2*(A11*qPhysuudd1123 + A33*qPhysuudd3323))*sup2 + + (-(A33*dchi1*qPhysuudd1323) + + A13*(-(dchi2*qPhysuudd1223) + dchi3*qPhysuudd1323) + + dchi3*(A11*qPhysuudd1123 + A22*qPhysuudd2223) + + A23*(-(dchi2*qPhysuudd2223) + dchi3*qPhysuudd2323))*sup3))/chi) +; + +rACABTF33 += +-(qPhysuudd1233*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3333*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1133*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1233* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1333*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2233*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2333*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1333 + AA22*qPhysuudd2233 + AA23*qPhysuudd2333 + + AA33*qPhysuudd3333 + qPhysuudd1133*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1333 + + (0.5*(A12*dchi1*qPhysuudd1133 + A23*dchi3*qPhysuudd3333))/chi)* + sup2) - qPhysuudd3333*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1233*sup3 + + qPhysuudd1233*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1333*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2233* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2333*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2333*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1233 + A13*dchi2*qPhysuudd1333)*sup2 + + (A12*dchi3*qPhysuudd1233 - + 0.5*dchi1*(A13*qPhysuudd1133 + A23*qPhysuudd1233))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1233 - + dchi3*(A11*qPhysuudd1333 + A12*qPhysuudd2333) + + dchi1*(A22*qPhysuudd2233 + A33*qPhysuudd3333))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1333) - + A22*dchi3*qPhysuudd2333 + + dchi2*(A11*qPhysuudd1133 + A33*qPhysuudd3333))*sup2 + + (-(A33*dchi1*qPhysuudd1333) + + A13*(-(dchi2*qPhysuudd1233) + dchi3*qPhysuudd1333) + + dchi3*(A11*qPhysuudd1133 + A22*qPhysuudd2233) + + A23*(-(dchi2*qPhysuudd2233) + dchi3*qPhysuudd2333))*sup3))/chi) +; + + +if (givehPsi0) { + +gADM11 += +g11/chi +; + +gADM12 += +g12/chi +; + +gADM13 += +g13/chi +; + +gADM21 += +g12/chi +; + +gADM22 += +g22/chi +; + +gADM23 += +g23/chi +; + +gADM31 += +g13/chi +; + +gADM32 += +g23/chi +; + +gADM33 += +g33/chi +; + +vu1 += +-yp +; + +vu2 += +xp +; + +vu3 += +0 +; + +wu1 += +((-(ADMginv13*sup2) + ADMginv12*sup3)*vu1 + + (ADMginv13*sup1 - ADMginv11*sup3)*vu2 + + (-(ADMginv12*sup1) + ADMginv11*sup2)*vu3)/Power(chi,1.5) +; + +wu2 += +((-(ADMginv23*sup2) + ADMginv22*sup3)*vu1 + + (ADMginv23*sup1 - ADMginv12*sup3)*vu2 + + (-(ADMginv22*sup1) + ADMginv12*sup2)*vu3)/Power(chi,1.5) +; + +wu3 += +((-(ADMginv33*sup2) + ADMginv23*sup3)*vu1 + + (ADMginv33*sup1 - ADMginv13*sup3)*vu2 + + (-(ADMginv23*sup1) + ADMginv13*sup2)*vu3)/Power(chi,1.5) +; + +sdotv += +(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*vu1 + + (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*vu2 + + (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*vu3 +; + +vu1 += +-(sdotv*sup1) + vu1 +; + +vu2 += +-(sdotv*sup2) + vu2 +; + +vu3 += +-(sdotv*sup3) + vu3 +; + +vdotv += +(gADM31*vu1 + (gADM23 + gADM32)*vu2)*vu3 + + vu1*((gADM12 + gADM21)*vu2 + gADM13*vu3) + gADM11*pow2(vu1) + + gADM22*pow2(vu2) + gADM33*pow2(vu3) +; + +vu1 += +vu1/Sqrt(vdotv) +; + +vu2 += +vu2/Sqrt(vdotv) +; + +vu3 += +vu3/Sqrt(vdotv) +; + +sdotw += +(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*wu1 + + (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*wu2 + + (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*wu3 +; + +vdotw += +(gADM11*vu1 + gADM21*vu2 + gADM31*vu3)*wu1 + + (gADM12*vu1 + gADM22*vu2 + gADM32*vu3)*wu2 + + (gADM13*vu1 + gADM23*vu2 + gADM33*vu3)*wu3 +; + +wu1 += +-(sdotw*sup1) - vdotw*vu1 + wu1 +; + +wu2 += +-(sdotw*sup2) - vdotw*vu2 + wu2 +; + +wu3 += +-(sdotw*sup3) - vdotw*vu3 + wu3 +; + +wdotw += +(gADM31*wu1 + (gADM23 + gADM32)*wu2)*wu3 + + wu1*((gADM12 + gADM21)*wu2 + gADM13*wu3) + gADM11*pow2(wu1) + + gADM22*pow2(wu2) + gADM33*pow2(wu3) +; + +wu1 += +wu1/Sqrt(wdotw) +; + +wu2 += +wu2/Sqrt(wdotw) +; + +wu3 += +wu3/Sqrt(wdotw) +; + +vd1 += +gADM11*vu1 + gADM12*vu2 + gADM13*vu3 +; + +vd2 += +gADM21*vu1 + gADM22*vu2 + gADM23*vu3 +; + +vd3 += +gADM31*vu1 + gADM32*vu2 + gADM33*vu3 +; + +wd1 += +gADM11*wu1 + gADM12*wu2 + gADM13*wu3 +; + +wd2 += +gADM21*wu1 + gADM22*wu2 + gADM23*wu3 +; + +wd3 += +gADM31*wu1 + gADM32*wu2 + gADM33*wu3 +; + +RehPsi0 += +Power(2.7182818284590452354,pow2(hPsi0parb)* + (2.*hPsi0parc*time - pow2(hPsi0parc) - pow2(time)))*hPsi0para +; + +ImhPsi0 += +0 +; + +rACABTF11 += +rACABTF11 + alpha*chi*(2.*ImhPsi0*vd1*wd1 + RehPsi0*(pow2(vd1) - pow2(wd1))) +; + +rACABTF12 += +rACABTF12 + alpha*chi*(vd2*(RehPsi0*vd1 + ImhPsi0*wd1) + + (ImhPsi0*vd1 - RehPsi0*wd1)*wd2) +; + +rACABTF13 += +rACABTF13 + alpha*chi*(vd3*(RehPsi0*vd1 + ImhPsi0*wd1) + + (ImhPsi0*vd1 - RehPsi0*wd1)*wd3) +; + +rACABTF22 += +rACABTF22 + alpha*chi*(2.*ImhPsi0*vd2*wd2 + RehPsi0*(pow2(vd2) - pow2(wd2))) +; + +rACABTF23 += +rACABTF23 + alpha*chi*(vd3*(RehPsi0*vd2 + ImhPsi0*wd2) + + (ImhPsi0*vd2 - RehPsi0*wd2)*wd3) +; + +rACABTF33 += +rACABTF33 + alpha*chi*(2.*ImhPsi0*vd3*wd3 + RehPsi0*(pow2(vd3) - pow2(wd3))) +; + + + } + +rA11 += +rACABTF11 + 0.5*qdd11*rACqq + 2.* + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)*sdown1 + rACss*pow2(sdown1) +; + +rA12 += +rACABTF12 + 0.5*qdd12*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* + sdown2 + sdown1*(qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3 + + rACss*sdown2) +; + +rA13 += +rACABTF13 + 0.5*qdd13*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* + sdown3 + sdown1*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + + rACss*sdown3) +; + +rA22 += +rACABTF22 + 0.5*qdd22*rACqq + 2.* + (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)*sdown2 + rACss*pow2(sdown2) +; + +rA23 += +rACABTF23 + 0.5*qdd23*rACqq + (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)* + sdown3 + sdown2*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + + rACss*sdown3) +; + +rA33 += +rACABTF33 + 0.5*qdd33*rACqq + 2.* + (qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3)*sdown3 + rACss*pow2(sdown3) +; + +rG1 += +qud11*rGamA1 + qud12*rGamA2 + qud13*rGamA3 + rGams*sup1 +; + +rG2 += +qud21*rGamA1 + qud22*rGamA2 + qud23*rGamA3 + rGams*sup2 +; + +rG3 += +qud31*rGamA1 + qud32*rGamA2 + qud33*rGamA3 + rGams*sup3 +; +#else +// code adapted from David 2012-8-18 + +detginv += +1/(2.*g12*g13*g23 + g11*g22*g33 - + g33*pow2(g12) - g22*pow2(g13) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +ginv11*chi +; + +ADMginv12 += +ginv12*chi +; + +ADMginv13 += +ginv13*chi +; + +ADMginv22 += +ginv22*chi +; + +ADMginv23 += +ginv23*chi +; + +ADMginv33 += +ginv33*chi +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +qdd11 += +g11/chi - pow2(sdown1) +; + +qdd12 += +-(sdown1*sdown2) + g12/chi +; + +qdd13 += +-(sdown1*sdown3) + g13/chi +; + +qdd22 += +g22/chi - pow2(sdown2) +; + +qdd23 += +-(sdown2*sdown3) + g23/chi +; + +qdd33 += +g33/chi - pow2(sdown3) +; + +quu11 += +ADMginv11 - pow2(sup1) +; + +quu12 += +ADMginv12 - sup1*sup2 +; + +quu13 += +ADMginv13 - sup1*sup3 +; + +quu22 += +ADMginv22 - pow2(sup2) +; + +quu23 += +ADMginv23 - sup2*sup3 +; + +quu33 += +ADMginv33 - pow2(sup3) +; + +qPhysuudd1111 += +-0.5*qdd11*quu11 + pow2(qud11) +; + +qPhysuudd1112 += +qud11*qud12 - 0.5*qdd12*quu11 +; + +qPhysuudd1113 += +qud11*qud13 - 0.5*qdd13*quu11 +; + +qPhysuudd1122 += +-0.5*qdd22*quu11 + pow2(qud12) +; + +qPhysuudd1123 += +qud12*qud13 - 0.5*qdd23*quu11 +; + +qPhysuudd1133 += +-0.5*qdd33*quu11 + pow2(qud13) +; + +qPhysuudd1211 += +qud11*qud21 - 0.5*qdd11*quu12 +; + +qPhysuudd1212 += +0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) +; + +qPhysuudd1213 += +0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) +; + +qPhysuudd1222 += +qud12*qud22 - 0.5*qdd22*quu12 +; + +qPhysuudd1223 += +0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) +; + +qPhysuudd1233 += +qud13*qud23 - 0.5*qdd33*quu12 +; + +qPhysuudd1311 += +qud11*qud31 - 0.5*qdd11*quu13 +; + +qPhysuudd1312 += +0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) +; + +qPhysuudd1313 += +0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) +; + +qPhysuudd1322 += +qud12*qud32 - 0.5*qdd22*quu13 +; + +qPhysuudd1323 += +0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) +; + +qPhysuudd1333 += +qud13*qud33 - 0.5*qdd33*quu13 +; + +qPhysuudd2211 += +-0.5*qdd11*quu22 + pow2(qud21) +; + +qPhysuudd2212 += +qud21*qud22 - 0.5*qdd12*quu22 +; + +qPhysuudd2213 += +qud21*qud23 - 0.5*qdd13*quu22 +; + +qPhysuudd2222 += +-0.5*qdd22*quu22 + pow2(qud22) +; + +qPhysuudd2223 += +qud22*qud23 - 0.5*qdd23*quu22 +; + +qPhysuudd2233 += +-0.5*qdd33*quu22 + pow2(qud23) +; + +qPhysuudd2311 += +qud21*qud31 - 0.5*qdd11*quu23 +; + +qPhysuudd2312 += +0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) +; + +qPhysuudd2313 += +0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) +; + +qPhysuudd2322 += +qud22*qud32 - 0.5*qdd22*quu23 +; + +qPhysuudd2323 += +0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) +; + +qPhysuudd2333 += +qud23*qud33 - 0.5*qdd33*quu23 +; + +qPhysuudd3311 += +-0.5*qdd11*quu33 + pow2(qud31) +; + +qPhysuudd3312 += +qud31*qud32 - 0.5*qdd12*quu33 +; + +qPhysuudd3313 += +qud31*qud33 - 0.5*qdd13*quu33 +; + +qPhysuudd3322 += +-0.5*qdd22*quu33 + pow2(qud32) +; + +qPhysuudd3323 += +qud32*qud33 - 0.5*qdd23*quu33 +; + +qPhysuudd3333 += +-0.5*qdd33*quu33 + pow2(qud33) +; + +muL += +2./alpha +; + +muStilde += +1/chi +; + +vbetas += +2.*sqrt(0.33333333333333333333*muStilde) +; + +vbetaA += +sqrt(muStilde) +; + +K += +Khat + 2.*Theta +; + +dK1 += +dKhat1 + 2.*dTheta1 +; + +dK2 += +dKhat2 + 2.*dTheta2 +; + +dK3 += +dKhat3 + 2.*dTheta3 +; + +dginv111 += +-2.*(dg123*ginv12*ginv13 + ginv11*(dg112*ginv12 + dg113*ginv13)) - + dg111*pow2(ginv11) - dg122*pow2(ginv12) - dg133*pow2(ginv13) +; + +dginv112 += +-(ginv11*(dg111*ginv12 + dg112*ginv22 + dg113*ginv23)) - + ginv12*(dg113*ginv13 + dg122*ginv22 + dg123*ginv23) - + ginv13*(dg123*ginv22 + dg133*ginv23) - dg112*pow2(ginv12) +; + +dginv113 += +-(ginv11*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33)) - + ginv12*(dg112*ginv13 + dg122*ginv23 + dg123*ginv33) - + ginv13*(dg123*ginv23 + dg133*ginv33) - dg113*pow2(ginv13) +; + +dginv122 += +-2.*(dg123*ginv22*ginv23 + ginv12*(dg112*ginv22 + dg113*ginv23)) - + dg111*pow2(ginv12) - dg122*pow2(ginv22) - dg133*pow2(ginv23) +; + +dginv123 += +-(ginv13*(dg112*ginv22 + dg113*ginv23)) - dg133*ginv23*ginv33 - + ginv12*(dg111*ginv13 + dg112*ginv23 + dg113*ginv33) - + ginv22*(dg122*ginv23 + dg123*ginv33) - dg123*pow2(ginv23) +; + +dginv133 += +-2.*(dg123*ginv23*ginv33 + ginv13*(dg112*ginv23 + dg113*ginv33)) - + dg111*pow2(ginv13) - dg122*pow2(ginv23) - dg133*pow2(ginv33) +; + +dginv211 += +-2.*(dg223*ginv12*ginv13 + ginv11*(dg212*ginv12 + dg213*ginv13)) - + dg211*pow2(ginv11) - dg222*pow2(ginv12) - dg233*pow2(ginv13) +; + +dginv212 += +-(ginv11*(dg211*ginv12 + dg212*ginv22 + dg213*ginv23)) - + ginv12*(dg213*ginv13 + dg222*ginv22 + dg223*ginv23) - + ginv13*(dg223*ginv22 + dg233*ginv23) - dg212*pow2(ginv12) +; + +dginv213 += +-(ginv11*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33)) - + ginv12*(dg212*ginv13 + dg222*ginv23 + dg223*ginv33) - + ginv13*(dg223*ginv23 + dg233*ginv33) - dg213*pow2(ginv13) +; + +dginv222 += +-2.*(dg223*ginv22*ginv23 + ginv12*(dg212*ginv22 + dg213*ginv23)) - + dg211*pow2(ginv12) - dg222*pow2(ginv22) - dg233*pow2(ginv23) +; + +dginv223 += +-(ginv13*(dg212*ginv22 + dg213*ginv23)) - dg233*ginv23*ginv33 - + ginv12*(dg211*ginv13 + dg212*ginv23 + dg213*ginv33) - + ginv22*(dg222*ginv23 + dg223*ginv33) - dg223*pow2(ginv23) +; + +dginv233 += +-2.*(dg223*ginv23*ginv33 + ginv13*(dg212*ginv23 + dg213*ginv33)) - + dg211*pow2(ginv13) - dg222*pow2(ginv23) - dg233*pow2(ginv33) +; + +dginv311 += +-2.*(dg323*ginv12*ginv13 + ginv11*(dg312*ginv12 + dg313*ginv13)) - + dg311*pow2(ginv11) - dg322*pow2(ginv12) - dg333*pow2(ginv13) +; + +dginv312 += +-(ginv11*(dg311*ginv12 + dg312*ginv22 + dg313*ginv23)) - + ginv12*(dg313*ginv13 + dg322*ginv22 + dg323*ginv23) - + ginv13*(dg323*ginv22 + dg333*ginv23) - dg312*pow2(ginv12) +; + +dginv313 += +-(ginv11*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33)) - + ginv12*(dg312*ginv13 + dg322*ginv23 + dg323*ginv33) - + ginv13*(dg323*ginv23 + dg333*ginv33) - dg313*pow2(ginv13) +; + +dginv322 += +-2.*(dg323*ginv22*ginv23 + ginv12*(dg312*ginv22 + dg313*ginv23)) - + dg311*pow2(ginv12) - dg322*pow2(ginv22) - dg333*pow2(ginv23) +; + +dginv323 += +-(ginv13*(dg312*ginv22 + dg313*ginv23)) - dg333*ginv23*ginv33 - + ginv12*(dg311*ginv13 + dg312*ginv23 + dg313*ginv33) - + ginv22*(dg322*ginv23 + dg323*ginv33) - dg323*pow2(ginv23) +; + +dginv333 += +-2.*(dg323*ginv23*ginv33 + ginv13*(dg312*ginv23 + dg313*ginv33)) - + dg311*pow2(ginv13) - dg322*pow2(ginv23) - dg333*pow2(ginv33) +; + +gammado111 += +0.5*dg111 +; + +gammado112 += +0.5*dg211 +; + +gammado113 += +0.5*dg311 +; + +gammado122 += +-0.5*dg122 + dg212 +; + +gammado123 += +0.5*(-dg123 + dg213 + dg312) +; + +gammado133 += +-0.5*dg133 + dg313 +; + +gammado211 += +dg112 - 0.5*dg211 +; + +gammado212 += +0.5*dg122 +; + +gammado213 += +0.5*(dg123 - dg213 + dg312) +; + +gammado222 += +0.5*dg222 +; + +gammado223 += +0.5*dg322 +; + +gammado233 += +-0.5*dg233 + dg323 +; + +gammado311 += +dg113 - 0.5*dg311 +; + +gammado312 += +0.5*(dg123 + dg213 - dg312) +; + +gammado313 += +0.5*dg133 +; + +gammado322 += +dg223 - 0.5*dg322 +; + +gammado323 += +0.5*dg233 +; + +gammado333 += +0.5*dg333 +; + +gamma111 += +gammado111*ginv11 + gammado211*ginv12 + gammado311*ginv13 +; + +gamma112 += +gammado112*ginv11 + gammado212*ginv12 + gammado312*ginv13 +; + +gamma113 += +gammado113*ginv11 + gammado213*ginv12 + gammado313*ginv13 +; + +gamma122 += +gammado122*ginv11 + gammado222*ginv12 + gammado322*ginv13 +; + +gamma123 += +gammado123*ginv11 + gammado223*ginv12 + gammado323*ginv13 +; + +gamma133 += +gammado133*ginv11 + gammado233*ginv12 + gammado333*ginv13 +; + +gamma211 += +gammado111*ginv12 + gammado211*ginv22 + gammado311*ginv23 +; + +gamma212 += +gammado112*ginv12 + gammado212*ginv22 + gammado312*ginv23 +; + +gamma213 += +gammado113*ginv12 + gammado213*ginv22 + gammado313*ginv23 +; + +gamma222 += +gammado122*ginv12 + gammado222*ginv22 + gammado322*ginv23 +; + +gamma223 += +gammado123*ginv12 + gammado223*ginv22 + gammado323*ginv23 +; + +gamma233 += +gammado133*ginv12 + gammado233*ginv22 + gammado333*ginv23 +; + +gamma311 += +gammado111*ginv13 + gammado211*ginv23 + gammado311*ginv33 +; + +gamma312 += +gammado112*ginv13 + gammado212*ginv23 + gammado312*ginv33 +; + +gamma313 += +gammado113*ginv13 + gammado213*ginv23 + gammado313*ginv33 +; + +gamma322 += +gammado122*ginv13 + gammado222*ginv23 + gammado322*ginv33 +; + +gamma323 += +gammado123*ginv13 + gammado223*ginv23 + gammado323*ginv33 +; + +gamma333 += +gammado133*ginv13 + gammado233*ginv23 + gammado333*ginv33 +; + +Gfromg1 += +gamma111*ginv11 + gamma122*ginv22 + + 2.*(gamma112*ginv12 + gamma113*ginv13 + gamma123*ginv23) + gamma133*ginv33 +; + +Gfromg2 += +gamma211*ginv11 + gamma222*ginv22 + + 2.*(gamma212*ginv12 + gamma213*ginv13 + gamma223*ginv23) + gamma233*ginv33 +; + +Gfromg3 += +gamma311*ginv11 + gamma322*ginv22 + + 2.*(gamma312*ginv12 + gamma313*ginv13 + gamma323*ginv23) + gamma333*ginv33 +; + +dGfromgdu11 += +(ddg1111 - dg111*((8.*dg112 + 2.*dg211)*ginv12 + + (8.*dg113 + 2.*dg311)*ginv13) - + (dg113*(4.*dg112 + dg211) + dg112*dg311 + dg111*(dg213 + dg312))* + ginv23 - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - + ginv33*(dg113*dg311 + dg111*dg313 + 2.*pow2(dg113)))*pow2(ginv11) + + (ddg1122 + ddg1212 - (dg123*(8.*dg112 + 2.*dg211) + + dg113*(4.*dg122 + 2.*dg212) + dg122*dg311 + + 2.*(dg111*dg223 + dg112*(dg213 + dg312)) + dg111*dg322)*ginv13 - + (dg123*(4.*dg122 + 2.*dg212) + + 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* + ginv23 - ginv22*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122)) - + ginv33*(dg123*(dg213 + dg312) + dg122*dg313 + dg113*(dg223 + dg322) + + dg112*dg323 + 2.*pow2(dg123)))*pow2(ginv12) + + (ddg1133 + ddg1313 - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*ginv23 - + ginv22*(dg133*dg212 + dg113*dg223 + dg123*(dg213 + dg312) + + dg112*(dg233 + dg323) + 2.*pow2(dg123)) - + ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133)))*pow2(ginv13) \ ++ ginv13*(ddg1333*ginv33 + ginv22* + (ddg1223 - (dg133*dg222 + dg123*(4.*dg223 + dg322) + + dg122*(dg233 + dg323))*ginv23 - + (dg133*dg223 + dg123*(dg233 + 2.*dg323))*ginv33) + + ginv23*(ddg1233 + ddg1323 - + (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)*ginv33) - + (dg123*dg222 + dg122*dg223)*pow2(ginv22) - + (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + + dg122*dg333)*pow2(ginv23) - 2.*dg133*dg333*pow2(ginv33)) + + ginv11*(ddg1313*ginv33 + ginv12* + (2.*ddg1112 + ddg1211 - (dg113*(12.*dg112 + 3.*dg211) + + 3.*dg112*dg311 + dg111*(8.*dg123 + 3.*(dg213 + dg312)))*ginv13 \ +- (dg122*(4.*dg112 + dg211) + 6.*dg112*dg212 + dg111*dg222)*ginv22 - + (dg123*dg211 + dg122*dg311 + + 4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213 + dg312)) + + dg111*(dg223 + dg322))*ginv23 - + (dg123*dg311 + dg113*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*dg112*dg313 + dg111*dg323)*ginv33) + + ginv22*(ddg1212 - (dg113*dg222 + 2.*(dg123*dg212 + dg112*dg223) + + dg122*(dg213 + dg312) + dg112*dg322)*ginv23 - + (dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323)*ginv33) + + ginv13*(2.*ddg1113 + ddg1311 - + (dg123*(4.*dg112 + dg211) + dg111*dg223 + + 2.*(dg113*dg212 + dg112*(dg213 + dg312)))*ginv22 - + (dg133*dg211 + dg123*dg311 + + 4.*(dg113*(dg123 + dg213 + dg312) + dg112*(dg133 + dg313)) + + dg111*(dg233 + dg323))*ginv23 - + (dg133*(4.*dg113 + dg311) + 6.*dg113*dg313 + dg111*dg333)*ginv33) + + ginv23*(ddg1213 + ddg1312 - + (dg133*(dg213 + dg312) + 2.*dg123*dg313 + + dg113*(dg233 + 2.*dg323) + dg112*dg333)*ginv33) - + (3.*dg112*dg211 + dg111*(4.*dg122 + 3.*dg212) + 6.*pow2(dg112))* + pow2(ginv12) - (3.*dg113*dg311 + dg111*(4.*dg133 + 3.*dg313) + + 6.*pow2(dg113))*pow2(ginv13) - + (dg122*dg212 + dg112*dg222)*pow2(ginv22) - + (dg133*dg212 + dg123*(dg213 + dg312) + dg122*dg313 + + dg113*(dg223 + dg322) + dg112*(dg233 + dg323))*pow2(ginv23) - + (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + + ginv12*(ddg1323*ginv33 + ginv22* + (ddg1222 - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)* + ginv23 - (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33) + + ginv23*(ddg1223 + ddg1322 - + (dg133*(dg223 + dg322) + dg123*(dg233 + 4.*dg323) + dg122*dg333)* + ginv33) + ginv13*(2.*ddg1123 + ddg1213 + ddg1312 - + (dg113*dg222 + 4.*(dg123*(dg122 + dg212) + dg112*dg223) + + dg122*(dg213 + dg312) + dg112*dg322)*ginv22 - + (dg133*(4.*dg123 + dg213 + dg312) + 4.*dg123*dg313 + + dg113*(dg233 + 4.*dg323) + dg112*dg333)*ginv33 - + ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg122*dg313 + + dg113*dg322) + 4.* + (dg122*dg133 + dg113*dg223 + dg123*(dg213 + dg312) + + dg112*dg323 + pow2(dg123)))) - + (dg133*(4.*dg112 + dg211) + dg113*(8.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* + pow2(ginv13) - 2.*dg122*dg222*pow2(ginv22) - + (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* + pow2(ginv23) - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) - + 2.*pow2(dg111)*pow3(ginv11) - + (dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*pow3(ginv12) - + (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*pow3(ginv13) +; + +dGfromgdu12 += +(ddg1112 + ddg1211 - (4.*(dg112*dg113 + dg111*dg123) + + 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))*ginv13 - + (dg122*(6.*dg112 + 2.*dg211) + 6.*dg112*dg212 + 2.*dg111*dg222)* + ginv22 - (4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213)) + + dg122*dg311 + 2.*(dg123*dg211 + dg111*dg223 + dg112*dg312) + + dg111*dg322)*ginv23 - (dg123*dg311 + + dg113*(2.*(dg123 + dg213) + dg312) + dg112*dg313 + dg111*dg323)* + ginv33)*pow2(ginv12) - ((2.*(dg113*dg123 + dg112*dg133) + + dg123*dg311 + dg113*dg312 + dg112*dg313 + dg111*dg323)*ginv22 + + (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*ginv23)* + pow2(ginv13) + (ddg1222 - (4.*(dg123*dg222 + dg122*dg223) + + 2.*dg122*dg322)*ginv23 - + (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33)*pow2(ginv22) + + (ddg1233 + ddg1323 - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)* + ginv33)*pow2(ginv23) + ginv11* + (ginv23*(ddg1113 - 2.*dg113*(dg133 + dg313)*ginv33) + + ginv22*(ddg1112 - (dg112*(4.*dg123 + 2.*dg213) + + 2.*(dg113*(dg122 + dg212) + dg112*dg312))*ginv23 - + (dg113*(2.*dg123 + dg312) + dg112*dg313)*ginv33) + + ginv12*(ddg1111 - dg111*(6.*dg113 + 2.*dg311)*ginv13 - + (dg113*(8.*dg112 + 2.*dg211) + dg112*dg311 + + dg111*(2.*(dg123 + dg213) + dg312))*ginv23 - + ginv22*(2.*(dg112*dg211 + dg111*(dg122 + dg212)) + + 6.*pow2(dg112)) - ginv33* + (dg113*dg311 + dg111*dg313 + 2.*pow2(dg113))) - + ginv13*((dg112*(4.*dg113 + dg311) + dg111*(2.*dg123 + dg312))* + ginv22 + ginv23*(dg113*dg311 + dg111*(2.*dg133 + dg313) + + 4.*pow2(dg113))) - dg111*(6.*dg112 + 2.*dg211)*pow2(ginv12) - + 2.*dg112*(dg122 + dg212)*pow2(ginv22) - + (2.*(dg112*dg133 + dg113*(dg123 + dg213)) + dg113*dg312 + dg112*dg313)* + pow2(ginv23)) + ginv13*(ginv22* + (ddg1123 + ddg1312 - (dg133*(2.*dg123 + dg312) + + 2.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33 - + ginv23*(2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg113*dg223 + + dg112*dg233) + dg122*dg313 + dg113*dg322 + + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg123)))) + + ginv23*(ddg1133 + ddg1313 - + ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))) - + (2.*(dg123*(dg122 + dg212) + dg112*dg223) + dg122*dg312 + + dg112*dg322)*pow2(ginv22) - + (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*pow2(ginv23)\ +) + ginv23*(ddg1333*ginv33 - 2.*dg133*dg333*pow2(ginv33)) + + ginv12*(ddg1313*ginv33 + ginv13* + (ddg1113 + ddg1311 - (2.* + (dg123*dg211 + dg113*(dg122 + dg212) + dg111*dg223) + + dg122*dg311 + dg112*(8.*dg123 + 2.*dg213 + 4.*dg312) + + dg111*dg322)*ginv22 - + (dg133*(4.*dg112 + 2.*dg211) + + dg113*(8.*dg123 + 4.*(dg213 + dg312)) + 4.*dg112*dg313 + + 2.*(dg123*dg311 + dg111*(dg233 + dg323)))*ginv23 - + (dg133*(2.*dg113 + dg311) + 4.*dg113*dg313 + dg111*dg333)*ginv33) + + ginv23*(ddg1123 + 2.*ddg1213 + ddg1312 - + (2.*(dg133*(dg123 + dg213) + dg113*dg233) + dg133*dg312 + + 4.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33) + + ginv22*(ddg1122 + 2.*ddg1212 - + (4.*(dg122*dg213 + dg113*dg222) + + 6.*(dg123*(dg122 + dg212) + dg112*dg223) + + 3.*(dg122*dg312 + dg112*dg322))*ginv23 - + ginv33*(dg122*dg313 + dg113*dg322 + + 2.*(dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323 + + pow2(dg123)))) - + 2.*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow2(ginv13) - + (4.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))*pow2(ginv22) - + (4.*(dg123*dg213 + dg113*dg223) + + 2.*(dg133*(dg122 + dg212) + dg123*dg312 + dg122*dg313 + + dg113*dg322 + dg112*(dg233 + dg323) + pow2(dg123)))*pow2(ginv23) \ +- (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + + ginv22*(ddg1323*ginv33 + ginv23* + (2.*ddg1223 + ddg1322 - (2.*(dg133*dg223 + dg123*dg233) + + dg133*dg322 + 6.*dg123*dg323 + dg122*dg333)*ginv33) - + (2.*(dg133*dg222 + dg122*dg233) + dg123*(6.*dg223 + 3.*dg322) + + 3.*dg122*dg323)*pow2(ginv23) - + (dg133*dg323 + dg123*dg333)*pow2(ginv33)) - + 2.*((dg111*(dg112*ginv22 + dg113*ginv23) + ginv12*pow2(dg111))* + pow2(ginv11) + (dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112))* + pow3(ginv12) + dg122*dg222*pow3(ginv22)) - + (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + dg122*dg333)* + pow3(ginv23) +; + +dGfromgdu13 += +-(((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*ginv23 + + (2.*(dg113*dg122 + dg112*dg123) + dg123*dg211 + dg113*dg212 + + dg112*dg213 + dg111*dg223)*ginv33 + + 2.*ginv13*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)))* + pow2(ginv12)) + (ddg1113 + ddg1311 - + (dg123*(2.*dg112 + dg211) + dg113*dg212 + dg111*dg223 + + dg112*(dg213 + 2.*dg312))*ginv22 - + (dg133*dg211 + 2.*(dg113*dg213 + dg123*dg311) + + 4.*(dg113*(dg123 + dg312) + dg112*(dg133 + dg313)) + + dg111*(dg233 + 2.*dg323))*ginv23 - + (dg133*(6.*dg113 + 2.*dg311) + 6.*dg113*dg313 + 2.*dg111*dg333)*ginv33\ +)*pow2(ginv13) - (2.*dg122*dg222*ginv23 + + (dg123*dg222 + dg122*dg223)*ginv33)*pow2(ginv22) + + (ddg1223 + ddg1322 - (3.*(dg133*dg223 + dg123*dg233) + 6.*dg123*dg323 + + 2.*(dg133*dg322 + dg122*dg333))*ginv33)*pow2(ginv23) + + ddg1333*pow2(ginv33) + ginv11* + (ddg1113*ginv33 - ginv22*(2.*dg112*(dg122 + dg212)*ginv23 + + (dg113*dg212 + dg112*(2.*dg123 + dg213))*ginv33) + + ginv23*(ddg1112 - (dg113*(4.*dg123 + 2.*dg213) + + 2.*(dg113*dg312 + dg112*(dg133 + dg313)))*ginv33) - + ginv12*(dg111*(6.*dg112 + 2.*dg211)*ginv13 + + (dg113*(4.*dg112 + dg211) + dg111*(2.*dg123 + dg213))*ginv33 + + ginv23*(dg112*dg211 + dg111*(2.*dg122 + dg212) + 4.*pow2(dg112))) + + ginv13*(ddg1111 - (dg113*(8.*dg112 + dg211) + 2.*dg112*dg311 + + dg111*(dg213 + 2.*(dg123 + dg312)))*ginv23 - + ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - + ginv33*(2.*(dg113*dg311 + dg111*(dg133 + dg313)) + 6.*pow2(dg113))) \ +- dg111*(6.*dg113 + 2.*dg311)*pow2(ginv13) - + (dg113*dg212 + dg112*dg213 + + 2.*(dg113*dg122 + dg112*(dg123 + dg312)))*pow2(ginv23) - + 2.*dg113*(dg133 + dg313)*pow2(ginv33)) + + ginv12*((ddg1123 + ddg1213)*ginv33 + + ginv13*(ddg1112 + ddg1211 - + (dg122*(2.*dg112 + dg211) + 4.*dg112*dg212 + dg111*dg222)*ginv22 - + (dg123*(8.*dg112 + 2.*dg211) + + 4.*(dg113*(dg122 + dg212) + dg112*(dg213 + dg312)) + + 2.*(dg122*dg311 + dg111*(dg223 + dg322)))*ginv23 - + (dg133*(2.*dg112 + dg211) + + dg113*(8.*dg123 + 4.*dg213 + 2.*dg312) + + 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* + ginv33) - ginv22*((dg122*dg213 + dg113*dg222 + + 2.*(dg123*(dg122 + dg212) + dg112*dg223))*ginv33 + + ginv23*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))) + + ginv23*(ddg1122 + ddg1212 - + ginv33*(dg133*(2.*dg122 + dg212) + + 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322) + + dg112*(dg233 + 2.*dg323) + + 4.*(dg123*dg213 + dg113*dg223 + pow2(dg123)))) - + (4.*(dg112*dg113 + dg111*dg123) + + 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))* + pow2(ginv13) - (dg123*(4.*dg122 + 2.*dg212) + + 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* + pow2(ginv23) - (dg133*(2.*dg123 + dg213) + 2.*dg123*dg313 + + dg113*(dg233 + 2.*dg323))*pow2(ginv33)) + + ginv22*(ddg1223*ginv33 + ginv23* + (ddg1222 - (dg133*dg222 + dg123*(6.*dg223 + 2.*dg322) + + dg122*(dg233 + 2.*dg323))*ginv33) - + (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*pow2(ginv23) - + (dg133*dg223 + dg123*(dg233 + 2.*dg323))*pow2(ginv33)) + + ginv23*((ddg1233 + 2.*ddg1323)*ginv33 - + (dg133*(2.*dg233 + 4.*dg323) + 4.*dg123*dg333)*pow2(ginv33)) + + ginv13*((ddg1133 + 2.*ddg1313)*ginv33 + + ginv23*(ddg1123 + ddg1213 + 2.*ddg1312 - + (dg133*(6.*dg123 + 3.*dg213 + 4.*dg312) + 6.*dg123*dg313 + + dg113*(3.*dg233 + 6.*dg323) + 4.*dg112*dg333)*ginv33) + + ginv22*(ddg1212 - (dg123*(2.*dg122 + 4.*dg212) + dg113*dg222 + + dg122*(dg213 + 2.*dg312) + dg112*(4.*dg223 + 2.*dg322))*ginv23 \ +- ginv33*(dg133*dg212 + dg112*(dg233 + 2.*dg323) + + 2.*(dg113*dg223 + dg123*(dg213 + dg312) + pow2(dg123)))) - + (dg122*dg212 + dg112*dg222)*pow2(ginv22) - + (4.*(dg123*dg312 + dg112*dg323) + + 2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg112*dg233 + + dg122*dg313 + dg113*(dg223 + dg322) + pow2(dg123)))*pow2(ginv23) \ +- (4.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))*pow2(ginv33)) - + (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* + pow3(ginv23) - 2.*((dg111*(dg112*ginv23 + dg113*ginv33) + + ginv13*pow2(dg111))*pow2(ginv11) + + (dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow3(ginv13) + + dg133*dg333*pow3(ginv33)) +; + +dGfromgdu21 += +(ddg1211 - (4.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - + 2.*(dg112 + dg211)*dg212*ginv22 - + (2.*(dg113*dg212 + (dg112 + dg211)*dg213) + dg212*dg311 + + dg211*dg312)*ginv23 - (dg213*(2.*dg113 + dg311) + dg211*dg313)* + ginv33 - ginv12*(4.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211)))* + pow2(ginv11) + (ddg1222 + ddg2212 - + (4.*(dg212*(dg123 + dg213) + (dg112 + dg211)*dg223) + dg222*dg311 + + 2.*(dg122*dg213 + dg113*dg222 + dg212*dg312) + dg211*dg322)*ginv13 \ +- (2.*dg122 + 6.*dg212)*dg222*ginv22 - + ((2.*dg122 + 4.*dg212)*dg223 + + dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)*ginv23 - + (dg223*(2.*(dg123 + dg213) + dg312) + dg222*dg313 + dg213*dg322 + + dg212*dg323)*ginv33)*pow2(ginv12) + + (ddg1233 + ddg2313 - (2.*((dg123 + dg213)*dg223 + dg212*dg233) + + dg223*dg312 + dg212*dg323)*ginv22 - + (dg233*(4.*dg213 + 2.*dg312) + + 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + + dg212*dg333))*ginv23 - + (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33)*pow2(ginv13) + + ginv11*(ddg2313*ginv33 + ginv22* + (ddg2212 - (dg222*(2.*dg213 + dg312) + dg212*(4.*dg223 + dg322))* + ginv23 - (dg223*(2.*dg213 + dg312) + dg212*dg323)*ginv33) + + ginv23*(ddg2213 + ddg2312 - + (dg233*(2.*dg213 + dg312) + 2.*(dg223*dg313 + dg213*dg323) + + dg212*dg333)*ginv33) + + ginv13*(2.*ddg1213 + ddg2311 - + (2.*(dg112 + dg211)*dg223 + + dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv22 - + (2.*(dg133*dg213 + dg113*dg233) + dg233*dg311 + 6.*dg213*dg313 + + dg211*dg333)*ginv33 - + ginv23*(2.*(dg133*dg212 + dg123*dg213 + dg113*dg223 + + (dg112 + dg211)*dg233) + dg223*dg311 + dg211*dg323 + + 4.*(dg213*dg312 + dg212*dg313 + pow2(dg213)))) + + ginv12*(2.*ddg1212 + ddg2211 - + (6.*(dg113*dg212 + dg112*dg213) + 4.*dg111*dg223 + + 3.*dg212*dg311 + dg211*(4.*dg123 + 6.*dg213 + 3.*dg312))*ginv13 \ +- (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + + (dg112 + dg211)*dg223) + dg222*dg311 + + dg212*(8.*dg213 + 4.*dg312) + dg211*dg322)*ginv23 - + ginv22*(2.*(dg122*dg212 + (dg112 + dg211)*dg222) + + 6.*pow2(dg212)) - ginv33* + (dg223*dg311 + dg211*dg323 + + 2.*(dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313 + + pow2(dg213)))) - + (6.*dg112*dg212 + dg211*(2.*dg122 + 6.*dg212) + 2.*dg111*dg222)* + pow2(ginv12) - (2.*(dg133*dg211 + dg111*dg233) + + dg213*(6.*dg113 + 3.*dg311) + 3.*dg211*dg313)*pow2(ginv13) - + 2.*dg212*dg222*pow2(ginv22) - + (2.*(dg213*dg223 + dg212*dg233) + dg223*dg312 + dg222*dg313 + + dg213*dg322 + dg212*dg323)*pow2(ginv23) - + (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + + ginv12*(ddg2323*ginv33 + ginv13* + (2.*ddg1223 + ddg2213 + ddg2312 - + (2.*((dg123 + dg213)*dg222 + dg122*dg223) + dg222*dg312 + + dg212*(8.*dg223 + dg322))*ginv22 - + (dg223*(8.*dg213 + 4.*(dg123 + dg312)) + + 2.*(dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322) + + 4.*dg212*(dg233 + dg323))*ginv23 - + (2.*(dg133*dg223 + (dg123 + dg213)*dg233) + dg233*dg312 + + 4.*(dg223*dg313 + dg213*dg323) + dg212*dg333)*ginv33) + + ginv23*(ddg2223 + ddg2322 - + (dg233*(2.*dg223 + dg322) + 4.*dg223*dg323 + dg222*dg333)*ginv33) + + ginv22*(ddg2222 - dg222*(6.*dg223 + 2.*dg322)*ginv23 - + ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223))) - + (4.*(dg123*dg213 + dg113*dg223) + + 2.*((dg112 + dg211)*dg233 + dg223*dg311 + dg213*dg312 + + dg212*(dg133 + dg313) + dg211*dg323 + pow2(dg213)))*pow2(ginv13) \ +- 2.*(pow2(dg222)*pow2(ginv22) + + (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))*pow2(ginv23)) - + (dg233*dg323 + dg223*dg333)*pow2(ginv33)) + + ginv13*(ddg2333*ginv33 + ginv22* + (ddg2223 - 2.*dg223*(dg233 + dg323)*ginv33 - + ginv23*(dg223*dg322 + dg222*(2.*dg233 + dg323) + 4.*pow2(dg223))) + + ginv23*(ddg2233 + ddg2323 - + ginv33*(3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))) - + (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)* + pow2(ginv23) - 2.*(dg222*dg223*pow2(ginv22) + + dg233*dg333*pow2(ginv33))) - + 2.*(dg111*dg211*pow3(ginv11) + + (dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212))*pow3(ginv12)) - + (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + dg211*dg333)* + pow3(ginv13) +; + +dGfromgdu22 += +-((2.*dg111*dg211*ginv12 + (dg112*dg211 + dg111*dg212)*ginv22 + + (dg113*dg211 + dg111*dg213)*ginv23)*pow2(ginv11)) + + (ddg1212 + ddg2211 - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + + dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))*ginv13 - + (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + dg112*dg223) + + dg222*dg311 + dg212*(8.*dg213 + 2.*dg312) + + dg211*(4.*dg223 + dg322))*ginv23 - + ginv22*(4.*dg211*dg222 + 3.*(dg122*dg212 + dg112*dg222) + + 6.*pow2(dg212)) - ginv33* + (dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + dg212*dg313 + + dg211*dg323 + 2.*pow2(dg213)))*pow2(ginv12) - + ((dg112*dg233 + dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + + dg212*(dg133 + dg313) + dg211*dg323)*ginv22 + + (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + + dg211*dg333)*ginv23)*pow2(ginv13) + + (ddg2222 - dg222*(8.*dg223 + 2.*dg322)*ginv23 - + ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223)))*pow2(ginv22) + + (ddg2233 + ddg2323 - ginv33*(3.*(dg233*dg323 + dg223*dg333) + + 2.*pow2(dg233)))*pow2(ginv23) + + ginv13*(ginv22*(ddg1223 + ddg2312 - + (dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322 + + 4.*(dg223*(dg123 + dg213 + dg312) + dg212*(dg233 + dg323)))* + ginv23 - (dg233*(dg123 + dg312) + dg223*(dg133 + 2.*dg313) + + 2.*dg213*dg323 + dg212*dg333)*ginv33) + + ginv23*(ddg1233 + ddg2313 - + (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33) - + ((dg122 + 4.*dg212)*dg223 + dg222*(dg123 + dg312) + dg212*dg322)* + pow2(ginv22) - (dg233*(4.*dg213 + 2.*dg312) + + 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + + dg212*dg333))*pow2(ginv23)) + + ginv11*(-(ginv13*((2.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + + dg212*dg311 + dg211*(dg123 + dg312))*ginv22 + + (dg111*dg233 + dg213*(4.*dg113 + dg311) + dg211*(dg133 + dg313))* + ginv23)) + ginv12*(ddg1211 - + (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - + (6.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv22 - + (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + dg212*dg311 + + dg211*(dg123 + 4.*dg213 + dg312))*ginv23 - + (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33) + + ginv22*(ddg1212 - (dg122*dg213 + dg113*dg222 + 2.*dg112*dg223 + + dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv23 - + (dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313)*ginv33) + + ginv23*(ddg1213 - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*ginv33) - + (3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))*pow2(ginv12) - + (dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))*pow2(ginv22) - + (dg113*dg223 + dg112*dg233 + dg213*(dg123 + dg312) + + dg212*(dg133 + dg313) + 2.*pow2(dg213))*pow2(ginv23)) + + ginv23*(ddg2333*ginv33 - 2.*dg233*dg333*pow2(ginv33)) + + ginv12*(ddg2313*ginv33 + ginv22* + (ddg1222 + 2.*ddg2212 - ((3.*dg122 + 12.*dg212)*dg223 + + dg222*(8.*dg213 + 3.*(dg123 + dg312)) + 3.*dg212*dg322)*ginv23 \ +- (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + dg222*dg313 + dg213*dg322 + + 2.*dg212*dg323)*ginv33) + + ginv23*(ddg1223 + 2.*ddg2213 + ddg2312 - + (dg233*(dg123 + 4.*dg213 + dg312) + dg223*(dg133 + 4.*dg313) + + 4.*dg213*dg323 + dg212*dg333)*ginv33) + + ginv13*(ddg1213 + ddg2311 - + (dg122*dg213 + dg222*(dg113 + dg311) + + 4.*((dg112 + dg211)*dg223 + dg212*(dg123 + dg213 + dg312)) + + dg211*dg322)*ginv22 - + (dg233*(dg113 + dg311) + dg213*(dg133 + 4.*dg313) + dg211*dg333)* + ginv33 - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg223*dg311 + + dg211*dg323) + 4.* + (dg113*dg223 + dg211*dg233 + dg213*(dg123 + dg312) + + dg212*dg313 + pow2(dg213)))) - + (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* + pow2(ginv13) - (2.*dg122 + 8.*dg212)*dg222*pow2(ginv22) - + ((dg122 + 4.*dg212)*dg233 + dg223*(8.*dg213 + 2.*(dg123 + dg312)) + + dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* + pow2(ginv23) - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + + ginv22*(ddg2323*ginv33 + ginv23* + (2.*ddg2223 + ddg2322 - (dg233*(4.*dg223 + dg322) + + 6.*dg223*dg323 + dg222*dg333)*ginv33) - + (3.*dg223*dg322 + dg222*(4.*dg233 + 3.*dg323) + 6.*pow2(dg223))* + pow2(ginv23) - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) - + (2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*pow3(ginv12) - + 2.*pow2(dg222)*pow3(ginv22) - + (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)*pow3(ginv23) +; + +dGfromgdu23 += +-((2.*dg111*dg211*ginv13 + (dg112*dg211 + dg111*dg212)*ginv23 + + (dg113*dg211 + dg111*dg213)*ginv33)*pow2(ginv11)) - + ((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv13 + + (dg122*dg213 + dg212*(dg123 + 2.*dg213) + dg113*dg222 + + (dg112 + 2.*dg211)*dg223)*ginv33 + + 2.*ginv23*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212)))* + pow2(ginv12) + (ddg1213 + ddg2311 - + ((dg112 + 2.*dg211)*dg223 + dg212*(dg123 + 2.*(dg213 + dg312)))* + ginv22 - (3.*(dg133*dg213 + dg113*dg233) + 6.*dg213*dg313 + + 2.*(dg233*dg311 + dg211*dg333))*ginv33 - + ginv23*(4.*(dg213*dg312 + dg212*dg313) + + 2.*(dg133*dg212 + dg123*dg213 + (dg112 + dg211)*dg233 + + dg223*(dg113 + dg311) + dg211*dg323 + pow2(dg213))))*pow2(ginv13) \ ++ (ddg2223 + ddg2322 - (dg233*(6.*dg223 + 2.*dg322) + 6.*dg223*dg323 + + 2.*dg222*dg333)*ginv33)*pow2(ginv23) + ddg2333*pow2(ginv33) + + ginv11*(ddg1213*ginv33 + ginv13* + (ddg1211 - 2.*(dg112 + dg211)*dg212*ginv22 - + (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + 2.*dg212*dg311 + + dg211*(dg123 + 2.*(dg213 + dg312)))*ginv23 - + (dg111*dg233 + dg213*(6.*dg113 + 2.*dg311) + + dg211*(dg133 + 2.*dg313))*ginv33) - + ginv12*((4.*dg112*dg212 + dg211*(dg122 + 2.*dg212) + dg111*dg222)* + ginv23 + (dg211*(dg123 + 2.*dg213) + + 2.*(dg113*dg212 + dg112*dg213) + dg111*dg223)*ginv33 + + ginv13*(3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))) - + ginv22*((dg212*(dg123 + 2.*dg213) + dg112*dg223)*ginv33 + + ginv23*(dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))) + + ginv23*(ddg1212 - ginv33*(dg112*dg233 + dg212*(dg133 + 2.*dg313) + + 2.*(dg113*dg223 + dg213*(dg123 + dg312) + pow2(dg213)))) - + (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*pow2(ginv13) - + (dg122*dg213 + dg113*dg222 + dg112*dg223 + + dg212*(dg123 + 2.*(dg213 + dg312)))*pow2(ginv23) - + (dg113*dg233 + dg213*(dg133 + 2.*dg313))*pow2(ginv33)) + + ginv22*(ddg2223*ginv33 + ginv23* + (ddg2222 - ginv33*(2.*(dg223*dg322 + dg222*(dg233 + dg323)) + + 6.*pow2(dg223))) - dg222*(6.*dg223 + 2.*dg322)*pow2(ginv23) - + 2.*dg223*(dg233 + dg323)*pow2(ginv33)) + + ginv12*((ddg1223 + ddg2213)*ginv33 - + ginv22*((2.*dg122 + 6.*dg212)*dg222*ginv23 + + ((dg123 + 2.*dg213)*dg222 + (dg122 + 4.*dg212)*dg223)*ginv33) + + ginv23*(ddg1222 + ddg2212 - + ((dg122 + 2.*dg212)*dg233 + + dg223*(4.*dg123 + 8.*dg213 + 2.*dg312) + + dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* + ginv33) + ginv13*(ddg1212 + ddg2211 - + (4.*(dg112 + dg211)*dg223 + + dg212*(8.*dg213 + 4.*(dg123 + dg312)) + + 2.*(dg122*dg213 + dg222*(dg113 + dg311) + dg211*dg322))*ginv23 \ +- ginv22*(dg122*dg212 + (dg112 + 2.*dg211)*dg222 + 4.*pow2(dg212)) - + ginv33*((dg112 + 2.*dg211)*dg233 + dg212*(dg133 + 2.*dg313) + + 2.*(dg223*dg311 + dg213*dg312 + dg211*dg323) + + 4.*(dg123*dg213 + dg113*dg223 + pow2(dg213)))) - + (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + + dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))* + pow2(ginv13) - ((2.*dg122 + 4.*dg212)*dg223 + + dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)* + pow2(ginv23) - ((dg123 + 2.*dg213)*dg233 + + dg223*(dg133 + 2.*dg313) + 2.*dg213*dg323)*pow2(ginv33)) + + ginv13*((ddg1233 + 2.*ddg2313)*ginv33 + + ginv22*(ddg2212 - ((dg122 + 8.*dg212)*dg223 + + dg222*(dg123 + 2.*(dg213 + dg312)) + 2.*dg212*dg322)*ginv23 - + (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*(dg233 + dg323))* + ginv33) + ginv23*(ddg1223 + ddg2213 + 2.*ddg2312 - + (3.*(dg133*dg223 + dg123*dg233) + dg233*(6.*dg213 + 4.*dg312) + + 6.*(dg223*dg313 + dg213*dg323) + 4.*dg212*dg333)*ginv33) - + 2.*dg212*dg222*pow2(ginv22) - + ((dg122 + 4.*dg212)*dg233 + dg223*(2.*dg123 + 4.*(dg213 + dg312)) + + dg222*(dg133 + 2.*dg313) + 2.*dg213*dg322 + 4.*dg212*dg323)* + pow2(ginv23) - (dg233*(2.*dg133 + 4.*dg313) + 4.*dg213*dg333)* + pow2(ginv33)) + ginv23*((ddg2233 + 2.*ddg2323)*ginv33 - + (4.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))*pow2(ginv33)) - + (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* + pow3(ginv13) - 2.*((dg222*dg223*ginv33 + ginv23*pow2(dg222))* + pow2(ginv22) + (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))* + pow3(ginv23) + dg233*dg333*pow3(ginv33)) +; + +dGfromgdu31 += +(ddg1311 - ((4.*dg112 + 2.*dg211)*dg311 + 4.*dg111*dg312)*ginv12 - + (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - + (dg311*(dg213 + 2.*dg312) + dg211*dg313 + + 2.*(dg113*dg312 + dg112*dg313))*ginv23 - + 2.*(dg113 + dg311)*dg313*ginv33 - + ginv13*(4.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311)))*pow2(ginv11) \ ++ (ddg1322 + ddg2312 - (2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))* + ginv22 - ((2.*dg213 + 4.*dg312)*dg322 + + 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + + (dg122 + dg212)*dg323))*ginv23 - + (dg313*(dg223 + 2.*dg322) + (dg213 + 2.*(dg123 + dg312))*dg323)* + ginv33 - ginv13*(4.*(dg123*dg312 + dg112*dg323) + + 2.*(dg213*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + + dg311*(dg223 + dg322) + dg211*dg323 + pow2(dg312))))*pow2(ginv12) \ ++ (ddg1333 + ddg3313 - (dg233*dg312 + dg223*dg313 + + (dg213 + 2.*(dg123 + dg312))*dg323 + dg212*dg333)*ginv22 - + (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + + 4.*(dg313*dg323 + dg312*dg333))*ginv23 - + (2.*dg133 + 6.*dg313)*dg333*ginv33)*pow2(ginv13) + + ginv11*(ddg3313*ginv33 + ginv22* + (ddg2312 - (dg222*dg313 + dg213*dg322 + + 2.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - + (dg223*dg313 + (dg213 + 2.*dg312)*dg323)*ginv33) + + ginv23*(ddg2313 + ddg3312 - + (dg313*(dg233 + 4.*dg323) + (dg213 + 2.*dg312)*dg333)*ginv33) + + ginv12*(2.*ddg1312 + ddg2311 - + (dg311*(4.*dg123 + 3.*dg213 + 6.*dg312) + 3.*dg211*dg313 + + 6.*(dg113*dg312 + dg112*dg313) + 4.*dg111*dg323)*ginv13 - + (dg222*dg311 + (2.*dg122 + 6.*dg212)*dg312 + + (2.*dg112 + dg211)*dg322)*ginv22 - + (4.*dg312*dg313 + 2.*((dg123 + dg213)*dg313 + + (dg113 + dg311)*dg323))*ginv33 - + ginv23*((2.*dg123 + 4.*dg213)*dg312 + dg311*(dg223 + 2.*dg322) + + dg211*dg323 + 2.*(dg122*dg313 + dg113*dg322 + dg112*dg323) + + 4.*(dg212*dg313 + pow2(dg312)))) + + ginv13*(2.*ddg1313 + ddg3311 - + ((4.*dg213 + 8.*dg312)*dg313 + dg311*(dg233 + 2.*dg323) + + dg211*dg333 + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + + dg112*dg333))*ginv23 - + ginv22*(dg223*dg311 + dg211*dg323 + + 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + + pow2(dg312))) - ginv33* + (2.*(dg133*dg313 + (dg113 + dg311)*dg333) + 6.*pow2(dg313))) - + ((2.*dg122 + 3.*dg212)*dg311 + (6.*dg112 + 3.*dg211)*dg312 + + 2.*dg111*dg322)*pow2(ginv12) - + (6.*dg113*dg313 + dg311*(2.*dg133 + 6.*dg313) + 2.*dg111*dg333)* + pow2(ginv13) - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - + (dg313*(dg223 + 2.*dg322) + dg213*dg323 + dg312*(dg233 + 2.*dg323) + + dg212*dg333)*pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + + ginv12*(ddg3323*ginv33 + ginv13* + (2.*ddg1323 + ddg2313 + ddg3312 - + (dg222*dg313 + (2.*dg123 + dg213)*dg322 + + dg312*(4.*dg223 + 2.*dg322) + (2.*dg122 + 4.*dg212)*dg323)* + ginv22 - ((4.*dg213 + 8.*dg312)*dg323 + + 4.*(dg313*(dg223 + dg322) + dg123*dg323) + + 2.*(dg233*dg312 + dg133*dg322 + (dg122 + dg212)*dg333))*ginv23 \ +- (dg313*(dg233 + 8.*dg323) + (dg213 + 2.*dg312)*dg333 + + 2.*(dg133*dg323 + dg123*dg333))*ginv33) + + ginv22*(ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - + ginv23*(3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))) + + ginv23*(ddg2323 + ddg3322 - + ginv33*(dg233*dg323 + (dg223 + 2.*dg322)*dg333 + 4.*pow2(dg323))) - + (dg311*(dg233 + 4.*dg323) + + 4.*((dg123 + dg312)*dg313 + dg113*dg323) + dg211*dg333 + + 2.*(dg133*dg312 + dg213*dg313 + dg112*dg333))*pow2(ginv13) - + (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* + pow2(ginv23) - 2.*(dg222*dg322*pow2(ginv22) + + dg323*dg333*pow2(ginv33))) + + ginv13*(ddg3333*ginv33 + ginv23* + (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33) + + ginv22*(ddg2323 - (4.*dg223*dg323 + dg322*(dg233 + 2.*dg323) + + dg222*dg333)*ginv23 - + ginv33*(dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))) - + (dg223*dg322 + dg222*dg323)*pow2(ginv22) - + 2.*((dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow2(ginv23) + + pow2(dg333)*pow2(ginv33))) - + (dg222*dg311 + dg211*dg322 + 2.*((dg122 + dg212)*dg312 + dg112*dg322))* + pow3(ginv12) - 2.*(dg111*dg311*pow3(ginv11) + + (dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313))*pow3(ginv13)) +; + +dGfromgdu32 += +-((2.*dg111*dg311*ginv12 + (dg112*dg311 + dg111*dg312)*ginv22 + + (dg113*dg311 + dg111*dg313)*ginv23)*pow2(ginv11)) + + (ddg1312 + ddg2311 - (4.*dg311*dg312 + + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + + (dg112 + dg211)*dg313 + dg111*dg323))*ginv13 - + ((3.*dg122 + 6.*dg212)*dg312 + 3.*dg112*dg322 + + 2.*(dg222*dg311 + dg211*dg322))*ginv22 - + ((dg123 + 2.*(dg213 + dg312))*dg313 + (dg113 + 2.*dg311)*dg323)* + ginv33 - ginv23*(4.*(dg213*dg312 + dg212*dg313) + + 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322 + + dg311*(dg223 + dg322) + (dg112 + dg211)*dg323 + pow2(dg312))))* + pow2(ginv12) - ((dg123*dg313 + dg312*(dg133 + 2.*dg313) + + (dg113 + 2.*dg311)*dg323 + dg112*dg333)*ginv22 + + 2.*ginv23*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313)))* + pow2(ginv13) + (ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - + ginv23*(4.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322)))*pow2(ginv22) \ ++ (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33)*pow2(ginv23) + + ginv11*(-(ginv13*((dg311*(dg123 + 2.*dg312) + + 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv22 + + (4.*dg113*dg313 + dg311*(dg133 + 2.*dg313) + dg111*dg333)*ginv23)\ +) + ginv12*(ddg1311 - ((dg122 + 2.*dg212)*dg311 + + (6.*dg112 + 2.*dg211)*dg312 + dg111*dg322)*ginv22 - + (dg311*(dg123 + 2.*(dg213 + dg312)) + 2.*dg211*dg313 + + 4.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv23 - + 2.*(dg113 + dg311)*dg313*ginv33 - + ginv13*(3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))) + + ginv22*(ddg1312 - ((dg123 + 2.*dg312)*dg313 + dg113*dg323)*ginv33 - + ginv23*(dg122*dg313 + dg113*dg322 + + 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + + pow2(dg312)))) + + ginv23*(ddg1313 - ginv33* + (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))) - + ((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*pow2(ginv12) - + ((dg122 + 2.*dg212)*dg312 + dg112*dg322)*pow2(ginv22) - + (dg133*dg312 + (dg123 + 2.*(dg213 + dg312))*dg313 + dg113*dg323 + + dg112*dg333)*pow2(ginv23)) + + ginv13*(ginv23*(ddg1333 + ddg3313 - (2.*dg133 + 6.*dg313)*dg333*ginv33) + + ginv22*(ddg1323 + ddg3312 - + (dg133*dg322 + (4.*dg123 + 2.*dg213 + 8.*dg312)*dg323 + + dg122*dg333 + 2.*(dg233*dg312 + dg313*(dg223 + dg322) + + dg212*dg333))*ginv23 - + ((dg133 + 4.*dg313)*dg323 + (dg123 + 2.*dg312)*dg333)*ginv33) - + (dg123*dg322 + dg122*dg323 + + 2.*(dg312*(dg223 + dg322) + dg212*dg323))*pow2(ginv22) - + (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + + 4.*(dg313*dg323 + dg312*dg333))*pow2(ginv23)) + + ginv12*(ddg3313*ginv33 + ginv22* + (ddg1322 + 2.*ddg2312 - (4.*(dg222*dg313 + dg213*dg322) + + 3.*(dg123*dg322 + dg122*dg323) + + 6.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - + ((2.*dg213 + 4.*dg312)*dg323 + + 2.*(dg313*(dg223 + dg322) + dg123*dg323))*ginv33) + + ginv23*(ddg1323 + 2.*ddg2313 + ddg3312 - + (dg133*dg323 + dg313*(2.*dg233 + 8.*dg323) + + (dg123 + 2.*(dg213 + dg312))*dg333)*ginv33) + + ginv13*(ddg1313 + ddg3311 - + (8.*dg312*dg313 + 4.* + ((dg123 + dg213)*dg313 + (dg113 + dg311)*dg323) + + 2.*(dg233*dg311 + dg133*dg312 + (dg112 + dg211)*dg333))*ginv23 \ +- ginv22*(dg122*dg313 + dg113*dg322 + + 2.*(dg213*dg312 + dg212*dg313 + dg311*(dg223 + dg322) + + dg211*dg323) + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg312))) \ +- ginv33*(dg133*dg313 + (dg113 + 2.*dg311)*dg333 + 4.*pow2(dg313))) - + (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* + pow2(ginv13) - (2.*dg122*dg322 + 4.*(dg222*dg312 + dg212*dg322))* + pow2(ginv22) - (dg133*dg322 + + 4.*(dg313*(dg223 + dg322) + (dg213 + dg312)*dg323) + + dg122*dg333 + 2.*(dg233*dg312 + dg123*dg323 + dg212*dg333))* + pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + + ginv22*(ddg3323*ginv33 + ginv23* + (2.*ddg2323 + ddg3322 - ginv33* + (2.*(dg233*dg323 + (dg223 + dg322)*dg333) + 6.*pow2(dg323))) - + (6.*dg223*dg323 + dg322*(2.*dg233 + 6.*dg323) + 2.*dg222*dg333)* + pow2(ginv23) - 2.*dg323*dg333*pow2(ginv33)) + + ginv23*(ddg3333*ginv33 - 2.*pow2(dg333)*pow2(ginv33)) - + ((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* + pow3(ginv12) - 2.*(dg222*dg322*pow3(ginv22) + + (dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow3(ginv23)) +; + +dGfromgdu33 += +-((2.*dg111*dg311*ginv13 + (dg112*dg311 + dg111*dg312)*ginv23 + + (dg113*dg311 + dg111*dg313)*ginv33)*pow2(ginv11)) - + (((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* + ginv13 + (dg222*dg311 + dg211*dg322 + + 2.*((dg122 + dg212)*dg312 + dg112*dg322))*ginv23 + + (dg223*dg311 + (dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + + dg113*dg322 + (dg112 + dg211)*dg323)*ginv33)*pow2(ginv12) + + (ddg1313 + ddg3311 - ((2.*dg213 + 8.*dg312)*dg313 + + dg311*(dg233 + 4.*dg323) + dg211*dg333 + + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + dg112*dg333))*ginv23 \ +- ginv22*(dg223*dg311 + (dg123 + dg213)*dg312 + dg212*dg313 + + (dg112 + dg211)*dg323 + 2.*pow2(dg312)) - + ginv33*(4.*dg311*dg333 + 3.*(dg133*dg313 + dg113*dg333) + + 6.*pow2(dg313)))*pow2(ginv13) - + (2.*dg222*dg322*ginv23 + (dg223*dg322 + dg222*dg323)*ginv33)* + pow2(ginv22) + (ddg2323 + ddg3322 - + ginv33*(4.*dg322*dg333 + 3.*(dg233*dg323 + dg223*dg333) + + 6.*pow2(dg323)))*pow2(ginv23) + ddg3333*pow2(ginv33) + + ginv13*((ddg1333 + 2.*ddg3313)*ginv33 + + ginv22*(ddg2312 - (dg222*dg313 + (dg123 + dg213)*dg322 + + dg122*dg323 + 4.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 \ +- (dg312*(dg233 + 4.*dg323) + 2.*(dg223*dg313 + (dg123 + dg213)*dg323) + + dg212*dg333)*ginv33) + + ginv23*(ddg1323 + ddg2313 + 2.*ddg3312 - + (12.*dg313*dg323 + (3.*dg213 + 8.*dg312)*dg333 + + 3.*(dg233*dg313 + dg133*dg323 + dg123*dg333))*ginv33) - + (dg222*dg312 + dg212*dg322)*pow2(ginv22) - + ((dg133 + 4.*dg313)*dg322 + (2.*dg213 + 8.*dg312)*dg323 + + dg122*dg333 + 2.*(dg233*dg312 + dg223*dg313 + dg123*dg323 + + dg212*dg333))*pow2(ginv23) - + (2.*dg133 + 8.*dg313)*dg333*pow2(ginv33)) + + ginv23*((ddg2333 + 2.*ddg3323)*ginv33 - + (2.*dg233 + 8.*dg323)*dg333*pow2(ginv33)) + + ginv12*((ddg1323 + ddg2313)*ginv33 - + ginv22*((2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))*ginv23 + + (dg222*dg313 + (dg123 + dg213)*dg322 + dg122*dg323 + + 2.*(dg223*dg312 + dg212*dg323))*ginv33) + + ginv23*(ddg1322 + ddg2312 - + (dg233*dg312 + dg133*dg322 + + 4.*(dg313*(dg223 + dg322) + (dg123 + dg213 + dg312)*dg323) + + (dg122 + dg212)*dg333)*ginv33) + + ginv13*(ddg1312 + ddg2311 - + (dg222*dg311 + (dg122 + 4.*dg212)*dg312 + (dg112 + dg211)*dg322)* + ginv22 - (dg133*dg312 + dg311*(dg233 + 4.*dg323) + + 4.*((dg123 + dg213 + dg312)*dg313 + dg113*dg323) + + (dg112 + dg211)*dg333)*ginv33 - + ginv23*(2.*(dg223*dg311 + dg122*dg313 + dg113*dg322 + + dg211*dg323) + 4.* + ((dg123 + dg213)*dg312 + dg212*dg313 + dg311*dg322 + + dg112*dg323 + pow2(dg312)))) - + (4.*dg311*dg312 + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + + (dg112 + dg211)*dg313 + dg111*dg323))*pow2(ginv13) - + ((2.*dg213 + 4.*dg312)*dg322 + + 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + + (dg122 + dg212)*dg323))*pow2(ginv23) - + (dg133*dg323 + dg313*(dg233 + 4.*dg323) + (dg123 + dg213)*dg333)* + pow2(ginv33)) + ginv11*(ddg1313*ginv33 - + ginv12*(((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*ginv13 + + ((dg122 + dg212)*dg311 + (4.*dg112 + dg211)*dg312 + dg111*dg322)* + ginv23 + ((dg123 + dg213)*dg311 + dg211*dg313 + + 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv33) - + ginv22*(((dg122 + 2.*dg212)*dg312 + dg112*dg322)*ginv23 + + ((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323)*ginv33) + + ginv13*(ddg1311 - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - + ((dg123 + dg213)*dg311 + 4.*(dg113 + dg311)*dg312 + + (4.*dg112 + dg211)*dg313 + dg111*dg323)*ginv23 - + (6.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)*ginv33) + + ginv23*(ddg1312 - (dg312*(dg133 + 4.*dg313) + + 2.*((dg123 + dg213)*dg313 + dg113*dg323) + dg112*dg333)*ginv33) \ +- (3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))*pow2(ginv13) - + ((dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + + dg112*dg323 + 2.*pow2(dg312))*pow2(ginv23) - + (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))*pow2(ginv33)) + + ginv22*(ddg2323*ginv33 + ginv23* + (ddg2322 - (6.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* + ginv33) - (3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))* + pow2(ginv23) - (dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))* + pow2(ginv33)) - (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + + dg111*dg333)*pow3(ginv13) - + (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)*pow3(ginv23) - + 2.*pow2(dg333)*pow3(ginv33) +; + +R11 += +gammado111*Gfromg1 + gammado112*Gfromg2 + gammado113*Gfromg3 + + (-0.5*ddg1111 + 3.*gamma111*gammado111 + + 2.*(gamma211*gammado112 + gamma311*gammado113) + + gamma211*gammado211 + gamma311*gammado311)*ginv11 + + (-ddg1211 + 3.*(gamma112*gammado111 + gamma111*gammado112) + + 2.*(gamma212*gammado112 + gamma312*gammado113 + + gamma211*gammado122 + gamma311*gammado123) + gamma212*gammado211 + + gamma211*gammado212 + gamma312*gammado311 + gamma311*gammado312)*ginv12 \ ++ (-ddg1311 + 3.*(gamma113*gammado111 + gamma111*gammado113) + + 2.*(gamma213*gammado112 + gamma313*gammado113 + + gamma211*gammado123 + gamma311*gammado133) + gamma213*gammado211 + + gamma211*gammado213 + gamma313*gammado311 + gamma311*gammado313)*ginv13 \ ++ (-0.5*ddg2211 + 3.*gamma112*gammado112 + + 2.*(gamma212*gammado122 + gamma312*gammado123) + + gamma212*gammado212 + gamma312*gammado312)*ginv22 + + (-ddg2311 + 3.*(gamma113*gammado112 + gamma112*gammado113) + + 2.*(gamma213*gammado122 + (gamma212 + gamma313)*gammado123 + + gamma312*gammado133) + gamma213*gammado212 + gamma212*gammado213 + + gamma313*gammado312 + gamma312*gammado313)*ginv23 + + (-0.5*ddg3311 + 3.*gamma113*gammado113 + + 2.*(gamma213*gammado123 + gamma313*gammado133) + + gamma213*gammado213 + gamma313*gammado313)*ginv33 + dG11*g11 + + dG12*g12 + dG13*g13 +; + +R12 += +(-0.5*ddg1112 + gamma112*gammado111 + (gamma111 + gamma212)*gammado112 + + gamma312*gammado113 + gamma111*gammado211 + 2.*gamma211*gammado212 + + gamma311*(gammado213 + gammado312))*ginv11 + + (-ddg1212 + gamma122*gammado111 + (2.*gamma112 + gamma222)*gammado112 + + gamma322*gammado113 + (gamma111 + gamma212)*gammado122 + + gamma112*gammado211 + (gamma111 + 2.*gamma212)*gammado212 + + 2.*gamma211*gammado222 + gamma312* + (gammado123 + gammado213 + gammado312) + + gamma311*(gammado223 + gammado322))*ginv12 + + (-ddg1312 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + + (gamma112 + gamma323)*gammado113 + (gamma111 + gamma212)*gammado123 + + gamma312*gammado133 + gamma113*gammado211 + + (gamma111 + gamma313)*gammado213 + + 2.*(gamma213*gammado212 + gamma211*gammado223) + + gamma313*gammado312 + gamma311*(gammado233 + gammado323))*ginv13 + + (-0.5*ddg2212 + gamma122*gammado112 + (gamma112 + gamma222)*gammado122 + + gamma322*gammado123 + gamma112*gammado212 + 2.*gamma212*gammado222 + + gamma312*(gammado223 + gammado322))*ginv22 + + (-ddg2312 + gamma123*gammado112 + gamma122*gammado113 + + (gamma113 + gamma223)*gammado122 + + (gamma112 + gamma222 + gamma323)*gammado123 + gamma322*gammado133 + + gamma113*gammado212 + gamma112*gammado213 + + 2.*(gamma213*gammado222 + gamma212*gammado223) + + gamma313*(gammado223 + gammado322) + + gamma312*(gammado233 + gammado323))*ginv23 + + (-0.5*ddg3312 + gamma123*gammado113 + (gamma113 + gamma223)*gammado123 + + gamma323*gammado133 + gamma113*gammado213 + 2.*gamma213*gammado223 + + gamma313*(gammado233 + gammado323))*ginv33 + + 0.5*((gammado112 + gammado211)*Gfromg1 + + (gammado122 + gammado212)*Gfromg2 + (gammado123 + gammado213)*Gfromg3 + + dG21*g11 + (dG11 + dG22)*g12 + dG23*g13 + + dG12*g22 + dG13*g23) +; + +R13 += +(-0.5*ddg1113 + gamma113*gammado111 + gamma213*gammado112 + + (gamma111 + gamma313)*gammado113 + gamma111*gammado311 + + gamma211*(gammado213 + gammado312) + 2.*gamma311*gammado313)*ginv11 + + (-ddg1213 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + + (gamma112 + gamma323)*gammado113 + gamma213*gammado122 + + (gamma111 + gamma313)*gammado123 + gamma112*gammado311 + + gamma111*gammado312 + gamma212*(gammado213 + gammado312) + + gamma211*(gammado223 + gammado322) + + 2.*(gamma312*gammado313 + gamma311*gammado323))*ginv12 + + (-ddg1313 + gamma133*gammado111 + gamma233*gammado112 + + (2.*gamma113 + gamma333)*gammado113 + + (gamma111 + gamma313)*gammado133 + gamma113*gammado311 + + gamma213*(gammado123 + gammado213 + gammado312) + + (gamma111 + 2.*gamma313)*gammado313 + + gamma211*(gammado233 + gammado323) + 2.*gamma311*gammado333)*ginv13 + + (-0.5*ddg2213 + gamma123*gammado112 + gamma223*gammado122 + + (gamma112 + gamma323)*gammado123 + gamma112*gammado312 + + gamma212*(gammado223 + gammado322) + 2.*gamma312*gammado323)*ginv22 + + (-ddg2313 + gamma133*gammado112 + gamma123*gammado113 + + gamma233*gammado122 + (gamma113 + gamma223 + gamma333)*gammado123 + + (gamma112 + gamma323)*gammado133 + gamma113*gammado312 + + gamma112*gammado313 + gamma213*(gammado223 + gammado322) + + gamma212*(gammado233 + gammado323) + + 2.*(gamma313*gammado323 + gamma312*gammado333))*ginv23 + + (-0.5*ddg3313 + gamma133*gammado113 + gamma233*gammado123 + + (gamma113 + gamma333)*gammado133 + gamma113*gammado313 + + gamma213*(gammado233 + gammado323) + 2.*gamma313*gammado333)*ginv33 + + 0.5*((gammado113 + gammado311)*Gfromg1 + + (gammado123 + gammado312)*Gfromg2 + (gammado133 + gammado313)*Gfromg3 + + dG31*g11 + dG32*g12 + (dG11 + dG33)*g13 + + dG12*g23 + dG13*g33) +; + +R22 += +gammado212*Gfromg1 + gammado222*Gfromg2 + gammado223*Gfromg3 + + (-0.5*ddg1122 + gamma112*(gammado112 + 2.*gammado211) + + 3.*gamma212*gammado212 + gamma312*(2.*gammado213 + gammado312))*ginv11 \ ++ (-ddg1222 + gamma122*(gammado112 + 2.*gammado211) + + gamma112*(gammado122 + 2.*gammado212) + + 3.*(gamma222*gammado212 + gamma212*gammado222) + + 2.*(gamma322*gammado213 + gamma312*gammado223) + + gamma322*gammado312 + gamma312*gammado322)*ginv12 + + (-ddg1322 + gamma123*(gammado112 + 2.*gammado211) + + gamma112*(gammado123 + 2.*gammado213) + + 3.*(gamma223*gammado212 + gamma212*gammado223) + + 2.*(gamma323*gammado213 + gamma312*gammado233) + + gamma323*gammado312 + gamma312*gammado323)*ginv13 + + (-0.5*ddg2222 + gamma122*(gammado122 + 2.*gammado212) + + 3.*gamma222*gammado222 + gamma322*(2.*gammado223 + gammado322))*ginv22 \ ++ (-ddg2322 + gamma123*(gammado122 + 2.*gammado212) + + gamma122*(gammado123 + 2.*gammado213) + + 3.*(gamma223*gammado222 + gamma222*gammado223) + + 2.*(gamma323*gammado223 + gamma322*gammado233) + + gamma323*gammado322 + gamma322*gammado323)*ginv23 + + (-0.5*ddg3322 + gamma123*(gammado123 + 2.*gammado213) + + 3.*gamma223*gammado223 + gamma323*(2.*gammado233 + gammado323))*ginv33 \ ++ dG21*g12 + dG22*g22 + dG23*g23 +; + +R23 += +(-0.5*ddg1123 + gamma113*gammado211 + gamma213*gammado212 + + (gamma212 + gamma313)*gammado213 + + gamma112*(gammado113 + gammado311) + gamma212*gammado312 + + 2.*gamma312*gammado313)*ginv11 + + (-ddg1223 + gamma123*gammado211 + (gamma113 + gamma223)*gammado212 + + (gamma222 + gamma323)*gammado213 + gamma213*gammado222 + + (gamma212 + gamma313)*gammado223 + + gamma122*(gammado113 + gammado311) + gamma222*gammado312 + + gamma112*(gammado123 + gammado312) + gamma212*gammado322 + + 2.*(gamma322*gammado313 + gamma312*gammado323))*ginv12 + + (-ddg1323 + gamma133*gammado211 + gamma233*gammado212 + + (gamma113 + gamma223 + gamma333)*gammado213 + gamma213*gammado223 + + (gamma212 + gamma313)*gammado233 + + gamma123*(gammado113 + gammado311) + gamma223*gammado312 + + gamma112*(gammado133 + gammado313) + gamma212*gammado323 + + 2.*(gamma323*gammado313 + gamma312*gammado333))*ginv13 + + (-0.5*ddg2223 + gamma123*gammado212 + gamma223*gammado222 + + (gamma222 + gamma323)*gammado223 + + gamma122*(gammado123 + gammado312) + gamma222*gammado322 + + 2.*gamma322*gammado323)*ginv22 + + (-ddg2323 + gamma133*gammado212 + gamma233*gammado222 + + (2.*gamma223 + gamma333)*gammado223 + + (gamma222 + gamma323)*gammado233 + + gamma123*(gammado123 + gammado213 + gammado312) + + gamma122*(gammado133 + gammado313) + gamma223*gammado322 + + (gamma222 + 2.*gamma323)*gammado323 + 2.*gamma322*gammado333)*ginv23 + + (-0.5*ddg3323 + gamma133*gammado213 + gamma233*gammado223 + + (gamma223 + gamma333)*gammado233 + + gamma123*(gammado133 + gammado313) + gamma223*gammado323 + + 2.*gamma323*gammado333)*ginv33 + + 0.5*((gammado213 + gammado312)*Gfromg1 + + (gammado223 + gammado322)*Gfromg2 + (gammado233 + gammado323)*Gfromg3 + + dG31*g12 + dG21*g13 + dG32*g22 + + (dG22 + dG33)*g23 + dG23*g33) +; + +R33 += +gammado313*Gfromg1 + gammado323*Gfromg2 + gammado333*Gfromg3 + + (-0.5*ddg1133 + gamma113*(gammado113 + 2.*gammado311) + + gamma213*(gammado213 + 2.*gammado312) + 3.*gamma313*gammado313)*ginv11 \ ++ (-ddg1233 + gamma123*(gammado113 + 2.*gammado311) + + gamma113*(gammado123 + 2.*gammado312) + + gamma223*(gammado213 + 2.*gammado312) + + gamma213*(gammado223 + 2.*gammado322) + + 3.*(gamma323*gammado313 + gamma313*gammado323))*ginv12 + + (-ddg1333 + gamma133*(gammado113 + 2.*gammado311) + + gamma233*(gammado213 + 2.*gammado312) + + gamma113*(gammado133 + 2.*gammado313) + + gamma213*(gammado233 + 2.*gammado323) + + 3.*(gamma333*gammado313 + gamma313*gammado333))*ginv13 + + (-0.5*ddg2233 + gamma123*(gammado123 + 2.*gammado312) + + gamma223*(gammado223 + 2.*gammado322) + 3.*gamma323*gammado323)*ginv22 \ ++ (-ddg2333 + gamma133*(gammado123 + 2.*gammado312) + + gamma123*(gammado133 + 2.*gammado313) + + gamma233*(gammado223 + 2.*gammado322) + + gamma223*(gammado233 + 2.*gammado323) + + 3.*(gamma333*gammado323 + gamma323*gammado333))*ginv23 + + (-0.5*ddg3333 + gamma133*(gammado133 + 2.*gammado313) + + gamma233*(gammado233 + 2.*gammado323) + 3.*gamma333*gammado333)*ginv33 \ ++ dG31*g13 + dG32*g23 + dG33*g33 +; + +ff += +chi +; + +oochipsipower += +1/chipsipower +; + +f += +oochipsipower*log(ff) +; + +psim4 += +exp(-4.*f) +; + +df1 += +(dchi1*oochipsipower)/chi +; + +df2 += +(dchi2*oochipsipower)/chi +; + +df3 += +(dchi3*oochipsipower)/chi +; + +ddf11 += +(ddchi11*oochipsipower)/chi - chipsipower*pow2(df1) +; + +ddf12 += +-(chipsipower*df1*df2) + (ddchi12*oochipsipower)/chi +; + +ddf13 += +-(chipsipower*df1*df3) + (ddchi13*oochipsipower)/chi +; + +ddf22 += +(ddchi22*oochipsipower)/chi - chipsipower*pow2(df2) +; + +ddf23 += +-(chipsipower*df2*df3) + (ddchi23*oochipsipower)/chi +; + +ddf33 += +(ddchi33*oochipsipower)/chi - chipsipower*pow2(df3) +; + +cddf11 += +ddf11 - df1*gamma111 - df2*gamma211 - df3*gamma311 +; + +cddf12 += +ddf12 - df1*gamma112 - df2*gamma212 - df3*gamma312 +; + +cddf13 += +ddf13 - df1*gamma113 - df2*gamma213 - df3*gamma313 +; + +cddf22 += +ddf22 - df1*gamma122 - df2*gamma222 - df3*gamma322 +; + +cddf23 += +ddf23 - df1*gamma123 - df2*gamma223 - df3*gamma323 +; + +cddf33 += +ddf33 - df1*gamma133 - df2*gamma233 - df3*gamma333 +; + +trcddf += +cddf11*ginv11 + cddf22*ginv22 + + 2.*(cddf12*ginv12 + cddf13*ginv13 + cddf23*ginv23) + cddf33*ginv33 +; + +Rphi11 += +-2.*(cddf11 + trcddf*g11) + (4. - 4.*ginv11*g11)*pow2(df1) - + g11*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi12 += +df1*df2*(4. - 8.*ginv12*g12) - 2.*(cddf12 + trcddf*g12) - + g12*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi13 += +df1*(4.*df3 - 8.*df2*ginv12*g13) - 2.*(cddf13 + trcddf*g13) - + g13*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi22 += +-2.*(cddf22 + trcddf*g22) + (4. - 4.*ginv22*g22)*pow2(df2) - + g22*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv11*pow2(df1) + ginv33*pow2(df3))) +; + +Rphi23 += +df2*(4.*df3 - 8.*df1*ginv12*g23) - 2.*(cddf23 + trcddf*g23) - + g23*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi33 += +-2.*(cddf33 + trcddf*g33) - + g33*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2))) + + (4. - 4.*ginv33*g33)*pow2(df3) +; + +Rf11 += +R11 + Rphi11 +; + +Rf12 += +R12 + Rphi12 +; + +Rf13 += +R13 + Rphi13 +; + +Rf22 += +R22 + Rphi22 +; + +Rf23 += +R23 + Rphi23 +; + +Rf33 += +R33 + Rphi33 +; + +Rhat += +psim4*(ginv11*Rf11 + ginv22*Rf22 + + 2.*(ginv12*Rf12 + ginv13*Rf13 + ginv23*Rf23) + ginv33*Rf33) +; + +cdda11 += +dda11 - da2*gamma211 - da3*gamma311 + + 2.*((da2*df1 + da1*df2)*ginv12 + (da3*df1 + da1*df3)*ginv13 + + da2*df2*ginv22 + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g11 \ ++ da1*(-4.*df1 - gamma111 + 2.*df1*ginv11*g11) +; + +cdda12 += +dda12 - 2.*(da2*df1 + da1*df2) - da1*gamma112 - da2*gamma212 - + da3*gamma312 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g12 +; + +cdda13 += +dda13 - 2.*(da3*df1 + da1*df3) - da1*gamma113 - da2*gamma213 - + da3*gamma313 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g13 +; + +cdda22 += +dda22 - da1*gamma122 - da3*gamma322 + + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + (da3*df2 + da2*df3)*ginv23 + + da3*df3*ginv33)*g22 + + da2*(-4.*df2 - gamma222 + 2.*df2*ginv22*g22) +; + +cdda23 += +dda23 - 2.*(da3*df2 + da2*df3) - da1*gamma123 - da2*gamma223 - + da3*gamma323 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g23 +; + +cdda33 += +dda33 - da1*gamma133 - da2*gamma233 + + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23)*g33 + + da3*(-4.*df3 - gamma333 + 2.*df3*ginv33*g33) +; + +dda12 += +dda12 - 2.*(da2*df1 + da1*df2) - da1*gamma112 - da2*gamma212 - + da3*gamma312 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g12 +; + +dda13 += +dda13 - 2.*(da3*df1 + da1*df3) - da1*gamma113 - da2*gamma213 - + da3*gamma313 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g13 +; + +dda23 += +dda23 - 2.*(da3*df2 + da2*df3) - da1*gamma123 - da2*gamma223 - + da3*gamma323 + 2.*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)*g23 +; + +trcdda += +(cdda11*ginv11 + (cdda12 + dda12)*ginv12 + (cdda13 + dda13)*ginv13 + + cdda22*ginv22 + (cdda23 + dda23)*ginv23 + cdda33*ginv33)*psim4 +; + +AA11 += +2.*(ginv23*A12*A13 + + A11*(ginv12*A12 + ginv13*A13)) + ginv11*pow2(A11) + + ginv22*pow2(A12) + ginv33*pow2(A13) +; + +AA12 += +A12*(ginv11*A11 + ginv22*A22) + ginv33*A13*A23 + + ginv13*(A12*A13 + A11*A23) + + ginv23*(A13*A22 + A12*A23) + + ginv12*(A11*A22 + pow2(A12)) +; + +AA13 += +ginv22*A12*A23 + ginv12*(A12*A13 + A11*A23) + + A13*(ginv11*A11 + ginv33*A33) + + ginv23*(A13*A23 + A12*A33) + + ginv13*(A11*A33 + pow2(A13)) +; + +AA21 += +A12*(ginv11*A11 + ginv22*A22) + ginv33*A13*A23 + + ginv13*(A12*A13 + A11*A23) + + ginv23*(A13*A22 + A12*A23) + + ginv12*(A11*A22 + pow2(A12)) +; + +AA22 += +2.*(ginv23*A22*A23 + + A12*(ginv12*A22 + ginv13*A23)) + ginv11*pow2(A12) + + ginv22*pow2(A22) + ginv33*pow2(A23) +; + +AA23 += +ginv11*A12*A13 + ginv12*(A13*A22 + A12*A23) + + A23*(ginv22*A22 + ginv33*A33) + + ginv13*(A13*A23 + A12*A33) + + ginv23*(A22*A33 + pow2(A23)) +; + +AA31 += +ginv22*A12*A23 + ginv12*(A12*A13 + A11*A23) + + A13*(ginv11*A11 + ginv33*A33) + + ginv23*(A13*A23 + A12*A33) + + ginv13*(A11*A33 + pow2(A13)) +; + +AA32 += +ginv11*A12*A13 + ginv12*(A13*A22 + A12*A23) + + A23*(ginv22*A22 + ginv33*A33) + + ginv13*(A13*A23 + A12*A33) + + ginv23*(A22*A33 + pow2(A23)) +; + +AA33 += +2.*(ginv23*A23*A33 + + A13*(ginv12*A23 + ginv13*A33)) + ginv11*pow2(A13) + + ginv22*pow2(A23) + ginv33*pow2(A33) +; + +Ainv11 += +2.*(ginv11*(ginv12*A12 + ginv13*A13) + ginv12*ginv13*A23) + + A11*pow2(ginv11) + A22*pow2(ginv12) + A33*pow2(ginv13) +; + +Ainv12 += +ginv11*(ginv12*A11 + ginv22*A12 + ginv23*A13) + + ginv12*(ginv13*A13 + ginv22*A22 + ginv23*A23) + + ginv13*(ginv22*A23 + ginv23*A33) + A12*pow2(ginv12) +; + +Ainv13 += +ginv11*(ginv13*A11 + ginv23*A12 + ginv33*A13) + + ginv12*(ginv13*A12 + ginv23*A22 + ginv33*A23) + + ginv13*(ginv23*A23 + ginv33*A33) + A13*pow2(ginv13) +; + +Ainv22 += +2.*(ginv12*(ginv22*A12 + ginv23*A13) + ginv22*ginv23*A23) + + A11*pow2(ginv12) + A22*pow2(ginv22) + A33*pow2(ginv23) +; + +Ainv23 += +ginv13*(ginv22*A12 + ginv23*A13) + + ginv12*(ginv13*A11 + ginv23*A12 + ginv33*A13) + + ginv22*(ginv23*A22 + ginv33*A23) + ginv23*ginv33*A33 + + A23*pow2(ginv23) +; + +Ainv33 += +2.*(ginv13*(ginv23*A12 + ginv33*A13) + ginv23*ginv33*A23) + + A11*pow2(ginv13) + A22*pow2(ginv23) + A33*pow2(ginv33) +; + +cdA111 += +dA111 - 2.*(gamma111*A11 + gamma211*A12 + gamma311*A13) +; + +cdA112 += +dA112 - gamma112*A11 - (gamma111 + gamma212)*A12 - + gamma312*A13 - gamma211*A22 - gamma311*A23 +; + +cdA113 += +dA113 - gamma113*A11 - gamma213*A12 - + (gamma111 + gamma313)*A13 - gamma211*A23 - gamma311*A33 +; + +cdA122 += +dA122 - 2.*(gamma112*A12 + gamma212*A22 + gamma312*A23) +; + +cdA123 += +dA123 - gamma113*A12 - gamma112*A13 - gamma213*A22 - + (gamma212 + gamma313)*A23 - gamma312*A33 +; + +cdA133 += +dA133 - 2.*(gamma113*A13 + gamma213*A23 + gamma313*A33) +; + +cdA211 += +dA211 - 2.*(gamma112*A11 + gamma212*A12 + gamma312*A13) +; + +cdA212 += +dA212 - gamma122*A11 - (gamma112 + gamma222)*A12 - + gamma322*A13 - gamma212*A22 - gamma312*A23 +; + +cdA213 += +dA213 - gamma123*A11 - gamma223*A12 - + (gamma112 + gamma323)*A13 - gamma212*A23 - gamma312*A33 +; + +cdA222 += +dA222 - 2.*(gamma122*A12 + gamma222*A22 + gamma322*A23) +; + +cdA223 += +dA223 - gamma123*A12 - gamma122*A13 - gamma223*A22 - + (gamma222 + gamma323)*A23 - gamma322*A33 +; + +cdA233 += +dA233 - 2.*(gamma123*A13 + gamma223*A23 + gamma323*A33) +; + +cdA311 += +dA311 - 2.*(gamma113*A11 + gamma213*A12 + gamma313*A13) +; + +cdA312 += +dA312 - gamma123*A11 - (gamma113 + gamma223)*A12 - + gamma323*A13 - gamma213*A22 - gamma313*A23 +; + +cdA313 += +dA313 - gamma133*A11 - gamma233*A12 - + (gamma113 + gamma333)*A13 - gamma213*A23 - gamma313*A33 +; + +cdA322 += +dA322 - 2.*(gamma123*A12 + gamma223*A22 + gamma323*A23) +; + +cdA323 += +dA323 - gamma133*A12 - gamma123*A13 - gamma233*A22 - + (gamma223 + gamma333)*A23 - gamma323*A33 +; + +cdA333 += +dA333 - 2.*(gamma133*A13 + gamma233*A23 + gamma333*A33) +; + +divbeta += +db11 + db22 + db33 +; + +totdivbeta += +0.66666666666666666667*divbeta +; + +lieg11 += +dg111*beta1 + dg211*beta2 + dg311*beta3 + + (2.*db11 - totdivbeta)*g11 + 2.*(db12*g12 + db13*g13) +; + +lieg12 += +dg112*beta1 + dg212*beta2 + dg312*beta3 + db21*g11 + + (db11 + db22 - totdivbeta)*g12 + db23*g13 + db12*g22 + + db13*g23 +; + +lieg13 += +dg113*beta1 + dg213*beta2 + dg313*beta3 + db31*g11 + + db32*g12 + (db11 + db33 - totdivbeta)*g13 + db12*g23 + + db13*g33 +; + +lieg22 += +dg122*beta1 + dg222*beta2 + dg322*beta3 - + totdivbeta*g22 + 2.*(db21*g12 + db22*g22 + db23*g23) +; + +lieg23 += +dg123*beta1 + dg223*beta2 + dg323*beta3 + db31*g12 + + db21*g13 + db32*g22 + (db22 + db33 - totdivbeta)*g23 + + db23*g33 +; + +lieg33 += +dg133*beta1 + dg233*beta2 + dg333*beta3 - + totdivbeta*g33 + 2.*(db31*g13 + db32*g23 + db33*g33) +; + +lieA11 += +(2.*db11 - totdivbeta)*A11 + 2.*(db12*A12 + db13*A13) + + dA111*beta1 + dA211*beta2 + dA311*beta3 +; + +lieA12 += +db21*A11 + (db11 + db22 - totdivbeta)*A12 + db23*A13 + + db12*A22 + db13*A23 + dA112*beta1 + dA212*beta2 + + dA312*beta3 +; + +lieA13 += +db31*A11 + db32*A12 + (db11 + db33 - totdivbeta)*A13 + + db12*A23 + db13*A33 + dA113*beta1 + dA213*beta2 + + dA313*beta3 +; + +lieA22 += +-(totdivbeta*A22) + 2.*(db21*A12 + db22*A22 + + db23*A23) + dA122*beta1 + dA222*beta2 + dA322*beta3 +; + +lieA23 += +db31*A12 + db21*A13 + db32*A22 + + (db22 + db33 - totdivbeta)*A23 + db23*A33 + dA123*beta1 + + dA223*beta2 + dA323*beta3 +; + +lieA33 += +-(totdivbeta*A33) + 2.*(db31*A13 + db32*A23 + + db33*A33) + dA133*beta1 + dA233*beta2 + dA333*beta3 +; + +betas += +sdown1*beta1 + sdown2*beta2 + sdown3*beta3 +; + +Dbetas += +(db11*sdown1 + db12*sdown2 + db13*sdown3)*sup1 + + (db21*sdown1 + db22*sdown2 + db23*sdown3)*sup2 + + (db31*sdown1 + db32*sdown2 + db33*sdown3)*sup3 +; + +Dalpha += +da1*sup1 + da2*sup2 + da3*sup3 +; + +DKhat += +dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3 +; + +DK += +dK1*sup1 + dK2*sup2 + dK3*sup3 +; + +DTheta += +dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 +; + +Gams += +sdown1*G1 + sdown2*G2 + sdown3*G3 +; + +DGams += +(dG11*sdown1 + dG12*sdown2 + dG13*sdown3)*sup1 + + (dG21*sdown1 + dG22*sdown2 + dG23*sdown3)*sup2 + + (dG31*sdown1 + dG32*sdown2 + dG33*sdown3)*sup3 +; + +GamA1 += +qud11*G1 + qud12*G2 + qud13*G3 +; + +GamA2 += +qud21*G1 + qud22*G2 + qud23*G3 +; + +GamA3 += +qud31*G1 + qud32*G2 + qud33*G3 +; + +DGamA1 += +(dG11*qud11 + dG12*qud12 + dG13*qud13)*sup1 + + (dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + + (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3 +; + +DGamA2 += +(dG11*qud21 + dG12*qud22 + dG13*qud23)*sup1 + + (dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + + (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3 +; + +DGamA3 += +(dG11*qud31 + dG12*qud32 + dG13*qud33)*sup1 + + (dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + + (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3 +; + +betaA1 += +qud11*beta1 + qud12*beta2 + qud13*beta3 +; + +betaA2 += +qud21*beta1 + qud22*beta2 + qud23*beta3 +; + +betaA3 += +qud31*beta1 + qud32*beta2 + qud33*beta3 +; + +DbetaA1 += +(db11*qud11 + db12*qud12 + db13*qud13)*sup1 + + (db21*qud11 + db22*qud12 + db23*qud13)*sup2 + + (db31*qud11 + db32*qud12 + db33*qud13)*sup3 +; + +DbetaA2 += +(db11*qud21 + db12*qud22 + db13*qud23)*sup1 + + (db21*qud21 + db22*qud22 + db23*qud23)*sup2 + + (db31*qud21 + db32*qud22 + db33*qud23)*sup3 +; + +DbetaA3 += +(db11*qud31 + db12*qud32 + db13*qud33)*sup1 + + (db21*qud31 + db22*qud32 + db23*qud33)*sup2 + + (db31*qud31 + db32*qud32 + db33*qud33)*sup3 +; + +lienKhat += +-((DKhat + Khat/r)*sqrt(muL)) +; + +lienTheta += +-DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta +; + +lienK += +lienKhat + 2.*lienTheta +; + +rKhat += +lienKhat*alpha + dKhat1*beta1 + dKhat2*beta2 + + dKhat3*beta3 +; + +rGams += +-(((db11*sdown1 + db12*sdown2)*beta1 + + (db21*sdown1 + db22*sdown2 + db23*sdown3)*beta2 + + db31*sdown1*beta3)*pow2(shiftdriver)) + + beta3*(2.*ddb231*sdown1*shiftdriver*beta2 + + sdown2*(2.*ddb132*shiftdriver*beta1 - db32*pow2(shiftdriver)) + + sdown3*(shiftdriver*(dG33 + 2.*ddb133*beta1) - + db33*pow2(shiftdriver))) + + sdown3*(db13*(db21*shiftdriver*beta2 - + beta1*pow2(shiftdriver)) + + shiftdriver*((db12*db23 + db13*(db11 + db33) + dG13)*beta1 + + (db23*db33 + dG23)*beta2 + + beta3*(db13*db31 + db23*db32 + pow2(db33)) + + ddb113*pow2(beta1))) + + shiftdriver*((dG22*sdown2 + db22*(db21*sdown1 + db23*sdown3) + + 2.*ddb123*sdown3*beta1)*beta2 + + 2.*((ddb232*sdown2 + ddb233*sdown3)*beta2*beta3 + + beta1*((ddb121*sdown1 + ddb122*sdown2)*beta2 + + ddb131*sdown1*beta3)) + + sdown2*((db13*db32 + dG12)*beta1 + + (db32*(db22 + db33) + dG32)*beta3 + + db12*((db11 + db22)*beta1 + db31*beta3) + + beta2*(db12*db21 + db23*db32 + pow2(db22))) + + (ddb111*sdown1 + ddb112*sdown2)*pow2(beta1) + + (ddb221*sdown1 + ddb222*sdown2 + ddb223*sdown3)*pow2(beta2) + + (ddb332*sdown2 + ddb333*sdown3)*pow2(beta3) + + sdown1*((db11*db21 + db23*db31 + dG21)*beta2 + + (db21*db32 + db31*(db11 + db33) + dG31)*beta3 + + beta1*(db12*db21 + db13*db31 + dG11 + pow2(db11)) + + ddb331*pow2(beta3))) +; + +rTheta += +lienTheta*alpha + dTheta1*beta1 + dTheta2*beta2 + + dTheta3*beta3 +; + +rACss += +sup1*(2.*lieA13*sup3 + 1.3333333333333333333*dK1*alpha*chi + + sup2*(-(cdda12*psim4) + 2.*(lieA12 - AA12*alpha) + + 0.66666666666666666667*trcdda*g12)) + + sup3*(2.*((psim4*Rf13*sup1 - AA23*sup2)*alpha + + sup2*(lieA23 + (-AA32 + psim4*Rf23)*alpha)) + + 1.3333333333333333333*dK3*alpha*chi + + sup1*(-(dda13*psim4) - 2.*AA13*alpha + + 0.66666666666666666667*trcdda*g13)) + + (lieA11 - cdda11*psim4 - 2.*AA11*alpha + + 0.33333333333333333333*trcdda*g11)*pow2(sup1) + + (lieA22 - 2.*AA22*alpha + 0.33333333333333333333*trcdda*g22)* + pow2(sup2) - psim4*((cdda23 + dda23)*sup2*sup3 + + sup1*(dda12*sup2 + cdda13*sup3) + cdda22*pow2(sup2)) + + (lieA33 - cdda33*psim4 - 2.*AA33*alpha + + 0.33333333333333333333*trcdda*g33)*pow2(sup3) - + alpha*(sup2*(2.*AA21*sup1 + + 0.66666666666666666667*Rhat*sup3*g23) + + 0.33333333333333333333*(Rhat*g11*pow2(sup1) + + dGfromgdu11*qud11*pow2(chi))) + + alpha*(1.3333333333333333333*dK2*sup2*chi + + 2.*(sup1*(-(AA31*sup3) + K*sup2*A12) + K*sup2*sup3*A23 - + DTheta*chi) + ginv11* + (3.*dchi1*(sup1*A11 + sup2*A12 + sup3*A13) - + 2.*(cdA111*sup1 + cdA112*sup2 + cdA113*sup3)*chi) + + ginv12*(3.*(sup1*(dchi2*A11 + dchi1*A12) + + dchi2*(sup2*A12 + sup3*A13) + + dchi1*(sup2*A22 + sup3*A23)) - + 2.*((cdA112 + cdA211)*sup1 + (cdA122 + cdA212)*sup2 + + (cdA123 + cdA213)*sup3)*chi) + + ginv22*(3.*dchi2*(sup1*A12 + sup2*A22 + sup3*A23) - + 2.*(cdA212*sup1 + cdA222*sup2 + cdA223*sup3)*chi) + + ginv13*(3.*(dchi3*(sup1*A11 + sup2*A12) + + (dchi1*sup1 + dchi3*sup3)*A13 + + dchi1*(sup2*A23 + sup3*A33)) - + 2.*((cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 + cdA313)*sup3)*chi) + + ginv23*(3.*(sup1*(dchi3*A12 + dchi2*A13) + + sup2*(dchi3*A22 + dchi2*A23) + + sup3*(dchi3*A23 + dchi2*A33)) - + 2.*((cdA213 + cdA312)*sup1 + (cdA223 + cdA322)*sup2 + + (cdA233 + cdA323)*sup3)*chi) + + ginv33*(3.*dchi3*(sup1*A13 + sup2*A23 + sup3*A33) - + 2.*(cdA313*sup1 + cdA323*sup2 + cdA333*sup3)*chi) - + 0.66666666666666666667*Rhat*sup1*sup3*g13 + + psim4*(2.*Rf12*sup1*sup2 + Rf11*pow2(sup1) + Rf22*pow2(sup2) + + Rf33*pow2(sup3)) + K*(2.*sup1*sup3*A13 + + A11*pow2(sup1) + A22*pow2(sup2) + A33*pow2(sup3)) + + (0.33333333333333333333*dG11*qud11 - + sdown3*(Gfromg3*kappa1 + 0.66666666666666666667*dG33*sup3) + + sdown1*(0.66666666666666666667*dGfromgdu11*sup1 + + kappa1*G1) + kappa1* + (-(Gfromg1*sdown1) - Gfromg2*sdown2 + sdown2*G2 + + sdown3*G3))*pow2(chi) + + 0.33333333333333333333*(-(Rhat* + (g22*pow2(sup2) + g33*pow2(sup3))) + + ((dG12 - dGfromgdu12)*qud12 + (dG13 - dGfromgdu13)*qud13 + + (dG21 - dGfromgdu21)*qud21 + (dG22 - dGfromgdu22)*qud22 + + (dG23 - dGfromgdu23)*qud23 + (dG31 - dGfromgdu31)*qud31 + + (dG32 - dGfromgdu32)*qud32 + (dG33 - dGfromgdu33)*qud33)* + pow2(chi))) + 0.66666666666666666667* + (sup2*(sup3*trcdda*g23 + + (-(dG21*sdown1) - dG22*sdown2 + dGfromgdu22*sdown2 + + dGfromgdu23*sdown3)*alpha*pow2(chi)) + + alpha*((-(sdown3*(dG13*sup1 + dG23*sup2)) + + (-(dG31*sdown1) - dG32*sdown2 + dGfromgdu32*sdown2 + + dGfromgdu33*sdown3)*sup3 + + sdown1*(dGfromgdu21*sup2 + dGfromgdu31*sup3))*pow2(chi) + + sup1*(-(Rhat*sup2*g12) + + (-(dG11*sdown1) - dG12*sdown2 + dGfromgdu12*sdown2 + + dGfromgdu13*sdown3)*pow2(chi)))) +; + +rACqq += +-rACss + (Ainv22*lieg22 + 2.*(Ainv12*lieg12 + Ainv13*lieg13 + + Ainv23*lieg23) - (2.*Ainv22*A22 + + 4.*(Ainv12*A12 + Ainv13*A13 + Ainv23*A23))* + alpha + Ainv11*(lieg11 - 2.*A11*alpha) + + Ainv33*(lieg33 - 2.*A33*alpha))*chi +; + +rGamA1 += +-(((dG11*qud11 + dG12*qud12 + dG13*qud13)*sup1 + + (dG22*qud12 + dG23*qud13)*sup2 + (dG32*qud12 + dG33*qud13)*sup3 + + qud11*(dG21*sup2 + dG31*sup3))*vbetaA) + + (dG11*qud11 + dG12*qud12 + dG13*qud13)*beta1 + + (dG21*qud11 + dG22*qud12 + dG23*qud13)*beta2 + + (dG31*qud11 + dG32*qud12 + dG33*qud13)*beta3 - + ((((db11*quu11 + db21*quu12 + db31*quu13)*sdown1 + + (db12*quu11 + db22*quu12 + db32*quu13)*sdown2 + + (db13*quu11 + db23*quu12)*sdown3)*shiftdriver)/vbetaA + + (0.66666666666666666667*dTheta1*quu11 + + (1.3333333333333333333*dKhat2 + 0.66666666666666666667*dTheta2)* + quu12)*alpha + quu13* + ((db33*sdown3*shiftdriver)/vbetaA + + 1.3333333333333333333*dKhat3*alpha))/chi + + (2.3333333333333333333*((ddb121*qud11 + ddb122*qud12 + ddb123*qud13)* + quu12 + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13)*quu13) + + 0.33333333333333333333*((ddb122*qud22 + ddb123*qud23 + + ddb131*qud31 + ddb132*qud32)*quu11 + + (ddb221*qud21 + ddb222*qud22 + ddb223*qud23 + ddb231*qud31 + + ddb232*qud32 + ddb233*qud33)*quu12 + + (ddb231*qud21 + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + + ddb332*qud32 + ddb333*qud33)*quu13) + + (ddb221*qud11 + ddb222*qud12 + ddb223*qud13)*quu22 + + 2.*(ddb231*qud11 + ddb232*qud12 + ddb233*qud13)*quu23 + + (ddb331*qud11 + ddb332*qud12 + ddb333*qud13)*quu33 + + 1.3333333333333333333*((ddb111*qud11 + ddb112*qud12)*quu11 + + (ddb132*quu13*sdown2 + ddb113*quu11*sdown3)*sup1 + + (ddb232*quu13*sdown2 + ddb123*quu11*sdown3)*sup2 + + (ddb332*quu13*sdown2 + ddb133*quu11*sdown3)*sup3 + + sdown2*((ddb112*quu11 + ddb122*quu12)*sup1 + + (ddb122*quu11 + ddb222*quu12)*sup2 + + (ddb132*quu11 + ddb232*quu12)*sup3) + + sdown1*((ddb121*quu12 + ddb131*quu13)*sup1 + + (ddb221*quu12 + ddb231*quu13)*sup2 + + (ddb231*quu12 + ddb331*quu13)*sup3) + + sdown3*((ddb123*quu12 + ddb133*quu13)*sup1 + + (ddb223*quu12 + ddb233*quu13)*sup2 + + (ddb233*quu12 + ddb333*quu13)*sup3)) + + (shiftdriver*((db11*qud11 + db12*qud12 + db13*qud13)*sup1 + + (db21*qud11 + db22*qud12 + db23*qud13)*sup2 + + (db31*qud11 + db32*qud12 + db33*qud13)*sup3))/vbetaA + + ((dG21*quu12 + dG31*quu13)*sdown1 + + (dG12*quu11 + dG22*quu12 + dG32*quu13)*sdown2 + + (dG13*quu11 + dG23*quu12 + dG33*quu13)*sdown3)*vbetaA - + 0.66666666666666666667*dTheta3*quu13*alpha + + quu11*(0.33333333333333333333*(ddb121*qud21 + ddb133*qud33) + + dG11*sdown1*vbetaA + 1.3333333333333333333* + (ddb113*qud13 + sdown1*(ddb111*sup1 + ddb121*sup2 + ddb131*sup3) - + dKhat1*alpha)))/chi +; + +rGamA2 += +-(((dG11*qud21 + dG12*qud22 + dG13*qud23)*sup1 + + (dG22*qud22 + dG23*qud23)*sup2 + (dG32*qud22 + dG33*qud23)*sup3 + + qud21*(dG21*sup2 + dG31*sup3))*vbetaA) + + (dG11*qud21 + dG12*qud22 + dG13*qud23)*beta1 + + (dG21*qud21 + dG22*qud22 + dG23*qud23)*beta2 + + (dG31*qud21 + dG32*qud22 + dG33*qud23)*beta3 - + ((((db11*quu12 + db21*quu22 + db31*quu23)*sdown1 + + (db12*quu12 + db22*quu22 + db32*quu23)*sdown2 + + (db13*quu12 + db23*quu22)*sdown3)*shiftdriver)/vbetaA + + (0.66666666666666666667*dTheta1*quu12 + + (1.3333333333333333333*dKhat2 + 0.66666666666666666667*dTheta2)* + quu22)*alpha + quu23* + ((db33*sdown3*shiftdriver)/vbetaA + + 1.3333333333333333333*dKhat3*alpha))/chi + + ((ddb111*qud21 + ddb112*qud22)*quu11 + + 2.*(ddb131*qud21 + ddb132*qud22 + ddb133*qud23)*quu13 + + (1.3333333333333333333*ddb223*qud23 + + 0.33333333333333333333*(ddb121*qud11 + ddb231*qud31))*quu22 + + 2.3333333333333333333*((ddb121*qud21 + ddb122*qud22)*quu12 + + (ddb231*qud21 + ddb232*qud22)*quu23) + + 0.33333333333333333333*((ddb112*qud12 + ddb113*qud13 + + ddb132*qud32 + ddb133*qud33)*quu12 + + (ddb122*qud12 + ddb123*qud13 + ddb232*qud32 + ddb233*qud33)* + quu22 + (ddb132*qud12 + ddb133*qud13 + ddb332*qud32 + + ddb333*qud33)*quu23) + + (ddb331*qud21 + ddb332*qud22 + ddb333*qud23)*quu33 + + 1.3333333333333333333*((ddb221*qud21 + ddb222*qud22)*quu22 + + (ddb132*quu23*sdown2 + ddb113*quu12*sdown3)*sup1 + + (ddb232*quu23*sdown2 + ddb123*quu12*sdown3)*sup2 + + (ddb332*quu23*sdown2 + ddb133*quu12*sdown3)*sup3 + + sdown2*((ddb112*quu12 + ddb122*quu22)*sup1 + + (ddb122*quu12 + ddb222*quu22)*sup2 + + (ddb132*quu12 + ddb232*quu22)*sup3) + + sdown1*((ddb121*quu22 + ddb131*quu23)*sup1 + + (ddb221*quu22 + ddb231*quu23)*sup2 + + (ddb231*quu22 + ddb331*quu23)*sup3) + + sdown3*((ddb123*quu22 + ddb133*quu23)*sup1 + + (ddb223*quu22 + ddb233*quu23)*sup2 + + (ddb233*quu22 + ddb333*quu23)*sup3)) + + qud23*(ddb113*quu11 + (db33*shiftdriver*sup3)/vbetaA) + + (shiftdriver*((db11*qud21 + db12*qud22 + db13*qud23)*sup1 + + (db21*qud21 + db22*qud22 + db23*qud23)*sup2 + + (db31*qud21 + db32*qud22)*sup3))/vbetaA + + ((dG21*quu22 + dG31*quu23)*sdown1 + + (dG12*quu12 + dG22*quu22 + dG32*quu23)*sdown2 + + (dG13*quu12 + dG23*quu22 + dG33*quu23)*sdown3)*vbetaA + + quu23*(2.3333333333333333333*ddb233*qud23 + + 0.33333333333333333333*(ddb131*qud11 + ddb331*qud31) - + 0.66666666666666666667*dTheta3*alpha) + + quu12*(2.3333333333333333333*ddb123*qud23 + + 0.33333333333333333333*(ddb111*qud11 + ddb131*qud31) + + dG11*sdown1*vbetaA + 1.3333333333333333333* + (sdown1*(ddb111*sup1 + ddb121*sup2 + ddb131*sup3) - + dKhat1*alpha)))/chi +; + +rGamA3 += +-(((dG11*qud31 + dG12*qud32 + dG13*qud33)*sup1 + + (dG22*qud32 + dG23*qud33)*sup2 + (dG32*qud32 + dG33*qud33)*sup3 + + qud31*(dG21*sup2 + dG31*sup3))*vbetaA) + + (dG11*qud31 + dG12*qud32 + dG13*qud33)*beta1 + + (dG21*qud31 + dG22*qud32 + dG23*qud33)*beta2 + + (dG31*qud31 + dG32*qud32 + dG33*qud33)*beta3 - + ((((db11*quu13 + db21*quu23 + db31*quu33)*sdown1 + + (db12*quu13 + db22*quu23 + db32*quu33)*sdown2 + + (db13*quu13 + db23*quu23)*sdown3)*shiftdriver)/vbetaA + + (0.66666666666666666667*dTheta1*quu13 + + (1.3333333333333333333*dKhat2 + 0.66666666666666666667*dTheta2)* + quu23)*alpha + quu33* + ((db33*sdown3*shiftdriver)/vbetaA + + 1.3333333333333333333*dKhat3*alpha))/chi + + ((ddb111*qud31 + ddb112*qud32)*quu11 + + 2.*(ddb122*qud32 + ddb123*qud33)*quu12 + + (ddb222*qud32 + ddb223*qud33)*quu22 + + qud31*(2.*ddb121*quu12 + ddb221*quu22) + + (0.33333333333333333333*(ddb121*qud11 + ddb223*qud23) + + 2.3333333333333333333*ddb231*qud31)*quu23 + + 2.3333333333333333333*((ddb132*qud32 + ddb133*qud33)*quu13 + + (ddb232*qud32 + ddb233*qud33)*quu23) + + 0.33333333333333333333*((ddb112*qud12 + ddb113*qud13 + + ddb121*qud21 + ddb122*qud22)*quu13 + + (ddb122*qud12 + ddb123*qud13 + ddb221*qud21 + ddb222*qud22)* + quu23 + (ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + + ddb232*qud22)*quu33) + + 1.3333333333333333333*((ddb332*qud32 + ddb333*qud33)*quu33 + + (ddb132*quu33*sdown2 + ddb113*quu13*sdown3)*sup1 + + (ddb232*quu33*sdown2 + ddb123*quu13*sdown3)*sup2 + + (ddb332*quu33*sdown2 + ddb133*quu13*sdown3)*sup3 + + sdown2*((ddb112*quu13 + ddb122*quu23)*sup1 + + (ddb122*quu13 + ddb222*quu23)*sup2 + + (ddb132*quu13 + ddb232*quu23)*sup3) + + sdown1*((ddb121*quu23 + ddb131*quu33)*sup1 + + (ddb221*quu23 + ddb231*quu33)*sup2 + + (ddb231*quu23 + ddb331*quu33)*sup3) + + sdown3*((ddb123*quu23 + ddb133*quu33)*sup1 + + (ddb223*quu23 + ddb233*quu33)*sup2 + + (ddb233*quu23 + ddb333*quu33)*sup3)) + + qud33*(ddb113*quu11 + (db33*shiftdriver*sup3)/vbetaA) + + (shiftdriver*((db11*qud31 + db12*qud32 + db13*qud33)*sup1 + + (db21*qud31 + db22*qud32 + db23*qud33)*sup2 + + (db31*qud31 + db32*qud32)*sup3))/vbetaA + + ((dG21*quu23 + dG31*quu33)*sdown1 + + (dG12*quu13 + dG22*quu23 + dG32*quu33)*sdown2 + + (dG13*quu13 + dG23*quu23 + dG33*quu33)*sdown3)*vbetaA + + quu33*(0.33333333333333333333*(ddb131*qud11 + ddb233*qud23) + + 1.3333333333333333333*ddb331*qud31 - + 0.66666666666666666667*dTheta3*alpha) + + quu13*(0.33333333333333333333*(ddb111*qud11 + ddb123*qud23) + + ddb131*(2.3333333333333333333*qud31 + + 1.3333333333333333333*sdown1*sup3) + dG11*sdown1*vbetaA + + 1.3333333333333333333*(sdown1*(ddb111*sup1 + ddb121*sup2) - + dKhat1*alpha)))/chi +; + +rACsA1 += +-2.*((AA12*qud21 + AA13*qud31)*sup1 + (AA22*qud21 + AA23*qud31)*sup2 + + (AA32*qud21 + AA33*qud31)*sup3)*alpha - + ((cdda12*qud21 + cdda13*qud31)*sup1 + + (cdda22*qud21 + cdda23*qud31)*sup2 + dda23*qud21*sup3)*chi + + (-(cdda33*qud31*sup3) + 0.66666666666666666667*dK1*qud11*alpha)* + chi + sup1*(qud11*(lieA11 - 2.*AA11*alpha - cdda11*chi) + + qud21*(lieA12 + Rf12*alpha*chi) + + qud31*(lieA13 + Rf13*alpha*chi)) + + sup2*(lieA23*qud31 + qud11*(lieA12 - 2.*AA21*alpha - + dda12*chi + Rf12*alpha*chi) + + qud21*(lieA22 + Rf22*alpha*chi)) + + sup3*(qud11*(lieA13 - 2.*AA31*alpha - dda13*chi) + + qud21*(lieA23 + Rf23*alpha*chi) + + qud31*(lieA33 + alpha*(K*A33 + Rf33*chi)) - + 0.5*dG33*qdd13*alpha*pow2(chi)) + + alpha*(K*(sup1*(qud11*A11 + qud21*A12 + qud31*A13) + + qud11*(sup2*A12 + sup3*A13) + qud21*sup3*A23 + + sup2*(qud21*A22 + qud31*A23)) + + (-(dTheta1*qud11) - dTheta2*qud21 - dTheta3*qud31 + + 0.66666666666666666667*(dK2*qud21 + dK3*qud31) + qud31*Rf23*sup2 + + qud11*(Rf11*sup1 + Rf13*sup3))*chi + + ginv11*(1.5*dchi1*(qud11*A11 + qud21*A12 + qud31*A13) - + (cdA111*qud11 + cdA112*qud21 + cdA113*qud31)*chi) + + ginv12*(1.5*(qud11*(dchi2*A11 + dchi1*A12) + + dchi2*(qud21*A12 + qud31*A13) + + dchi1*(qud21*A22 + qud31*A23)) - + ((cdA112 + cdA211)*qud11 + (cdA122 + cdA212)*qud21 + + (cdA123 + cdA213)*qud31)*chi) + + ginv22*(1.5*dchi2*(qud11*A12 + qud21*A22 + qud31*A23) - + (cdA212*qud11 + cdA222*qud21 + cdA223*qud31)*chi) + + ginv13*(1.5*(dchi3*(qud11*A11 + qud21*A12) + + (dchi1*qud11 + dchi3*qud31)*A13 + + dchi1*(qud21*A23 + qud31*A33)) - + ((cdA113 + cdA311)*qud11 + (cdA123 + cdA312)*qud21 + + (cdA133 + cdA313)*qud31)*chi) + + ginv23*(1.5*(qud11*(dchi3*A12 + dchi2*A13) + + qud21*(dchi3*A22 + dchi2*A23) + + qud31*(dchi3*A23 + dchi2*A33)) - + ((cdA213 + cdA312)*qud11 + (cdA223 + cdA322)*qud21 + + (cdA233 + cdA323)*qud31)*chi) + + ginv33*(1.5*dchi3*(qud11*A13 + qud21*A23 + qud31*A33) - + (cdA313*qud11 + cdA323*qud21 + cdA333*qud31)*chi) + + 0.5*((-(dG11*qdd11) - dG12*qdd12 + dGfromgdu12*qdd12 + + dGfromgdu13*qdd13)*sup1 + + (-(dG21*qdd11) - dG22*qdd12 + dGfromgdu22*qdd12 + + dGfromgdu23*qdd13)*sup2 - + qdd13*(Gfromg3*kappa1 + dG13*sup1 + dG23*sup2) + + (-(dG31*qdd11) - dG32*qdd12 + dGfromgdu32*qdd12 + + dGfromgdu33*qdd13)*sup3 + + qdd11*(dGfromgdu11*sup1 + dGfromgdu21*sup2 + dGfromgdu31*sup3) + + kappa1*(-(Gfromg1*qdd11) - Gfromg2*qdd12 + qdd11*G1 + + qdd12*G2 + qdd13*G3))*pow2(chi)) +; + +rACsA2 += +-2.*((AA12*qud22 + AA13*qud32)*sup1 + (AA22*qud22 + AA23*qud32)*sup2 + + (AA32*qud22 + AA33*qud32)*sup3)*alpha - + ((cdda12*qud22 + cdda13*qud32)*sup1 + + (cdda22*qud22 + cdda23*qud32)*sup2 + dda23*qud22*sup3)*chi + + (-(cdda33*qud32*sup3) + 0.66666666666666666667*dK1*qud12*alpha)* + chi + sup1*(qud12*(lieA11 - 2.*AA11*alpha - cdda11*chi) + + qud22*(lieA12 + Rf12*alpha*chi) + + qud32*(lieA13 + Rf13*alpha*chi)) + + sup2*(lieA23*qud32 + qud12*(lieA12 - 2.*AA21*alpha - + dda12*chi + Rf12*alpha*chi) + + qud22*(lieA22 + Rf22*alpha*chi)) + + sup3*(qud12*(lieA13 - 2.*AA31*alpha - dda13*chi) + + qud22*(lieA23 + Rf23*alpha*chi) + + qud32*(lieA33 + alpha*(K*A33 + Rf33*chi)) - + 0.5*dG33*qdd23*alpha*pow2(chi)) + + alpha*(K*(sup1*(qud12*A11 + qud22*A12 + qud32*A13) + + qud12*(sup2*A12 + sup3*A13) + qud22*sup3*A23 + + sup2*(qud22*A22 + qud32*A23)) + + (-(dTheta1*qud12) - dTheta2*qud22 - dTheta3*qud32 + + 0.66666666666666666667*(dK2*qud22 + dK3*qud32) + qud32*Rf23*sup2 + + qud12*(Rf11*sup1 + Rf13*sup3))*chi + + ginv11*(1.5*dchi1*(qud12*A11 + qud22*A12 + qud32*A13) - + (cdA111*qud12 + cdA112*qud22 + cdA113*qud32)*chi) + + ginv12*(1.5*(qud12*(dchi2*A11 + dchi1*A12) + + dchi2*(qud22*A12 + qud32*A13) + + dchi1*(qud22*A22 + qud32*A23)) - + ((cdA112 + cdA211)*qud12 + (cdA122 + cdA212)*qud22 + + (cdA123 + cdA213)*qud32)*chi) + + ginv22*(1.5*dchi2*(qud12*A12 + qud22*A22 + qud32*A23) - + (cdA212*qud12 + cdA222*qud22 + cdA223*qud32)*chi) + + ginv13*(1.5*(dchi3*(qud12*A11 + qud22*A12) + + (dchi1*qud12 + dchi3*qud32)*A13 + + dchi1*(qud22*A23 + qud32*A33)) - + ((cdA113 + cdA311)*qud12 + (cdA123 + cdA312)*qud22 + + (cdA133 + cdA313)*qud32)*chi) + + ginv23*(1.5*(qud12*(dchi3*A12 + dchi2*A13) + + qud22*(dchi3*A22 + dchi2*A23) + + qud32*(dchi3*A23 + dchi2*A33)) - + ((cdA213 + cdA312)*qud12 + (cdA223 + cdA322)*qud22 + + (cdA233 + cdA323)*qud32)*chi) + + ginv33*(1.5*dchi3*(qud12*A13 + qud22*A23 + qud32*A33) - + (cdA313*qud12 + cdA323*qud22 + cdA333*qud32)*chi) + + 0.5*((-(dG11*qdd12) - dG12*qdd22 + dGfromgdu12*qdd22 + + dGfromgdu13*qdd23)*sup1 + + (-(dG21*qdd12) - dG22*qdd22 + dGfromgdu22*qdd22 + + dGfromgdu23*qdd23)*sup2 - + qdd23*(Gfromg3*kappa1 + dG13*sup1 + dG23*sup2) + + (-(dG31*qdd12) - dG32*qdd22 + dGfromgdu32*qdd22 + + dGfromgdu33*qdd23)*sup3 + + qdd12*(dGfromgdu11*sup1 + dGfromgdu21*sup2 + dGfromgdu31*sup3) + + kappa1*(-(Gfromg1*qdd12) - Gfromg2*qdd22 + qdd12*G1 + + qdd22*G2 + qdd23*G3))*pow2(chi)) +; + +rACsA3 += +-2.*((AA12*qud23 + AA13*qud33)*sup1 + (AA22*qud23 + AA23*qud33)*sup2 + + (AA32*qud23 + AA33*qud33)*sup3)*alpha - + ((cdda12*qud23 + cdda13*qud33)*sup1 + + (cdda22*qud23 + cdda23*qud33)*sup2 + dda23*qud23*sup3)*chi + + (-(cdda33*qud33*sup3) + 0.66666666666666666667*dK1*qud13*alpha)* + chi + sup1*(qud13*(lieA11 - 2.*AA11*alpha - cdda11*chi) + + qud23*(lieA12 + Rf12*alpha*chi) + + qud33*(lieA13 + Rf13*alpha*chi)) + + sup2*(lieA23*qud33 + qud13*(lieA12 - 2.*AA21*alpha - + dda12*chi + Rf12*alpha*chi) + + qud23*(lieA22 + Rf22*alpha*chi)) + + sup3*(qud13*(lieA13 - 2.*AA31*alpha - dda13*chi) + + qud23*(lieA23 + Rf23*alpha*chi) + + qud33*(lieA33 + alpha*(K*A33 + Rf33*chi)) - + 0.5*dG33*qdd33*alpha*pow2(chi)) + + alpha*(K*(sup1*(qud13*A11 + qud23*A12 + qud33*A13) + + qud13*(sup2*A12 + sup3*A13) + qud23*sup3*A23 + + sup2*(qud23*A22 + qud33*A23)) + + (-(dTheta1*qud13) - dTheta2*qud23 - dTheta3*qud33 + + 0.66666666666666666667*(dK2*qud23 + dK3*qud33) + qud33*Rf23*sup2 + + qud13*(Rf11*sup1 + Rf13*sup3))*chi + + ginv11*(1.5*dchi1*(qud13*A11 + qud23*A12 + qud33*A13) - + (cdA111*qud13 + cdA112*qud23 + cdA113*qud33)*chi) + + ginv12*(1.5*(qud13*(dchi2*A11 + dchi1*A12) + + dchi2*(qud23*A12 + qud33*A13) + + dchi1*(qud23*A22 + qud33*A23)) - + ((cdA112 + cdA211)*qud13 + (cdA122 + cdA212)*qud23 + + (cdA123 + cdA213)*qud33)*chi) + + ginv22*(1.5*dchi2*(qud13*A12 + qud23*A22 + qud33*A23) - + (cdA212*qud13 + cdA222*qud23 + cdA223*qud33)*chi) + + ginv13*(1.5*(dchi3*(qud13*A11 + qud23*A12) + + (dchi1*qud13 + dchi3*qud33)*A13 + + dchi1*(qud23*A23 + qud33*A33)) - + ((cdA113 + cdA311)*qud13 + (cdA123 + cdA312)*qud23 + + (cdA133 + cdA313)*qud33)*chi) + + ginv23*(1.5*(qud13*(dchi3*A12 + dchi2*A13) + + qud23*(dchi3*A22 + dchi2*A23) + + qud33*(dchi3*A23 + dchi2*A33)) - + ((cdA213 + cdA312)*qud13 + (cdA223 + cdA322)*qud23 + + (cdA233 + cdA323)*qud33)*chi) + + ginv33*(1.5*dchi3*(qud13*A13 + qud23*A23 + qud33*A33) - + (cdA313*qud13 + cdA323*qud23 + cdA333*qud33)*chi) + + 0.5*((-(dG11*qdd13) - dG12*qdd23 + dGfromgdu12*qdd23 + + dGfromgdu13*qdd33)*sup1 + + (-(dG21*qdd13) - dG22*qdd23 + dGfromgdu22*qdd23 + + dGfromgdu23*qdd33)*sup2 - + qdd33*(Gfromg3*kappa1 + dG13*sup1 + dG23*sup2) + + (-(dG31*qdd13) - dG32*qdd23 + dGfromgdu32*qdd23 + + dGfromgdu33*qdd33)*sup3 + + qdd13*(dGfromgdu11*sup1 + dGfromgdu21*sup2 + dGfromgdu31*sup3) + + kappa1*(-(Gfromg1*qdd13) - Gfromg2*qdd23 + qdd13*G1 + + qdd23*G2 + qdd33*G3))*pow2(chi)) +; + +rACABTF11 += +2.*(lieA12*qPhysuudd1211 + lieA13*qPhysuudd1311 + + qPhysuudd2311*(lieA23 - cdA123*sup1*alpha)) + + qPhysuudd1111*(lieA11 + alpha* + (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ ++ alpha*(qPhysuudd1111*(cdA113*sup3 + + 0.66666666666666666667*K*A11) + + 1.3333333333333333333*K*(qPhysuudd1211*A12 + + qPhysuudd1311*A13 + qPhysuudd2311*A23) + + qPhysuudd3311*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + + sup3*(cdA123*qPhysuudd1211 + + qPhysuudd1111*(-cdA311 + (0.5*dchi3*A11)/chi)) + + qPhysuudd2211*A22*(0.66666666666666666667*K + + (0.5*dchi3*sup3)/chi) + + sup2*(-2.*cdA213*qPhysuudd1311 - cdA223*qPhysuudd2311 + + cdA322*qPhysuudd2311 + cdA323*qPhysuudd3311 + + (0.5*dchi2*qPhysuudd1111*A11)/chi) + + (dchi3*(-0.5*qPhysuudd1311*sup2 + qPhysuudd1211*sup3)*A12 + + (-0.5*dchi3*qPhysuudd3311*sup1 + dchi2*qPhysuudd1311*sup2)* + A13 + sup1*(-0.5*dchi2*qPhysuudd1211*A11 + + dchi1*qPhysuudd2311*A23) + + 0.5*((-(dchi3*qPhysuudd2311*sup1) + dchi2*qPhysuudd1211*sup2)* + A12 + dchi3*qPhysuudd1311*sup3*A13 - + (dchi1*qPhysuudd1211 + dchi3*qPhysuudd2311)*sup2*A22 + + sup1*((dchi1*qPhysuudd1211 - dchi2*qPhysuudd2211)*A12 + + (dchi1*qPhysuudd1311 - dchi2*qPhysuudd2311)*A13 + + dchi1*qPhysuudd2211*A22) - + (dchi3*qPhysuudd3311*sup2 + dchi1*qPhysuudd1211*sup3)* + A23 + ((-(dchi1*qPhysuudd1311) + dchi2*qPhysuudd2311)* + sup2 + (-(dchi2*qPhysuudd2211) + dchi3*qPhysuudd2311)*sup3\ +)*A23 + qPhysuudd3311*(dchi1*sup1 + dchi2*sup2)*A33 - + sup3*((dchi1*qPhysuudd1111 + dchi2*qPhysuudd1211)*A13 + + (dchi1*qPhysuudd1311 + dchi2*qPhysuudd2311)*A33)))/ + chi) - cdda11*qPhysuudd1111*chi + + qPhysuudd1211*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + + (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + + qPhysuudd1311*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + + qPhysuudd2211*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + + cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + + qPhysuudd2311*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* + alpha - cdda23*chi) + + qPhysuudd3311*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - + cdda33*chi) - qPhysuudd1211* + ((AA12 + AA21)*alpha + dda12*chi) - + qPhysuudd1311*(alpha*(AA13 + AA31 + + (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - + qPhysuudd2311*((AA23 + AA32)*alpha + dda23*chi) +; + +rACABTF12 += +2.*(lieA12*qPhysuudd1212 + lieA13*qPhysuudd1312 + + qPhysuudd2312*(lieA23 - cdA123*sup1*alpha)) + + qPhysuudd1112*(lieA11 + alpha* + (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ ++ alpha*(qPhysuudd1112*(cdA113*sup3 + + 0.66666666666666666667*K*A11) + + 1.3333333333333333333*K*(qPhysuudd1212*A12 + + qPhysuudd1312*A13 + qPhysuudd2312*A23) + + qPhysuudd3312*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + + sup3*(cdA123*qPhysuudd1212 + + qPhysuudd1112*(-cdA311 + (0.5*dchi3*A11)/chi)) + + qPhysuudd2212*A22*(0.66666666666666666667*K + + (0.5*dchi3*sup3)/chi) + + sup2*(-2.*cdA213*qPhysuudd1312 - cdA223*qPhysuudd2312 + + cdA322*qPhysuudd2312 + cdA323*qPhysuudd3312 + + (0.5*dchi2*qPhysuudd1112*A11)/chi) + + (dchi3*(-0.5*qPhysuudd1312*sup2 + qPhysuudd1212*sup3)*A12 + + (-0.5*dchi3*qPhysuudd3312*sup1 + dchi2*qPhysuudd1312*sup2)* + A13 + sup1*(-0.5*dchi2*qPhysuudd1212*A11 + + dchi1*qPhysuudd2312*A23) + + 0.5*((-(dchi3*qPhysuudd2312*sup1) + dchi2*qPhysuudd1212*sup2)* + A12 + dchi3*qPhysuudd1312*sup3*A13 - + (dchi1*qPhysuudd1212 + dchi3*qPhysuudd2312)*sup2*A22 + + sup1*((dchi1*qPhysuudd1212 - dchi2*qPhysuudd2212)*A12 + + (dchi1*qPhysuudd1312 - dchi2*qPhysuudd2312)*A13 + + dchi1*qPhysuudd2212*A22) - + (dchi3*qPhysuudd3312*sup2 + dchi1*qPhysuudd1212*sup3)* + A23 + ((-(dchi1*qPhysuudd1312) + dchi2*qPhysuudd2312)* + sup2 + (-(dchi2*qPhysuudd2212) + dchi3*qPhysuudd2312)*sup3\ +)*A23 + qPhysuudd3312*(dchi1*sup1 + dchi2*sup2)*A33 - + sup3*((dchi1*qPhysuudd1112 + dchi2*qPhysuudd1212)*A13 + + (dchi1*qPhysuudd1312 + dchi2*qPhysuudd2312)*A33)))/ + chi) - cdda11*qPhysuudd1112*chi + + qPhysuudd1212*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + + (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + + qPhysuudd1312*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + + qPhysuudd2212*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + + cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + + qPhysuudd2312*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* + alpha - cdda23*chi) + + qPhysuudd3312*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - + cdda33*chi) - qPhysuudd1212* + ((AA12 + AA21)*alpha + dda12*chi) - + qPhysuudd1312*(alpha*(AA13 + AA31 + + (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - + qPhysuudd2312*((AA23 + AA32)*alpha + dda23*chi) +; + +rACABTF13 += +2.*(lieA12*qPhysuudd1213 + lieA13*qPhysuudd1313 + + qPhysuudd2313*(lieA23 - cdA123*sup1*alpha)) + + qPhysuudd1113*(lieA11 + alpha* + (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ ++ alpha*(qPhysuudd1113*(cdA113*sup3 + + 0.66666666666666666667*K*A11) + + 1.3333333333333333333*K*(qPhysuudd1213*A12 + + qPhysuudd1313*A13 + qPhysuudd2313*A23) + + qPhysuudd3313*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + + sup3*(cdA123*qPhysuudd1213 + + qPhysuudd1113*(-cdA311 + (0.5*dchi3*A11)/chi)) + + qPhysuudd2213*A22*(0.66666666666666666667*K + + (0.5*dchi3*sup3)/chi) + + sup2*(-2.*cdA213*qPhysuudd1313 - cdA223*qPhysuudd2313 + + cdA322*qPhysuudd2313 + cdA323*qPhysuudd3313 + + (0.5*dchi2*qPhysuudd1113*A11)/chi) + + (dchi3*(-0.5*qPhysuudd1313*sup2 + qPhysuudd1213*sup3)*A12 + + (-0.5*dchi3*qPhysuudd3313*sup1 + dchi2*qPhysuudd1313*sup2)* + A13 + sup1*(-0.5*dchi2*qPhysuudd1213*A11 + + dchi1*qPhysuudd2313*A23) + + 0.5*((-(dchi3*qPhysuudd2313*sup1) + dchi2*qPhysuudd1213*sup2)* + A12 + dchi3*qPhysuudd1313*sup3*A13 - + (dchi1*qPhysuudd1213 + dchi3*qPhysuudd2313)*sup2*A22 + + sup1*((dchi1*qPhysuudd1213 - dchi2*qPhysuudd2213)*A12 + + (dchi1*qPhysuudd1313 - dchi2*qPhysuudd2313)*A13 + + dchi1*qPhysuudd2213*A22) - + (dchi3*qPhysuudd3313*sup2 + dchi1*qPhysuudd1213*sup3)* + A23 + ((-(dchi1*qPhysuudd1313) + dchi2*qPhysuudd2313)* + sup2 + (-(dchi2*qPhysuudd2213) + dchi3*qPhysuudd2313)*sup3\ +)*A23 + qPhysuudd3313*(dchi1*sup1 + dchi2*sup2)*A33 - + sup3*((dchi1*qPhysuudd1113 + dchi2*qPhysuudd1213)*A13 + + (dchi1*qPhysuudd1313 + dchi2*qPhysuudd2313)*A33)))/ + chi) - cdda11*qPhysuudd1113*chi + + qPhysuudd1213*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + + (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + + qPhysuudd1313*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + + qPhysuudd2213*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + + cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + + qPhysuudd2313*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* + alpha - cdda23*chi) + + qPhysuudd3313*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - + cdda33*chi) - qPhysuudd1213* + ((AA12 + AA21)*alpha + dda12*chi) - + qPhysuudd1313*(alpha*(AA13 + AA31 + + (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - + qPhysuudd2313*((AA23 + AA32)*alpha + dda23*chi) +; + +rACABTF22 += +2.*(lieA12*qPhysuudd1222 + lieA13*qPhysuudd1322 + + qPhysuudd2322*(lieA23 - cdA123*sup1*alpha)) + + qPhysuudd1122*(lieA11 + alpha* + (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ ++ alpha*(qPhysuudd1122*(cdA113*sup3 + + 0.66666666666666666667*K*A11) + + 1.3333333333333333333*K*(qPhysuudd1222*A12 + + qPhysuudd1322*A13 + qPhysuudd2322*A23) + + qPhysuudd3322*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + + sup3*(cdA123*qPhysuudd1222 + + qPhysuudd1122*(-cdA311 + (0.5*dchi3*A11)/chi)) + + qPhysuudd2222*A22*(0.66666666666666666667*K + + (0.5*dchi3*sup3)/chi) + + sup2*(-2.*cdA213*qPhysuudd1322 - cdA223*qPhysuudd2322 + + cdA322*qPhysuudd2322 + cdA323*qPhysuudd3322 + + (0.5*dchi2*qPhysuudd1122*A11)/chi) + + (dchi3*(-0.5*qPhysuudd1322*sup2 + qPhysuudd1222*sup3)*A12 + + (-0.5*dchi3*qPhysuudd3322*sup1 + dchi2*qPhysuudd1322*sup2)* + A13 + sup1*(-0.5*dchi2*qPhysuudd1222*A11 + + dchi1*qPhysuudd2322*A23) + + 0.5*((-(dchi3*qPhysuudd2322*sup1) + dchi2*qPhysuudd1222*sup2)* + A12 + dchi3*qPhysuudd1322*sup3*A13 - + (dchi1*qPhysuudd1222 + dchi3*qPhysuudd2322)*sup2*A22 + + sup1*((dchi1*qPhysuudd1222 - dchi2*qPhysuudd2222)*A12 + + (dchi1*qPhysuudd1322 - dchi2*qPhysuudd2322)*A13 + + dchi1*qPhysuudd2222*A22) - + (dchi3*qPhysuudd3322*sup2 + dchi1*qPhysuudd1222*sup3)* + A23 + ((-(dchi1*qPhysuudd1322) + dchi2*qPhysuudd2322)* + sup2 + (-(dchi2*qPhysuudd2222) + dchi3*qPhysuudd2322)*sup3\ +)*A23 + qPhysuudd3322*(dchi1*sup1 + dchi2*sup2)*A33 - + sup3*((dchi1*qPhysuudd1122 + dchi2*qPhysuudd1222)*A13 + + (dchi1*qPhysuudd1322 + dchi2*qPhysuudd2322)*A33)))/ + chi) - cdda11*qPhysuudd1122*chi + + qPhysuudd1222*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + + (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + + qPhysuudd1322*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + + qPhysuudd2222*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + + cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + + qPhysuudd2322*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* + alpha - cdda23*chi) + + qPhysuudd3322*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - + cdda33*chi) - qPhysuudd1222* + ((AA12 + AA21)*alpha + dda12*chi) - + qPhysuudd1322*(alpha*(AA13 + AA31 + + (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - + qPhysuudd2322*((AA23 + AA32)*alpha + dda23*chi) +; + +rACABTF23 += +2.*(lieA12*qPhysuudd1223 + lieA13*qPhysuudd1323 + + qPhysuudd2323*(lieA23 - cdA123*sup1*alpha)) + + qPhysuudd1123*(lieA11 + alpha* + (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ ++ alpha*(qPhysuudd1123*(cdA113*sup3 + + 0.66666666666666666667*K*A11) + + 1.3333333333333333333*K*(qPhysuudd1223*A12 + + qPhysuudd1323*A13 + qPhysuudd2323*A23) + + qPhysuudd3323*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + + sup3*(cdA123*qPhysuudd1223 + + qPhysuudd1123*(-cdA311 + (0.5*dchi3*A11)/chi)) + + qPhysuudd2223*A22*(0.66666666666666666667*K + + (0.5*dchi3*sup3)/chi) + + sup2*(-2.*cdA213*qPhysuudd1323 - cdA223*qPhysuudd2323 + + cdA322*qPhysuudd2323 + cdA323*qPhysuudd3323 + + (0.5*dchi2*qPhysuudd1123*A11)/chi) + + (dchi3*(-0.5*qPhysuudd1323*sup2 + qPhysuudd1223*sup3)*A12 + + (-0.5*dchi3*qPhysuudd3323*sup1 + dchi2*qPhysuudd1323*sup2)* + A13 + sup1*(-0.5*dchi2*qPhysuudd1223*A11 + + dchi1*qPhysuudd2323*A23) + + 0.5*((-(dchi3*qPhysuudd2323*sup1) + dchi2*qPhysuudd1223*sup2)* + A12 + dchi3*qPhysuudd1323*sup3*A13 - + (dchi1*qPhysuudd1223 + dchi3*qPhysuudd2323)*sup2*A22 + + sup1*((dchi1*qPhysuudd1223 - dchi2*qPhysuudd2223)*A12 + + (dchi1*qPhysuudd1323 - dchi2*qPhysuudd2323)*A13 + + dchi1*qPhysuudd2223*A22) - + (dchi3*qPhysuudd3323*sup2 + dchi1*qPhysuudd1223*sup3)* + A23 + ((-(dchi1*qPhysuudd1323) + dchi2*qPhysuudd2323)* + sup2 + (-(dchi2*qPhysuudd2223) + dchi3*qPhysuudd2323)*sup3\ +)*A23 + qPhysuudd3323*(dchi1*sup1 + dchi2*sup2)*A33 - + sup3*((dchi1*qPhysuudd1123 + dchi2*qPhysuudd1223)*A13 + + (dchi1*qPhysuudd1323 + dchi2*qPhysuudd2323)*A33)))/ + chi) - cdda11*qPhysuudd1123*chi + + qPhysuudd1223*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + + (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + + qPhysuudd1323*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + + qPhysuudd2223*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + + cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + + qPhysuudd2323*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* + alpha - cdda23*chi) + + qPhysuudd3323*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - + cdda33*chi) - qPhysuudd1223* + ((AA12 + AA21)*alpha + dda12*chi) - + qPhysuudd1323*(alpha*(AA13 + AA31 + + (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - + qPhysuudd2323*((AA23 + AA32)*alpha + dda23*chi) +; + +rACABTF33 += +2.*(lieA12*qPhysuudd1233 + lieA13*qPhysuudd1333 + + qPhysuudd2333*(lieA23 - cdA123*sup1*alpha)) + + qPhysuudd1133*(lieA11 + alpha* + (-AA11 - cdA211*sup2 + sup2*(cdA112 - (0.5*dchi1*A12)/chi))) \ ++ alpha*(qPhysuudd1133*(cdA113*sup3 + + 0.66666666666666666667*K*A11) + + 1.3333333333333333333*K*(qPhysuudd1233*A12 + + qPhysuudd1333*A13 + qPhysuudd2333*A23) + + qPhysuudd3333*(-(cdA233*sup2) + 0.66666666666666666667*K*A33) + + sup3*(cdA123*qPhysuudd1233 + + qPhysuudd1133*(-cdA311 + (0.5*dchi3*A11)/chi)) + + qPhysuudd2233*A22*(0.66666666666666666667*K + + (0.5*dchi3*sup3)/chi) + + sup2*(-2.*cdA213*qPhysuudd1333 - cdA223*qPhysuudd2333 + + cdA322*qPhysuudd2333 + cdA323*qPhysuudd3333 + + (0.5*dchi2*qPhysuudd1133*A11)/chi) + + (dchi3*(-0.5*qPhysuudd1333*sup2 + qPhysuudd1233*sup3)*A12 + + (-0.5*dchi3*qPhysuudd3333*sup1 + dchi2*qPhysuudd1333*sup2)* + A13 + sup1*(-0.5*dchi2*qPhysuudd1233*A11 + + dchi1*qPhysuudd2333*A23) + + 0.5*((-(dchi3*qPhysuudd2333*sup1) + dchi2*qPhysuudd1233*sup2)* + A12 + dchi3*qPhysuudd1333*sup3*A13 - + (dchi1*qPhysuudd1233 + dchi3*qPhysuudd2333)*sup2*A22 + + sup1*((dchi1*qPhysuudd1233 - dchi2*qPhysuudd2233)*A12 + + (dchi1*qPhysuudd1333 - dchi2*qPhysuudd2333)*A13 + + dchi1*qPhysuudd2233*A22) - + (dchi3*qPhysuudd3333*sup2 + dchi1*qPhysuudd1233*sup3)* + A23 + ((-(dchi1*qPhysuudd1333) + dchi2*qPhysuudd2333)* + sup2 + (-(dchi2*qPhysuudd2233) + dchi3*qPhysuudd2333)*sup3\ +)*A23 + qPhysuudd3333*(dchi1*sup1 + dchi2*sup2)*A33 - + sup3*((dchi1*qPhysuudd1133 + dchi2*qPhysuudd1233)*A13 + + (dchi1*qPhysuudd1333 + dchi2*qPhysuudd2333)*A33)))/ + chi) - cdda11*qPhysuudd1133*chi + + qPhysuudd1233*(((-cdA112 + cdA211)*sup1 + (cdA122 - cdA212)*sup2 + + (cdA213 - 2.*cdA312)*sup3)*alpha - cdda12*chi) + + qPhysuudd1333*(((-cdA113 + cdA311)*sup1 + (cdA123 + cdA312)*sup2 + + (cdA133 - cdA313)*sup3)*alpha - cdda13*chi) + + qPhysuudd2233*(lieA22 + (-AA22 - cdA122*sup1 + cdA212*sup1 + + cdA223*sup3 - cdA322*sup3)*alpha - cdda22*chi) + + qPhysuudd2333*(((cdA213 + cdA312)*sup1 + (cdA233 - cdA323)*sup3)* + alpha - cdda23*chi) + + qPhysuudd3333*(lieA33 + (-AA33 - cdA133*sup1 + cdA313*sup1)*alpha - + cdda33*chi) - qPhysuudd1233* + ((AA12 + AA21)*alpha + dda12*chi) - + qPhysuudd1333*(alpha*(AA13 + AA31 + + (0.5*dchi3*sup1*A11)/chi) + dda13*chi) - + qPhysuudd2333*((AA23 + AA32)*alpha + dda23*chi) +; + + +if (givehPsi0) { + +gADM11 += +g11/chi +; + +gADM12 += +g12/chi +; + +gADM13 += +g13/chi +; + +gADM21 += +g12/chi +; + +gADM22 += +g22/chi +; + +gADM23 += +g23/chi +; + +gADM31 += +g13/chi +; + +gADM32 += +g23/chi +; + +gADM33 += +g33/chi +; + +vu1 += +-yp +; + +vu2 += +xp +; + +vu3 += +0 +; + +wu1 += +((-(ADMginv13*sup2) + ADMginv12*sup3)*vu1 + + (ADMginv13*sup1 - ADMginv11*sup3)*vu2 + + (-(ADMginv12*sup1) + ADMginv11*sup2)*vu3)/Power(chi,1.5) +; + +wu2 += +((-(ADMginv23*sup2) + ADMginv22*sup3)*vu1 + + (ADMginv23*sup1 - ADMginv12*sup3)*vu2 + + (-(ADMginv22*sup1) + ADMginv12*sup2)*vu3)/Power(chi,1.5) +; + +wu3 += +((-(ADMginv33*sup2) + ADMginv23*sup3)*vu1 + + (ADMginv33*sup1 - ADMginv13*sup3)*vu2 + + (-(ADMginv23*sup1) + ADMginv13*sup2)*vu3)/Power(chi,1.5) +; + +sdotv += +(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*vu1 + + (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*vu2 + + (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*vu3 +; + +vu1 += +-(sdotv*sup1) + vu1 +; + +vu2 += +-(sdotv*sup2) + vu2 +; + +vu3 += +-(sdotv*sup3) + vu3 +; + +vdotv += +(gADM31*vu1 + (gADM23 + gADM32)*vu2)*vu3 + + vu1*((gADM12 + gADM21)*vu2 + gADM13*vu3) + gADM11*pow2(vu1) + + gADM22*pow2(vu2) + gADM33*pow2(vu3) +; + +vu1 += +vu1/Sqrt(vdotv) +; + +vu2 += +vu2/Sqrt(vdotv) +; + +vu3 += +vu3/Sqrt(vdotv) +; + +sdotw += +(gADM11*sup1 + gADM21*sup2 + gADM31*sup3)*wu1 + + (gADM12*sup1 + gADM22*sup2 + gADM32*sup3)*wu2 + + (gADM13*sup1 + gADM23*sup2 + gADM33*sup3)*wu3 +; + +vdotw += +(gADM11*vu1 + gADM21*vu2 + gADM31*vu3)*wu1 + + (gADM12*vu1 + gADM22*vu2 + gADM32*vu3)*wu2 + + (gADM13*vu1 + gADM23*vu2 + gADM33*vu3)*wu3 +; + +wu1 += +-(sdotw*sup1) - vdotw*vu1 + wu1 +; + +wu2 += +-(sdotw*sup2) - vdotw*vu2 + wu2 +; + +wu3 += +-(sdotw*sup3) - vdotw*vu3 + wu3 +; + +wdotw += +(gADM31*wu1 + (gADM23 + gADM32)*wu2)*wu3 + + wu1*((gADM12 + gADM21)*wu2 + gADM13*wu3) + gADM11*pow2(wu1) + + gADM22*pow2(wu2) + gADM33*pow2(wu3) +; + +wu1 += +wu1/Sqrt(wdotw) +; + +wu2 += +wu2/Sqrt(wdotw) +; + +wu3 += +wu3/Sqrt(wdotw) +; + +vd1 += +gADM11*vu1 + gADM12*vu2 + gADM13*vu3 +; + +vd2 += +gADM21*vu1 + gADM22*vu2 + gADM23*vu3 +; + +vd3 += +gADM31*vu1 + gADM32*vu2 + gADM33*vu3 +; + +wd1 += +gADM11*wu1 + gADM12*wu2 + gADM13*wu3 +; + +wd2 += +gADM21*wu1 + gADM22*wu2 + gADM23*wu3 +; + +wd3 += +gADM31*wu1 + gADM32*wu2 + gADM33*wu3 +; + +RehPsi0 += +Power(2.7182818284590452354,pow2(hPsi0parb)* + (2.*hPsi0parc*time - pow2(hPsi0parc) - pow2(time)))*hPsi0para +; + +ImhPsi0 += +0 +; + +rACABTF11 += +rACABTF11 + alpha*chi* + (2.*ImhPsi0*vd1*wd1 + RehPsi0*(pow2(vd1) - pow2(wd1))) +; + +rACABTF12 += +rACABTF12 + (vd2*(RehPsi0*vd1 + ImhPsi0*wd1) + + (ImhPsi0*vd1 - RehPsi0*wd1)*wd2)*alpha*chi +; + +rACABTF13 += +rACABTF13 + (vd3*(RehPsi0*vd1 + ImhPsi0*wd1) + + (ImhPsi0*vd1 - RehPsi0*wd1)*wd3)*alpha*chi +; + +rACABTF22 += +rACABTF22 + alpha*chi* + (2.*ImhPsi0*vd2*wd2 + RehPsi0*(pow2(vd2) - pow2(wd2))) +; + +rACABTF23 += +rACABTF23 + (vd3*(RehPsi0*vd2 + ImhPsi0*wd2) + + (ImhPsi0*vd2 - RehPsi0*wd2)*wd3)*alpha*chi +; + +rACABTF33 += +rACABTF33 + alpha*chi* + (2.*ImhPsi0*vd3*wd3 + RehPsi0*(pow2(vd3) - pow2(wd3))) +; + + + } + +rA11 += +rACABTF11 + 0.5*qdd11*rACqq + 2.* + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)*sdown1 + rACss*pow2(sdown1) +; + +rA12 += +rACABTF12 + 0.5*qdd12*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* + sdown2 + sdown1*(qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3 + + rACss*sdown2) +; + +rA13 += +rACABTF13 + 0.5*qdd13*rACqq + (qud11*rACsA1 + qud21*rACsA2 + qud31*rACsA3)* + sdown3 + sdown1*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + + rACss*sdown3) +; + +rA22 += +rACABTF22 + 0.5*qdd22*rACqq + 2.* + (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)*sdown2 + rACss*pow2(sdown2) +; + +rA23 += +rACABTF23 + 0.5*qdd23*rACqq + (qud12*rACsA1 + qud22*rACsA2 + qud32*rACsA3)* + sdown3 + sdown2*(qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3 + + rACss*sdown3) +; + +rA33 += +rACABTF33 + 0.5*qdd33*rACqq + 2.* + (qud13*rACsA1 + qud23*rACsA2 + qud33*rACsA3)*sdown3 + rACss*pow2(sdown3) +; + +rG1 += +qud11*rGamA1 + qud12*rGamA2 + qud13*rGamA3 + rGams*sup1 +; + +rG2 += +qud21*rGamA1 + qud22*rGamA2 + qud23*rGamA3 + rGams*sup2 +; + +rG3 += +qud31*rGamA1 + qud32*rGamA2 + qud33*rGamA3 + rGams*sup3 +; + +#if 0 +rG1 -= kappa1*(G1-Gfromg1); +rG2 -= kappa1*(G2-Gfromg2); +rG3 -= kappa1*(G3-Gfromg3); + +rA11 -= kappa1*A11/r; +rA12 -= kappa1*A12/r; +rA13 -= kappa1*A13/r; +rA22 -= kappa1*A22/r; +rA23 -= kappa1*A23/r; +rA33 -= kappa1*A33/r; +#endif + +#endif +} /* function */ +// f and tof are uper index +#ifdef fortran1 +void decompose2p1_1 +#endif +#ifdef fortran2 +void DECOMPOSE2P1_1 +#endif +#ifdef fortran3 +void decompose2p1_1_ +#endif +(double & r,double & xp,double & yp,double & zp,double & chi, + double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, + double & f1,double & f2,double & f3,double & tofs,double & tof1,double & tof2,double & tof3) +{ +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double modshatARG; +double oomodshat; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +tofs += +f1*sdown1 + f2*sdown2 + f3*sdown3 +; + +tof1 += +f1*qud11 + f2*qud12 + f3*qud13 +; + +tof2 += +f1*qud21 + f2*qud22 + f3*qud23 +; + +tof3 += +f1*qud31 + f2*qud32 + f3*qud33 +; +} /* function */ +// f and tof are lower index +#ifdef fortran1 +void decompose2p1_2 +#endif +#ifdef fortran2 +void DECOMPOSE2P1_2 +#endif +#ifdef fortran3 +void decompose2p1_2_ +#endif +(double & r,double & xp,double & yp,double & zp,double & chi, + double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, + double & f11,double & f12,double & f13,double & f22,double & f23,double & f33, + double & tofqq,double & tofss,double & tofs1,double & tofs2,double & tofs3, + double & tof11,double & tof12,double & tof13,double & tof22,double & tof23,double & tof33) +{ +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double modshatARG; +double oomodshat; +double qdd11; +double qdd12; +double qdd13; +double qdd22; +double qdd23; +double qdd33; +double qPhysuudd1111; +double qPhysuudd1112; +double qPhysuudd1113; +double qPhysuudd1122; +double qPhysuudd1123; +double qPhysuudd1133; +double qPhysuudd1211; +double qPhysuudd1212; +double qPhysuudd1213; +double qPhysuudd1222; +double qPhysuudd1223; +double qPhysuudd1233; +double qPhysuudd1311; +double qPhysuudd1312; +double qPhysuudd1313; +double qPhysuudd1322; +double qPhysuudd1323; +double qPhysuudd1333; +double qPhysuudd2211; +double qPhysuudd2212; +double qPhysuudd2213; +double qPhysuudd2222; +double qPhysuudd2223; +double qPhysuudd2233; +double qPhysuudd2311; +double qPhysuudd2312; +double qPhysuudd2313; +double qPhysuudd2322; +double qPhysuudd2323; +double qPhysuudd2333; +double qPhysuudd3311; +double qPhysuudd3312; +double qPhysuudd3313; +double qPhysuudd3322; +double qPhysuudd3323; +double qPhysuudd3333; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double quu11; +double quu12; +double quu13; +double quu22; +double quu23; +double quu33; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +qdd11 += +g11/chi - pow2(sdown1) +; + +qdd12 += +g12/chi - sdown1*sdown2 +; + +qdd13 += +g13/chi - sdown1*sdown3 +; + +qdd22 += +g22/chi - pow2(sdown2) +; + +qdd23 += +g23/chi - sdown2*sdown3 +; + +qdd33 += +g33/chi - pow2(sdown3) +; + +quu11 += +ADMginv11 - pow2(sup1) +; + +quu12 += +ADMginv12 - sup1*sup2 +; + +quu13 += +ADMginv13 - sup1*sup3 +; + +quu22 += +ADMginv22 - pow2(sup2) +; + +quu23 += +ADMginv23 - sup2*sup3 +; + +quu33 += +ADMginv33 - pow2(sup3) +; + +qPhysuudd1111 += +-0.5*qdd11*quu11 + pow2(qud11) +; + +qPhysuudd1112 += +qud11*qud12 - 0.5*qdd12*quu11 +; + +qPhysuudd1113 += +qud11*qud13 - 0.5*qdd13*quu11 +; + +qPhysuudd1122 += +-0.5*qdd22*quu11 + pow2(qud12) +; + +qPhysuudd1123 += +qud12*qud13 - 0.5*qdd23*quu11 +; + +qPhysuudd1133 += +-0.5*qdd33*quu11 + pow2(qud13) +; + +qPhysuudd1211 += +qud11*qud21 - 0.5*qdd11*quu12 +; + +qPhysuudd1212 += +0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) +; + +qPhysuudd1213 += +0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) +; + +qPhysuudd1222 += +qud12*qud22 - 0.5*qdd22*quu12 +; + +qPhysuudd1223 += +0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) +; + +qPhysuudd1233 += +qud13*qud23 - 0.5*qdd33*quu12 +; + +qPhysuudd1311 += +qud11*qud31 - 0.5*qdd11*quu13 +; + +qPhysuudd1312 += +0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) +; + +qPhysuudd1313 += +0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) +; + +qPhysuudd1322 += +qud12*qud32 - 0.5*qdd22*quu13 +; + +qPhysuudd1323 += +0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) +; + +qPhysuudd1333 += +qud13*qud33 - 0.5*qdd33*quu13 +; + +qPhysuudd2211 += +-0.5*qdd11*quu22 + pow2(qud21) +; + +qPhysuudd2212 += +qud21*qud22 - 0.5*qdd12*quu22 +; + +qPhysuudd2213 += +qud21*qud23 - 0.5*qdd13*quu22 +; + +qPhysuudd2222 += +-0.5*qdd22*quu22 + pow2(qud22) +; + +qPhysuudd2223 += +qud22*qud23 - 0.5*qdd23*quu22 +; + +qPhysuudd2233 += +-0.5*qdd33*quu22 + pow2(qud23) +; + +qPhysuudd2311 += +qud21*qud31 - 0.5*qdd11*quu23 +; + +qPhysuudd2312 += +0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) +; + +qPhysuudd2313 += +0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) +; + +qPhysuudd2322 += +qud22*qud32 - 0.5*qdd22*quu23 +; + +qPhysuudd2323 += +0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) +; + +qPhysuudd2333 += +qud23*qud33 - 0.5*qdd33*quu23 +; + +qPhysuudd3311 += +-0.5*qdd11*quu33 + pow2(qud31) +; + +qPhysuudd3312 += +qud31*qud32 - 0.5*qdd12*quu33 +; + +qPhysuudd3313 += +qud31*qud33 - 0.5*qdd13*quu33 +; + +qPhysuudd3322 += +-0.5*qdd22*quu33 + pow2(qud32) +; + +qPhysuudd3323 += +qud32*qud33 - 0.5*qdd23*quu33 +; + +qPhysuudd3333 += +-0.5*qdd33*quu33 + pow2(qud33) +; + +tofss += +2.*(f23*sup2*sup3 + sup1*(f12*sup2 + f13*sup3)) + f11*pow2(sup1) + + f22*pow2(sup2) + f33*pow2(sup3) +; + +tofqq += +f12*quu12 + f13*quu13 + f23*quu23 + 0.5*(f11*quu11 + f22*quu22 + f33*quu33) +; + +tofs1 += +(f11*qud11 + f12*qud21 + f13*qud31)*sup1 + + (f12*qud11 + f22*qud21 + f23*qud31)*sup2 + + (f13*qud11 + f23*qud21 + f33*qud31)*sup3 +; + +tofs2 += +(f11*qud12 + f12*qud22 + f13*qud32)*sup1 + + (f12*qud12 + f22*qud22 + f23*qud32)*sup2 + + (f13*qud12 + f23*qud22 + f33*qud32)*sup3 +; + +tofs3 += +(f11*qud13 + f12*qud23 + f13*qud33)*sup1 + + (f12*qud13 + f22*qud23 + f23*qud33)*sup2 + + (f13*qud13 + f23*qud23 + f33*qud33)*sup3 +; + +tof11 += +f11*qPhysuudd1111 + f22*qPhysuudd2211 + + 2.*(f12*qPhysuudd1211 + f13*qPhysuudd1311 + f23*qPhysuudd2311) + + f33*qPhysuudd3311 +; + +tof12 += +f11*qPhysuudd1112 + f22*qPhysuudd2212 + + 2.*(f12*qPhysuudd1212 + f13*qPhysuudd1312 + f23*qPhysuudd2312) + + f33*qPhysuudd3312 +; + +tof13 += +f11*qPhysuudd1113 + f22*qPhysuudd2213 + + 2.*(f12*qPhysuudd1213 + f13*qPhysuudd1313 + f23*qPhysuudd2313) + + f33*qPhysuudd3313 +; + +tof22 += +f11*qPhysuudd1122 + f22*qPhysuudd2222 + + 2.*(f12*qPhysuudd1222 + f13*qPhysuudd1322 + f23*qPhysuudd2322) + + f33*qPhysuudd3322 +; + +tof23 += +f11*qPhysuudd1123 + f22*qPhysuudd2223 + + 2.*(f12*qPhysuudd1223 + f13*qPhysuudd1323 + f23*qPhysuudd2323) + + f33*qPhysuudd3323 +; + +tof33 += +f11*qPhysuudd1133 + f22*qPhysuudd2233 + + 2.*(f12*qPhysuudd1233 + f13*qPhysuudd1333 + f23*qPhysuudd2333) + + f33*qPhysuudd3333 +; +} /*function */ +// f and tof are uper index +#ifdef fortran1 +void compose2p1_1 +#endif +#ifdef fortran2 +void COMPOSE2P1_1 +#endif +#ifdef fortran3 +void compose2p1_1_ +#endif +(double & r,double & xp,double & yp,double & zp,double & chi, + double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, + double & f1,double & f2,double & f3,double & tofs,double & tof1,double & tof2,double & tof3) +{ +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double modshatARG; +double oomodshat; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +f1 += +qud11*tof1 + qud12*tof2 + qud13*tof3 + sup1*tofs +; + +f2 += +qud21*tof1 + qud22*tof2 + qud23*tof3 + sup2*tofs +; + +f3 += +qud31*tof1 + qud32*tof2 + qud33*tof3 + sup3*tofs +; +} /* function */ +// f and tof are lower index +#ifdef fortran1 +void compose2p1_2 +#endif +#ifdef fortran2 +void COMPOSE2P1_2 +#endif +#ifdef fortran3 +void compose2p1_2_ +#endif +(double & r,double & xp,double & yp,double & zp,double & chi, + double & g11,double & g12,double & g13,double & g22,double & g23,double & g33, + double & f11,double & f12,double & f13,double & f22,double & f23,double & f33, + double & tofqq,double & tofss,double & tofs1,double & tofs2,double & tofs3, + double & tof11,double & tof12,double & tof13,double & tof22,double & tof23,double & tof33) +{ +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double modshatARG; +double oomodshat; +double qdd11; +double qdd12; +double qdd13; +double qdd22; +double qdd23; +double qdd33; +double qPhysuudd1111; +double qPhysuudd1112; +double qPhysuudd1113; +double qPhysuudd1122; +double qPhysuudd1123; +double qPhysuudd1133; +double qPhysuudd1211; +double qPhysuudd1212; +double qPhysuudd1213; +double qPhysuudd1222; +double qPhysuudd1223; +double qPhysuudd1233; +double qPhysuudd1311; +double qPhysuudd1312; +double qPhysuudd1313; +double qPhysuudd1322; +double qPhysuudd1323; +double qPhysuudd1333; +double qPhysuudd2211; +double qPhysuudd2212; +double qPhysuudd2213; +double qPhysuudd2222; +double qPhysuudd2223; +double qPhysuudd2233; +double qPhysuudd2311; +double qPhysuudd2312; +double qPhysuudd2313; +double qPhysuudd2322; +double qPhysuudd2323; +double qPhysuudd2333; +double qPhysuudd3311; +double qPhysuudd3312; +double qPhysuudd3313; +double qPhysuudd3322; +double qPhysuudd3323; +double qPhysuudd3333; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double quu11; +double quu12; +double quu13; +double quu22; +double quu23; +double quu33; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; + + + +shat1 += +0 +; + +shat2 += +0 +; + +shat3 += +0 +; + + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +qdd11 += +g11/chi - pow2(sdown1) +; + +qdd12 += +g12/chi - sdown1*sdown2 +; + +qdd13 += +g13/chi - sdown1*sdown3 +; + +qdd22 += +g22/chi - pow2(sdown2) +; + +qdd23 += +g23/chi - sdown2*sdown3 +; + +qdd33 += +g33/chi - pow2(sdown3) +; + +quu11 += +ADMginv11 - pow2(sup1) +; + +quu12 += +ADMginv12 - sup1*sup2 +; + +quu13 += +ADMginv13 - sup1*sup3 +; + +quu22 += +ADMginv22 - pow2(sup2) +; + +quu23 += +ADMginv23 - sup2*sup3 +; + +quu33 += +ADMginv33 - pow2(sup3) +; + +qPhysuudd1111 += +-0.5*qdd11*quu11 + pow2(qud11) +; + +qPhysuudd1112 += +qud11*qud12 - 0.5*qdd12*quu11 +; + +qPhysuudd1113 += +qud11*qud13 - 0.5*qdd13*quu11 +; + +qPhysuudd1122 += +-0.5*qdd22*quu11 + pow2(qud12) +; + +qPhysuudd1123 += +qud12*qud13 - 0.5*qdd23*quu11 +; + +qPhysuudd1133 += +-0.5*qdd33*quu11 + pow2(qud13) +; + +qPhysuudd1211 += +qud11*qud21 - 0.5*qdd11*quu12 +; + +qPhysuudd1212 += +0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) +; + +qPhysuudd1213 += +0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) +; + +qPhysuudd1222 += +qud12*qud22 - 0.5*qdd22*quu12 +; + +qPhysuudd1223 += +0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) +; + +qPhysuudd1233 += +qud13*qud23 - 0.5*qdd33*quu12 +; + +qPhysuudd1311 += +qud11*qud31 - 0.5*qdd11*quu13 +; + +qPhysuudd1312 += +0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) +; + +qPhysuudd1313 += +0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) +; + +qPhysuudd1322 += +qud12*qud32 - 0.5*qdd22*quu13 +; + +qPhysuudd1323 += +0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) +; + +qPhysuudd1333 += +qud13*qud33 - 0.5*qdd33*quu13 +; + +qPhysuudd2211 += +-0.5*qdd11*quu22 + pow2(qud21) +; + +qPhysuudd2212 += +qud21*qud22 - 0.5*qdd12*quu22 +; + +qPhysuudd2213 += +qud21*qud23 - 0.5*qdd13*quu22 +; + +qPhysuudd2222 += +-0.5*qdd22*quu22 + pow2(qud22) +; + +qPhysuudd2223 += +qud22*qud23 - 0.5*qdd23*quu22 +; + +qPhysuudd2233 += +-0.5*qdd33*quu22 + pow2(qud23) +; + +qPhysuudd2311 += +qud21*qud31 - 0.5*qdd11*quu23 +; + +qPhysuudd2312 += +0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) +; + +qPhysuudd2313 += +0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) +; + +qPhysuudd2322 += +qud22*qud32 - 0.5*qdd22*quu23 +; + +qPhysuudd2323 += +0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) +; + +qPhysuudd2333 += +qud23*qud33 - 0.5*qdd33*quu23 +; + +qPhysuudd3311 += +-0.5*qdd11*quu33 + pow2(qud31) +; + +qPhysuudd3312 += +qud31*qud32 - 0.5*qdd12*quu33 +; + +qPhysuudd3313 += +qud31*qud33 - 0.5*qdd13*quu33 +; + +qPhysuudd3322 += +-0.5*qdd22*quu33 + pow2(qud32) +; + +qPhysuudd3323 += +qud32*qud33 - 0.5*qdd23*quu33 +; + +qPhysuudd3333 += +-0.5*qdd33*quu33 + pow2(qud33) +; + +// my equations +#if 0 +f11 += +qPhysuudd1111*tof11 + qPhysuudd2211*tof22 + + 2.*(qPhysuudd1211*tof12 + qPhysuudd1311*tof13 + qPhysuudd2311*tof23) + + qPhysuudd3311*tof33 + qdd11*tofqq + + 1.*sdown1*(qud11*tofs1 + qud21*tofs2 + qud31*tofs3) + tofss*pow2(sdown1) +; + +f12 += +qPhysuudd1112*tof11 + qPhysuudd2212*tof22 + + 2.*(qPhysuudd1212*tof12 + qPhysuudd1312*tof13 + qPhysuudd2312*tof23) + + qPhysuudd3312*tof33 + qdd12*tofqq + + 0.5*((qud12*sdown1 + qud11*sdown2)*tofs1 + + (qud22*sdown1 + qud21*sdown2)*tofs2 + + (qud32*sdown1 + qud31*sdown2)*tofs3) + sdown1*sdown2*tofss +; + +f13 += +qPhysuudd1113*tof11 + qPhysuudd2213*tof22 + + 2.*(qPhysuudd1213*tof12 + qPhysuudd1313*tof13 + qPhysuudd2313*tof23) + + qPhysuudd3313*tof33 + qdd13*tofqq + + 0.5*((qud13*sdown1 + qud11*sdown3)*tofs1 + + (qud23*sdown1 + qud21*sdown3)*tofs2 + + (qud33*sdown1 + qud31*sdown3)*tofs3) + sdown1*sdown3*tofss +; + +f22 += +qPhysuudd1122*tof11 + qPhysuudd2222*tof22 + + 2.*(qPhysuudd1222*tof12 + qPhysuudd1322*tof13 + qPhysuudd2322*tof23) + + qPhysuudd3322*tof33 + qdd22*tofqq + + 1.*sdown2*(qud12*tofs1 + qud22*tofs2 + qud32*tofs3) + tofss*pow2(sdown2) +; + +f23 += +qPhysuudd1123*tof11 + qPhysuudd2223*tof22 + + 2.*(qPhysuudd1223*tof12 + qPhysuudd1323*tof13 + qPhysuudd2323*tof23) + + qPhysuudd3323*tof33 + qdd23*tofqq + + 0.5*((qud13*sdown2 + qud12*sdown3)*tofs1 + + (qud23*sdown2 + qud22*sdown3)*tofs2 + + (qud33*sdown2 + qud32*sdown3)*tofs3) + sdown2*sdown3*tofss +; + +f33 += +qPhysuudd1133*tof11 + qPhysuudd2233*tof22 + + 2.*(qPhysuudd1233*tof12 + qPhysuudd1333*tof13 + qPhysuudd2333*tof23) + + qPhysuudd3333*tof33 + qdd33*tofqq + + 1.*sdown3*(qud13*tofs1 + qud23*tofs2 + qud33*tofs3) + tofss*pow2(sdown3) +; +// David's equations +#else +f11 += +tof11 + 0.5*qdd11*tofqq + 2.*sdown1* + (qud11*tofs1 + qud21*tofs2 + qud31*tofs3) + tofss*pow2(sdown1) +; + +f12 += +tof12 + 0.5*qdd12*tofqq + (qud12*sdown1 + qud11*sdown2)*tofs1 + + (qud22*sdown1 + qud21*sdown2)*tofs2 + + (qud32*sdown1 + qud31*sdown2)*tofs3 + sdown1*sdown2*tofss +; + +f13 += +tof13 + 0.5*qdd13*tofqq + (qud13*sdown1 + qud11*sdown3)*tofs1 + + (qud23*sdown1 + qud21*sdown3)*tofs2 + + (qud33*sdown1 + qud31*sdown3)*tofs3 + sdown1*sdown3*tofss +; + +f22 += +tof22 + 0.5*qdd22*tofqq + 2.*sdown2* + (qud12*tofs1 + qud22*tofs2 + qud32*tofs3) + tofss*pow2(sdown2) +; + +f23 += +tof23 + 0.5*qdd23*tofqq + (qud13*sdown2 + qud12*sdown3)*tofs1 + + (qud23*sdown2 + qud22*sdown3)*tofs2 + + (qud33*sdown2 + qud32*sdown3)*tofs3 + sdown2*sdown3*tofss +; + +f33 += +tof33 + 0.5*qdd33*tofqq + 2.*sdown3* + (qud13*tofs1 + qud23*tofs2 + qud33*tofs3) + tofss*pow2(sdown3) +; +#endif + +} /* function */ +#ifdef fortran1 +void racqq_point +#endif +#ifdef fortran2 +void RACQQ_POINT +#endif +#ifdef fortran3 +void racqq_point_ +#endif +(double &A11, +double &A12, +double &A13, +double &A22, +double &A23, +double &A33, +double &alpha, +double &beta1, +double &beta2, +double &beta3, +double &chi, +double &db11, +double &db12, +double &db13, +double &db21, +double &db22, +double &db23, +double &db31, +double &db32, +double &db33, +double &dg111, +double &dg112, +double &dg113, +double &dg122, +double &dg123, +double &dg133, +double &dg211, +double &dg212, +double &dg213, +double &dg222, +double &dg223, +double &dg233, +double &dg311, +double &dg312, +double &dg313, +double &dg322, +double &dg323, +double &dg333, +double &g11, +double &g12, +double &g13, +double &g22, +double &g23, +double &g33, +double &rACqq, +double &rACss) +{ + +double Ainv11; +double Ainv12; +double Ainv13; +double Ainv22; +double Ainv23; +double Ainv33; +double detginv; +double divbeta; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double lieg11; +double lieg12; +double lieg13; +double lieg22; +double lieg23; +double lieg33; +double totdivbeta; + + + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +divbeta += +db11 + db22 + db33 +; + +totdivbeta += +0.66666666666666666667*divbeta +; + +Ainv11 += +2.*(A23*ginv12*ginv13 + ginv11*(A12*ginv12 + A13*ginv13)) + + A11*pow2(ginv11) + A22*pow2(ginv12) + A33*pow2(ginv13) +; + +Ainv12 += +ginv11*(A11*ginv12 + A12*ginv22 + A13*ginv23) + + ginv12*(A13*ginv13 + A22*ginv22 + A23*ginv23) + + ginv13*(A23*ginv22 + A33*ginv23) + A12*pow2(ginv12) +; + +Ainv13 += +ginv11*(A11*ginv13 + A12*ginv23 + A13*ginv33) + + ginv12*(A12*ginv13 + A22*ginv23 + A23*ginv33) + + ginv13*(A23*ginv23 + A33*ginv33) + A13*pow2(ginv13) +; + +Ainv22 += +2.*(A23*ginv22*ginv23 + ginv12*(A12*ginv22 + A13*ginv23)) + + A11*pow2(ginv12) + A22*pow2(ginv22) + A33*pow2(ginv23) +; + +Ainv23 += +ginv13*(A12*ginv22 + A13*ginv23) + A33*ginv23*ginv33 + + ginv12*(A11*ginv13 + A12*ginv23 + A13*ginv33) + + ginv22*(A22*ginv23 + A23*ginv33) + A23*pow2(ginv23) +; + +Ainv33 += +2.*(A23*ginv23*ginv33 + ginv13*(A12*ginv23 + A13*ginv33)) + + A11*pow2(ginv13) + A22*pow2(ginv23) + A33*pow2(ginv33) +; + +lieg11 += +beta1*dg111 + beta2*dg211 + beta3*dg311 + + 2.*(db11*g11 + db12*g12 + db13*g13) - g11*totdivbeta +; + +lieg12 += +beta1*dg112 + beta2*dg212 + beta3*dg312 + db21*g11 + db23*g13 + db12*g22 + + db13*g23 + g12*(db11 + db22 - totdivbeta) +; + +lieg13 += +beta1*dg113 + beta2*dg213 + beta3*dg313 + db31*g11 + db32*g12 + db12*g23 + + db13*g33 + g13*(db11 + db33 - totdivbeta) +; + +lieg22 += +beta1*dg122 + beta2*dg222 + beta3*dg322 + + 2.*(db21*g12 + db22*g22 + db23*g23) - g22*totdivbeta +; + +lieg23 += +beta1*dg123 + beta2*dg223 + beta3*dg323 + db31*g12 + db21*g13 + db32*g22 + + db23*g33 + g23*(db22 + db33 - totdivbeta) +; + +lieg33 += +beta1*dg133 + beta2*dg233 + beta3*dg333 + + 2.*(db31*g13 + db32*g23 + db33*g33) - g33*totdivbeta +; + +rACqq += +chi*(-((4.*(A12*Ainv12 + A13*Ainv13 + A23*Ainv23) + + 2.*(A11*Ainv11 + A22*Ainv22 + A33*Ainv33))*alpha) + + Ainv11*lieg11 + Ainv22*lieg22 + + 2.*(Ainv12*lieg12 + Ainv13*lieg13 + Ainv23*lieg23) + Ainv33*lieg33) - + rACss +; + +} /* function */ +#ifdef fortran1 +void rkhat_point +#endif +#ifdef fortran2 +void RKHAT_POINT +#endif +#ifdef fortran3 +void rkhat_point_ +#endif +(double &alpha, +double &beta1, +double &beta2, +double &beta3, +double &chi, +double &dKhat1, +double &dKhat2, +double &dKhat3, +double &dTheta1, +double &dTheta2, +double &dTheta3, +double &g11, +double &g12, +double &g13, +double &g22, +double &g23, +double &g33, +double &kappa1, +double &kappa2, +double &Khat, +double &r, +double &rKhat, +double &Theta, +double &xp, +double &yp, +double &zp) +{ + +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double DKhat; +double DTheta; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double lienK; +double lienKhat; +double lienTheta; +double modshatARG; +double muL; +double oomodshat; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +muL += +2./alpha +; + +DKhat += +dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3 +; + +DTheta += +dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 +; + +lienKhat += +-((DKhat + Khat/r)*sqrt(muL)) +; + +lienTheta += +-DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta +; + +lienK += +lienKhat + 2.*lienTheta +; + +rKhat += +beta1*dKhat1 + beta2*dKhat2 + beta3*dKhat3 + alpha*lienKhat +; + +} /* function */ +#ifdef fortran1 +void rtheta_point +#endif +#ifdef fortran2 +void RTHETA_POINT +#endif +#ifdef fortran3 +void rtheta_point_ +#endif +(double &alpha, +double &beta1, +double &beta2, +double &beta3, +double &chi, +double &dTheta1, +double &dTheta2, +double &dTheta3, +double &g11, +double &g12, +double &g13, +double &g22, +double &g23, +double &g33, +double &kappa1, +double &kappa2, +double &r, +double &rTheta, +double &Theta, +double &xp, +double &yp, +double &zp) +{ + +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double DTheta; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double lienTheta; +double modshatARG; +double oomodshat; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; + + + +shat1 += +0 +; + +shat2 += +0 +; + +shat3 += +0 +; + + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +DTheta += +dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 +; + +lienTheta += +-DTheta - (kappa1*(2. + kappa2) + 1/r)*Theta +; + +rTheta += +beta1*dTheta1 + beta2*dTheta2 + beta3*dTheta3 + alpha*lienTheta +; + +} /* function */ + +#ifdef fortran1 +void rgam_point +#endif +#ifdef fortran2 +void RGAM_POINT +#endif +#ifdef fortran3 +void rgam_point_ +#endif +(double &alpha, +double &beta1, +double &beta2, +double &beta3, +double &chi, +double &db11, +double &db12, +double &db13, +double &db21, +double &db22, +double &db23, +double &db31, +double &db32, +double &db33, +double &ddb111, +double &ddb112, +double &ddb113, +double &ddb121, +double &ddb122, +double &ddb123, +double &ddb131, +double &ddb132, +double &ddb133, +double &ddb221, +double &ddb222, +double &ddb223, +double &ddb231, +double &ddb232, +double &ddb233, +double &ddb331, +double &ddb332, +double &ddb333, +double &dG11, +double &dG12, +double &dG13, +double &dG21, +double &dG22, +double &dG23, +double &dG31, +double &dG32, +double &dG33, +double &dKhat1, +double &dKhat2, +double &dKhat3, +double &dTheta1, +double &dTheta2, +double &dTheta3, +double &g11, +double &g12, +double &g13, +double &g22, +double &g23, +double &g33, +double &r, +double &rGamA1, +double &rGamA2, +double &rGamA3, +double &rGams, +double &shiftdriver, +double &xp, +double &yp, +double &zp) +{ + +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double detginv; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double modshatARG; +double muL; +double muStilde; +double oomodshat; +double qdd11; +double qdd12; +double qdd13; +double qdd22; +double qdd23; +double qdd33; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double quu11; +double quu12; +double quu13; +double quu22; +double quu23; +double quu33; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; +double vbetaA; +double vbetas; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +qdd11 += +g11/chi - pow2(sdown1) +; + +qdd12 += +g12/chi - sdown1*sdown2 +; + +qdd13 += +g13/chi - sdown1*sdown3 +; + +qdd22 += +g22/chi - pow2(sdown2) +; + +qdd23 += +g23/chi - sdown2*sdown3 +; + +qdd33 += +g33/chi - pow2(sdown3) +; + +quu11 += +ADMginv11 - pow2(sup1) +; + +quu12 += +ADMginv12 - sup1*sup2 +; + +quu13 += +ADMginv13 - sup1*sup3 +; + +quu22 += +ADMginv22 - pow2(sup2) +; + +quu23 += +ADMginv23 - sup2*sup3 +; + +quu33 += +ADMginv33 - pow2(sup3) +; + +muL += +2./alpha +; + +muStilde += +1/chi +; + +vbetas += +2.*sqrt(0.33333333333333333333*muStilde) +; + +vbetaA += +sqrt(muStilde) +; + +rGams += +(beta1*dG11 + beta2*dG21 + beta3*dG31 + + (ddb111*quu11 + ddb221*quu22 + + 2.*(ddb121*quu12 + ddb131*quu13 + ddb231*quu23) + ddb331*quu33)/chi\ +)*sdown1 + (beta1*dG12 + beta2*dG22 + beta3*dG32 + + (ddb112*quu11 + ddb222*quu22 + + 2.*(ddb122*quu12 + ddb132*quu13 + ddb232*quu23) + ddb332*quu33)/chi\ +)*sdown2 + (beta1*dG13 + beta2*dG23 + beta3*dG33 + + (ddb113*quu11 + ddb223*quu22 + + 2.*(ddb123*quu12 + ddb133*quu13 + ddb233*quu23) + ddb333*quu33)/chi\ +)*sdown3 - ((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + ddb121*qud21 + + ddb122*qud22 + ddb123*qud23 + ddb131*qud31 + ddb132*qud32 + + ddb133*qud33)*sup1 + (ddb121*qud11 + ddb122*qud12 + + ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + ddb223*qud23 + + ddb231*qud31 + ddb232*qud32 + ddb233*qud33)*sup2 + + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + ddb332*qud32 + + ddb333*qud33)*sup3)/chi - (dG11 + dG22 + dG33)*vbetas + + 2.*((0.33333333333333333333*alpha* + (dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3))/(chi + chi*vbetas) + + ((db11 + db22 + db33)*shiftdriver)/(vbetaA*sqrt(3.))) + + (1.3333333333333333333*alpha*(dKhat1*sup1 + dKhat2*sup2 + dKhat3*sup3)* + sqrt(muL))/(chi*(vbetas + sqrt(muL))) +; + +rGamA1 += +-(((dG21*qud11 + dG22*qud12 + dG23*qud13)*sup2 + + (dG31*qud11 + dG32*qud12 + dG33*qud13)*sup3)*vbetaA) + + qud11*(beta2*dG21 + beta3*dG31 + + (1.3333333333333333333*ddb111*quu11 + + 2.3333333333333333333*(ddb121*quu12 + ddb131*quu13) + + ddb221*quu22 + ddb331*quu33 + + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + + dG11*(beta1 - sup1*vbetaA)) + + qud12*(beta2*dG22 + beta3*dG32 + + (1.3333333333333333333*ddb112*quu11 + + 2.3333333333333333333*(ddb122*quu12 + ddb132*quu13) + + ddb222*quu22 + 2.*ddb232*quu23 + ddb332*quu33 + + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + + dG12*(beta1 - sup1*vbetaA)) + + qud13*(beta2*dG23 + beta3*dG33 + + (1.3333333333333333333*ddb113*quu11 + + 2.3333333333333333333*(ddb123*quu12 + ddb133*quu13) + + ddb223*quu22 + 2.*ddb233*quu23 + ddb333*quu33 + + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + + dG13*(beta1 - sup1*vbetaA)) + + (0.33333333333333333333*((ddb121*qud21 + ddb122*qud22 + ddb123*qud23 + + ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu11 + + (ddb221*qud21 + ddb223*qud23 + ddb231*qud31 + ddb232*qud32 + + ddb233*qud33)*quu12 + + (ddb231*qud21 + ddb232*qud22 + ddb233*qud23 + ddb331*qud31 + + ddb332*qud32)*quu13) - + alpha*((1.3333333333333333333*dKhat1 + + 0.66666666666666666667*dTheta1)*quu11 + + 1.3333333333333333333*(dKhat2*quu12 + dKhat3*quu13)) + + 1.3333333333333333333*((ddb132*quu13*sdown2 + ddb113*quu11*sdown3)* + sup1 + (quu13*(ddb231*sdown1 + ddb232*sdown2) + + quu12*(ddb222*sdown2 + ddb223*sdown3))*sup2 + + (quu12*(ddb232*sdown2 + ddb233*sdown3) + + quu13*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + + sdown1*((ddb121*quu12 + ddb131*quu13)*sup1 + ddb221*quu12*sup2 + + ddb131*quu11*sup3) + + sdown2*((ddb112*quu11 + ddb122*quu12)*sup1 + + quu11*(ddb122*sup2 + ddb132*sup3)) + + sdown3*((ddb123*quu12 + ddb133*quu13)*sup1 + + quu11*(ddb123*sup2 + ddb133*sup3))) + + qud11*(2.*ddb231*quu23 + (db21*shiftdriver*sup2)/vbetaA) - + (((db11*quu11 + db21*quu12)*sdown1 + + (db12*quu11 + db22*quu12 + db32*quu13)*sdown2 + + (db13*quu11 + db23*quu12 + db33*quu13)*sdown3)*shiftdriver)/ + vbetaA + ((dG22*quu12 + dG32*quu13)*sdown2 + + (dG13*quu11 + dG23*quu12)*sdown3)*vbetaA + + quu11*(1.3333333333333333333*sdown1*(ddb111*sup1 + ddb121*sup2) + + (dG11*sdown1 + dG12*sdown2)*vbetaA) + + quu12*(-0.66666666666666666667*alpha*dTheta2 + + 0.33333333333333333333*ddb222*qud22 + + sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + + quu13*(-0.66666666666666666667*alpha*dTheta3 + + 0.33333333333333333333*ddb333*qud33 - + (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + + sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi +; + +rGamA2 += +-(((dG21*qud21 + dG22*qud22 + dG23*qud23)*sup2 + + (dG31*qud21 + dG32*qud22 + dG33*qud23)*sup3)*vbetaA) + + qud21*(beta2*dG21 + beta3*dG31 + + (ddb111*quu11 + 2.*ddb131*quu13 + + 1.3333333333333333333*ddb221*quu22 + + 2.3333333333333333333*(ddb121*quu12 + ddb231*quu23) + + ddb331*quu33 + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + + dG11*(beta1 - sup1*vbetaA)) + + qud22*(beta2*dG22 + beta3*dG32 + + (ddb112*quu11 + 2.*ddb132*quu13 + + 1.3333333333333333333*ddb222*quu22 + + 2.3333333333333333333*(ddb122*quu12 + ddb232*quu23) + + ddb332*quu33 + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/ + vbetaA)/chi + dG12*(beta1 - sup1*vbetaA)) + + qud23*(beta2*dG23 + beta3*dG33 + + (ddb113*quu11 + 2.*ddb133*quu13 + + 1.3333333333333333333*ddb223*quu22 + + 2.3333333333333333333*(ddb123*quu12 + ddb233*quu23) + + ddb333*quu33 + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/ + vbetaA)/chi + dG13*(beta1 - sup1*vbetaA)) + + (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + + ddb131*qud31 + ddb132*qud32 + ddb133*qud33)*quu12 + + (ddb121*qud11 + ddb123*qud13 + ddb231*qud31 + ddb232*qud32 + + ddb233*qud33)*quu22 + + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb331*qud31 + + ddb332*qud32)*quu23) - + alpha*((1.3333333333333333333*dKhat1 + + 0.66666666666666666667*dTheta1)*quu12 + + 1.3333333333333333333*(dKhat2*quu22 + dKhat3*quu23)) + + 1.3333333333333333333*((ddb132*quu23*sdown2 + ddb113*quu12*sdown3)* + sup1 + (quu23*(ddb231*sdown1 + ddb232*sdown2) + + quu22*(ddb222*sdown2 + ddb223*sdown3))*sup2 + + (quu22*(ddb232*sdown2 + ddb233*sdown3) + + quu23*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + + sdown1*((ddb121*quu22 + ddb131*quu23)*sup1 + ddb221*quu22*sup2 + + ddb131*quu12*sup3) + + sdown2*((ddb112*quu12 + ddb122*quu22)*sup1 + + quu12*(ddb122*sup2 + ddb132*sup3)) + + sdown3*((ddb123*quu22 + ddb133*quu23)*sup1 + + quu12*(ddb123*sup2 + ddb133*sup3))) - + (((db11*quu12 + db21*quu22)*sdown1 + + (db12*quu12 + db22*quu22 + db32*quu23)*sdown2 + + (db13*quu12 + db23*quu22 + db33*quu23)*sdown3)*shiftdriver)/ + vbetaA + (db21*qud21*shiftdriver*sup2)/vbetaA + + ((dG22*quu22 + dG32*quu23)*sdown2 + (dG13*quu12 + dG23*quu22)*sdown3)* + vbetaA + quu12*(1.3333333333333333333*sdown1* + (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ ++ quu22*(-0.66666666666666666667*alpha*dTheta2 + + 0.33333333333333333333*ddb122*qud12 + + sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)) + + quu23*(-0.66666666666666666667*alpha*dTheta3 + + 0.33333333333333333333*ddb333*qud33 - + (db31*sdown1*shiftdriver)/vbetaA + dG31*sdown1*vbetaA + + sdown3*(1.3333333333333333333*ddb233*sup2 + dG33*vbetaA)))/chi +; + +rGamA3 += +-(((dG21*qud31 + dG22*qud32 + dG23*qud33)*sup2 + + (dG31*qud31 + dG32*qud32 + dG33*qud33)*sup3)*vbetaA) + + qud31*(beta2*dG21 + beta3*dG31 + + (ddb111*quu11 + 2.*ddb121*quu12 + ddb221*quu22 + + 2.3333333333333333333*(ddb131*quu13 + ddb231*quu23) + + 1.3333333333333333333*ddb331*quu33 + + (shiftdriver*(db11*sup1 + db31*sup3))/vbetaA)/chi + + dG11*(beta1 - sup1*vbetaA)) + + qud32*(beta2*dG22 + beta3*dG32 + + (ddb112*quu11 + 2.*ddb122*quu12 + ddb222*quu22 + + 2.3333333333333333333*(ddb132*quu13 + ddb232*quu23) + + 1.3333333333333333333*ddb332*quu33 + + (shiftdriver*(db12*sup1 + db22*sup2 + db32*sup3))/vbetaA)/chi + + dG12*(beta1 - sup1*vbetaA)) + + qud33*(beta2*dG23 + beta3*dG33 + + (ddb113*quu11 + 2.*ddb123*quu12 + ddb223*quu22 + + 2.3333333333333333333*(ddb133*quu13 + ddb233*quu23) + + 1.3333333333333333333*ddb333*quu33 + + (shiftdriver*(db13*sup1 + db23*sup2 + db33*sup3))/vbetaA)/chi + + dG13*(beta1 - sup1*vbetaA)) + + (0.33333333333333333333*((ddb111*qud11 + ddb112*qud12 + ddb113*qud13 + + ddb121*qud21 + ddb122*qud22 + ddb123*qud23)*quu13 + + (ddb121*qud11 + ddb123*qud13 + ddb221*qud21 + ddb222*qud22 + + ddb223*qud23)*quu23 + + (ddb131*qud11 + ddb132*qud12 + ddb133*qud13 + ddb231*qud21 + + ddb232*qud22)*quu33) - + alpha*((1.3333333333333333333*dKhat1 + + 0.66666666666666666667*dTheta1)*quu13 + + 1.3333333333333333333*(dKhat2*quu23 + dKhat3*quu33)) + + 1.3333333333333333333*((ddb132*quu33*sdown2 + ddb113*quu13*sdown3)* + sup1 + (quu33*(ddb231*sdown1 + ddb232*sdown2) + + quu23*(ddb222*sdown2 + ddb223*sdown3))*sup2 + + (quu23*(ddb232*sdown2 + ddb233*sdown3) + + quu33*(ddb331*sdown1 + ddb332*sdown2 + ddb333*sdown3))*sup3 + + sdown1*((ddb121*quu23 + ddb131*quu33)*sup1 + ddb221*quu23*sup2 + + ddb131*quu13*sup3) + + sdown2*((ddb112*quu13 + ddb122*quu23)*sup1 + + quu13*(ddb122*sup2 + ddb132*sup3)) + + sdown3*((ddb123*quu23 + ddb133*quu33)*sup1 + + quu13*(ddb123*sup2 + ddb133*sup3))) - + (((db11*quu13 + db21*quu23)*sdown1 + + (db12*quu13 + db22*quu23 + db32*quu33)*sdown2 + + (db13*quu13 + db23*quu23 + db33*quu33)*sdown3)*shiftdriver)/ + vbetaA + (db21*qud31*shiftdriver*sup2)/vbetaA + + ((dG22*quu23 + dG32*quu33)*sdown2 + (dG13*quu13 + dG23*quu23)*sdown3)* + vbetaA + quu13*(1.3333333333333333333*sdown1* + (ddb111*sup1 + ddb121*sup2) + (dG11*sdown1 + dG12*sdown2)*vbetaA) \ ++ quu33*(-0.66666666666666666667*alpha*dTheta3 + + ddb233*(0.33333333333333333333*qud23 + + 1.3333333333333333333*sdown3*sup2) - + (db31*sdown1*shiftdriver)/vbetaA + + (dG31*sdown1 + dG33*sdown3)*vbetaA) + + quu23*(-0.66666666666666666667*alpha*dTheta2 + + 0.33333333333333333333*ddb122*qud12 + + sdown1*(1.3333333333333333333*ddb231*sup3 + dG21*vbetaA)))/chi +; + +} /* function */ +#ifdef fortran1 +void ra_point +#endif +#ifdef fortran2 +void RA_POINT +#endif +#ifdef fortran3 +void ra_point_ +#endif +(double &A11, +double &A12, +double &A13, +double &A22, +double &A23, +double &A33, +double &alpha, +double &beta1, +double &beta2, +double &beta3, +double &chi, +double &da1, +double &dA111, +double &dA112, +double &dA113, +double &dA122, +double &dA123, +double &dA133, +double &da2, +double &dA211, +double &dA212, +double &dA213, +double &dA222, +double &dA223, +double &dA233, +double &da3, +double &dA311, +double &dA312, +double &dA313, +double &dA322, +double &dA323, +double &dA333, +double &db11, +double &db12, +double &db13, +double &db21, +double &db22, +double &db23, +double &db31, +double &db32, +double &db33, +double &dchi1, +double &dchi2, +double &dchi3, +double &dda11, +double &dda12, +double &dda13, +double &dda22, +double &dda23, +double &dda33, +double &ddb111, +double &ddb112, +double &ddb113, +double &ddb121, +double &ddb122, +double &ddb123, +double &ddb131, +double &ddb132, +double &ddb133, +double &ddb221, +double &ddb222, +double &ddb223, +double &ddb231, +double &ddb232, +double &ddb233, +double &ddb331, +double &ddb332, +double &ddb333, +double &ddchi11, +double &ddchi12, +double &ddchi13, +double &ddchi22, +double &ddchi23, +double &ddchi33, +double &ddg1111, +double &ddg1112, +double &ddg1113, +double &ddg1122, +double &ddg1123, +double &ddg1133, +double &ddg1211, +double &ddg1212, +double &ddg1213, +double &ddg1222, +double &ddg1223, +double &ddg1233, +double &ddg1311, +double &ddg1312, +double &ddg1313, +double &ddg1322, +double &ddg1323, +double &ddg1333, +double &ddg2211, +double &ddg2212, +double &ddg2213, +double &ddg2222, +double &ddg2223, +double &ddg2233, +double &ddg2311, +double &ddg2312, +double &ddg2313, +double &ddg2322, +double &ddg2323, +double &ddg2333, +double &ddg3311, +double &ddg3312, +double &ddg3313, +double &ddg3322, +double &ddg3323, +double &ddg3333, +double &dG11, +double &dg111, +double &dg112, +double &dg113, +double &dG12, +double &dg122, +double &dg123, +double &dG13, +double &dg133, +double &dG21, +double &dg211, +double &dg212, +double &dg213, +double &dG22, +double &dg222, +double &dg223, +double &dG23, +double &dg233, +double &dG31, +double &dg311, +double &dg312, +double &dg313, +double &dG32, +double &dg322, +double &dg323, +double &dG33, +double &dg333, +double &dKhat1, +double &dKhat2, +double &dKhat3, +double &dTheta1, +double &dTheta2, +double &dTheta3, +double &G1, +double &g11, +double &g12, +double &g13, +double &G2, +double &g22, +double &g23, +double &G3, +double &g33, +double &kappa1, +double &Khat, +double &r, +double &rACABTF11, +double &rACABTF12, +double &rACABTF13, +double &rACABTF22, +double &rACABTF23, +double &rACABTF33, +double &rACsA1, +double &rACsA2, +double &rACsA3, +double &rACss, +double &Theta, +double &xp, +double &yp, +double &zp) +{ + +double AA11; +double AA12; +double AA13; +double AA21; +double AA22; +double AA23; +double AA31; +double AA32; +double AA33; +double ADMginv11; +double ADMginv12; +double ADMginv13; +double ADMginv22; +double ADMginv23; +double ADMginv33; +double cdA111; +double cdA112; +double cdA113; +double cdA122; +double cdA123; +double cdA133; +double cdA211; +double cdA212; +double cdA213; +double cdA222; +double cdA223; +double cdA233; +double cdA311; +double cdA312; +double cdA313; +double cdA322; +double cdA323; +double cdA333; +double cdda11; +double cdda12; +double cdda13; +double cdda22; +double cdda23; +double cdda33; +double cddf11; +double cddf12; +double cddf13; +double cddf22; +double cddf23; +double cddf33; +double chipsipower; +double ddf11; +double ddf12; +double ddf13; +double ddf22; +double ddf23; +double ddf33; +double detginv; +double df1; +double df2; +double df3; +double dGfromgdu11; +double dGfromgdu12; +double dGfromgdu13; +double dGfromgdu21; +double dGfromgdu22; +double dGfromgdu23; +double dGfromgdu31; +double dGfromgdu32; +double dGfromgdu33; +double divbeta; +double dK1; +double dK2; +double dK3; +double DTheta; +double f; +double ff; +double gamma111; +double gamma112; +double gamma113; +double gamma122; +double gamma123; +double gamma133; +double gamma211; +double gamma212; +double gamma213; +double gamma222; +double gamma223; +double gamma233; +double gamma311; +double gamma312; +double gamma313; +double gamma322; +double gamma323; +double gamma333; +double gammado111; +double gammado112; +double gammado113; +double gammado122; +double gammado123; +double gammado133; +double gammado211; +double gammado212; +double gammado213; +double gammado222; +double gammado223; +double gammado233; +double gammado311; +double gammado312; +double gammado313; +double gammado322; +double gammado323; +double gammado333; +double Gfromg1; +double Gfromg2; +double Gfromg3; +double ginv11; +double ginv12; +double ginv13; +double ginv22; +double ginv23; +double ginv33; +double K; +double lieA11; +double lieA12; +double lieA13; +double lieA22; +double lieA23; +double lieA33; +double modshatARG; +double oochipsipower; +double oomodshat; +double psim4; +double qdd11; +double qdd12; +double qdd13; +double qdd22; +double qdd23; +double qdd33; +double qPhysuudd1111; +double qPhysuudd1112; +double qPhysuudd1113; +double qPhysuudd1122; +double qPhysuudd1123; +double qPhysuudd1133; +double qPhysuudd1211; +double qPhysuudd1212; +double qPhysuudd1213; +double qPhysuudd1222; +double qPhysuudd1223; +double qPhysuudd1233; +double qPhysuudd1311; +double qPhysuudd1312; +double qPhysuudd1313; +double qPhysuudd1322; +double qPhysuudd1323; +double qPhysuudd1333; +double qPhysuudd2211; +double qPhysuudd2212; +double qPhysuudd2213; +double qPhysuudd2222; +double qPhysuudd2223; +double qPhysuudd2233; +double qPhysuudd2311; +double qPhysuudd2312; +double qPhysuudd2313; +double qPhysuudd2322; +double qPhysuudd2323; +double qPhysuudd2333; +double qPhysuudd3311; +double qPhysuudd3312; +double qPhysuudd3313; +double qPhysuudd3322; +double qPhysuudd3323; +double qPhysuudd3333; +double qud11; +double qud12; +double qud13; +double qud21; +double qud22; +double qud23; +double qud31; +double qud32; +double qud33; +double quu11; +double quu12; +double quu13; +double quu22; +double quu23; +double quu33; +double R11; +double R12; +double R13; +double R22; +double R23; +double R33; +double Rf11; +double Rf12; +double Rf13; +double Rf22; +double Rf23; +double Rf33; +double Rhat; +double Rphi11; +double Rphi12; +double Rphi13; +double Rphi22; +double Rphi23; +double Rphi33; +double sdown1; +double sdown2; +double sdown3; +double shat1; +double shat2; +double shat3; +double sup1; +double sup2; +double sup3; +double totdivbeta; +double trcdda; +double trcddf; + + + +chipsipower += +-4. +; + +shat1=xp/r;shat2=yp/r;shat3=zp/r; + +detginv += +1/(2.*g12*g13*g23 - g33*pow2(g12) + g22*(g11*g33 - pow2(g13)) - + g11*pow2(g23)) +; + +ginv11 += +detginv*(g22*g33 - pow2(g23)) +; + +ginv12 += +detginv*(g13*g23 - g12*g33) +; + +ginv13 += +detginv*(-(g13*g22) + g12*g23) +; + +ginv22 += +detginv*(g11*g33 - pow2(g13)) +; + +ginv23 += +detginv*(g12*g13 - g11*g23) +; + +ginv33 += +detginv*(g11*g22 - pow2(g12)) +; + +ADMginv11 += +chi*ginv11 +; + +ADMginv12 += +chi*ginv12 +; + +ADMginv13 += +chi*ginv13 +; + +ADMginv22 += +chi*ginv22 +; + +ADMginv23 += +chi*ginv23 +; + +ADMginv33 += +chi*ginv33 +; + +modshatARG += +2.*(ADMginv23*shat2*shat3 + shat1*(ADMginv12*shat2 + ADMginv13*shat3)) + + ADMginv11*pow2(shat1) + ADMginv22*pow2(shat2) + ADMginv33*pow2(shat3) +; + + +if (modshatARG<0.00001) { + printf("modshat is wrong (%e)\n",modshatARG); + modshatARG = 0.00001; + }oomodshat += +1/sqrt(modshatARG) +; + +sdown1 += +oomodshat*shat1 +; + +sdown2 += +oomodshat*shat2 +; + +sdown3 += +oomodshat*shat3 +; + +sup1 += +ADMginv11*sdown1 + ADMginv12*sdown2 + ADMginv13*sdown3 +; + +sup2 += +ADMginv12*sdown1 + ADMginv22*sdown2 + ADMginv23*sdown3 +; + +sup3 += +ADMginv13*sdown1 + ADMginv23*sdown2 + ADMginv33*sdown3 +; + +qud11 += +1. - sdown1*sup1 +; + +qud12 += +-(sdown2*sup1) +; + +qud13 += +-(sdown3*sup1) +; + +qud21 += +-(sdown1*sup2) +; + +qud22 += +1. - sdown2*sup2 +; + +qud23 += +-(sdown3*sup2) +; + +qud31 += +-(sdown1*sup3) +; + +qud32 += +-(sdown2*sup3) +; + +qud33 += +1. - sdown3*sup3 +; + +qdd11 += +g11/chi - pow2(sdown1) +; + +qdd12 += +g12/chi - sdown1*sdown2 +; + +qdd13 += +g13/chi - sdown1*sdown3 +; + +qdd22 += +g22/chi - pow2(sdown2) +; + +qdd23 += +g23/chi - sdown2*sdown3 +; + +qdd33 += +g33/chi - pow2(sdown3) +; + +quu11 += +ADMginv11 - pow2(sup1) +; + +quu12 += +ADMginv12 - sup1*sup2 +; + +quu13 += +ADMginv13 - sup1*sup3 +; + +quu22 += +ADMginv22 - pow2(sup2) +; + +quu23 += +ADMginv23 - sup2*sup3 +; + +quu33 += +ADMginv33 - pow2(sup3) +; + +qPhysuudd1111 += +-0.5*qdd11*quu11 + pow2(qud11) +; + +qPhysuudd1112 += +qud11*qud12 - 0.5*qdd12*quu11 +; + +qPhysuudd1113 += +qud11*qud13 - 0.5*qdd13*quu11 +; + +qPhysuudd1122 += +-0.5*qdd22*quu11 + pow2(qud12) +; + +qPhysuudd1123 += +qud12*qud13 - 0.5*qdd23*quu11 +; + +qPhysuudd1133 += +-0.5*qdd33*quu11 + pow2(qud13) +; + +qPhysuudd1211 += +qud11*qud21 - 0.5*qdd11*quu12 +; + +qPhysuudd1212 += +0.5*(qud12*qud21 + qud11*qud22 - qdd12*quu12) +; + +qPhysuudd1213 += +0.5*(qud13*qud21 + qud11*qud23 - qdd13*quu12) +; + +qPhysuudd1222 += +qud12*qud22 - 0.5*qdd22*quu12 +; + +qPhysuudd1223 += +0.5*(qud13*qud22 + qud12*qud23 - qdd23*quu12) +; + +qPhysuudd1233 += +qud13*qud23 - 0.5*qdd33*quu12 +; + +qPhysuudd1311 += +qud11*qud31 - 0.5*qdd11*quu13 +; + +qPhysuudd1312 += +0.5*(qud12*qud31 + qud11*qud32 - qdd12*quu13) +; + +qPhysuudd1313 += +0.5*(qud13*qud31 + qud11*qud33 - qdd13*quu13) +; + +qPhysuudd1322 += +qud12*qud32 - 0.5*qdd22*quu13 +; + +qPhysuudd1323 += +0.5*(qud13*qud32 + qud12*qud33 - qdd23*quu13) +; + +qPhysuudd1333 += +qud13*qud33 - 0.5*qdd33*quu13 +; + +qPhysuudd2211 += +-0.5*qdd11*quu22 + pow2(qud21) +; + +qPhysuudd2212 += +qud21*qud22 - 0.5*qdd12*quu22 +; + +qPhysuudd2213 += +qud21*qud23 - 0.5*qdd13*quu22 +; + +qPhysuudd2222 += +-0.5*qdd22*quu22 + pow2(qud22) +; + +qPhysuudd2223 += +qud22*qud23 - 0.5*qdd23*quu22 +; + +qPhysuudd2233 += +-0.5*qdd33*quu22 + pow2(qud23) +; + +qPhysuudd2311 += +qud21*qud31 - 0.5*qdd11*quu23 +; + +qPhysuudd2312 += +0.5*(qud22*qud31 + qud21*qud32 - qdd12*quu23) +; + +qPhysuudd2313 += +0.5*(qud23*qud31 + qud21*qud33 - qdd13*quu23) +; + +qPhysuudd2322 += +qud22*qud32 - 0.5*qdd22*quu23 +; + +qPhysuudd2323 += +0.5*(qud23*qud32 + qud22*qud33 - qdd23*quu23) +; + +qPhysuudd2333 += +qud23*qud33 - 0.5*qdd33*quu23 +; + +qPhysuudd3311 += +-0.5*qdd11*quu33 + pow2(qud31) +; + +qPhysuudd3312 += +qud31*qud32 - 0.5*qdd12*quu33 +; + +qPhysuudd3313 += +qud31*qud33 - 0.5*qdd13*quu33 +; + +qPhysuudd3322 += +-0.5*qdd22*quu33 + pow2(qud32) +; + +qPhysuudd3323 += +qud32*qud33 - 0.5*qdd23*quu33 +; + +qPhysuudd3333 += +-0.5*qdd33*quu33 + pow2(qud33) +; + +K += +Khat + 2.*Theta +; + +dK1 += +dKhat1 + 2.*dTheta1 +; + +dK2 += +dKhat2 + 2.*dTheta2 +; + +dK3 += +dKhat3 + 2.*dTheta3 +; + +gammado111 += +0.5*dg111 +; + +gammado112 += +0.5*dg211 +; + +gammado113 += +0.5*dg311 +; + +gammado122 += +-0.5*dg122 + dg212 +; + +gammado123 += +0.5*(-dg123 + dg213 + dg312) +; + +gammado133 += +-0.5*dg133 + dg313 +; + +gammado211 += +dg112 - 0.5*dg211 +; + +gammado212 += +0.5*dg122 +; + +gammado213 += +0.5*(dg123 - dg213 + dg312) +; + +gammado222 += +0.5*dg222 +; + +gammado223 += +0.5*dg322 +; + +gammado233 += +-0.5*dg233 + dg323 +; + +gammado311 += +dg113 - 0.5*dg311 +; + +gammado312 += +0.5*(dg123 + dg213 - dg312) +; + +gammado313 += +0.5*dg133 +; + +gammado322 += +dg223 - 0.5*dg322 +; + +gammado323 += +0.5*dg233 +; + +gammado333 += +0.5*dg333 +; + +gamma111 += +gammado111*ginv11 + gammado211*ginv12 + gammado311*ginv13 +; + +gamma112 += +gammado112*ginv11 + gammado212*ginv12 + gammado312*ginv13 +; + +gamma113 += +gammado113*ginv11 + gammado213*ginv12 + gammado313*ginv13 +; + +gamma122 += +gammado122*ginv11 + gammado222*ginv12 + gammado322*ginv13 +; + +gamma123 += +gammado123*ginv11 + gammado223*ginv12 + gammado323*ginv13 +; + +gamma133 += +gammado133*ginv11 + gammado233*ginv12 + gammado333*ginv13 +; + +gamma211 += +gammado111*ginv12 + gammado211*ginv22 + gammado311*ginv23 +; + +gamma212 += +gammado112*ginv12 + gammado212*ginv22 + gammado312*ginv23 +; + +gamma213 += +gammado113*ginv12 + gammado213*ginv22 + gammado313*ginv23 +; + +gamma222 += +gammado122*ginv12 + gammado222*ginv22 + gammado322*ginv23 +; + +gamma223 += +gammado123*ginv12 + gammado223*ginv22 + gammado323*ginv23 +; + +gamma233 += +gammado133*ginv12 + gammado233*ginv22 + gammado333*ginv23 +; + +gamma311 += +gammado111*ginv13 + gammado211*ginv23 + gammado311*ginv33 +; + +gamma312 += +gammado112*ginv13 + gammado212*ginv23 + gammado312*ginv33 +; + +gamma313 += +gammado113*ginv13 + gammado213*ginv23 + gammado313*ginv33 +; + +gamma322 += +gammado122*ginv13 + gammado222*ginv23 + gammado322*ginv33 +; + +gamma323 += +gammado123*ginv13 + gammado223*ginv23 + gammado323*ginv33 +; + +gamma333 += +gammado133*ginv13 + gammado233*ginv23 + gammado333*ginv33 +; + +Gfromg1 += +gamma111*ginv11 + gamma122*ginv22 + + 2.*(gamma112*ginv12 + gamma113*ginv13 + gamma123*ginv23) + gamma133*ginv33 +; + +Gfromg2 += +gamma211*ginv11 + gamma222*ginv22 + + 2.*(gamma212*ginv12 + gamma213*ginv13 + gamma223*ginv23) + gamma233*ginv33 +; + +Gfromg3 += +gamma311*ginv11 + gamma322*ginv22 + + 2.*(gamma312*ginv12 + gamma313*ginv13 + gamma323*ginv23) + gamma333*ginv33 +; + +dGfromgdu11 += +-((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)* + Power(ginv12,3)) - (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + + dg111*dg333)*Power(ginv13,3) - 2.*Power(ginv11,3)*pow2(dg111) + + (ddg1111 - dg111*((8.*dg112 + 2.*dg211)*ginv12 + + (8.*dg113 + 2.*dg311)*ginv13) - + (dg113*(4.*dg112 + dg211) + dg112*dg311 + dg111*(dg213 + dg312))* + ginv23 - ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - + ginv33*(dg113*dg311 + dg111*dg313 + 2.*pow2(dg113)))*pow2(ginv11) + + (ddg1122 + ddg1212 - (dg123*(8.*dg112 + 2.*dg211) + + dg113*(4.*dg122 + 2.*dg212) + dg122*dg311 + + 2.*(dg111*dg223 + dg112*(dg213 + dg312)) + dg111*dg322)*ginv13 - + (dg123*(4.*dg122 + 2.*dg212) + + 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* + ginv23 - ginv22*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122)) - + ginv33*(dg123*(dg213 + dg312) + dg122*dg313 + dg113*(dg223 + dg322) + + dg112*dg323 + 2.*pow2(dg123)))*pow2(ginv12) + + (ddg1133 + ddg1313 - (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*ginv23 - + ginv22*(dg133*dg212 + dg113*dg223 + dg123*(dg213 + dg312) + + dg112*(dg233 + dg323) + 2.*pow2(dg123)) - + ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133)))*pow2(ginv13) \ ++ ginv13*(ddg1333*ginv33 + ginv22* + (ddg1223 - (dg133*dg222 + dg123*(4.*dg223 + dg322) + + dg122*(dg233 + dg323))*ginv23 - + (dg133*dg223 + dg123*(dg233 + 2.*dg323))*ginv33) + + ginv23*(ddg1233 + ddg1323 - + (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)*ginv33) - + (dg123*dg222 + dg122*dg223)*pow2(ginv22) - + (dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + + dg122*dg333)*pow2(ginv23) - 2.*dg133*dg333*pow2(ginv33)) + + ginv11*(ddg1313*ginv33 + ginv12* + (2.*ddg1112 + ddg1211 - + (dg113*(12.*dg112 + 3.*dg211) + 3.*dg112*dg311 + + dg111*(8.*dg123 + 3.*(dg213 + dg312)))*ginv13 - + (dg122*(4.*dg112 + dg211) + 6.*dg112*dg212 + dg111*dg222)*ginv22 - + (dg123*dg211 + dg122*dg311 + + 4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213 + dg312)) + + dg111*(dg223 + dg322))*ginv23 - + (dg123*dg311 + dg113*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*dg112*dg313 + dg111*dg323)*ginv33) + + ginv22*(ddg1212 - (dg113*dg222 + 2.*(dg123*dg212 + dg112*dg223) + + dg122*(dg213 + dg312) + dg112*dg322)*ginv23 - + (dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323)*ginv33) + + ginv13*(2.*ddg1113 + ddg1311 - + (dg123*(4.*dg112 + dg211) + dg111*dg223 + + 2.*(dg113*dg212 + dg112*(dg213 + dg312)))*ginv22 - + (dg133*dg211 + dg123*dg311 + + 4.*(dg113*(dg123 + dg213 + dg312) + dg112*(dg133 + dg313)) + + dg111*(dg233 + dg323))*ginv23 - + (dg133*(4.*dg113 + dg311) + 6.*dg113*dg313 + dg111*dg333)*ginv33) + + ginv23*(ddg1213 + ddg1312 - + (dg133*(dg213 + dg312) + 2.*dg123*dg313 + + dg113*(dg233 + 2.*dg323) + dg112*dg333)*ginv33) - + (3.*dg112*dg211 + dg111*(4.*dg122 + 3.*dg212) + 6.*pow2(dg112))* + pow2(ginv12) - (3.*dg113*dg311 + dg111*(4.*dg133 + 3.*dg313) + + 6.*pow2(dg113))*pow2(ginv13) - + (dg122*dg212 + dg112*dg222)*pow2(ginv22) - + (dg133*dg212 + dg123*(dg213 + dg312) + dg122*dg313 + + dg113*(dg223 + dg322) + dg112*(dg233 + dg323))*pow2(ginv23) - + (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + + ginv12*(ddg1323*ginv33 + ginv22* + (ddg1222 - (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*ginv23 - + (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33) + + ginv23*(ddg1223 + ddg1322 - + (dg133*(dg223 + dg322) + dg123*(dg233 + 4.*dg323) + dg122*dg333)* + ginv33) + ginv13*(2.*ddg1123 + ddg1213 + ddg1312 - + (dg113*dg222 + 4.*(dg123*(dg122 + dg212) + dg112*dg223) + + dg122*(dg213 + dg312) + dg112*dg322)*ginv22 - + (dg133*(4.*dg123 + dg213 + dg312) + 4.*dg123*dg313 + + dg113*(dg233 + 4.*dg323) + dg112*dg333)*ginv33 - + ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg122*dg313 + + dg113*dg322) + 4.* + (dg122*dg133 + dg113*dg223 + dg123*(dg213 + dg312) + + dg112*dg323 + pow2(dg123)))) - + (dg133*(4.*dg112 + dg211) + dg113*(8.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* + pow2(ginv13) - 2.*dg122*dg222*pow2(ginv22) - + (dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* + pow2(ginv23) - (dg133*dg323 + dg123*dg333)*pow2(ginv33)) +; + +dGfromgdu12 += +-((dg133*dg322 + 2.*(dg133*dg223 + dg123*(dg233 + dg323)) + dg122*dg333)* + Power(ginv23,3)) - 2.*(dg122*dg222*Power(ginv22,3) + + Power(ginv12,3)*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)) + + (dg111*(dg112*ginv22 + dg113*ginv23) + ginv12*pow2(dg111))*pow2(ginv11)\ +) + (ddg1112 + ddg1211 - (4.*(dg112*dg113 + dg111*dg123) + + 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))*ginv13 - + (dg122*(6.*dg112 + 2.*dg211) + 6.*dg112*dg212 + 2.*dg111*dg222)* + ginv22 - (4.*(dg113*(dg122 + dg212) + dg112*(dg123 + dg213)) + + dg122*dg311 + 2.*(dg123*dg211 + dg111*dg223 + dg112*dg312) + + dg111*dg322)*ginv23 - + (dg123*dg311 + dg113*(2.*(dg123 + dg213) + dg312) + dg112*dg313 + + dg111*dg323)*ginv33)*pow2(ginv12) - + ((2.*(dg113*dg123 + dg112*dg133) + dg123*dg311 + dg113*dg312 + + dg112*dg313 + dg111*dg323)*ginv22 + + (dg133*(4.*dg113 + dg311) + 2.*dg113*dg313 + dg111*dg333)*ginv23)* + pow2(ginv13) + (ddg1222 - (4.*(dg123*dg222 + dg122*dg223) + + 2.*dg122*dg322)*ginv23 - + (dg123*(2.*dg223 + dg322) + dg122*dg323)*ginv33)*pow2(ginv22) + + (ddg1233 + ddg1323 - (dg133*(2.*dg233 + 3.*dg323) + 3.*dg123*dg333)* + ginv33)*pow2(ginv23) + ginv11* + (ginv23*(ddg1113 - 2.*dg113*(dg133 + dg313)*ginv33) + + ginv22*(ddg1112 - (dg112*(4.*dg123 + 2.*dg213) + + 2.*(dg113*(dg122 + dg212) + dg112*dg312))*ginv23 - + (dg113*(2.*dg123 + dg312) + dg112*dg313)*ginv33) + + ginv12*(ddg1111 - dg111*(6.*dg113 + 2.*dg311)*ginv13 - + (dg113*(8.*dg112 + 2.*dg211) + dg112*dg311 + + dg111*(2.*(dg123 + dg213) + dg312))*ginv23 - + ginv22*(2.*(dg112*dg211 + dg111*(dg122 + dg212)) + + 6.*pow2(dg112)) - ginv33* + (dg113*dg311 + dg111*dg313 + 2.*pow2(dg113))) - + ginv13*((dg112*(4.*dg113 + dg311) + dg111*(2.*dg123 + dg312))* + ginv22 + ginv23*(dg113*dg311 + dg111*(2.*dg133 + dg313) + + 4.*pow2(dg113))) - dg111*(6.*dg112 + 2.*dg211)*pow2(ginv12) - + 2.*dg112*(dg122 + dg212)*pow2(ginv22) - + (2.*(dg112*dg133 + dg113*(dg123 + dg213)) + dg113*dg312 + dg112*dg313)* + pow2(ginv23)) + ginv13*(ginv22* + (ddg1123 + ddg1312 - (dg133*(2.*dg123 + dg312) + + 2.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33 - + ginv23*(2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg113*dg223 + + dg112*dg233) + dg122*dg313 + dg113*dg322 + + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg123)))) + + ginv23*(ddg1133 + ddg1313 - + ginv33*(3.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))) - + (2.*(dg123*(dg122 + dg212) + dg112*dg223) + dg122*dg312 + + dg112*dg322)*pow2(ginv22) - + (dg133*(4.*dg123 + 2.*(dg213 + dg312)) + + 2.*(dg123*dg313 + dg113*(dg233 + dg323) + dg112*dg333))*pow2(ginv23)\ +) + ginv23*(ddg1333*ginv33 - 2.*dg133*dg333*pow2(ginv33)) + + ginv12*(ddg1313*ginv33 + ginv13* + (ddg1113 + ddg1311 - (2.* + (dg123*dg211 + dg113*(dg122 + dg212) + dg111*dg223) + + dg122*dg311 + dg112*(8.*dg123 + 2.*dg213 + 4.*dg312) + + dg111*dg322)*ginv22 - + (dg133*(4.*dg112 + 2.*dg211) + + dg113*(8.*dg123 + 4.*(dg213 + dg312)) + 4.*dg112*dg313 + + 2.*(dg123*dg311 + dg111*(dg233 + dg323)))*ginv23 - + (dg133*(2.*dg113 + dg311) + 4.*dg113*dg313 + dg111*dg333)*ginv33) + + ginv23*(ddg1123 + 2.*ddg1213 + ddg1312 - + (2.*(dg133*(dg123 + dg213) + dg113*dg233) + dg133*dg312 + + 4.*(dg123*dg313 + dg113*dg323) + dg112*dg333)*ginv33) + + ginv22*(ddg1122 + 2.*ddg1212 - + (4.*(dg122*dg213 + dg113*dg222) + + 6.*(dg123*(dg122 + dg212) + dg112*dg223) + + 3.*(dg122*dg312 + dg112*dg322))*ginv23 - + ginv33*(dg122*dg313 + dg113*dg322 + + 2.*(dg113*dg223 + dg123*(dg213 + dg312) + dg112*dg323 + + pow2(dg123)))) - + 2.*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113))*pow2(ginv13) - + (4.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))*pow2(ginv22) - + (4.*(dg123*dg213 + dg113*dg223) + + 2.*(dg133*(dg122 + dg212) + dg123*dg312 + dg122*dg313 + + dg113*dg322 + dg112*(dg233 + dg323) + pow2(dg123)))*pow2(ginv23) \ +- (dg133*dg313 + dg113*dg333)*pow2(ginv33)) + + ginv22*(ddg1323*ginv33 + ginv23* + (2.*ddg1223 + ddg1322 - (2.*(dg133*dg223 + dg123*dg233) + + dg133*dg322 + 6.*dg123*dg323 + dg122*dg333)*ginv33) - + (2.*(dg133*dg222 + dg122*dg233) + dg123*(6.*dg223 + 3.*dg322) + + 3.*dg122*dg323)*pow2(ginv23) - + (dg133*dg323 + dg123*dg333)*pow2(ginv33)) +; + +dGfromgdu13 += +-((dg133*dg222 + 2.*dg123*(dg223 + dg322) + dg122*(dg233 + 2.*dg323))* + Power(ginv23,3)) - 2.*(dg133*dg333*Power(ginv33,3) + + Power(ginv13,3)*(dg113*dg311 + dg111*(dg133 + dg313) + pow2(dg113)) + + (dg111*(dg112*ginv23 + dg113*ginv33) + ginv13*pow2(dg111))*pow2(ginv11)\ +) - ((dg122*(4.*dg112 + dg211) + 2.*dg112*dg212 + dg111*dg222)*ginv23 + + (2.*(dg113*dg122 + dg112*dg123) + dg123*dg211 + dg113*dg212 + + dg112*dg213 + dg111*dg223)*ginv33 + + 2.*ginv13*(dg112*dg211 + dg111*(dg122 + dg212) + pow2(dg112)))* + pow2(ginv12) + (ddg1113 + ddg1311 - + (dg123*(2.*dg112 + dg211) + dg113*dg212 + dg111*dg223 + + dg112*(dg213 + 2.*dg312))*ginv22 - + (dg133*dg211 + 2.*(dg113*dg213 + dg123*dg311) + + 4.*(dg113*(dg123 + dg312) + dg112*(dg133 + dg313)) + + dg111*(dg233 + 2.*dg323))*ginv23 - + (dg133*(6.*dg113 + 2.*dg311) + 6.*dg113*dg313 + 2.*dg111*dg333)*ginv33\ +)*pow2(ginv13) - (2.*dg122*dg222*ginv23 + + (dg123*dg222 + dg122*dg223)*ginv33)*pow2(ginv22) + + (ddg1223 + ddg1322 - (3.*(dg133*dg223 + dg123*dg233) + 6.*dg123*dg323 + + 2.*(dg133*dg322 + dg122*dg333))*ginv33)*pow2(ginv23) + + ddg1333*pow2(ginv33) + ginv11* + (ddg1113*ginv33 - ginv22*(2.*dg112*(dg122 + dg212)*ginv23 + + (dg113*dg212 + dg112*(2.*dg123 + dg213))*ginv33) + + ginv23*(ddg1112 - (dg113*(4.*dg123 + 2.*dg213) + + 2.*(dg113*dg312 + dg112*(dg133 + dg313)))*ginv33) - + ginv12*(dg111*(6.*dg112 + 2.*dg211)*ginv13 + + (dg113*(4.*dg112 + dg211) + dg111*(2.*dg123 + dg213))*ginv33 + + ginv23*(dg112*dg211 + dg111*(2.*dg122 + dg212) + 4.*pow2(dg112))) + + ginv13*(ddg1111 - (dg113*(8.*dg112 + dg211) + 2.*dg112*dg311 + + dg111*(dg213 + 2.*(dg123 + dg312)))*ginv23 - + ginv22*(dg112*dg211 + dg111*dg212 + 2.*pow2(dg112)) - + ginv33*(2.*(dg113*dg311 + dg111*(dg133 + dg313)) + 6.*pow2(dg113))) \ +- dg111*(6.*dg113 + 2.*dg311)*pow2(ginv13) - + (dg113*dg212 + dg112*dg213 + + 2.*(dg113*dg122 + dg112*(dg123 + dg312)))*pow2(ginv23) - + 2.*dg113*(dg133 + dg313)*pow2(ginv33)) + + ginv12*((ddg1123 + ddg1213)*ginv33 + + ginv13*(ddg1112 + ddg1211 - + (dg122*(2.*dg112 + dg211) + 4.*dg112*dg212 + dg111*dg222)*ginv22 - + (dg123*(8.*dg112 + 2.*dg211) + + 4.*(dg113*(dg122 + dg212) + dg112*(dg213 + dg312)) + + 2.*(dg122*dg311 + dg111*(dg223 + dg322)))*ginv23 - + (dg133*(2.*dg112 + dg211) + + dg113*(8.*dg123 + 4.*dg213 + 2.*dg312) + + 2.*(dg123*dg311 + dg112*dg313) + dg111*(dg233 + 2.*dg323))* + ginv33) - ginv22*((dg122*dg213 + dg113*dg222 + + 2.*(dg123*(dg122 + dg212) + dg112*dg223))*ginv33 + + ginv23*(3.*(dg122*dg212 + dg112*dg222) + 2.*pow2(dg122))) + + ginv23*(ddg1122 + ddg1212 - + ginv33*(dg133*(2.*dg122 + dg212) + + 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322) + + dg112*(dg233 + 2.*dg323) + + 4.*(dg123*dg213 + dg113*dg223 + pow2(dg123)))) - + (4.*(dg112*dg113 + dg111*dg123) + + 2.*(dg113*dg211 + dg112*dg311 + dg111*(dg213 + dg312)))* + pow2(ginv13) - (dg123*(4.*dg122 + 2.*dg212) + + 2.*(dg113*dg222 + dg122*(dg213 + dg312) + dg112*(dg223 + dg322)))* + pow2(ginv23) - (dg133*(2.*dg123 + dg213) + 2.*dg123*dg313 + + dg113*(dg233 + 2.*dg323))*pow2(ginv33)) + + ginv22*(ddg1223*ginv33 + ginv23* + (ddg1222 - (dg133*dg222 + dg123*(6.*dg223 + 2.*dg322) + + dg122*(dg233 + 2.*dg323))*ginv33) - + (3.*(dg123*dg222 + dg122*dg223) + 2.*dg122*dg322)*pow2(ginv23) - + (dg133*dg223 + dg123*(dg233 + 2.*dg323))*pow2(ginv33)) + + ginv23*((ddg1233 + 2.*ddg1323)*ginv33 - + (dg133*(2.*dg233 + 4.*dg323) + 4.*dg123*dg333)*pow2(ginv33)) + + ginv13*((ddg1133 + 2.*ddg1313)*ginv33 + + ginv23*(ddg1123 + ddg1213 + 2.*ddg1312 - + (dg133*(6.*dg123 + 3.*dg213 + 4.*dg312) + 6.*dg123*dg313 + + dg113*(3.*dg233 + 6.*dg323) + 4.*dg112*dg333)*ginv33) + + ginv22*(ddg1212 - (dg123*(2.*dg122 + 4.*dg212) + dg113*dg222 + + dg122*(dg213 + 2.*dg312) + dg112*(4.*dg223 + 2.*dg322))*ginv23 - + ginv33*(dg133*dg212 + dg112*(dg233 + 2.*dg323) + + 2.*(dg113*dg223 + dg123*(dg213 + dg312) + pow2(dg123)))) - + (dg122*dg212 + dg112*dg222)*pow2(ginv22) - + (4.*(dg123*dg312 + dg112*dg323) + + 2.*(dg133*(dg122 + dg212) + dg123*dg213 + dg112*dg233 + + dg122*dg313 + dg113*(dg223 + dg322) + pow2(dg123)))*pow2(ginv23) \ +- (4.*(dg133*dg313 + dg113*dg333) + 2.*pow2(dg133))*pow2(ginv33)) +; + +dGfromgdu21 += +-((dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + dg211*dg333)* + Power(ginv13,3)) - 2.*(dg111*dg211*Power(ginv11,3) + + Power(ginv12,3)*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212))) + + (ddg1211 - (4.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - + 2.*(dg112 + dg211)*dg212*ginv22 - + (2.*(dg113*dg212 + (dg112 + dg211)*dg213) + dg212*dg311 + + dg211*dg312)*ginv23 - + (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33 - + ginv12*(4.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211)))*pow2(ginv11) \ ++ (ddg1222 + ddg2212 - (4.*(dg212*(dg123 + dg213) + + (dg112 + dg211)*dg223) + dg222*dg311 + + 2.*(dg122*dg213 + dg113*dg222 + dg212*dg312) + dg211*dg322)*ginv13 \ +- (2.*dg122 + 6.*dg212)*dg222*ginv22 - + ((2.*dg122 + 4.*dg212)*dg223 + + dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)*ginv23 - + (dg223*(2.*(dg123 + dg213) + dg312) + dg222*dg313 + dg213*dg322 + + dg212*dg323)*ginv33)*pow2(ginv12) + + (ddg1233 + ddg2313 - (2.*((dg123 + dg213)*dg223 + dg212*dg233) + + dg223*dg312 + dg212*dg323)*ginv22 - + (dg233*(4.*dg213 + 2.*dg312) + + 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + + dg212*dg333))*ginv23 - + (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33)*pow2(ginv13) + + ginv11*(ddg2313*ginv33 + ginv22* + (ddg2212 - (dg222*(2.*dg213 + dg312) + dg212*(4.*dg223 + dg322))* + ginv23 - (dg223*(2.*dg213 + dg312) + dg212*dg323)*ginv33) + + ginv23*(ddg2213 + ddg2312 - + (dg233*(2.*dg213 + dg312) + 2.*(dg223*dg313 + dg213*dg323) + + dg212*dg333)*ginv33) + + ginv13*(2.*ddg1213 + ddg2311 - + (2.*(dg112 + dg211)*dg223 + + dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv22 - + (2.*(dg133*dg213 + dg113*dg233) + dg233*dg311 + 6.*dg213*dg313 + + dg211*dg333)*ginv33 - + ginv23*(2.*(dg133*dg212 + dg123*dg213 + dg113*dg223 + + (dg112 + dg211)*dg233) + dg223*dg311 + dg211*dg323 + + 4.*(dg213*dg312 + dg212*dg313 + pow2(dg213)))) + + ginv12*(2.*ddg1212 + ddg2211 - + (6.*(dg113*dg212 + dg112*dg213) + 4.*dg111*dg223 + + 3.*dg212*dg311 + dg211*(4.*dg123 + 6.*dg213 + 3.*dg312))*ginv13 \ +- (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + + (dg112 + dg211)*dg223) + dg222*dg311 + + dg212*(8.*dg213 + 4.*dg312) + dg211*dg322)*ginv23 - + ginv22*(2.*(dg122*dg212 + (dg112 + dg211)*dg222) + + 6.*pow2(dg212)) - ginv33* + (dg223*dg311 + dg211*dg323 + + 2.*(dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313 + + pow2(dg213)))) - + (6.*dg112*dg212 + dg211*(2.*dg122 + 6.*dg212) + 2.*dg111*dg222)* + pow2(ginv12) - (2.*(dg133*dg211 + dg111*dg233) + + dg213*(6.*dg113 + 3.*dg311) + 3.*dg211*dg313)*pow2(ginv13) - + 2.*dg212*dg222*pow2(ginv22) - + (2.*(dg213*dg223 + dg212*dg233) + dg223*dg312 + dg222*dg313 + + dg213*dg322 + dg212*dg323)*pow2(ginv23) - + (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + + ginv12*(ddg2323*ginv33 + ginv13* + (2.*ddg1223 + ddg2213 + ddg2312 - + (2.*((dg123 + dg213)*dg222 + dg122*dg223) + dg222*dg312 + + dg212*(8.*dg223 + dg322))*ginv22 - + (dg223*(8.*dg213 + 4.*(dg123 + dg312)) + + 2.*(dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322) + + 4.*dg212*(dg233 + dg323))*ginv23 - + (2.*(dg133*dg223 + (dg123 + dg213)*dg233) + dg233*dg312 + + 4.*(dg223*dg313 + dg213*dg323) + dg212*dg333)*ginv33) + + ginv23*(ddg2223 + ddg2322 - + (dg233*(2.*dg223 + dg322) + 4.*dg223*dg323 + dg222*dg333)*ginv33) + + ginv22*(ddg2222 - dg222*(6.*dg223 + 2.*dg322)*ginv23 - + ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223))) - + (4.*(dg123*dg213 + dg113*dg223) + + 2.*((dg112 + dg211)*dg233 + dg223*dg311 + dg213*dg312 + + dg212*(dg133 + dg313) + dg211*dg323 + pow2(dg213)))*pow2(ginv13) \ +- 2.*(pow2(dg222)*pow2(ginv22) + + (dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223))*pow2(ginv23)) - + (dg233*dg323 + dg223*dg333)*pow2(ginv33)) + + ginv13*(ddg2333*ginv33 + ginv22* + (ddg2223 - 2.*dg223*(dg233 + dg323)*ginv33 - + ginv23*(dg223*dg322 + dg222*(2.*dg233 + dg323) + 4.*pow2(dg223))) + + ginv23*(ddg2233 + ddg2323 - + ginv33*(3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))) - + (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + dg222*dg333)* + pow2(ginv23) - 2.*(dg222*dg223*pow2(ginv22) + dg233*dg333*pow2(ginv33))\ +) +; + +dGfromgdu22 += +-((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)* + Power(ginv12,3)) - (dg233*(4.*dg223 + dg322) + 2.*dg223*dg323 + + dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv22,3)*pow2(dg222) - + (2.*dg111*dg211*ginv12 + (dg112*dg211 + dg111*dg212)*ginv22 + + (dg113*dg211 + dg111*dg213)*ginv23)*pow2(ginv11) + + (ddg1212 + ddg2211 - (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + + dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))*ginv13 - + (2.*(dg123*dg212 + dg122*dg213 + dg113*dg222 + dg112*dg223) + + dg222*dg311 + dg212*(8.*dg213 + 2.*dg312) + + dg211*(4.*dg223 + dg322))*ginv23 - + ginv22*(4.*dg211*dg222 + 3.*(dg122*dg212 + dg112*dg222) + + 6.*pow2(dg212)) - ginv33* + (dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + dg212*dg313 + + dg211*dg323 + 2.*pow2(dg213)))*pow2(ginv12) - + ((dg112*dg233 + dg223*(dg113 + dg311) + dg213*(dg123 + dg312) + + dg212*(dg133 + dg313) + dg211*dg323)*ginv22 + + (dg233*dg311 + 2.*(dg113*dg233 + dg213*(dg133 + dg313)) + + dg211*dg333)*ginv23)*pow2(ginv13) + + (ddg2222 - dg222*(8.*dg223 + 2.*dg322)*ginv23 - + ginv33*(dg223*dg322 + dg222*dg323 + 2.*pow2(dg223)))*pow2(ginv22) + + (ddg2233 + ddg2323 - ginv33* + (3.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233)))*pow2(ginv23) + + ginv13*(ginv22*(ddg1223 + ddg2312 - + (dg122*dg233 + dg222*(dg133 + dg313) + dg213*dg322 + + 4.*(dg223*(dg123 + dg213 + dg312) + dg212*(dg233 + dg323)))* + ginv23 - (dg233*(dg123 + dg312) + dg223*(dg133 + 2.*dg313) + + 2.*dg213*dg323 + dg212*dg333)*ginv33) + + ginv23*(ddg1233 + ddg2313 - + (dg233*(2.*dg133 + 3.*dg313) + 3.*dg213*dg333)*ginv33) - + ((dg122 + 4.*dg212)*dg223 + dg222*(dg123 + dg312) + dg212*dg322)* + pow2(ginv22) - (dg233*(4.*dg213 + 2.*dg312) + + 2.*(dg123*dg233 + dg223*(dg133 + dg313) + dg213*dg323 + + dg212*dg333))*pow2(ginv23)) + + ginv11*(-(ginv13*((2.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + + dg212*dg311 + dg211*(dg123 + dg312))*ginv22 + + (dg111*dg233 + dg213*(4.*dg113 + dg311) + dg211*(dg133 + dg313))* + ginv23)) + ginv12*(ddg1211 - + (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*ginv13 - + (6.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv22 - + (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + dg212*dg311 + + dg211*(dg123 + 4.*dg213 + dg312))*ginv23 - + (dg213*(2.*dg113 + dg311) + dg211*dg313)*ginv33) + + ginv22*(ddg1212 - (dg122*dg213 + dg113*dg222 + 2.*dg112*dg223 + + dg212*(4.*dg213 + 2.*(dg123 + dg312)))*ginv23 - + (dg113*dg223 + dg213*(dg123 + dg312) + dg212*dg313)*ginv33) + + ginv23*(ddg1213 - (dg113*dg233 + dg213*(dg133 + 2.*dg313))*ginv33) - + (3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))*pow2(ginv12) - + (dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))*pow2(ginv22) - + (dg113*dg223 + dg112*dg233 + dg213*(dg123 + dg312) + + dg212*(dg133 + dg313) + 2.*pow2(dg213))*pow2(ginv23)) + + ginv23*(ddg2333*ginv33 - 2.*dg233*dg333*pow2(ginv33)) + + ginv12*(ddg2313*ginv33 + ginv22* + (ddg1222 + 2.*ddg2212 - + ((3.*dg122 + 12.*dg212)*dg223 + + dg222*(8.*dg213 + 3.*(dg123 + dg312)) + 3.*dg212*dg322)*ginv23 \ +- (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + dg222*dg313 + dg213*dg322 + + 2.*dg212*dg323)*ginv33) + + ginv23*(ddg1223 + 2.*ddg2213 + ddg2312 - + (dg233*(dg123 + 4.*dg213 + dg312) + dg223*(dg133 + 4.*dg313) + + 4.*dg213*dg323 + dg212*dg333)*ginv33) + + ginv13*(ddg1213 + ddg2311 - + (dg122*dg213 + dg222*(dg113 + dg311) + + 4.*((dg112 + dg211)*dg223 + dg212*(dg123 + dg213 + dg312)) + + dg211*dg322)*ginv22 - + (dg233*(dg113 + dg311) + dg213*(dg133 + 4.*dg313) + dg211*dg333)* + ginv33 - ginv23*(2.*(dg133*dg212 + dg112*dg233 + dg223*dg311 + + dg211*dg323) + 4.* + (dg113*dg223 + dg211*dg233 + dg213*(dg123 + dg312) + + dg212*dg313 + pow2(dg213)))) - + (dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* + pow2(ginv13) - (2.*dg122 + 8.*dg212)*dg222*pow2(ginv22) - + ((dg122 + 4.*dg212)*dg233 + dg223*(8.*dg213 + 2.*(dg123 + dg312)) + + dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* + pow2(ginv23) - (dg233*dg313 + dg213*dg333)*pow2(ginv33)) + + ginv22*(ddg2323*ginv33 + ginv23* + (2.*ddg2223 + ddg2322 - (dg233*(4.*dg223 + dg322) + 6.*dg223*dg323 + + dg222*dg333)*ginv33) - + (3.*dg223*dg322 + dg222*(4.*dg233 + 3.*dg323) + 6.*pow2(dg223))* + pow2(ginv23) - (dg233*dg323 + dg223*dg333)*pow2(ginv33)) +; + +dGfromgdu23 += +-((dg111*dg233 + 2.*dg213*(dg113 + dg311) + dg211*(dg133 + 2.*dg313))* + Power(ginv13,3)) - (2.*dg111*dg211*ginv13 + + (dg112*dg211 + dg111*dg212)*ginv23 + + (dg113*dg211 + dg111*dg213)*ginv33)*pow2(ginv11) - + ((2.*dg112*dg212 + dg211*(dg122 + 4.*dg212) + dg111*dg222)*ginv13 + + (dg122*dg213 + dg212*(dg123 + 2.*dg213) + dg113*dg222 + + (dg112 + 2.*dg211)*dg223)*ginv33 + + 2.*ginv23*(dg122*dg212 + (dg112 + dg211)*dg222 + pow2(dg212)))* + pow2(ginv12) + (ddg1213 + ddg2311 - + ((dg112 + 2.*dg211)*dg223 + dg212*(dg123 + 2.*(dg213 + dg312)))* + ginv22 - (3.*(dg133*dg213 + dg113*dg233) + 6.*dg213*dg313 + + 2.*(dg233*dg311 + dg211*dg333))*ginv33 - + ginv23*(4.*(dg213*dg312 + dg212*dg313) + + 2.*(dg133*dg212 + dg123*dg213 + (dg112 + dg211)*dg233 + + dg223*(dg113 + dg311) + dg211*dg323 + pow2(dg213))))*pow2(ginv13) \ +- 2.*(dg233*dg333*Power(ginv33,3) + + Power(ginv23,3)*(dg223*dg322 + dg222*(dg233 + dg323) + pow2(dg223)) + + (dg222*dg223*ginv33 + ginv23*pow2(dg222))*pow2(ginv22)) + + (ddg2223 + ddg2322 - (dg233*(6.*dg223 + 2.*dg322) + 6.*dg223*dg323 + + 2.*dg222*dg333)*ginv33)*pow2(ginv23) + ddg2333*pow2(ginv33) + + ginv11*(ddg1213*ginv33 + ginv13* + (ddg1211 - 2.*(dg112 + dg211)*dg212*ginv22 - + (4.*(dg113*dg212 + dg112*dg213) + dg111*dg223 + 2.*dg212*dg311 + + dg211*(dg123 + 2.*(dg213 + dg312)))*ginv23 - + (dg111*dg233 + dg213*(6.*dg113 + 2.*dg311) + + dg211*(dg133 + 2.*dg313))*ginv33) - + ginv12*((4.*dg112*dg212 + dg211*(dg122 + 2.*dg212) + dg111*dg222)* + ginv23 + (dg211*(dg123 + 2.*dg213) + + 2.*(dg113*dg212 + dg112*dg213) + dg111*dg223)*ginv33 + + ginv13*(3.*(dg112*dg211 + dg111*dg212) + 2.*pow2(dg211))) - + ginv22*((dg212*(dg123 + 2.*dg213) + dg112*dg223)*ginv33 + + ginv23*(dg122*dg212 + dg112*dg222 + 2.*pow2(dg212))) + + ginv23*(ddg1212 - ginv33* + (dg112*dg233 + dg212*(dg133 + 2.*dg313) + + 2.*(dg113*dg223 + dg213*(dg123 + dg312) + pow2(dg213)))) - + (3.*(dg113*dg211 + dg111*dg213) + 2.*dg211*dg311)*pow2(ginv13) - + (dg122*dg213 + dg113*dg222 + dg112*dg223 + + dg212*(dg123 + 2.*(dg213 + dg312)))*pow2(ginv23) - + (dg113*dg233 + dg213*(dg133 + 2.*dg313))*pow2(ginv33)) + + ginv22*(ddg2223*ginv33 + ginv23* + (ddg2222 - ginv33*(2.*(dg223*dg322 + dg222*(dg233 + dg323)) + + 6.*pow2(dg223))) - dg222*(6.*dg223 + 2.*dg322)*pow2(ginv23) - + 2.*dg223*(dg233 + dg323)*pow2(ginv33)) + + ginv12*((ddg1223 + ddg2213)*ginv33 - + ginv22*((2.*dg122 + 6.*dg212)*dg222*ginv23 + + ((dg123 + 2.*dg213)*dg222 + (dg122 + 4.*dg212)*dg223)*ginv33) + + ginv23*(ddg1222 + ddg2212 - + ((dg122 + 2.*dg212)*dg233 + + dg223*(4.*dg123 + 8.*dg213 + 2.*dg312) + + dg222*(dg133 + 2.*dg313) + 2.*(dg213*dg322 + dg212*dg323))* + ginv33) + ginv13*(ddg1212 + ddg2211 - + (4.*(dg112 + dg211)*dg223 + + dg212*(8.*dg213 + 4.*(dg123 + dg312)) + + 2.*(dg122*dg213 + dg222*(dg113 + dg311) + dg211*dg322))*ginv23 \ +- ginv22*(dg122*dg212 + (dg112 + 2.*dg211)*dg222 + 4.*pow2(dg212)) - + ginv33*((dg112 + 2.*dg211)*dg233 + dg212*(dg133 + 2.*dg313) + + 2.*(dg223*dg311 + dg213*dg312 + dg211*dg323) + + 4.*(dg123*dg213 + dg113*dg223 + pow2(dg213)))) - + (2.*(dg123*dg211 + dg112*dg213 + dg111*dg223 + + dg212*(dg113 + dg311)) + dg211*(4.*dg213 + 2.*dg312))* + pow2(ginv13) - ((2.*dg122 + 4.*dg212)*dg223 + + dg222*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*dg322)* + pow2(ginv23) - ((dg123 + 2.*dg213)*dg233 + + dg223*(dg133 + 2.*dg313) + 2.*dg213*dg323)*pow2(ginv33)) + + ginv13*((ddg1233 + 2.*ddg2313)*ginv33 + + ginv22*(ddg2212 - ((dg122 + 8.*dg212)*dg223 + + dg222*(dg123 + 2.*(dg213 + dg312)) + 2.*dg212*dg322)*ginv23 - + (dg223*(4.*dg213 + 2.*(dg123 + dg312)) + 2.*dg212*(dg233 + dg323))* + ginv33) + ginv23*(ddg1223 + ddg2213 + 2.*ddg2312 - + (3.*(dg133*dg223 + dg123*dg233) + dg233*(6.*dg213 + 4.*dg312) + + 6.*(dg223*dg313 + dg213*dg323) + 4.*dg212*dg333)*ginv33) - + 2.*dg212*dg222*pow2(ginv22) - + ((dg122 + 4.*dg212)*dg233 + dg223*(2.*dg123 + 4.*(dg213 + dg312)) + + dg222*(dg133 + 2.*dg313) + 2.*dg213*dg322 + 4.*dg212*dg323)* + pow2(ginv23) - (dg233*(2.*dg133 + 4.*dg313) + 4.*dg213*dg333)* + pow2(ginv33)) + ginv23*((ddg2233 + 2.*ddg2323)*ginv33 - + (4.*(dg233*dg323 + dg223*dg333) + 2.*pow2(dg233))*pow2(ginv33)) +; + +dGfromgdu31 += +-((dg222*dg311 + dg211*dg322 + 2.*((dg122 + dg212)*dg312 + dg112*dg322))* + Power(ginv12,3)) - 2.*(dg111*dg311*Power(ginv11,3) + + Power(ginv13,3)*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313))) + + (ddg1311 - ((4.*dg112 + 2.*dg211)*dg311 + 4.*dg111*dg312)*ginv12 - + (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - + (dg311*(dg213 + 2.*dg312) + dg211*dg313 + + 2.*(dg113*dg312 + dg112*dg313))*ginv23 - + 2.*(dg113 + dg311)*dg313*ginv33 - + ginv13*(4.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311)))*pow2(ginv11) \ ++ (ddg1322 + ddg2312 - (2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))* + ginv22 - ((2.*dg213 + 4.*dg312)*dg322 + + 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + + (dg122 + dg212)*dg323))*ginv23 - + (dg313*(dg223 + 2.*dg322) + (dg213 + 2.*(dg123 + dg312))*dg323)* + ginv33 - ginv13*(4.*(dg123*dg312 + dg112*dg323) + + 2.*(dg213*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + + dg311*(dg223 + dg322) + dg211*dg323 + pow2(dg312))))*pow2(ginv12) \ ++ (ddg1333 + ddg3313 - (dg233*dg312 + dg223*dg313 + + (dg213 + 2.*(dg123 + dg312))*dg323 + dg212*dg333)*ginv22 - + (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + + 4.*(dg313*dg323 + dg312*dg333))*ginv23 - + (2.*dg133 + 6.*dg313)*dg333*ginv33)*pow2(ginv13) + + ginv11*(ddg3313*ginv33 + ginv22* + (ddg2312 - (dg222*dg313 + dg213*dg322 + + 2.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - + (dg223*dg313 + (dg213 + 2.*dg312)*dg323)*ginv33) + + ginv23*(ddg2313 + ddg3312 - + (dg313*(dg233 + 4.*dg323) + (dg213 + 2.*dg312)*dg333)*ginv33) + + ginv12*(2.*ddg1312 + ddg2311 - + (dg311*(4.*dg123 + 3.*dg213 + 6.*dg312) + 3.*dg211*dg313 + + 6.*(dg113*dg312 + dg112*dg313) + 4.*dg111*dg323)*ginv13 - + (dg222*dg311 + (2.*dg122 + 6.*dg212)*dg312 + + (2.*dg112 + dg211)*dg322)*ginv22 - + (4.*dg312*dg313 + 2.*((dg123 + dg213)*dg313 + + (dg113 + dg311)*dg323))*ginv33 - + ginv23*((2.*dg123 + 4.*dg213)*dg312 + dg311*(dg223 + 2.*dg322) + + dg211*dg323 + 2.*(dg122*dg313 + dg113*dg322 + dg112*dg323) + + 4.*(dg212*dg313 + pow2(dg312)))) + + ginv13*(2.*ddg1313 + ddg3311 - + ((4.*dg213 + 8.*dg312)*dg313 + dg311*(dg233 + 2.*dg323) + + dg211*dg333 + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + + dg112*dg333))*ginv23 - + ginv22*(dg223*dg311 + dg211*dg323 + + 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + + pow2(dg312))) - + ginv33*(2.*(dg133*dg313 + (dg113 + dg311)*dg333) + 6.*pow2(dg313))) \ +- ((2.*dg122 + 3.*dg212)*dg311 + (6.*dg112 + 3.*dg211)*dg312 + + 2.*dg111*dg322)*pow2(ginv12) - + (6.*dg113*dg313 + dg311*(2.*dg133 + 6.*dg313) + 2.*dg111*dg333)* + pow2(ginv13) - (dg222*dg312 + dg212*dg322)*pow2(ginv22) - + (dg313*(dg223 + 2.*dg322) + dg213*dg323 + dg312*(dg233 + 2.*dg323) + + dg212*dg333)*pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + + ginv12*(ddg3323*ginv33 + ginv13* + (2.*ddg1323 + ddg2313 + ddg3312 - + (dg222*dg313 + (2.*dg123 + dg213)*dg322 + + dg312*(4.*dg223 + 2.*dg322) + (2.*dg122 + 4.*dg212)*dg323)* + ginv22 - ((4.*dg213 + 8.*dg312)*dg323 + + 4.*(dg313*(dg223 + dg322) + dg123*dg323) + + 2.*(dg233*dg312 + dg133*dg322 + (dg122 + dg212)*dg333))*ginv23 \ +- (dg313*(dg233 + 8.*dg323) + (dg213 + 2.*dg312)*dg333 + + 2.*(dg133*dg323 + dg123*dg333))*ginv33) + + ginv22*(ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - + ginv23*(3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))) + + ginv23*(ddg2323 + ddg3322 - + ginv33*(dg233*dg323 + (dg223 + 2.*dg322)*dg333 + 4.*pow2(dg323))) - + (dg311*(dg233 + 4.*dg323) + + 4.*((dg123 + dg312)*dg313 + dg113*dg323) + dg211*dg333 + + 2.*(dg133*dg312 + dg213*dg313 + dg112*dg333))*pow2(ginv13) - + (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* + pow2(ginv23) - 2.*(dg222*dg322*pow2(ginv22) + + dg323*dg333*pow2(ginv33))) + + ginv13*(ddg3333*ginv33 + ginv23* + (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33) + + ginv22*(ddg2323 - (4.*dg223*dg323 + dg322*(dg233 + 2.*dg323) + + dg222*dg333)*ginv23 - + ginv33*(dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))) - + (dg223*dg322 + dg222*dg323)*pow2(ginv22) - + 2.*((dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))*pow2(ginv23) + + pow2(dg333)*pow2(ginv33))) +; + +dGfromgdu32 += +-(((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* + Power(ginv12,3)) - 2.*(dg222*dg322*Power(ginv22,3) + + Power(ginv23,3)*(dg233*dg323 + (dg223 + dg322)*dg333 + pow2(dg323))) - + (2.*dg111*dg311*ginv12 + (dg112*dg311 + dg111*dg312)*ginv22 + + (dg113*dg311 + dg111*dg313)*ginv23)*pow2(ginv11) + + (ddg1312 + ddg2311 - (4.*dg311*dg312 + + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + + (dg112 + dg211)*dg313 + dg111*dg323))*ginv13 - + ((3.*dg122 + 6.*dg212)*dg312 + 3.*dg112*dg322 + + 2.*(dg222*dg311 + dg211*dg322))*ginv22 - + ((dg123 + 2.*(dg213 + dg312))*dg313 + (dg113 + 2.*dg311)*dg323)* + ginv33 - ginv23*(4.*(dg213*dg312 + dg212*dg313) + + 2.*(dg123*dg312 + dg122*dg313 + dg113*dg322 + + dg311*(dg223 + dg322) + (dg112 + dg211)*dg323 + pow2(dg312))))* + pow2(ginv12) - ((dg123*dg313 + dg312*(dg133 + 2.*dg313) + + (dg113 + 2.*dg311)*dg323 + dg112*dg333)*ginv22 + + 2.*ginv23*(dg133*dg313 + (dg113 + dg311)*dg333 + pow2(dg313)))* + pow2(ginv13) + (ddg2322 - 2.*(dg223 + dg322)*dg323*ginv33 - + ginv23*(4.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322)))*pow2(ginv22) \ ++ (ddg2333 + ddg3323 - (2.*dg233 + 6.*dg323)*dg333*ginv33)*pow2(ginv23) + + ginv11*(-(ginv13*((dg311*(dg123 + 2.*dg312) + + 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv22 + + (4.*dg113*dg313 + dg311*(dg133 + 2.*dg313) + dg111*dg333)*ginv23)\ +) + ginv12*(ddg1311 - ((dg122 + 2.*dg212)*dg311 + + (6.*dg112 + 2.*dg211)*dg312 + dg111*dg322)*ginv22 - + (dg311*(dg123 + 2.*(dg213 + dg312)) + 2.*dg211*dg313 + + 4.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv23 - + 2.*(dg113 + dg311)*dg313*ginv33 - + ginv13*(3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))) + + ginv22*(ddg1312 - ((dg123 + 2.*dg312)*dg313 + dg113*dg323)*ginv33 - + ginv23*(dg122*dg313 + dg113*dg322 + + 2.*((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323 + + pow2(dg312)))) + + ginv23*(ddg1313 - ginv33* + (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))) - + ((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*pow2(ginv12) - + ((dg122 + 2.*dg212)*dg312 + dg112*dg322)*pow2(ginv22) - + (dg133*dg312 + (dg123 + 2.*(dg213 + dg312))*dg313 + dg113*dg323 + + dg112*dg333)*pow2(ginv23)) + + ginv13*(ginv23*(ddg1333 + ddg3313 - (2.*dg133 + 6.*dg313)*dg333*ginv33) + + ginv22*(ddg1323 + ddg3312 - + (dg133*dg322 + (4.*dg123 + 2.*dg213 + 8.*dg312)*dg323 + + dg122*dg333 + 2.*(dg233*dg312 + dg313*(dg223 + dg322) + + dg212*dg333))*ginv23 - + ((dg133 + 4.*dg313)*dg323 + (dg123 + 2.*dg312)*dg333)*ginv33) - + (dg123*dg322 + dg122*dg323 + + 2.*(dg312*(dg223 + dg322) + dg212*dg323))*pow2(ginv22) - + (2.*(dg233*dg313 + dg133*dg323 + (dg123 + dg213)*dg333) + + 4.*(dg313*dg323 + dg312*dg333))*pow2(ginv23)) + + ginv12*(ddg3313*ginv33 + ginv22* + (ddg1322 + 2.*ddg2312 - + (4.*(dg222*dg313 + dg213*dg322) + + 3.*(dg123*dg322 + dg122*dg323) + + 6.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 - + ((2.*dg213 + 4.*dg312)*dg323 + + 2.*(dg313*(dg223 + dg322) + dg123*dg323))*ginv33) + + ginv23*(ddg1323 + 2.*ddg2313 + ddg3312 - + (dg133*dg323 + dg313*(2.*dg233 + 8.*dg323) + + (dg123 + 2.*(dg213 + dg312))*dg333)*ginv33) + + ginv13*(ddg1313 + ddg3311 - + (8.*dg312*dg313 + 4.* + ((dg123 + dg213)*dg313 + (dg113 + dg311)*dg323) + + 2.*(dg233*dg311 + dg133*dg312 + (dg112 + dg211)*dg333))*ginv23 \ +- ginv22*(dg122*dg313 + dg113*dg322 + + 2.*(dg213*dg312 + dg212*dg313 + dg311*(dg223 + dg322) + + dg211*dg323) + 4.*(dg123*dg312 + dg112*dg323 + pow2(dg312))) \ +- ginv33*(dg133*dg313 + (dg113 + 2.*dg311)*dg333 + 4.*pow2(dg313))) - + (2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* + pow2(ginv13) - (2.*dg122*dg322 + 4.*(dg222*dg312 + dg212*dg322))* + pow2(ginv22) - (dg133*dg322 + + 4.*(dg313*(dg223 + dg322) + (dg213 + dg312)*dg323) + + dg122*dg333 + 2.*(dg233*dg312 + dg123*dg323 + dg212*dg333))* + pow2(ginv23) - 2.*dg313*dg333*pow2(ginv33)) + + ginv22*(ddg3323*ginv33 + ginv23* + (2.*ddg2323 + ddg3322 - + ginv33*(2.*(dg233*dg323 + (dg223 + dg322)*dg333) + 6.*pow2(dg323))) \ +- (6.*dg223*dg323 + dg322*(2.*dg233 + 6.*dg323) + 2.*dg222*dg333)* + pow2(ginv23) - 2.*dg323*dg333*pow2(ginv33)) + + ginv23*(ddg3333*ginv33 - 2.*pow2(dg333)*pow2(ginv33)) +; + +dGfromgdu33 += +-((2.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)* + Power(ginv13,3)) - (2.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + + dg222*dg333)*Power(ginv23,3) - 2.*Power(ginv33,3)*pow2(dg333) - + (2.*dg111*dg311*ginv13 + (dg112*dg311 + dg111*dg312)*ginv23 + + (dg113*dg311 + dg111*dg313)*ginv33)*pow2(ginv11) - + (((dg122 + 2.*dg212)*dg311 + 2.*(dg112 + dg211)*dg312 + dg111*dg322)* + ginv13 + (dg222*dg311 + dg211*dg322 + + 2.*((dg122 + dg212)*dg312 + dg112*dg322))*ginv23 + + (dg223*dg311 + (dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + + dg113*dg322 + (dg112 + dg211)*dg323)*ginv33)*pow2(ginv12) + + (ddg1313 + ddg3311 - ((2.*dg213 + 8.*dg312)*dg313 + + dg311*(dg233 + 4.*dg323) + dg211*dg333 + + 2.*(dg133*dg312 + dg123*dg313 + dg113*dg323 + dg112*dg333))*ginv23 \ +- ginv22*(dg223*dg311 + (dg123 + dg213)*dg312 + dg212*dg313 + + (dg112 + dg211)*dg323 + 2.*pow2(dg312)) - + ginv33*(4.*dg311*dg333 + 3.*(dg133*dg313 + dg113*dg333) + + 6.*pow2(dg313)))*pow2(ginv13) - + (2.*dg222*dg322*ginv23 + (dg223*dg322 + dg222*dg323)*ginv33)* + pow2(ginv22) + (ddg2323 + ddg3322 - + ginv33*(4.*dg322*dg333 + 3.*(dg233*dg323 + dg223*dg333) + + 6.*pow2(dg323)))*pow2(ginv23) + ddg3333*pow2(ginv33) + + ginv13*((ddg1333 + 2.*ddg3313)*ginv33 + + ginv22*(ddg2312 - (dg222*dg313 + (dg123 + dg213)*dg322 + + dg122*dg323 + 4.*(dg312*(dg223 + dg322) + dg212*dg323))*ginv23 \ +- (dg312*(dg233 + 4.*dg323) + 2.*(dg223*dg313 + (dg123 + dg213)*dg323) + + dg212*dg333)*ginv33) + + ginv23*(ddg1323 + ddg2313 + 2.*ddg3312 - + (12.*dg313*dg323 + (3.*dg213 + 8.*dg312)*dg333 + + 3.*(dg233*dg313 + dg133*dg323 + dg123*dg333))*ginv33) - + (dg222*dg312 + dg212*dg322)*pow2(ginv22) - + ((dg133 + 4.*dg313)*dg322 + (2.*dg213 + 8.*dg312)*dg323 + + dg122*dg333 + 2.*(dg233*dg312 + dg223*dg313 + dg123*dg323 + + dg212*dg333))*pow2(ginv23) - + (2.*dg133 + 8.*dg313)*dg333*pow2(ginv33)) + + ginv23*((ddg2333 + 2.*ddg3323)*ginv33 - + (2.*dg233 + 8.*dg323)*dg333*pow2(ginv33)) + + ginv12*((ddg1323 + ddg2313)*ginv33 - + ginv22*((2.*dg122*dg322 + 3.*(dg222*dg312 + dg212*dg322))*ginv23 + + (dg222*dg313 + (dg123 + dg213)*dg322 + dg122*dg323 + + 2.*(dg223*dg312 + dg212*dg323))*ginv33) + + ginv23*(ddg1322 + ddg2312 - + (dg233*dg312 + dg133*dg322 + + 4.*(dg313*(dg223 + dg322) + (dg123 + dg213 + dg312)*dg323) + + (dg122 + dg212)*dg333)*ginv33) + + ginv13*(ddg1312 + ddg2311 - + (dg222*dg311 + (dg122 + 4.*dg212)*dg312 + (dg112 + dg211)*dg322)* + ginv22 - (dg133*dg312 + dg311*(dg233 + 4.*dg323) + + 4.*((dg123 + dg213 + dg312)*dg313 + dg113*dg323) + + (dg112 + dg211)*dg333)*ginv33 - + ginv23*(2.*(dg223*dg311 + dg122*dg313 + dg113*dg322 + + dg211*dg323) + 4.* + ((dg123 + dg213)*dg312 + dg212*dg313 + dg311*dg322 + + dg112*dg323 + pow2(dg312)))) - + (4.*dg311*dg312 + 2.*((dg123 + dg213)*dg311 + dg113*dg312 + + (dg112 + dg211)*dg313 + dg111*dg323))*pow2(ginv13) - + ((2.*dg213 + 4.*dg312)*dg322 + + 2.*(dg223*dg312 + dg222*dg313 + dg123*dg322 + + (dg122 + dg212)*dg323))*pow2(ginv23) - + (dg133*dg323 + dg313*(dg233 + 4.*dg323) + (dg123 + dg213)*dg333)* + pow2(ginv33)) + ginv11*(ddg1313*ginv33 - + ginv12*(((3.*dg112 + 2.*dg211)*dg311 + 3.*dg111*dg312)*ginv13 + + ((dg122 + dg212)*dg311 + (4.*dg112 + dg211)*dg312 + dg111*dg322)* + ginv23 + ((dg123 + dg213)*dg311 + dg211*dg313 + + 2.*(dg113*dg312 + dg112*dg313) + dg111*dg323)*ginv33) - + ginv22*(((dg122 + 2.*dg212)*dg312 + dg112*dg322)*ginv23 + + ((dg123 + dg213)*dg312 + dg212*dg313 + dg112*dg323)*ginv33) + + ginv13*(ddg1311 - (dg212*dg311 + (2.*dg112 + dg211)*dg312)*ginv22 - + ((dg123 + dg213)*dg311 + 4.*(dg113 + dg311)*dg312 + + (4.*dg112 + dg211)*dg313 + dg111*dg323)*ginv23 - + (6.*dg113*dg313 + dg311*(dg133 + 4.*dg313) + dg111*dg333)*ginv33) + + ginv23*(ddg1312 - (dg312*(dg133 + 4.*dg313) + + 2.*((dg123 + dg213)*dg313 + dg113*dg323) + dg112*dg333)*ginv33) \ +- (3.*(dg113*dg311 + dg111*dg313) + 2.*pow2(dg311))*pow2(ginv13) - + ((dg123 + dg213)*dg312 + (dg122 + dg212)*dg313 + dg113*dg322 + + dg112*dg323 + 2.*pow2(dg312))*pow2(ginv23) - + (dg133*dg313 + dg113*dg333 + 2.*pow2(dg313))*pow2(ginv33)) + + ginv22*(ddg2323*ginv33 + ginv23* + (ddg2322 - (6.*dg223*dg323 + dg322*(dg233 + 4.*dg323) + dg222*dg333)* + ginv33) - (3.*(dg223*dg322 + dg222*dg323) + 2.*pow2(dg322))* + pow2(ginv23) - (dg233*dg323 + dg223*dg333 + 2.*pow2(dg323))* + pow2(ginv33)) +; + +R11 += +dG11*g11 + dG12*g12 + dG13*g13 + gammado111*Gfromg1 + gammado112*Gfromg2 + + gammado113*Gfromg3 + (-0.5*ddg1111 + 3.*gamma111*gammado111 + + 2.*(gamma211*gammado112 + gamma311*gammado113) + + gamma211*gammado211 + gamma311*gammado311)*ginv11 + + (-ddg1211 + 3.*(gamma112*gammado111 + gamma111*gammado112) + + 2.*(gamma212*gammado112 + gamma312*gammado113 + + gamma211*gammado122 + gamma311*gammado123) + gamma212*gammado211 + + gamma211*gammado212 + gamma312*gammado311 + gamma311*gammado312)*ginv12 \ ++ (-ddg1311 + 3.*(gamma113*gammado111 + gamma111*gammado113) + + 2.*(gamma213*gammado112 + gamma313*gammado113 + + gamma211*gammado123 + gamma311*gammado133) + gamma213*gammado211 + + gamma211*gammado213 + gamma313*gammado311 + gamma311*gammado313)*ginv13 \ ++ (-0.5*ddg2211 + 3.*gamma112*gammado112 + + 2.*(gamma212*gammado122 + gamma312*gammado123) + + gamma212*gammado212 + gamma312*gammado312)*ginv22 + + (-ddg2311 + 3.*(gamma113*gammado112 + gamma112*gammado113) + + 2.*(gamma213*gammado122 + (gamma212 + gamma313)*gammado123 + + gamma312*gammado133) + gamma213*gammado212 + gamma212*gammado213 + + gamma313*gammado312 + gamma312*gammado313)*ginv23 + + (-0.5*ddg3311 + 3.*gamma113*gammado113 + + 2.*(gamma213*gammado123 + gamma313*gammado133) + gamma213*gammado213 + + gamma313*gammado313)*ginv33 +; + +R12 += +0.5*(dG21*g11 + (dG11 + dG22)*g12 + dG23*g13 + dG12*g22 + dG13*g23 + + (gammado112 + gammado211)*Gfromg1 + + (gammado122 + gammado212)*Gfromg2 + (gammado123 + gammado213)*Gfromg3) \ ++ (-0.5*ddg1112 + gamma112*gammado111 + (gamma111 + gamma212)*gammado112 + + gamma312*gammado113 + gamma111*gammado211 + 2.*gamma211*gammado212 + + gamma311*(gammado213 + gammado312))*ginv11 + + (-ddg1212 + gamma122*gammado111 + (2.*gamma112 + gamma222)*gammado112 + + gamma322*gammado113 + (gamma111 + gamma212)*gammado122 + + gamma112*gammado211 + (gamma111 + 2.*gamma212)*gammado212 + + 2.*gamma211*gammado222 + + gamma312*(gammado123 + gammado213 + gammado312) + + gamma311*(gammado223 + gammado322))*ginv12 + + (-ddg1312 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + + (gamma112 + gamma323)*gammado113 + (gamma111 + gamma212)*gammado123 + + gamma312*gammado133 + gamma113*gammado211 + + (gamma111 + gamma313)*gammado213 + + 2.*(gamma213*gammado212 + gamma211*gammado223) + + gamma313*gammado312 + gamma311*(gammado233 + gammado323))*ginv13 + + (-0.5*ddg2212 + gamma122*gammado112 + (gamma112 + gamma222)*gammado122 + + gamma322*gammado123 + gamma112*gammado212 + 2.*gamma212*gammado222 + + gamma312*(gammado223 + gammado322))*ginv22 + + (-ddg2312 + gamma123*gammado112 + gamma122*gammado113 + + (gamma113 + gamma223)*gammado122 + + (gamma112 + gamma222 + gamma323)*gammado123 + gamma322*gammado133 + + gamma113*gammado212 + gamma112*gammado213 + + 2.*(gamma213*gammado222 + gamma212*gammado223) + + gamma313*(gammado223 + gammado322) + + gamma312*(gammado233 + gammado323))*ginv23 + + (-0.5*ddg3312 + gamma123*gammado113 + (gamma113 + gamma223)*gammado123 + + gamma323*gammado133 + gamma113*gammado213 + 2.*gamma213*gammado223 + + gamma313*(gammado233 + gammado323))*ginv33 +; + +R13 += +0.5*(dG31*g11 + dG32*g12 + (dG11 + dG33)*g13 + dG12*g23 + dG13*g33 + + (gammado113 + gammado311)*Gfromg1 + + (gammado123 + gammado312)*Gfromg2 + (gammado133 + gammado313)*Gfromg3) \ ++ (-0.5*ddg1113 + gamma113*gammado111 + gamma213*gammado112 + + (gamma111 + gamma313)*gammado113 + gamma111*gammado311 + + gamma211*(gammado213 + gammado312) + 2.*gamma311*gammado313)*ginv11 + + (-ddg1213 + gamma123*gammado111 + (gamma113 + gamma223)*gammado112 + + (gamma112 + gamma323)*gammado113 + gamma213*gammado122 + + (gamma111 + gamma313)*gammado123 + gamma112*gammado311 + + gamma111*gammado312 + gamma212*(gammado213 + gammado312) + + gamma211*(gammado223 + gammado322) + + 2.*(gamma312*gammado313 + gamma311*gammado323))*ginv12 + + (-ddg1313 + gamma133*gammado111 + gamma233*gammado112 + + (2.*gamma113 + gamma333)*gammado113 + + (gamma111 + gamma313)*gammado133 + gamma113*gammado311 + + gamma213*(gammado123 + gammado213 + gammado312) + + (gamma111 + 2.*gamma313)*gammado313 + + gamma211*(gammado233 + gammado323) + 2.*gamma311*gammado333)*ginv13 + + (-0.5*ddg2213 + gamma123*gammado112 + gamma223*gammado122 + + (gamma112 + gamma323)*gammado123 + gamma112*gammado312 + + gamma212*(gammado223 + gammado322) + 2.*gamma312*gammado323)*ginv22 + + (-ddg2313 + gamma133*gammado112 + gamma123*gammado113 + + gamma233*gammado122 + (gamma113 + gamma223 + gamma333)*gammado123 + + (gamma112 + gamma323)*gammado133 + gamma113*gammado312 + + gamma112*gammado313 + gamma213*(gammado223 + gammado322) + + gamma212*(gammado233 + gammado323) + + 2.*(gamma313*gammado323 + gamma312*gammado333))*ginv23 + + (-0.5*ddg3313 + gamma133*gammado113 + gamma233*gammado123 + + (gamma113 + gamma333)*gammado133 + gamma113*gammado313 + + gamma213*(gammado233 + gammado323) + 2.*gamma313*gammado333)*ginv33 +; + +R22 += +dG21*g12 + dG22*g22 + dG23*g23 + gammado212*Gfromg1 + gammado222*Gfromg2 + + gammado223*Gfromg3 + (-0.5*ddg1122 + + gamma112*(gammado112 + 2.*gammado211) + 3.*gamma212*gammado212 + + gamma312*(2.*gammado213 + gammado312))*ginv11 + + (-ddg1222 + gamma122*(gammado112 + 2.*gammado211) + + gamma112*(gammado122 + 2.*gammado212) + + 3.*(gamma222*gammado212 + gamma212*gammado222) + + 2.*(gamma322*gammado213 + gamma312*gammado223) + + gamma322*gammado312 + gamma312*gammado322)*ginv12 + + (-ddg1322 + gamma123*(gammado112 + 2.*gammado211) + + gamma112*(gammado123 + 2.*gammado213) + + 3.*(gamma223*gammado212 + gamma212*gammado223) + + 2.*(gamma323*gammado213 + gamma312*gammado233) + + gamma323*gammado312 + gamma312*gammado323)*ginv13 + + (-0.5*ddg2222 + gamma122*(gammado122 + 2.*gammado212) + + 3.*gamma222*gammado222 + gamma322*(2.*gammado223 + gammado322))*ginv22 \ ++ (-ddg2322 + gamma123*(gammado122 + 2.*gammado212) + + gamma122*(gammado123 + 2.*gammado213) + + 3.*(gamma223*gammado222 + gamma222*gammado223) + + 2.*(gamma323*gammado223 + gamma322*gammado233) + + gamma323*gammado322 + gamma322*gammado323)*ginv23 + + (-0.5*ddg3322 + gamma123*(gammado123 + 2.*gammado213) + + 3.*gamma223*gammado223 + gamma323*(2.*gammado233 + gammado323))*ginv33 +; + +R23 += +0.5*(dG31*g12 + dG21*g13 + dG32*g22 + (dG22 + dG33)*g23 + dG23*g33 + + (gammado213 + gammado312)*Gfromg1 + + (gammado223 + gammado322)*Gfromg2 + (gammado233 + gammado323)*Gfromg3) \ ++ (-0.5*ddg1123 + gamma113*gammado211 + gamma213*gammado212 + + (gamma212 + gamma313)*gammado213 + + gamma112*(gammado113 + gammado311) + gamma212*gammado312 + + 2.*gamma312*gammado313)*ginv11 + + (-ddg1223 + gamma123*gammado211 + (gamma113 + gamma223)*gammado212 + + (gamma222 + gamma323)*gammado213 + gamma213*gammado222 + + (gamma212 + gamma313)*gammado223 + + gamma122*(gammado113 + gammado311) + gamma222*gammado312 + + gamma112*(gammado123 + gammado312) + gamma212*gammado322 + + 2.*(gamma322*gammado313 + gamma312*gammado323))*ginv12 + + (-ddg1323 + gamma133*gammado211 + gamma233*gammado212 + + (gamma113 + gamma223 + gamma333)*gammado213 + gamma213*gammado223 + + (gamma212 + gamma313)*gammado233 + + gamma123*(gammado113 + gammado311) + gamma223*gammado312 + + gamma112*(gammado133 + gammado313) + gamma212*gammado323 + + 2.*(gamma323*gammado313 + gamma312*gammado333))*ginv13 + + (-0.5*ddg2223 + gamma123*gammado212 + gamma223*gammado222 + + (gamma222 + gamma323)*gammado223 + + gamma122*(gammado123 + gammado312) + gamma222*gammado322 + + 2.*gamma322*gammado323)*ginv22 + + (-ddg2323 + gamma133*gammado212 + gamma233*gammado222 + + (2.*gamma223 + gamma333)*gammado223 + + (gamma222 + gamma323)*gammado233 + + gamma123*(gammado123 + gammado213 + gammado312) + + gamma122*(gammado133 + gammado313) + gamma223*gammado322 + + (gamma222 + 2.*gamma323)*gammado323 + 2.*gamma322*gammado333)*ginv23 + + (-0.5*ddg3323 + gamma133*gammado213 + gamma233*gammado223 + + (gamma223 + gamma333)*gammado233 + + gamma123*(gammado133 + gammado313) + gamma223*gammado323 + + 2.*gamma323*gammado333)*ginv33 +; + +R33 += +dG31*g13 + dG32*g23 + dG33*g33 + gammado313*Gfromg1 + gammado323*Gfromg2 + + gammado333*Gfromg3 + (-0.5*ddg1133 + + gamma113*(gammado113 + 2.*gammado311) + + gamma213*(gammado213 + 2.*gammado312) + 3.*gamma313*gammado313)*ginv11 \ ++ (-ddg1233 + gamma123*(gammado113 + 2.*gammado311) + + gamma113*(gammado123 + 2.*gammado312) + + gamma223*(gammado213 + 2.*gammado312) + + gamma213*(gammado223 + 2.*gammado322) + + 3.*(gamma323*gammado313 + gamma313*gammado323))*ginv12 + + (-ddg1333 + gamma133*(gammado113 + 2.*gammado311) + + gamma233*(gammado213 + 2.*gammado312) + + gamma113*(gammado133 + 2.*gammado313) + + gamma213*(gammado233 + 2.*gammado323) + + 3.*(gamma333*gammado313 + gamma313*gammado333))*ginv13 + + (-0.5*ddg2233 + gamma123*(gammado123 + 2.*gammado312) + + gamma223*(gammado223 + 2.*gammado322) + 3.*gamma323*gammado323)*ginv22 \ ++ (-ddg2333 + gamma133*(gammado123 + 2.*gammado312) + + gamma123*(gammado133 + 2.*gammado313) + + gamma233*(gammado223 + 2.*gammado322) + + gamma223*(gammado233 + 2.*gammado323) + + 3.*(gamma333*gammado323 + gamma323*gammado333))*ginv23 + + (-0.5*ddg3333 + gamma133*(gammado133 + 2.*gammado313) + + gamma233*(gammado233 + 2.*gammado323) + 3.*gamma333*gammado333)*ginv33 +; + +ff += +chi +; + +oochipsipower += +1/chipsipower +; + +f += +oochipsipower*log(ff) +; + +psim4 += +exp(-4.*f) +; + +df1 += +(dchi1*oochipsipower)/chi +; + +df2 += +(dchi2*oochipsipower)/chi +; + +df3 += +(dchi3*oochipsipower)/chi +; + +ddf11 += +(ddchi11*oochipsipower)/chi - chipsipower*pow2(df1) +; + +ddf12 += +-(chipsipower*df1*df2) + (ddchi12*oochipsipower)/chi +; + +ddf13 += +-(chipsipower*df1*df3) + (ddchi13*oochipsipower)/chi +; + +ddf22 += +(ddchi22*oochipsipower)/chi - chipsipower*pow2(df2) +; + +ddf23 += +-(chipsipower*df2*df3) + (ddchi23*oochipsipower)/chi +; + +ddf33 += +(ddchi33*oochipsipower)/chi - chipsipower*pow2(df3) +; + +cddf11 += +ddf11 - df1*gamma111 - df2*gamma211 - df3*gamma311 +; + +cddf12 += +ddf12 - df1*gamma112 - df2*gamma212 - df3*gamma312 +; + +cddf13 += +ddf13 - df1*gamma113 - df2*gamma213 - df3*gamma313 +; + +cddf22 += +ddf22 - df1*gamma122 - df2*gamma222 - df3*gamma322 +; + +cddf23 += +ddf23 - df1*gamma123 - df2*gamma223 - df3*gamma323 +; + +cddf33 += +ddf33 - df1*gamma133 - df2*gamma233 - df3*gamma333 +; + +trcddf += +cddf11*ginv11 + cddf22*ginv22 + + 2.*(cddf12*ginv12 + cddf13*ginv13 + cddf23*ginv23) + cddf33*ginv33 +; + +Rphi11 += +-2.*(cddf11 + g11*trcddf) + (4. - 4.*g11*ginv11)*pow2(df1) - + g11*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi12 += +df1*df2*(4. - 8.*g12*ginv12) - 2.*(cddf12 + g12*trcddf) - + g12*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi13 += +df1*(4.*df3 - 8.*df2*g13*ginv12) - 2.*(cddf13 + g13*trcddf) - + g13*(8.*df3*(df1*ginv13 + df2*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + ginv33*pow2(df3))) +; + +Rphi22 += +-2.*(cddf22 + g22*trcddf) + (4. - 4.*g22*ginv22)*pow2(df2) - + g22*(8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv11*pow2(df1) + ginv33*pow2(df3))) +; + +Rphi23 += +df2*(-8.*df1*g23*ginv12 + df3*(4. - 8.*g23*ginv23)) - + 2.*(cddf23 + g23*trcddf) - g23* + (8.*df1*df3*ginv13 + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2) + + ginv33*pow2(df3))) +; + +Rphi33 += +-2.*(cddf33 + g33*trcddf) - g33* + (8.*(df1*(df2*ginv12 + df3*ginv13) + df2*df3*ginv23) + + 4.*(ginv11*pow2(df1) + ginv22*pow2(df2))) + + (4. - 4.*g33*ginv33)*pow2(df3) +; + +Rf11 += +R11 + Rphi11 +; + +Rf12 += +R12 + Rphi12 +; + +Rf13 += +R13 + Rphi13 +; + +Rf22 += +R22 + Rphi22 +; + +Rf23 += +R23 + Rphi23 +; + +Rf33 += +R33 + Rphi33 +; + +Rhat += +psim4*(ginv11*Rf11 + ginv22*Rf22 + + 2.*(ginv12*Rf12 + ginv13*Rf13 + ginv23*Rf23) + ginv33*Rf33) +; + +cdda11 += +dda11 - da2*gamma211 - da3*gamma311 + + da1*(-gamma111 + df1*(-4. + 2.*g11*ginv11)) + + 2.*g11*((da2*df1 + da1*df2)*ginv12 + (da3*df1 + da1*df3)*ginv13 + + da2*df2*ginv22 + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) +; + +cdda12 += +dda12 - da1*gamma112 - da2*gamma212 - da3*gamma312 + + 2.*(-(da2*df1) - da1*df2 + g12* + (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) +; + +cdda13 += +dda13 - da1*gamma113 - da2*gamma213 - da3*gamma313 + + 2.*(-(da3*df1) - da1*df3 + g13* + (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) +; + +cdda22 += +dda22 - da1*gamma122 - da2*(4.*df2 + gamma222) - da3*gamma322 + + 2.*g22*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) +; + +cdda23 += +dda23 - da1*gamma123 - da2*gamma223 - da3*gamma323 + + 2.*(-(da3*df2) - da2*df3 + g23* + (da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33)) +; + +cdda33 += +dda33 - da1*gamma133 - da2*gamma233 - da3*(4.*df3 + gamma333) + + 2.*g33*(da1*df1*ginv11 + (da2*df1 + da1*df2)*ginv12 + + (da3*df1 + da1*df3)*ginv13 + da2*df2*ginv22 + + (da3*df2 + da2*df3)*ginv23 + da3*df3*ginv33) +; + +trcdda += +(cdda11*ginv11 + cdda22*ginv22 + + 2.*(cdda12*ginv12 + cdda13*ginv13 + cdda23*ginv23) + cdda33*ginv33)*psim4 +; + +AA11 += +2.*(A11*(A12*ginv12 + A13*ginv13) + A12*A13*ginv23) + ginv11*pow2(A11) + + ginv22*pow2(A12) + ginv33*pow2(A13) +; + +AA12 += +(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + + (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) +; + +AA13 += +(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + + A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) +; + +AA21 += +(A12*A13 + A11*A23)*ginv13 + A12*(A11*ginv11 + A22*ginv22) + + (A13*A22 + A12*A23)*ginv23 + A13*A23*ginv33 + ginv12*(A11*A22 + pow2(A12)) +; + +AA22 += +2.*(A12*(A22*ginv12 + A23*ginv13) + A22*A23*ginv23) + ginv11*pow2(A12) + + ginv22*pow2(A22) + ginv33*pow2(A23) +; + +AA23 += +A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + + A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) +; + +AA31 += +(A12*A13 + A11*A23)*ginv12 + A12*A23*ginv22 + (A13*A23 + A12*A33)*ginv23 + + A13*(A11*ginv11 + A33*ginv33) + ginv13*(A11*A33 + pow2(A13)) +; + +AA32 += +A12*A13*ginv11 + (A13*A22 + A12*A23)*ginv12 + (A13*A23 + A12*A33)*ginv13 + + A23*(A22*ginv22 + A33*ginv33) + ginv23*(A22*A33 + pow2(A23)) +; + +AA33 += +2.*(A13*(A23*ginv12 + A33*ginv13) + A23*A33*ginv23) + ginv11*pow2(A13) + + ginv22*pow2(A23) + ginv33*pow2(A33) +; + +cdA111 += +dA111 - 2.*(A11*gamma111 + A12*gamma211 + A13*gamma311) +; + +cdA112 += +dA112 - A11*gamma112 - A22*gamma211 - A12*(gamma111 + gamma212) - + A23*gamma311 - A13*gamma312 +; + +cdA113 += +dA113 - A11*gamma113 - A23*gamma211 - A12*gamma213 - A33*gamma311 - + A13*(gamma111 + gamma313) +; + +cdA122 += +dA122 - 2.*(A12*gamma112 + A22*gamma212 + A23*gamma312) +; + +cdA123 += +dA123 - A13*gamma112 - A12*gamma113 - A22*gamma213 - A33*gamma312 - + A23*(gamma212 + gamma313) +; + +cdA133 += +dA133 - 2.*(A13*gamma113 + A23*gamma213 + A33*gamma313) +; + +cdA211 += +dA211 - 2.*(A11*gamma112 + A12*gamma212 + A13*gamma312) +; + +cdA212 += +dA212 - A11*gamma122 - A22*gamma212 - A12*(gamma112 + gamma222) - + A23*gamma312 - A13*gamma322 +; + +cdA213 += +dA213 - A11*gamma123 - A23*gamma212 - A12*gamma223 - A33*gamma312 - + A13*(gamma112 + gamma323) +; + +cdA222 += +dA222 - 2.*(A12*gamma122 + A22*gamma222 + A23*gamma322) +; + +cdA223 += +dA223 - A13*gamma122 - A12*gamma123 - A22*gamma223 - A33*gamma322 - + A23*(gamma222 + gamma323) +; + +cdA233 += +dA233 - 2.*(A13*gamma123 + A23*gamma223 + A33*gamma323) +; + +cdA311 += +dA311 - 2.*(A11*gamma113 + A12*gamma213 + A13*gamma313) +; + +cdA312 += +dA312 - A11*gamma123 - A22*gamma213 - A12*(gamma113 + gamma223) - + A23*gamma313 - A13*gamma323 +; + +cdA313 += +dA313 - A11*gamma133 - A23*gamma213 - A12*gamma233 - A33*gamma313 - + A13*(gamma113 + gamma333) +; + +cdA322 += +dA322 - 2.*(A12*gamma123 + A22*gamma223 + A23*gamma323) +; + +cdA323 += +dA323 - A13*gamma123 - A12*gamma133 - A22*gamma233 - A33*gamma323 - + A23*(gamma223 + gamma333) +; + +cdA333 += +dA333 - 2.*(A13*gamma133 + A23*gamma233 + A33*gamma333) +; + +divbeta += +db11 + db22 + db33 +; + +totdivbeta += +0.66666666666666666667*divbeta +; + +lieA11 += +beta1*dA111 + beta2*dA211 + beta3*dA311 + + 2.*(A11*db11 + A12*db12 + A13*db13) - A11*totdivbeta +; + +lieA12 += +beta1*dA112 + beta2*dA212 + beta3*dA312 + A22*db12 + A23*db13 + A11*db21 + + A13*db23 + A12*(db11 + db22 - totdivbeta) +; + +lieA13 += +beta1*dA113 + beta2*dA213 + beta3*dA313 + A23*db12 + A33*db13 + A11*db31 + + A12*db32 + A13*(db11 + db33 - totdivbeta) +; + +lieA22 += +beta1*dA122 + beta2*dA222 + beta3*dA322 + + 2.*(A12*db21 + A22*db22 + A23*db23) - A22*totdivbeta +; + +lieA23 += +beta1*dA123 + beta2*dA223 + beta3*dA323 + A13*db21 + A33*db23 + A12*db31 + + A22*db32 + A23*(db22 + db33 - totdivbeta) +; + +lieA33 += +beta1*dA133 + beta2*dA233 + beta3*dA333 + + 2.*(A13*db31 + A23*db32 + A33*db33) - A33*totdivbeta +; + +DTheta += +dTheta1*sup1 + dTheta2*sup2 + dTheta3*sup3 +; + +rACss += +2.*((A23*alpha*K + lieA23)*sup2*sup3 + + sup1*((A12*alpha*K + lieA12)*sup2 + A13*alpha*K*sup3) + + psim4*((-cdda23 + alpha*Rf23)*sup2*sup3 + + sup1*((-cdda12 + alpha*Rf12)*sup2 - cdda13*sup3))) + + 0.66666666666666666667*(g13*sup1 + g23*sup2)*sup3*trcdda + + sup1*(2.*(-(AA31*alpha) + lieA13)*sup3 + + 0.66666666666666666667*g12*sup2*trcdda) + + (lieA11 + psim4*(-cdda11 + alpha*Rf11) + + 0.33333333333333333333*g11*(-(alpha*Rhat) + trcdda))*pow2(sup1) + + (lieA22 - cdda22*psim4 + alpha* + (A22*K + psim4*Rf22 - 0.33333333333333333333*g22*Rhat) + + 0.33333333333333333333*g22*trcdda)*pow2(sup2) + + (lieA33 - cdda33*psim4 + alpha* + (A33*K + psim4*Rf33 - 0.33333333333333333333*g33*Rhat) + + 0.33333333333333333333*g33*trcdda)*pow2(sup3) + + alpha*(ginv11*((-2.*cdA111*chi + 3.*A11*dchi1)*sup1 + + (-2.*cdA112*chi + 3.*A12*dchi1)*sup2 + + (-2.*cdA113*chi + 3.*A13*dchi1)*sup3) + + ginv22*((-2.*cdA212*chi + 3.*A12*dchi2)*sup1 + + (-2.*cdA222*chi + 3.*A22*dchi2)*sup2 + + (-2.*cdA223*chi + 3.*A23*dchi2)*sup3) + + ginv33*((-2.*cdA313*chi + 3.*A13*dchi3)*sup1 + + (-2.*cdA323*chi + 3.*A23*dchi3)*sup2 + + (-2.*cdA333*chi + 3.*A33*dchi3)*sup3) + + chi*(-2.*DTheta + 1.3333333333333333333* + (dK1*sup1 + dK2*sup2 + dK3*sup3)) + + ginv12*((-2.*cdA212*chi + 3.*A12*dchi2)*sup2 + + (-2.*cdA213*chi + 3.*A13*dchi2)*sup3 - + 2.*chi*((cdA112 + cdA211)*sup1 + cdA122*sup2 + cdA123*sup3) + + 3.*((A12*dchi1 + A11*dchi2)*sup1 + dchi1*(A22*sup2 + A23*sup3))) + + ginv13*((-2.*cdA312*chi + 3.*A12*dchi3)*sup2 + + (-2.*cdA313*chi + 3.*A13*dchi3)*sup3 - + 2.*chi*((cdA113 + cdA311)*sup1 + cdA123*sup2 + cdA133*sup3) + + 3.*((A13*dchi1 + A11*dchi3)*sup1 + dchi1*(A23*sup2 + A33*sup3))) + + ginv23*((-2.*cdA322*chi + 3.*A22*dchi3)*sup2 + + (-2.*cdA323*chi + 3.*A23*dchi3)*sup3 - + 2.*chi*((cdA213 + cdA312)*sup1 + cdA223*sup2 + cdA233*sup3) + + 3.*((A13*dchi2 + A12*dchi3)*sup1 + dchi2*(A23*sup2 + A33*sup3))) + + (0.33333333333333333333*((dG11 - dGfromgdu11)*qud11 + + (dG12 - dGfromgdu12)*qud12 + (dG13 - dGfromgdu13)*qud13 + + (dG21 - dGfromgdu21)*qud21 + (dG22 - dGfromgdu22)*qud22 + + (dG23 - dGfromgdu23)*qud23 + (dG31 - dGfromgdu31)*qud31 + + (dG32 - dGfromgdu32)*qud32 + (dG33 - dGfromgdu33)*qud33) + + kappa1*((G1 - Gfromg1)*sdown1 + (G2 - Gfromg2)*sdown2 + + (G3 - Gfromg3)*sdown3) + + 0.66666666666666666667* + ((dGfromgdu21*sdown1 + dGfromgdu22*sdown2)*sup2 + + sdown3*((-dG13 + dGfromgdu13)*sup1 - dG23*sup2 - dG33*sup3) + + sdown1*((-dG11 + dGfromgdu11)*sup1 - dG21*sup2 - dG31*sup3 + + dGfromgdu31*sup3) + + sdown2*((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3 + + dGfromgdu32*sup3)))*pow2(chi) + + 0.66666666666666666667*sup2* + (-(Rhat*(g12*sup1 + g23*sup3)) + dGfromgdu23*sdown3*pow2(chi)) + + sup3*((2.*psim4*Rf13 - 0.66666666666666666667*g13*Rhat)*sup1 + + 0.66666666666666666667*dGfromgdu33*sdown3*pow2(chi)) + + (-2.*AA11 + A11*K)*pow2(sup1) - + 2.*((AA23 + AA32)*sup2*sup3 + sup1*((AA12 + AA21)*sup2 + AA13*sup3) + + AA22*pow2(sup2) + AA33*pow2(sup3))) +; + +rACsA1 += +(qud11*(lieA11 + alpha*chi*Rf11) + + qud21*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + + qud31*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + + qud11*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + + (A13*alpha*K + lieA13)*sup3 + + alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + + qud21*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + + (A23*alpha*K + lieA23)*sup3 + + alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + + qud31*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + + (A33*alpha*K + lieA33)*sup3 + + alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + + alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud11 + + (-(cdA112*chi) + 1.5*A12*dchi1)*qud21 + + (-(cdA113*chi) + 1.5*A13*dchi1)*qud31) + + ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud11 + + (-(cdA222*chi) + 1.5*A22*dchi2)*qud21 + + (-(cdA223*chi) + 1.5*A23*dchi2)*qud31) + + ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud11 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud21 + + (-(cdA333*chi) + 1.5*A33*dchi3)*qud31) + + chi*((0.66666666666666666667*dK1 - dTheta1)*qud11 + + (0.66666666666666666667*dK2 - dTheta2)*qud21 + + (0.66666666666666666667*dK3 - dTheta3)*qud31) + + ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud21 + + (-(cdA213*chi) + 1.5*A13*dchi2)*qud31 - + chi*((cdA112 + cdA211)*qud11 + cdA122*qud21 + cdA123*qud31) + + 1.5*((A12*dchi1 + A11*dchi2)*qud11 + dchi1*(A22*qud21 + A23*qud31))\ +) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud21 + + (-(cdA313*chi) + 1.5*A13*dchi3)*qud31 - + chi*((cdA113 + cdA311)*qud11 + cdA123*qud21 + cdA133*qud31) + + 1.5*((A13*dchi1 + A11*dchi3)*qud11 + dchi1*(A23*qud21 + A33*qud31))\ +) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud21 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud31 - + chi*((cdA213 + cdA312)*qud11 + cdA223*qud21 + cdA233*qud31) + + 1.5*((A13*dchi2 + A12*dchi3)*qud11 + dchi2*(A23*qud21 + A33*qud31))\ +) + 0.5*(kappa1*((G1 - Gfromg1)*qdd11 + (G2 - Gfromg2)*qdd12 + + (G3 - Gfromg3)*qdd13) - dG13*qdd13*sup1 - dG21*qdd11*sup2 + + (dGfromgdu22*qdd12 - dG23*qdd13)*sup2 + + (dGfromgdu31*qdd11 + dGfromgdu32*qdd12 - dG33*qdd13)*sup3 + + qdd11*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - + dG31*sup3) + qdd12* + ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + + sup1*(-2.*AA11*qud11 + 0.5*dGfromgdu13*qdd13*pow2(chi))) + + sup2*(chi*(-(cdda12*qud11) - cdda22*qud21 - cdda23*qud31 + + alpha*qud21*Rf22) + alpha* + (chi*(qud11*Rf12 + qud31*Rf23) + 0.5*dGfromgdu23*qdd13*pow2(chi))) + + sup3*(chi*(-(cdda13*qud11) - cdda23*qud21 - cdda33*qud31 + + alpha*qud21*Rf23) + alpha* + (chi*(qud11*Rf13 + qud31*Rf33) + 0.5*dGfromgdu33*qdd13*pow2(chi))) +; + +rACsA2 += +(qud12*(lieA11 + alpha*chi*Rf11) + + qud22*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + + qud32*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + + qud12*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + + (A13*alpha*K + lieA13)*sup3 + + alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + + qud22*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + + (A23*alpha*K + lieA23)*sup3 + + alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + + qud32*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + + (A33*alpha*K + lieA33)*sup3 + + alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + + alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud12 + + (-(cdA112*chi) + 1.5*A12*dchi1)*qud22 + + (-(cdA113*chi) + 1.5*A13*dchi1)*qud32) + + ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud12 + + (-(cdA222*chi) + 1.5*A22*dchi2)*qud22 + + (-(cdA223*chi) + 1.5*A23*dchi2)*qud32) + + ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud12 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud22 + + (-(cdA333*chi) + 1.5*A33*dchi3)*qud32) + + chi*((0.66666666666666666667*dK1 - dTheta1)*qud12 + + (0.66666666666666666667*dK2 - dTheta2)*qud22 + + (0.66666666666666666667*dK3 - dTheta3)*qud32) + + ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud22 + + (-(cdA213*chi) + 1.5*A13*dchi2)*qud32 - + chi*((cdA112 + cdA211)*qud12 + cdA122*qud22 + cdA123*qud32) + + 1.5*((A12*dchi1 + A11*dchi2)*qud12 + dchi1*(A22*qud22 + A23*qud32))\ +) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud22 + + (-(cdA313*chi) + 1.5*A13*dchi3)*qud32 - + chi*((cdA113 + cdA311)*qud12 + cdA123*qud22 + cdA133*qud32) + + 1.5*((A13*dchi1 + A11*dchi3)*qud12 + dchi1*(A23*qud22 + A33*qud32))\ +) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud22 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud32 - + chi*((cdA213 + cdA312)*qud12 + cdA223*qud22 + cdA233*qud32) + + 1.5*((A13*dchi2 + A12*dchi3)*qud12 + dchi2*(A23*qud22 + A33*qud32))\ +) + 0.5*(kappa1*((G1 - Gfromg1)*qdd12 + (G2 - Gfromg2)*qdd22 + + (G3 - Gfromg3)*qdd23) - dG13*qdd23*sup1 - dG21*qdd12*sup2 + + (dGfromgdu22*qdd22 - dG23*qdd23)*sup2 + + (dGfromgdu31*qdd12 + dGfromgdu32*qdd22 - dG33*qdd23)*sup3 + + qdd12*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - + dG31*sup3) + qdd22* + ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + + sup1*(-2.*AA11*qud12 + 0.5*dGfromgdu13*qdd23*pow2(chi))) + + sup2*(chi*(-(cdda12*qud12) - cdda22*qud22 - cdda23*qud32 + + alpha*qud22*Rf22) + alpha* + (chi*(qud12*Rf12 + qud32*Rf23) + 0.5*dGfromgdu23*qdd23*pow2(chi))) + + sup3*(chi*(-(cdda13*qud12) - cdda23*qud22 - cdda33*qud32 + + alpha*qud22*Rf23) + alpha* + (chi*(qud12*Rf13 + qud32*Rf33) + 0.5*dGfromgdu33*qdd23*pow2(chi))) +; + +rACsA3 += +(qud13*(lieA11 + alpha*chi*Rf11) + + qud23*(lieA12 + alpha*(-2.*AA12 + chi*Rf12)) + + qud33*(lieA13 + alpha*(-2.*AA13 + chi*Rf13)))*sup1 + + qud13*((-(cdda11*chi) + A11*alpha*K)*sup1 + lieA12*sup2 + + (A13*alpha*K + lieA13)*sup3 + + alpha*((-2.*AA21 + A12*K)*sup2 - 2.*AA31*sup3)) + + qud23*((-(cdda12*chi) + A12*alpha*K)*sup1 + lieA22*sup2 + + (A23*alpha*K + lieA23)*sup3 + + alpha*((-2.*AA22 + A22*K)*sup2 - 2.*AA32*sup3)) + + qud33*((-(cdda13*chi) + A13*alpha*K)*sup1 + lieA23*sup2 + + (A33*alpha*K + lieA33)*sup3 + + alpha*((-2.*AA23 + A23*K)*sup2 - 2.*AA33*sup3)) + + alpha*(ginv11*((-(cdA111*chi) + 1.5*A11*dchi1)*qud13 + + (-(cdA112*chi) + 1.5*A12*dchi1)*qud23 + + (-(cdA113*chi) + 1.5*A13*dchi1)*qud33) + + ginv22*((-(cdA212*chi) + 1.5*A12*dchi2)*qud13 + + (-(cdA222*chi) + 1.5*A22*dchi2)*qud23 + + (-(cdA223*chi) + 1.5*A23*dchi2)*qud33) + + ginv33*((-(cdA313*chi) + 1.5*A13*dchi3)*qud13 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud23 + + (-(cdA333*chi) + 1.5*A33*dchi3)*qud33) + + chi*((0.66666666666666666667*dK1 - dTheta1)*qud13 + + (0.66666666666666666667*dK2 - dTheta2)*qud23 + + (0.66666666666666666667*dK3 - dTheta3)*qud33) + + ginv12*((-(cdA212*chi) + 1.5*A12*dchi2)*qud23 + + (-(cdA213*chi) + 1.5*A13*dchi2)*qud33 - + chi*((cdA112 + cdA211)*qud13 + cdA122*qud23 + cdA123*qud33) + + 1.5*((A12*dchi1 + A11*dchi2)*qud13 + dchi1*(A22*qud23 + A23*qud33))\ +) + ginv13*((-(cdA312*chi) + 1.5*A12*dchi3)*qud23 + + (-(cdA313*chi) + 1.5*A13*dchi3)*qud33 - + chi*((cdA113 + cdA311)*qud13 + cdA123*qud23 + cdA133*qud33) + + 1.5*((A13*dchi1 + A11*dchi3)*qud13 + dchi1*(A23*qud23 + A33*qud33))\ +) + ginv23*((-(cdA322*chi) + 1.5*A22*dchi3)*qud23 + + (-(cdA323*chi) + 1.5*A23*dchi3)*qud33 - + chi*((cdA213 + cdA312)*qud13 + cdA223*qud23 + cdA233*qud33) + + 1.5*((A13*dchi2 + A12*dchi3)*qud13 + dchi2*(A23*qud23 + A33*qud33))\ +) + 0.5*(kappa1*((G1 - Gfromg1)*qdd13 + (G2 - Gfromg2)*qdd23 + + (G3 - Gfromg3)*qdd33) - dG13*qdd33*sup1 - dG21*qdd13*sup2 + + (dGfromgdu22*qdd23 - dG23*qdd33)*sup2 + + (dGfromgdu31*qdd13 + dGfromgdu32*qdd23 - dG33*qdd33)*sup3 + + qdd13*((-dG11 + dGfromgdu11)*sup1 + dGfromgdu21*sup2 - + dG31*sup3) + qdd23* + ((-dG12 + dGfromgdu12)*sup1 - dG22*sup2 - dG32*sup3))*pow2(chi) + + sup1*(-2.*AA11*qud13 + 0.5*dGfromgdu13*qdd33*pow2(chi))) + + sup2*(chi*(-(cdda12*qud13) - cdda22*qud23 - cdda23*qud33 + + alpha*qud23*Rf22) + alpha* + (chi*(qud13*Rf12 + qud33*Rf23) + 0.5*dGfromgdu23*qdd33*pow2(chi))) + + sup3*(chi*(-(cdda13*qud13) - cdda23*qud23 - cdda33*qud33 + + alpha*qud23*Rf23) + alpha* + (chi*(qud13*Rf13 + qud33*Rf33) + 0.5*dGfromgdu33*qdd33*pow2(chi))) +; + +rACABTF11 += +-(qPhysuudd1211*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3311*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1111*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1211* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1311*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2211*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2311*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1311 + AA22*qPhysuudd2211 + AA23*qPhysuudd2311 + + AA33*qPhysuudd3311 + qPhysuudd1111*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1311 + + (0.5*(A12*dchi1*qPhysuudd1111 + A23*dchi3*qPhysuudd3311))/chi)* + sup2) - qPhysuudd3311*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1211*sup3 + + qPhysuudd1211*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1311*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2211* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2311*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2311*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1211 + A13*dchi2*qPhysuudd1311)*sup2 + + (A12*dchi3*qPhysuudd1211 - + 0.5*dchi1*(A13*qPhysuudd1111 + A23*qPhysuudd1211))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1211 - + dchi3*(A11*qPhysuudd1311 + A12*qPhysuudd2311) + + dchi1*(A22*qPhysuudd2211 + A33*qPhysuudd3311))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1311) - + A22*dchi3*qPhysuudd2311 + + dchi2*(A11*qPhysuudd1111 + A33*qPhysuudd3311))*sup2 + + (-(A33*dchi1*qPhysuudd1311) + + A13*(-(dchi2*qPhysuudd1211) + dchi3*qPhysuudd1311) + + dchi3*(A11*qPhysuudd1111 + A22*qPhysuudd2211) + + A23*(-(dchi2*qPhysuudd2211) + dchi3*qPhysuudd2311))*sup3))/chi) +; + +rACABTF12 += +-(qPhysuudd1212*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3312*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1112*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1212* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1312*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2212*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2312*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1312 + AA22*qPhysuudd2212 + AA23*qPhysuudd2312 + + AA33*qPhysuudd3312 + qPhysuudd1112*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1312 + + (0.5*(A12*dchi1*qPhysuudd1112 + A23*dchi3*qPhysuudd3312))/chi)* + sup2) - qPhysuudd3312*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1212*sup3 + + qPhysuudd1212*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1312*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2212* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2312*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2312*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1212 + A13*dchi2*qPhysuudd1312)*sup2 + + (A12*dchi3*qPhysuudd1212 - + 0.5*dchi1*(A13*qPhysuudd1112 + A23*qPhysuudd1212))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1212 - + dchi3*(A11*qPhysuudd1312 + A12*qPhysuudd2312) + + dchi1*(A22*qPhysuudd2212 + A33*qPhysuudd3312))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1312) - + A22*dchi3*qPhysuudd2312 + + dchi2*(A11*qPhysuudd1112 + A33*qPhysuudd3312))*sup2 + + (-(A33*dchi1*qPhysuudd1312) + + A13*(-(dchi2*qPhysuudd1212) + dchi3*qPhysuudd1312) + + dchi3*(A11*qPhysuudd1112 + A22*qPhysuudd2212) + + A23*(-(dchi2*qPhysuudd2212) + dchi3*qPhysuudd2312))*sup3))/chi) +; + +rACABTF13 += +-(qPhysuudd1213*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3313*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1113*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1213* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1313*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2213*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2313*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1313 + AA22*qPhysuudd2213 + AA23*qPhysuudd2313 + + AA33*qPhysuudd3313 + qPhysuudd1113*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1313 + + (0.5*(A12*dchi1*qPhysuudd1113 + A23*dchi3*qPhysuudd3313))/chi)* + sup2) - qPhysuudd3313*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1213*sup3 + + qPhysuudd1213*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1313*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2213* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2313*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2313*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1213 + A13*dchi2*qPhysuudd1313)*sup2 + + (A12*dchi3*qPhysuudd1213 - + 0.5*dchi1*(A13*qPhysuudd1113 + A23*qPhysuudd1213))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1213 - + dchi3*(A11*qPhysuudd1313 + A12*qPhysuudd2313) + + dchi1*(A22*qPhysuudd2213 + A33*qPhysuudd3313))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1313) - + A22*dchi3*qPhysuudd2313 + + dchi2*(A11*qPhysuudd1113 + A33*qPhysuudd3313))*sup2 + + (-(A33*dchi1*qPhysuudd1313) + + A13*(-(dchi2*qPhysuudd1213) + dchi3*qPhysuudd1313) + + dchi3*(A11*qPhysuudd1113 + A22*qPhysuudd2213) + + A23*(-(dchi2*qPhysuudd2213) + dchi3*qPhysuudd2313))*sup3))/chi) +; + +rACABTF22 += +-(qPhysuudd1222*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3322*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1122*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1222* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1322*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2222*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2322*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1322 + AA22*qPhysuudd2222 + AA23*qPhysuudd2322 + + AA33*qPhysuudd3322 + qPhysuudd1122*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1322 + + (0.5*(A12*dchi1*qPhysuudd1122 + A23*dchi3*qPhysuudd3322))/chi)* + sup2) - qPhysuudd3322*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1222*sup3 + + qPhysuudd1222*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1322*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2222* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2322*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2322*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1222 + A13*dchi2*qPhysuudd1322)*sup2 + + (A12*dchi3*qPhysuudd1222 - + 0.5*dchi1*(A13*qPhysuudd1122 + A23*qPhysuudd1222))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1222 - + dchi3*(A11*qPhysuudd1322 + A12*qPhysuudd2322) + + dchi1*(A22*qPhysuudd2222 + A33*qPhysuudd3322))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1322) - + A22*dchi3*qPhysuudd2322 + + dchi2*(A11*qPhysuudd1122 + A33*qPhysuudd3322))*sup2 + + (-(A33*dchi1*qPhysuudd1322) + + A13*(-(dchi2*qPhysuudd1222) + dchi3*qPhysuudd1322) + + dchi3*(A11*qPhysuudd1122 + A22*qPhysuudd2222) + + A23*(-(dchi2*qPhysuudd2222) + dchi3*qPhysuudd2322))*sup3))/chi) +; + +rACABTF23 += +-(qPhysuudd1223*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3323*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1123*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1223* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1323*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2223*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2323*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1323 + AA22*qPhysuudd2223 + AA23*qPhysuudd2323 + + AA33*qPhysuudd3323 + qPhysuudd1123*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1323 + + (0.5*(A12*dchi1*qPhysuudd1123 + A23*dchi3*qPhysuudd3323))/chi)* + sup2) - qPhysuudd3323*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1223*sup3 + + qPhysuudd1223*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1323*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2223* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2323*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2323*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1223 + A13*dchi2*qPhysuudd1323)*sup2 + + (A12*dchi3*qPhysuudd1223 - + 0.5*dchi1*(A13*qPhysuudd1123 + A23*qPhysuudd1223))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1223 - + dchi3*(A11*qPhysuudd1323 + A12*qPhysuudd2323) + + dchi1*(A22*qPhysuudd2223 + A33*qPhysuudd3323))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1323) - + A22*dchi3*qPhysuudd2323 + + dchi2*(A11*qPhysuudd1123 + A33*qPhysuudd3323))*sup2 + + (-(A33*dchi1*qPhysuudd1323) + + A13*(-(dchi2*qPhysuudd1223) + dchi3*qPhysuudd1323) + + dchi3*(A11*qPhysuudd1123 + A22*qPhysuudd2223) + + A23*(-(dchi2*qPhysuudd2223) + dchi3*qPhysuudd2323))*sup3))/chi) +; + +rACABTF33 += +-(qPhysuudd1233*(2.*cdda12*chi + alpha*(AA21 + cdA112*sup1))) + + qPhysuudd3333*(-(cdda33*chi) + lieA33 + + alpha*(0.66666666666666666667*A33*K + cdA313*sup1 + cdA323*sup2)) + + qPhysuudd1133*(-(cdda11*chi) + lieA11 + + alpha*(-AA11 + 0.66666666666666666667*A11*K + cdA112*sup2 + + cdA113*sup3)) + qPhysuudd1233* + (2.*lieA12 + alpha*(-AA12 + 1.3333333333333333333*A12*K + cdA211*sup1 + + cdA122*sup2 + cdA123*sup3)) + + qPhysuudd1333*(2.*(-(cdda13*chi) + lieA13) + + alpha*(-AA31 + 1.3333333333333333333*A13*K + cdA311*sup1 + + cdA123*sup2 + cdA133*sup3)) + + qPhysuudd2233*(-(cdda22*chi) + lieA22 + + alpha*(0.66666666666666666667*A22*K + cdA212*sup1 + cdA223*sup3)) + + qPhysuudd2333*(2.*(-(cdda23*chi) + lieA23) + + alpha*(-AA32 + 1.3333333333333333333*A23*K + cdA213*sup1 + + cdA322*sup2 + cdA233*sup3)) - + alpha*(AA13*qPhysuudd1333 + AA22*qPhysuudd2233 + AA23*qPhysuudd2333 + + AA33*qPhysuudd3333 + qPhysuudd1133*(cdA211*sup2 + cdA311*sup3)) + + alpha*(-((2.*cdA213*qPhysuudd1333 + + (0.5*(A12*dchi1*qPhysuudd1133 + A23*dchi3*qPhysuudd3333))/chi)* + sup2) - qPhysuudd3333*((cdA133 + (0.5*A13*dchi3)/chi)*sup1 + + cdA233*sup2) - 2.*cdA312*qPhysuudd1233*sup3 + + qPhysuudd1233*((-cdA212 + (0.5*A12*dchi2)/chi)*sup2 + cdA213*sup3) + + qPhysuudd1333*((-cdA113 + (0.5*A13*dchi1)/chi)*sup1 + cdA312*sup2 - + cdA313*sup3) - qPhysuudd2233* + ((cdA122 + (0.5*A12*dchi2)/chi)*sup1 + cdA322*sup3) + + qPhysuudd2333*((cdA312 + (A23*dchi1)/chi)*sup1 + + (0.5*A23*dchi2*sup2)/chi - cdA323*sup3) - + qPhysuudd2333*((2.*cdA123 + (0.5*A13*dchi2)/chi)*sup1 + cdA223*sup2 + + (0.5*A33*dchi2*sup3)/chi) + + ((-0.5*A22*dchi1*qPhysuudd1233 + A13*dchi2*qPhysuudd1333)*sup2 + + (A12*dchi3*qPhysuudd1233 - + 0.5*dchi1*(A13*qPhysuudd1133 + A23*qPhysuudd1233))*sup3 + + 0.5*(((A12*dchi1 - A11*dchi2)*qPhysuudd1233 - + dchi3*(A11*qPhysuudd1333 + A12*qPhysuudd2333) + + dchi1*(A22*qPhysuudd2233 + A33*qPhysuudd3333))*sup1 + + (-((A23*dchi1 + A12*dchi3)*qPhysuudd1333) - + A22*dchi3*qPhysuudd2333 + + dchi2*(A11*qPhysuudd1133 + A33*qPhysuudd3333))*sup2 + + (-(A33*dchi1*qPhysuudd1333) + + A13*(-(dchi2*qPhysuudd1233) + dchi3*qPhysuudd1333) + + dchi3*(A11*qPhysuudd1133 + A22*qPhysuudd2233) + + A23*(-(dchi2*qPhysuudd2233) + dchi3*qPhysuudd2333))*sup3))/chi) +; + +} /* function */ + +} diff --git a/AMSS_NCKU_source/z4c_rhs_point.C b/AMSS_NCKU_source/Z4C/z4c_rhs_point.C similarity index 96% rename from AMSS_NCKU_source/z4c_rhs_point.C rename to AMSS_NCKU_source/Z4C/z4c_rhs_point.C index 73d54e1..c5896b9 100644 --- a/AMSS_NCKU_source/z4c_rhs_point.C +++ b/AMSS_NCKU_source/Z4C/z4c_rhs_point.C @@ -1,2186 +1,2186 @@ - - -// Z4c rhs without advection term -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include "macrodef.fh" - -#define Power(x, y) (pow((double)(x), (double)(y))) -#define Sqrt(x) sqrt(x) -#define Log(x) log((double)(x)) -#define pow2(x) ((x) * (x)) -#define pow3(x) ((x) * (x) * (x)) -#define pow4(x) ((x) * (x) * (x) * (x)) -#define pow2inv(x) (1.0 / ((x) * (x))) - -#define Cal(x, y, z) ((x) ? (y) : (z)) - -#define Tan(x) tan(x) -#define ArcTan(x) atan(x) -#define Sin(x) sin(x) -#define Cos(x) cos(x) -#define Csc(x) (1. / sin(x)) -#define Abs(x) (fabs(x)) -#define sqrt2 (sqrt(2)) -#define Tanh(x) tanh(x) -#define Sech(x) (1 / cosh(x)) - -extern "C" -{ - -#ifdef fortran1 - void z4c_rhs_point -#endif -#ifdef fortran2 - void Z4C_RHS_POINT -#endif -#ifdef fortran3 - void - z4c_rhs_point_ -#endif - (double &A11, - double &A12, - double &A13, - double &A22, - double &A23, - double &A33, - double &alpha, - double &B1, - double &B2, - double &B3, - double &beta1, - double &beta2, - double &beta3, - double &chi, - double &chiDivFloor, - double &da1, - double &dA111, - double &dA112, - double &dA113, - double &dA122, - double &dA123, - double &dA133, - double &da2, - double &dA211, - double &dA212, - double &dA213, - double &dA222, - double &dA223, - double &dA233, - double &da3, - double &dA311, - double &dA312, - double &dA313, - double &dA322, - double &dA323, - double &dA333, - double &db11, - double &dB11, - double &db12, - double &dB12, - double &db13, - double &dB13, - double &db21, - double &dB21, - double &db22, - double &dB22, - double &db23, - double &dB23, - double &db31, - double &dB31, - double &db32, - double &dB32, - double &db33, - double &dB33, - double &dchi1, - double &dchi2, - double &dchi3, - double &dda11, - double &dda12, - double &dda13, - double &dda22, - double &dda23, - double &dda33, - double &ddb111, - double &ddb112, - double &ddb113, - double &ddb121, - double &ddb122, - double &ddb123, - double &ddb131, - double &ddb132, - double &ddb133, - double &ddb221, - double &ddb222, - double &ddb223, - double &ddb231, - double &ddb232, - double &ddb233, - double &ddb331, - double &ddb332, - double &ddb333, - double &ddchi11, - double &ddchi12, - double &ddchi13, - double &ddchi22, - double &ddchi23, - double &ddchi33, - double &deldelg1111, - double &deldelg1112, - double &deldelg1113, - double &deldelg1122, - double &deldelg1123, - double &deldelg1133, - double &deldelg1211, - double &deldelg1212, - double &deldelg1213, - double &deldelg1222, - double &deldelg1223, - double &deldelg1233, - double &deldelg1311, - double &deldelg1312, - double &deldelg1313, - double &deldelg1322, - double &deldelg1323, - double &deldelg1333, - double &deldelg2211, - double &deldelg2212, - double &deldelg2213, - double &deldelg2222, - double &deldelg2223, - double &deldelg2233, - double &deldelg2311, - double &deldelg2312, - double &deldelg2313, - double &deldelg2322, - double &deldelg2323, - double &deldelg2333, - double &deldelg3311, - double &deldelg3312, - double &deldelg3313, - double &deldelg3322, - double &deldelg3323, - double &deldelg3333, - double &delG11, - double &delg111, - double &delg112, - double &delg113, - double &delG12, - double &delg122, - double &delg123, - double &delG13, - double &delg133, - double &delG21, - double &delg211, - double &delg212, - double &delg213, - double &delG22, - double &delg222, - double &delg223, - double &delG23, - double &delg233, - double &delG31, - double &delg311, - double &delg312, - double &delg313, - double &delG32, - double &delg322, - double &delg323, - double &delG33, - double &delg333, - double &dKhat1, - double &dKhat2, - double &dKhat3, - double &dTheta1, - double &dTheta2, - double &dTheta3, - double &G1, - double &g11, - double &g12, - double &g13, - double &G2, - double &g22, - double &g23, - double &G3, - double &g33, - double &kappa1, - double &kappa2, - double &Khat, - double &rA11, - double &rA12, - double &rA13, - double &rA22, - double &rA23, - double &rA33, - double &rchi, - double &rG1, - double &rg11, - double &rg12, - double &rg13, - double &rG2, - double &rg22, - double &rg23, - double &rG3, - double &rg33, - double &rKhat, - double &rTheta, - double &Theta) - { - - double AA11; - double AA12; - double AA13; - double AA22; - double AA23; - double AA33; - double Ainv11; - double Ainv12; - double Ainv13; - double Ainv22; - double Ainv23; - double Ainv33; - double cAA; - double cdda11; - double cdda12; - double cdda13; - double cdda22; - double cdda23; - double cdda33; - double cddf11; - double cddf12; - double cddf13; - double cddf22; - double cddf23; - double cddf33; - double chiguard; - double chiguarded; - double chipsipower; - double ddf11; - double ddf12; - double ddf13; - double ddf22; - double ddf23; - double ddf33; - double detginv; - double df1; - double df2; - double df3; - double dGd11; - double dGd12; - double dGd13; - double dGd21; - double dGd22; - double dGd23; - double dGd31; - double dGd32; - double dGd33; - double dginv111; - double dginv112; - double dginv113; - double dginv122; - double dginv123; - double dginv133; - double dginv211; - double dginv212; - double dginv213; - double dginv222; - double dginv223; - double dginv233; - double dginv311; - double dginv312; - double dginv313; - double dginv322; - double dginv323; - double dginv333; - double divAinv1; - double divAinv2; - double divAinv3; - double divbeta; - double dK1; - double dK2; - double dK3; - double dphi1; - double dphi2; - double dphi3; - double dZ11; - double DZ11; - double dZ12; - double DZ12; - double dZ13; - double DZ13; - double dZ21; - double DZ21; - double dZ22; - double DZ22; - double dZ23; - double DZ23; - double dZ31; - double DZ31; - double dZ32; - double DZ32; - double dZ33; - double DZ33; - double dZinv11; - double DZinv11; - double dZinv12; - double DZinv12; - double dZinv13; - double DZinv13; - double dZinv21; - double DZinv21; - double dZinv22; - double DZinv22; - double dZinv23; - double DZinv23; - double dZinv31; - double DZinv31; - double dZinv32; - double DZinv32; - double dZinv33; - double DZinv33; - double DZsym11; - double DZsym12; - double DZsym13; - double DZsym21; - double DZsym22; - double DZsym23; - double DZsym31; - double DZsym32; - double DZsym33; - double f; - double ff; - double gamma111; - double gamma112; - double gamma113; - double gamma122; - double gamma123; - double gamma133; - double gamma211; - double gamma212; - double gamma213; - double gamma222; - double gamma223; - double gamma233; - double gamma311; - double gamma312; - double gamma313; - double gamma322; - double gamma323; - double gamma333; - double gammado111; - double gammado112; - double gammado113; - double gammado122; - double gammado123; - double gammado133; - double gammado211; - double gammado212; - double gammado213; - double gammado222; - double gammado223; - double gammado233; - double gammado311; - double gammado312; - double gammado313; - double gammado322; - double gammado323; - double gammado333; - double gammaF111; - double gammaF112; - double gammaF113; - double gammaF121; - double gammaF122; - double gammaF123; - double gammaF131; - double gammaF132; - double gammaF133; - double gammaF211; - double gammaF212; - double gammaF213; - double gammaF221; - double gammaF222; - double gammaF223; - double gammaF231; - double gammaF232; - double gammaF233; - double gammaF311; - double gammaF312; - double gammaF313; - double gammaF321; - double gammaF322; - double gammaF323; - double gammaF331; - double gammaF332; - double gammaF333; - double Gd1; - double Gd2; - double Gd3; - double Gfromg1; - double Gfromg2; - double Gfromg3; - double ginv11; - double ginv12; - double ginv13; - double ginv22; - double ginv23; - double ginv33; - double Hhat; - double K; - double lieA11; - double lieA12; - double lieA13; - double lieA22; - double lieA23; - double lieA33; - double liechi; - double lieg11; - double lieg12; - double lieg13; - double lieg22; - double lieg23; - double lieg33; - double oochipsipower; - double ootddivbeta1; - double ootddivbeta2; - double ootddivbeta3; - double pseudolieG1; - double pseudolieG2; - double pseudolieG3; - double psim4; - double R11; - double R12; - double R13; - double R22; - double R23; - double R33; - double Rhat; - double Rphi11; - double Rphi12; - double Rphi13; - double Rphi22; - double Rphi23; - double Rphi33; - double totdivbeta; - double trcdda; - double trcddf; - double trDZsym; - double Z1; - double Z2; - double Z3; - double Zinv1; - double Zinv2; - double Zinv3; - - chipsipower = - -4.; - - K = - Khat + 2. * Theta; - - dK1 = - dKhat1 + 2. * dTheta1; - - dK2 = - dKhat2 + 2. * dTheta2; - - dK3 = - dKhat3 + 2. * dTheta3; - - detginv = - 1 / (2. * g12 * g13 * g23 - g33 * pow2(g12) + g22 * (g11 * g33 - pow2(g13)) - - g11 * pow2(g23)); - - ginv11 = - detginv * (g22 * g33 - pow2(g23)); - - ginv12 = - detginv * (g13 * g23 - g12 * g33); - - ginv13 = - detginv * (-(g13 * g22) + g12 * g23); - - ginv22 = - detginv * (g11 * g33 - pow2(g13)); - - ginv23 = - detginv * (g12 * g13 - g11 * g23); - - ginv33 = - detginv * (g11 * g22 - pow2(g12)); - - dginv111 = - -2. * (delg123 * ginv12 * ginv13 + ginv11 * (delg112 * ginv12 + delg113 * ginv13)) - - delg111 * pow2(ginv11) - delg122 * pow2(ginv12) - delg133 * pow2(ginv13); - - dginv112 = - -(ginv11 * (delg111 * ginv12 + delg112 * ginv22 + delg113 * ginv23)) - - ginv12 * (delg113 * ginv13 + delg122 * ginv22 + delg123 * ginv23) - - ginv13 * (delg123 * ginv22 + delg133 * ginv23) - delg112 * pow2(ginv12); - - dginv113 = - -(ginv11 * (delg111 * ginv13 + delg112 * ginv23 + delg113 * ginv33)) - - ginv12 * (delg112 * ginv13 + delg122 * ginv23 + delg123 * ginv33) - - ginv13 * (delg123 * ginv23 + delg133 * ginv33) - delg113 * pow2(ginv13); - - dginv122 = - -2. * (delg123 * ginv22 * ginv23 + ginv12 * (delg112 * ginv22 + delg113 * ginv23)) - - delg111 * pow2(ginv12) - delg122 * pow2(ginv22) - delg133 * pow2(ginv23); - - dginv123 = - -(ginv13 * (delg112 * ginv22 + delg113 * ginv23)) - delg133 * ginv23 * ginv33 - - ginv12 * (delg111 * ginv13 + delg112 * ginv23 + delg113 * ginv33) - - ginv22 * (delg122 * ginv23 + delg123 * ginv33) - delg123 * pow2(ginv23); - - dginv133 = - -2. * (delg123 * ginv23 * ginv33 + ginv13 * (delg112 * ginv23 + delg113 * ginv33)) - - delg111 * pow2(ginv13) - delg122 * pow2(ginv23) - delg133 * pow2(ginv33); - - dginv211 = - -2. * (delg223 * ginv12 * ginv13 + ginv11 * (delg212 * ginv12 + delg213 * ginv13)) - - delg211 * pow2(ginv11) - delg222 * pow2(ginv12) - delg233 * pow2(ginv13); - - dginv212 = - -(ginv11 * (delg211 * ginv12 + delg212 * ginv22 + delg213 * ginv23)) - - ginv12 * (delg213 * ginv13 + delg222 * ginv22 + delg223 * ginv23) - - ginv13 * (delg223 * ginv22 + delg233 * ginv23) - delg212 * pow2(ginv12); - - dginv213 = - -(ginv11 * (delg211 * ginv13 + delg212 * ginv23 + delg213 * ginv33)) - - ginv12 * (delg212 * ginv13 + delg222 * ginv23 + delg223 * ginv33) - - ginv13 * (delg223 * ginv23 + delg233 * ginv33) - delg213 * pow2(ginv13); - - dginv222 = - -2. * (delg223 * ginv22 * ginv23 + ginv12 * (delg212 * ginv22 + delg213 * ginv23)) - - delg211 * pow2(ginv12) - delg222 * pow2(ginv22) - delg233 * pow2(ginv23); - - dginv223 = - -(ginv13 * (delg212 * ginv22 + delg213 * ginv23)) - delg233 * ginv23 * ginv33 - - ginv12 * (delg211 * ginv13 + delg212 * ginv23 + delg213 * ginv33) - - ginv22 * (delg222 * ginv23 + delg223 * ginv33) - delg223 * pow2(ginv23); - - dginv233 = - -2. * (delg223 * ginv23 * ginv33 + ginv13 * (delg212 * ginv23 + delg213 * ginv33)) - - delg211 * pow2(ginv13) - delg222 * pow2(ginv23) - delg233 * pow2(ginv33); - - dginv311 = - -2. * (delg323 * ginv12 * ginv13 + ginv11 * (delg312 * ginv12 + delg313 * ginv13)) - - delg311 * pow2(ginv11) - delg322 * pow2(ginv12) - delg333 * pow2(ginv13); - - dginv312 = - -(ginv11 * (delg311 * ginv12 + delg312 * ginv22 + delg313 * ginv23)) - - ginv12 * (delg313 * ginv13 + delg322 * ginv22 + delg323 * ginv23) - - ginv13 * (delg323 * ginv22 + delg333 * ginv23) - delg312 * pow2(ginv12); - - dginv313 = - -(ginv11 * (delg311 * ginv13 + delg312 * ginv23 + delg313 * ginv33)) - - ginv12 * (delg312 * ginv13 + delg322 * ginv23 + delg323 * ginv33) - - ginv13 * (delg323 * ginv23 + delg333 * ginv33) - delg313 * pow2(ginv13); - - dginv322 = - -2. * (delg323 * ginv22 * ginv23 + ginv12 * (delg312 * ginv22 + delg313 * ginv23)) - - delg311 * pow2(ginv12) - delg322 * pow2(ginv22) - delg333 * pow2(ginv23); - - dginv323 = - -(ginv13 * (delg312 * ginv22 + delg313 * ginv23)) - delg333 * ginv23 * ginv33 - - ginv12 * (delg311 * ginv13 + delg312 * ginv23 + delg313 * ginv33) - - ginv22 * (delg322 * ginv23 + delg323 * ginv33) - delg323 * pow2(ginv23); - - dginv333 = - -2. * (delg323 * ginv23 * ginv33 + ginv13 * (delg312 * ginv23 + delg313 * ginv33)) - - delg311 * pow2(ginv13) - delg322 * pow2(ginv23) - delg333 * pow2(ginv33); - - gammado111 = - 0.5 * delg111; - - gammado112 = - 0.5 * delg211; - - gammado113 = - 0.5 * delg311; - - gammado122 = - -0.5 * delg122 + delg212; - - gammado123 = - 0.5 * (-delg123 + delg213 + delg312); - - gammado133 = - -0.5 * delg133 + delg313; - - gammado211 = - delg112 - 0.5 * delg211; - - gammado212 = - 0.5 * delg122; - - gammado213 = - 0.5 * (delg123 - delg213 + delg312); - - gammado222 = - 0.5 * delg222; - - gammado223 = - 0.5 * delg322; - - gammado233 = - -0.5 * delg233 + delg323; - - gammado311 = - delg113 - 0.5 * delg311; - - gammado312 = - 0.5 * (delg123 + delg213 - delg312); - - gammado313 = - 0.5 * delg133; - - gammado322 = - delg223 - 0.5 * delg322; - - gammado323 = - 0.5 * delg233; - - gammado333 = - 0.5 * delg333; - - gamma111 = - gammado111 * ginv11 + gammado211 * ginv12 + gammado311 * ginv13; - - gamma112 = - gammado112 * ginv11 + gammado212 * ginv12 + gammado312 * ginv13; - - gamma113 = - gammado113 * ginv11 + gammado213 * ginv12 + gammado313 * ginv13; - - gamma122 = - gammado122 * ginv11 + gammado222 * ginv12 + gammado322 * ginv13; - - gamma123 = - gammado123 * ginv11 + gammado223 * ginv12 + gammado323 * ginv13; - - gamma133 = - gammado133 * ginv11 + gammado233 * ginv12 + gammado333 * ginv13; - - gamma211 = - gammado111 * ginv12 + gammado211 * ginv22 + gammado311 * ginv23; - - gamma212 = - gammado112 * ginv12 + gammado212 * ginv22 + gammado312 * ginv23; - - gamma213 = - gammado113 * ginv12 + gammado213 * ginv22 + gammado313 * ginv23; - - gamma222 = - gammado122 * ginv12 + gammado222 * ginv22 + gammado322 * ginv23; - - gamma223 = - gammado123 * ginv12 + gammado223 * ginv22 + gammado323 * ginv23; - - gamma233 = - gammado133 * ginv12 + gammado233 * ginv22 + gammado333 * ginv23; - - gamma311 = - gammado111 * ginv13 + gammado211 * ginv23 + gammado311 * ginv33; - - gamma312 = - gammado112 * ginv13 + gammado212 * ginv23 + gammado312 * ginv33; - - gamma313 = - gammado113 * ginv13 + gammado213 * ginv23 + gammado313 * ginv33; - - gamma322 = - gammado122 * ginv13 + gammado222 * ginv23 + gammado322 * ginv33; - - gamma323 = - gammado123 * ginv13 + gammado223 * ginv23 + gammado323 * ginv33; - - gamma333 = - gammado133 * ginv13 + gammado233 * ginv23 + gammado333 * ginv33; - - Gfromg1 = - gamma111 * ginv11 + gamma122 * ginv22 + - 2. * (gamma112 * ginv12 + gamma113 * ginv13 + gamma123 * ginv23) + gamma133 * ginv33; - - Gfromg2 = - gamma211 * ginv11 + gamma222 * ginv22 + - 2. * (gamma212 * ginv12 + gamma213 * ginv13 + gamma223 * ginv23) + gamma233 * ginv33; - - Gfromg3 = - gamma311 * ginv11 + gamma322 * ginv22 + - 2. * (gamma312 * ginv12 + gamma313 * ginv13 + gamma323 * ginv23) + gamma333 * ginv33; - - R11 = - delG11 * g11 + delG12 * g12 + delG13 * g13 + gammado111 * Gfromg1 + - gammado112 * Gfromg2 + gammado113 * Gfromg3 + - (-0.5 * deldelg1111 + 3. * gamma111 * gammado111 + - 2. * (gamma211 * gammado112 + gamma311 * gammado113) + - gamma211 * gammado211 + gamma311 * gammado311) * - ginv11 + - (-deldelg1211 + 3. * (gamma112 * gammado111 + gamma111 * gammado112) + - 2. * (gamma212 * gammado112 + gamma312 * gammado113 + - gamma211 * gammado122 + gamma311 * gammado123) + - gamma212 * gammado211 + - gamma211 * gammado212 + gamma312 * gammado311 + gamma311 * gammado312) * - ginv12 + - (-deldelg1311 + 3. * (gamma113 * gammado111 + gamma111 * gammado113) + - 2. * (gamma213 * gammado112 + gamma313 * gammado113 + - gamma211 * gammado123 + gamma311 * gammado133) + - gamma213 * gammado211 + - gamma211 * gammado213 + gamma313 * gammado311 + gamma311 * gammado313) * - ginv13 + - (-0.5 * deldelg2211 + 3. * gamma112 * gammado112 + - 2. * (gamma212 * gammado122 + gamma312 * gammado123) + - gamma212 * gammado212 + gamma312 * gammado312) * - ginv22 + - (-deldelg2311 + 3. * (gamma113 * gammado112 + gamma112 * gammado113) + - 2. * (gamma213 * gammado122 + (gamma212 + gamma313) * gammado123 + - gamma312 * gammado133) + - gamma213 * gammado212 + gamma212 * gammado213 + - gamma313 * gammado312 + gamma312 * gammado313) * - ginv23 + - (-0.5 * deldelg3311 + 3. * gamma113 * gammado113 + - 2. * (gamma213 * gammado123 + gamma313 * gammado133) + gamma213 * gammado213 + - gamma313 * gammado313) * - ginv33; - - R12 = - 0.5 * (delG21 * g11 + (delG11 + delG22) * g12 + delG23 * g13 + delG12 * g22 + - delG13 * g23 + (gammado112 + gammado211) * Gfromg1 + - (gammado122 + gammado212) * Gfromg2 + (gammado123 + gammado213) * Gfromg3) + - (-0.5 * deldelg1112 + gamma112 * gammado111 + - (gamma111 + gamma212) * gammado112 + gamma312 * gammado113 + - gamma111 * gammado211 + 2. * gamma211 * gammado212 + - gamma311 * (gammado213 + gammado312)) * - ginv11 + - (-deldelg1212 + gamma122 * gammado111 + - (2. * gamma112 + gamma222) * gammado112 + gamma322 * gammado113 + - (gamma111 + gamma212) * gammado122 + gamma112 * gammado211 + - (gamma111 + 2. * gamma212) * gammado212 + 2. * gamma211 * gammado222 + - gamma312 * (gammado123 + gammado213 + gammado312) + - gamma311 * (gammado223 + gammado322)) * - ginv12 + - (-deldelg1312 + gamma123 * gammado111 + (gamma113 + gamma223) * gammado112 + - (gamma112 + gamma323) * gammado113 + (gamma111 + gamma212) * gammado123 + - gamma312 * gammado133 + gamma113 * gammado211 + - (gamma111 + gamma313) * gammado213 + - 2. * (gamma213 * gammado212 + gamma211 * gammado223) + - gamma313 * gammado312 + gamma311 * (gammado233 + gammado323)) * - ginv13 + - (-0.5 * deldelg2212 + gamma122 * gammado112 + - (gamma112 + gamma222) * gammado122 + gamma322 * gammado123 + - gamma112 * gammado212 + 2. * gamma212 * gammado222 + - gamma312 * (gammado223 + gammado322)) * - ginv22 + - (-deldelg2312 + gamma123 * gammado112 + gamma122 * gammado113 + - (gamma113 + gamma223) * gammado122 + - (gamma112 + gamma222 + gamma323) * gammado123 + gamma322 * gammado133 + - gamma113 * gammado212 + gamma112 * gammado213 + - 2. * (gamma213 * gammado222 + gamma212 * gammado223) + - gamma313 * (gammado223 + gammado322) + - gamma312 * (gammado233 + gammado323)) * - ginv23 + - (-0.5 * deldelg3312 + gamma123 * gammado113 + - (gamma113 + gamma223) * gammado123 + gamma323 * gammado133 + - gamma113 * gammado213 + 2. * gamma213 * gammado223 + - gamma313 * (gammado233 + gammado323)) * - ginv33; - - R13 = - 0.5 * (delG31 * g11 + delG32 * g12 + (delG11 + delG33) * g13 + delG12 * g23 + - delG13 * g33 + (gammado113 + gammado311) * Gfromg1 + - (gammado123 + gammado312) * Gfromg2 + (gammado133 + gammado313) * Gfromg3) + - (-0.5 * deldelg1113 + gamma113 * gammado111 + gamma213 * gammado112 + - (gamma111 + gamma313) * gammado113 + gamma111 * gammado311 + - gamma211 * (gammado213 + gammado312) + 2. * gamma311 * gammado313) * - ginv11 + - (-deldelg1213 + gamma123 * gammado111 + (gamma113 + gamma223) * gammado112 + - (gamma112 + gamma323) * gammado113 + gamma213 * gammado122 + - (gamma111 + gamma313) * gammado123 + gamma112 * gammado311 + - gamma111 * gammado312 + gamma212 * (gammado213 + gammado312) + - gamma211 * (gammado223 + gammado322) + - 2. * (gamma312 * gammado313 + gamma311 * gammado323)) * - ginv12 + - (-deldelg1313 + gamma133 * gammado111 + gamma233 * gammado112 + - (2. * gamma113 + gamma333) * gammado113 + - (gamma111 + gamma313) * gammado133 + gamma113 * gammado311 + - gamma213 * (gammado123 + gammado213 + gammado312) + - (gamma111 + 2. * gamma313) * gammado313 + - gamma211 * (gammado233 + gammado323) + 2. * gamma311 * gammado333) * - ginv13 + - (-0.5 * deldelg2213 + gamma123 * gammado112 + gamma223 * gammado122 + - (gamma112 + gamma323) * gammado123 + gamma112 * gammado312 + - gamma212 * (gammado223 + gammado322) + 2. * gamma312 * gammado323) * - ginv22 + - (-deldelg2313 + gamma133 * gammado112 + gamma123 * gammado113 + - gamma233 * gammado122 + (gamma113 + gamma223 + gamma333) * gammado123 + - (gamma112 + gamma323) * gammado133 + gamma113 * gammado312 + - gamma112 * gammado313 + gamma213 * (gammado223 + gammado322) + - gamma212 * (gammado233 + gammado323) + - 2. * (gamma313 * gammado323 + gamma312 * gammado333)) * - ginv23 + - (-0.5 * deldelg3313 + gamma133 * gammado113 + gamma233 * gammado123 + - (gamma113 + gamma333) * gammado133 + gamma113 * gammado313 + - gamma213 * (gammado233 + gammado323) + 2. * gamma313 * gammado333) * - ginv33; - - R22 = - delG21 * g12 + delG22 * g22 + delG23 * g23 + gammado212 * Gfromg1 + - gammado222 * Gfromg2 + gammado223 * Gfromg3 + - (-0.5 * deldelg1122 + gamma112 * (gammado112 + 2. * gammado211) + - 3. * gamma212 * gammado212 + gamma312 * (2. * gammado213 + gammado312)) * - ginv11 + - (-deldelg1222 + gamma122 * (gammado112 + 2. * gammado211) + - gamma112 * (gammado122 + 2. * gammado212) + - 3. * (gamma222 * gammado212 + gamma212 * gammado222) + - 2. * (gamma322 * gammado213 + gamma312 * gammado223) + - gamma322 * gammado312 + gamma312 * gammado322) * - ginv12 + - (-deldelg1322 + gamma123 * (gammado112 + 2. * gammado211) + - gamma112 * (gammado123 + 2. * gammado213) + - 3. * (gamma223 * gammado212 + gamma212 * gammado223) + - 2. * (gamma323 * gammado213 + gamma312 * gammado233) + - gamma323 * gammado312 + gamma312 * gammado323) * - ginv13 + - (-0.5 * deldelg2222 + gamma122 * (gammado122 + 2. * gammado212) + - 3. * gamma222 * gammado222 + gamma322 * (2. * gammado223 + gammado322)) * - ginv22 + - (-deldelg2322 + gamma123 * (gammado122 + 2. * gammado212) + - gamma122 * (gammado123 + 2. * gammado213) + - 3. * (gamma223 * gammado222 + gamma222 * gammado223) + - 2. * (gamma323 * gammado223 + gamma322 * gammado233) + - gamma323 * gammado322 + gamma322 * gammado323) * - ginv23 + - (-0.5 * deldelg3322 + gamma123 * (gammado123 + 2. * gammado213) + - 3. * gamma223 * gammado223 + gamma323 * (2. * gammado233 + gammado323)) * - ginv33; - - R23 = - 0.5 * (delG31 * g12 + delG21 * g13 + delG32 * g22 + (delG22 + delG33) * g23 + - delG23 * g33 + (gammado213 + gammado312) * Gfromg1 + - (gammado223 + gammado322) * Gfromg2 + (gammado233 + gammado323) * Gfromg3) + - (-0.5 * deldelg1123 + gamma113 * gammado211 + gamma213 * gammado212 + - (gamma212 + gamma313) * gammado213 + - gamma112 * (gammado113 + gammado311) + gamma212 * gammado312 + - 2. * gamma312 * gammado313) * - ginv11 + - (-deldelg1223 + gamma123 * gammado211 + (gamma113 + gamma223) * gammado212 + - (gamma222 + gamma323) * gammado213 + gamma213 * gammado222 + - (gamma212 + gamma313) * gammado223 + - gamma122 * (gammado113 + gammado311) + gamma222 * gammado312 + - gamma112 * (gammado123 + gammado312) + gamma212 * gammado322 + - 2. * (gamma322 * gammado313 + gamma312 * gammado323)) * - ginv12 + - (-deldelg1323 + gamma133 * gammado211 + gamma233 * gammado212 + - (gamma113 + gamma223 + gamma333) * gammado213 + gamma213 * gammado223 + - (gamma212 + gamma313) * gammado233 + - gamma123 * (gammado113 + gammado311) + gamma223 * gammado312 + - gamma112 * (gammado133 + gammado313) + gamma212 * gammado323 + - 2. * (gamma323 * gammado313 + gamma312 * gammado333)) * - ginv13 + - (-0.5 * deldelg2223 + gamma123 * gammado212 + gamma223 * gammado222 + - (gamma222 + gamma323) * gammado223 + - gamma122 * (gammado123 + gammado312) + gamma222 * gammado322 + - 2. * gamma322 * gammado323) * - ginv22 + - (-deldelg2323 + gamma133 * gammado212 + gamma233 * gammado222 + - (2. * gamma223 + gamma333) * gammado223 + - (gamma222 + gamma323) * gammado233 + - gamma123 * (gammado123 + gammado213 + gammado312) + - gamma122 * (gammado133 + gammado313) + gamma223 * gammado322 + - (gamma222 + 2. * gamma323) * gammado323 + 2. * gamma322 * gammado333) * - ginv23 + - (-0.5 * deldelg3323 + gamma133 * gammado213 + gamma233 * gammado223 + - (gamma223 + gamma333) * gammado233 + - gamma123 * (gammado133 + gammado313) + gamma223 * gammado323 + - 2. * gamma323 * gammado333) * - ginv33; - - R33 = - delG31 * g13 + delG32 * g23 + delG33 * g33 + gammado313 * Gfromg1 + - gammado323 * Gfromg2 + gammado333 * Gfromg3 + - (-0.5 * deldelg1133 + gamma113 * (gammado113 + 2. * gammado311) + - gamma213 * (gammado213 + 2. * gammado312) + 3. * gamma313 * gammado313) * - ginv11 + - (-deldelg1233 + gamma123 * (gammado113 + 2. * gammado311) + - gamma113 * (gammado123 + 2. * gammado312) + - gamma223 * (gammado213 + 2. * gammado312) + - gamma213 * (gammado223 + 2. * gammado322) + - 3. * (gamma323 * gammado313 + gamma313 * gammado323)) * - ginv12 + - (-deldelg1333 + gamma133 * (gammado113 + 2. * gammado311) + - gamma233 * (gammado213 + 2. * gammado312) + - gamma113 * (gammado133 + 2. * gammado313) + - gamma213 * (gammado233 + 2. * gammado323) + - 3. * (gamma333 * gammado313 + gamma313 * gammado333)) * - ginv13 + - (-0.5 * deldelg2233 + gamma123 * (gammado123 + 2. * gammado312) + - gamma223 * (gammado223 + 2. * gammado322) + 3. * gamma323 * gammado323) * - ginv22 + - (-deldelg2333 + gamma133 * (gammado123 + 2. * gammado312) + - gamma123 * (gammado133 + 2. * gammado313) + - gamma233 * (gammado223 + 2. * gammado322) + - gamma223 * (gammado233 + 2. * gammado323) + - 3. * (gamma333 * gammado323 + gamma323 * gammado333)) * - ginv23 + - (-0.5 * deldelg3333 + gamma133 * (gammado133 + 2. * gammado313) + - gamma233 * (gammado233 + 2. * gammado323) + 3. * gamma333 * gammado333) * - ginv33; - - chiguard = - chiDivFloor; - - chiguarded = - chi; - - if (chiguarded < chiguard) - chiguarded = chiguard; - - ff = - chiguarded; - - oochipsipower = - 1 / chipsipower; - - f = - oochipsipower * log(ff); - - psim4 = - exp(-4. * f); - - df1 = - (dchi1 * oochipsipower) / chiguarded; - - df2 = - (dchi2 * oochipsipower) / chiguarded; - - df3 = - (dchi3 * oochipsipower) / chiguarded; - - ddf11 = - (ddchi11 * oochipsipower) / chiguarded - chipsipower * pow2(df1); - - ddf12 = - -(chipsipower * df1 * df2) + (ddchi12 * oochipsipower) / chiguarded; - - ddf13 = - -(chipsipower * df1 * df3) + (ddchi13 * oochipsipower) / chiguarded; - - ddf22 = - (ddchi22 * oochipsipower) / chiguarded - chipsipower * pow2(df2); - - ddf23 = - -(chipsipower * df2 * df3) + (ddchi23 * oochipsipower) / chiguarded; - - ddf33 = - (ddchi33 * oochipsipower) / chiguarded - chipsipower * pow2(df3); - - cddf11 = - ddf11 - df1 * gamma111 - df2 * gamma211 - df3 * gamma311; - - cddf12 = - ddf12 - df1 * gamma112 - df2 * gamma212 - df3 * gamma312; - - cddf13 = - ddf13 - df1 * gamma113 - df2 * gamma213 - df3 * gamma313; - - cddf22 = - ddf22 - df1 * gamma122 - df2 * gamma222 - df3 * gamma322; - - cddf23 = - ddf23 - df1 * gamma123 - df2 * gamma223 - df3 * gamma323; - - cddf33 = - ddf33 - df1 * gamma133 - df2 * gamma233 - df3 * gamma333; - - trcddf = - cddf11 * ginv11 + cddf22 * ginv22 + - 2. * (cddf12 * ginv12 + cddf13 * ginv13 + cddf23 * ginv23) + cddf33 * ginv33; - - Rphi11 = - -2. * (cddf11 + g11 * trcddf) + (4. - 4. * g11 * ginv11) * pow2(df1) - - g11 * (8. * (df1 * (df2 * ginv12 + df3 * ginv13) + df2 * df3 * ginv23) + - 4. * (ginv22 * pow2(df2) + ginv33 * pow2(df3))); - - Rphi12 = - df1 * df2 * (4. - 8. * g12 * ginv12) - 2. * (cddf12 + g12 * trcddf) - - g12 * (8. * df3 * (df1 * ginv13 + df2 * ginv23) + - 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2) + ginv33 * pow2(df3))); - - Rphi13 = - df1 * (4. * df3 - 8. * df2 * g13 * ginv12) - 2. * (cddf13 + g13 * trcddf) - - g13 * (8. * df3 * (df1 * ginv13 + df2 * ginv23) + - 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2) + ginv33 * pow2(df3))); - - Rphi22 = - -2. * (cddf22 + g22 * trcddf) + (4. - 4. * g22 * ginv22) * pow2(df2) - - g22 * (8. * (df1 * (df2 * ginv12 + df3 * ginv13) + df2 * df3 * ginv23) + - 4. * (ginv11 * pow2(df1) + ginv33 * pow2(df3))); - - Rphi23 = - df2 * (-8. * df1 * g23 * ginv12 + df3 * (4. - 8. * g23 * ginv23)) - - 2. * (cddf23 + g23 * trcddf) - g23 * (8. * df1 * df3 * ginv13 + 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2) + ginv33 * pow2(df3))); - - Rphi33 = - -2. * (cddf33 + g33 * trcddf) - g33 * (8. * (df1 * (df2 * ginv12 + df3 * ginv13) + df2 * df3 * ginv23) + 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2))) + - (4. - 4. * g33 * ginv33) * pow2(df3); - - cdda11 = - dda11 - da2 * gamma211 - da3 * gamma311 + - da1 * (-gamma111 + df1 * (-4. + 2. * g11 * ginv11)) + - 2. * g11 * ((da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33); - - cdda12 = - dda12 - da1 * gamma112 - da2 * gamma212 - da3 * gamma312 + - 2. * (-(da2 * df1) - da1 * df2 + g12 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33)); - - cdda13 = - dda13 - da1 * gamma113 - da2 * gamma213 - da3 * gamma313 + - 2. * (-(da3 * df1) - da1 * df3 + g13 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33)); - - cdda22 = - dda22 - da1 * gamma122 - da2 * (4. * df2 + gamma222) - da3 * gamma322 + - 2. * g22 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33); - - cdda23 = - dda23 - da1 * gamma123 - da2 * gamma223 - da3 * gamma323 + - 2. * (-(da3 * df2) - da2 * df3 + g23 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33)); - - cdda33 = - dda33 - da1 * gamma133 - da2 * gamma233 - da3 * (4. * df3 + gamma333) + - 2. * g33 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33); - - trcdda = - (cdda11 * ginv11 + cdda22 * ginv22 + - 2. * (cdda12 * ginv12 + cdda13 * ginv13 + cdda23 * ginv23) + cdda33 * ginv33) * - psim4; - - AA11 = - 2. * (A11 * (A12 * ginv12 + A13 * ginv13) + A12 * A13 * ginv23) + ginv11 * pow2(A11) + - ginv22 * pow2(A12) + ginv33 * pow2(A13); - - AA12 = - (A12 * A13 + A11 * A23) * ginv13 + A12 * (A11 * ginv11 + A22 * ginv22) + - (A13 * A22 + A12 * A23) * ginv23 + A13 * A23 * ginv33 + ginv12 * (A11 * A22 + pow2(A12)); - - AA13 = - (A12 * A13 + A11 * A23) * ginv12 + A12 * A23 * ginv22 + (A13 * A23 + A12 * A33) * ginv23 + - A13 * (A11 * ginv11 + A33 * ginv33) + ginv13 * (A11 * A33 + pow2(A13)); - - AA22 = - 2. * (A12 * (A22 * ginv12 + A23 * ginv13) + A22 * A23 * ginv23) + ginv11 * pow2(A12) + - ginv22 * pow2(A22) + ginv33 * pow2(A23); - - AA23 = - A12 * A13 * ginv11 + (A13 * A22 + A12 * A23) * ginv12 + (A13 * A23 + A12 * A33) * ginv13 + - A23 * (A22 * ginv22 + A33 * ginv33) + ginv23 * (A22 * A33 + pow2(A23)); - - AA33 = - 2. * (A13 * (A23 * ginv12 + A33 * ginv13) + A23 * A33 * ginv23) + ginv11 * pow2(A13) + - ginv22 * pow2(A23) + ginv33 * pow2(A33); - - cAA = - AA11 * ginv11 + AA22 * ginv22 + 2. * (AA12 * ginv12 + AA13 * ginv13 + AA23 * ginv23) + - AA33 * ginv33; - - Ainv11 = - 2. * (A23 * ginv12 * ginv13 + ginv11 * (A12 * ginv12 + A13 * ginv13)) + - A11 * pow2(ginv11) + A22 * pow2(ginv12) + A33 * pow2(ginv13); - - Ainv12 = - ginv11 * (A11 * ginv12 + A12 * ginv22 + A13 * ginv23) + - ginv12 * (A13 * ginv13 + A22 * ginv22 + A23 * ginv23) + - ginv13 * (A23 * ginv22 + A33 * ginv23) + A12 * pow2(ginv12); - - Ainv13 = - ginv11 * (A11 * ginv13 + A12 * ginv23 + A13 * ginv33) + - ginv12 * (A12 * ginv13 + A22 * ginv23 + A23 * ginv33) + - ginv13 * (A23 * ginv23 + A33 * ginv33) + A13 * pow2(ginv13); - - Ainv22 = - 2. * (A23 * ginv22 * ginv23 + ginv12 * (A12 * ginv22 + A13 * ginv23)) + - A11 * pow2(ginv12) + A22 * pow2(ginv22) + A33 * pow2(ginv23); - - Ainv23 = - ginv13 * (A12 * ginv22 + A13 * ginv23) + A33 * ginv23 * ginv33 + - ginv12 * (A11 * ginv13 + A12 * ginv23 + A13 * ginv33) + - ginv22 * (A22 * ginv23 + A23 * ginv33) + A23 * pow2(ginv23); - - Ainv33 = - 2. * (A23 * ginv23 * ginv33 + ginv13 * (A12 * ginv23 + A13 * ginv33)) + - A11 * pow2(ginv13) + A22 * pow2(ginv23) + A33 * pow2(ginv33); - - divAinv1 = - (-1.5 * (Ainv11 * dchi1 + Ainv12 * dchi2 + Ainv13 * dchi3)) / chiguarded + - Ainv11 * gamma111 + Ainv22 * gamma122 + - 2. * (Ainv12 * gamma112 + Ainv13 * gamma113 + Ainv23 * gamma123) + - Ainv33 * gamma133 - (0.66666666666666666667 * dKhat1 + 0.33333333333333333333 * dTheta1) * ginv11 - - (0.66666666666666666667 * dKhat2 + 0.33333333333333333333 * dTheta2) * ginv12 - - (0.66666666666666666667 * dKhat3 + 0.33333333333333333333 * dTheta3) * ginv13; - - divAinv2 = - (-1.5 * (Ainv12 * dchi1 + Ainv22 * dchi2 + Ainv23 * dchi3)) / chiguarded + - Ainv11 * gamma211 + Ainv22 * gamma222 + - 2. * (Ainv12 * gamma212 + Ainv13 * gamma213 + Ainv23 * gamma223) + - Ainv33 * gamma233 - (0.66666666666666666667 * dKhat1 + 0.33333333333333333333 * dTheta1) * ginv12 - - (0.66666666666666666667 * dKhat2 + 0.33333333333333333333 * dTheta2) * ginv22 - - (0.66666666666666666667 * dKhat3 + 0.33333333333333333333 * dTheta3) * ginv23; - - divAinv3 = - (-1.5 * (Ainv13 * dchi1 + Ainv23 * dchi2 + Ainv33 * dchi3)) / chiguarded + - Ainv11 * gamma311 + Ainv22 * gamma322 + - 2. * (Ainv12 * gamma312 + Ainv13 * gamma313 + Ainv23 * gamma323) + - Ainv33 * gamma333 - (0.66666666666666666667 * dKhat1 + 0.33333333333333333333 * dTheta1) * ginv13 - - (0.66666666666666666667 * dKhat2 + 0.33333333333333333333 * dTheta2) * ginv23 - - (0.66666666666666666667 * dKhat3 + 0.33333333333333333333 * dTheta3) * ginv33; - - Rhat = - psim4 * (ginv11 * (R11 + Rphi11) + ginv22 * (R22 + Rphi22) + - 2. * (ginv12 * (R12 + Rphi12) + ginv13 * (R13 + Rphi13) + - ginv23 * (R23 + Rphi23)) + - ginv33 * (R33 + Rphi33)); - - Hhat = - -cAA + Rhat + 0.66666666666666666667 * pow2(K); - - divbeta = - db11 + db22 + db33; - - totdivbeta = - 0.66666666666666666667 * divbeta; - - ootddivbeta1 = - 0.33333333333333333333 * (ddb111 + ddb122 + ddb133); - - ootddivbeta2 = - 0.33333333333333333333 * (ddb121 + ddb222 + ddb233); - - ootddivbeta3 = - 0.33333333333333333333 * (ddb131 + ddb232 + ddb333); - - lieg11 = - 2. * (db11 * g11 + db12 * g12 + db13 * g13) - g11 * totdivbeta; - - lieg12 = - db21 * g11 + db23 * g13 + db12 * g22 + db13 * g23 + g12 * (db11 + db22 - totdivbeta); - - lieg13 = - db31 * g11 + db32 * g12 + db12 * g23 + db13 * g33 + g13 * (db11 + db33 - totdivbeta); - - lieg22 = - 2. * (db21 * g12 + db22 * g22 + db23 * g23) - g22 * totdivbeta; - - lieg23 = - db31 * g12 + db21 * g13 + db32 * g22 + db23 * g33 + g23 * (db22 + db33 - totdivbeta); - - lieg33 = - 2. * (db31 * g13 + db32 * g23 + db33 * g33) - g33 * totdivbeta; - - lieA11 = - 2. * (A11 * db11 + A12 * db12 + A13 * db13) - A11 * totdivbeta; - - lieA12 = - A22 * db12 + A23 * db13 + A11 * db21 + A13 * db23 + A12 * (db11 + db22 - totdivbeta); - - lieA13 = - A23 * db12 + A33 * db13 + A11 * db31 + A12 * db32 + A13 * (db11 + db33 - totdivbeta); - - lieA22 = - 2. * (A12 * db21 + A22 * db22 + A23 * db23) - A22 * totdivbeta; - - lieA23 = - A13 * db21 + A33 * db23 + A12 * db31 + A22 * db32 + A23 * (db22 + db33 - totdivbeta); - - lieA33 = - 2. * (A13 * db31 + A23 * db32 + A33 * db33) - A33 * totdivbeta; - - liechi = - 0.16666666666666666667 * chiguarded * chipsipower * divbeta; - - pseudolieG1 = - -(db11 * Gfromg1) - db21 * Gfromg2 - db31 * Gfromg3 + ddb221 * ginv22 + - 2. * ddb231 * ginv23 + ddb331 * ginv33 + ginv11 * (ddb111 + ootddivbeta1) + - ginv12 * (2. * ddb121 + ootddivbeta2) + ginv13 * (2. * ddb131 + ootddivbeta3) + - Gfromg1 * totdivbeta; - - pseudolieG2 = - -(db12 * Gfromg1) - db22 * Gfromg2 - db32 * Gfromg3 + ddb112 * ginv11 + - 2. * ddb132 * ginv13 + ddb332 * ginv33 + ginv12 * (2. * ddb122 + ootddivbeta1) + - ginv22 * (ddb222 + ootddivbeta2) + ginv23 * (2. * ddb232 + ootddivbeta3) + - Gfromg2 * totdivbeta; - - pseudolieG3 = - -(db13 * Gfromg1) - db23 * Gfromg2 - db33 * Gfromg3 + ddb113 * ginv11 + - 2. * ddb123 * ginv12 + ddb223 * ginv22 + ginv13 * (2. * ddb133 + ootddivbeta1) + - ginv23 * (2. * ddb233 + ootddivbeta2) + ginv33 * (ddb333 + ootddivbeta3) + - Gfromg3 * totdivbeta; - - rg11 = - -2. * A11 * alpha + lieg11; - - rg12 = - -2. * A12 * alpha + lieg12; - - rg13 = - -2. * A13 * alpha + lieg13; - - rg22 = - -2. * A22 * alpha + lieg22; - - rg23 = - -2. * A23 * alpha + lieg23; - - rg33 = - -2. * A33 * alpha + lieg33; - - rA11 = - lieA11 + alpha * (-2. * AA11 + A11 * K + psim4 * R11 - 0.33333333333333333333 * g11 * Rhat) + psim4 * (-cdda11 + alpha * Rphi11) + - 0.33333333333333333333 * g11 * trcdda; - - rA12 = - lieA12 + alpha * (-2. * AA12 + A12 * K + psim4 * R12 - 0.33333333333333333333 * g12 * Rhat) + psim4 * (-cdda12 + alpha * Rphi12) + - 0.33333333333333333333 * g12 * trcdda; - - rA13 = - lieA13 + alpha * (-2. * AA13 + A13 * K + psim4 * R13 - 0.33333333333333333333 * g13 * Rhat) + psim4 * (-cdda13 + alpha * Rphi13) + - 0.33333333333333333333 * g13 * trcdda; - - rA22 = - lieA22 + alpha * (-2. * AA22 + A22 * K + psim4 * R22 - 0.33333333333333333333 * g22 * Rhat) + psim4 * (-cdda22 + alpha * Rphi22) + - 0.33333333333333333333 * g22 * trcdda; - - rA23 = - lieA23 + alpha * (-2. * AA23 + A23 * K + psim4 * R23 - 0.33333333333333333333 * g23 * Rhat) + psim4 * (-cdda23 + alpha * Rphi23) + - 0.33333333333333333333 * g23 * trcdda; - - rA33 = - lieA33 + alpha * (-2. * AA33 + A33 * K + psim4 * R33 - 0.33333333333333333333 * g33 * Rhat) + psim4 * (-cdda33 + alpha * Rphi33) + - 0.33333333333333333333 * g33 * trcdda; - - rG1 = - -2. * (Ainv11 * da1 + Ainv12 * da2 + Ainv13 * da3) + - alpha * (2. * divAinv1 + 2. * (-G1 + Gfromg1) * kappa1) + pseudolieG1; - - rG2 = - -2. * (Ainv12 * da1 + Ainv22 * da2 + Ainv23 * da3) + - alpha * (2. * divAinv2 + 2. * (-G2 + Gfromg2) * kappa1) + pseudolieG2; - - rG3 = - -2. * (Ainv13 * da1 + Ainv23 * da2 + Ainv33 * da3) + - alpha * (2. * divAinv3 + 2. * (-G3 + Gfromg3) * kappa1) + pseudolieG3; - - rKhat = - -trcdda + alpha * (cAA + kappa1 * (Theta - kappa2 * Theta) + - 0.33333333333333333333 * pow2(K)); - - rchi = - -0.16666666666666666667 * alpha * chiguarded * chipsipower * K + liechi; - - rTheta = - alpha * (0.5 * Hhat - kappa1 * (2. + kappa2) * Theta); - -#if 0 -// this part is for CCZ4 -dginv111 -= --2.*(delg123*ginv12*ginv13 + ginv11*(delg112*ginv12 + delg113*ginv13)) - - delg111*pow2(ginv11) - delg122*pow2(ginv12) - delg133*pow2(ginv13) -; - -dginv112 -= --(ginv11*(delg111*ginv12 + delg112*ginv22 + delg113*ginv23)) - - ginv12*(delg113*ginv13 + delg122*ginv22 + delg123*ginv23) - - ginv13*(delg123*ginv22 + delg133*ginv23) - delg112*pow2(ginv12) -; - -dginv113 -= --(ginv11*(delg111*ginv13 + delg112*ginv23 + delg113*ginv33)) - - ginv12*(delg112*ginv13 + delg122*ginv23 + delg123*ginv33) - - ginv13*(delg123*ginv23 + delg133*ginv33) - delg113*pow2(ginv13) -; - -dginv122 -= --2.*(delg123*ginv22*ginv23 + ginv12*(delg112*ginv22 + delg113*ginv23)) - - delg111*pow2(ginv12) - delg122*pow2(ginv22) - delg133*pow2(ginv23) -; - -dginv123 -= --(ginv13*(delg112*ginv22 + delg113*ginv23)) - delg133*ginv23*ginv33 - - ginv12*(delg111*ginv13 + delg112*ginv23 + delg113*ginv33) - - ginv22*(delg122*ginv23 + delg123*ginv33) - delg123*pow2(ginv23) -; - -dginv133 -= --2.*(delg123*ginv23*ginv33 + ginv13*(delg112*ginv23 + delg113*ginv33)) - - delg111*pow2(ginv13) - delg122*pow2(ginv23) - delg133*pow2(ginv33) -; - -dginv211 -= --2.*(delg223*ginv12*ginv13 + ginv11*(delg212*ginv12 + delg213*ginv13)) - - delg211*pow2(ginv11) - delg222*pow2(ginv12) - delg233*pow2(ginv13) -; - -dginv212 -= --(ginv11*(delg211*ginv12 + delg212*ginv22 + delg213*ginv23)) - - ginv12*(delg213*ginv13 + delg222*ginv22 + delg223*ginv23) - - ginv13*(delg223*ginv22 + delg233*ginv23) - delg212*pow2(ginv12) -; - -dginv213 -= --(ginv11*(delg211*ginv13 + delg212*ginv23 + delg213*ginv33)) - - ginv12*(delg212*ginv13 + delg222*ginv23 + delg223*ginv33) - - ginv13*(delg223*ginv23 + delg233*ginv33) - delg213*pow2(ginv13) -; - -dginv222 -= --2.*(delg223*ginv22*ginv23 + ginv12*(delg212*ginv22 + delg213*ginv23)) - - delg211*pow2(ginv12) - delg222*pow2(ginv22) - delg233*pow2(ginv23) -; - -dginv223 -= --(ginv13*(delg212*ginv22 + delg213*ginv23)) - delg233*ginv23*ginv33 - - ginv12*(delg211*ginv13 + delg212*ginv23 + delg213*ginv33) - - ginv22*(delg222*ginv23 + delg223*ginv33) - delg223*pow2(ginv23) -; - -dginv233 -= --2.*(delg223*ginv23*ginv33 + ginv13*(delg212*ginv23 + delg213*ginv33)) - - delg211*pow2(ginv13) - delg222*pow2(ginv23) - delg233*pow2(ginv33) -; - -dginv311 -= --2.*(delg323*ginv12*ginv13 + ginv11*(delg312*ginv12 + delg313*ginv13)) - - delg311*pow2(ginv11) - delg322*pow2(ginv12) - delg333*pow2(ginv13) -; - -dginv312 -= --(ginv11*(delg311*ginv12 + delg312*ginv22 + delg313*ginv23)) - - ginv12*(delg313*ginv13 + delg322*ginv22 + delg323*ginv23) - - ginv13*(delg323*ginv22 + delg333*ginv23) - delg312*pow2(ginv12) -; - -dginv313 -= --(ginv11*(delg311*ginv13 + delg312*ginv23 + delg313*ginv33)) - - ginv12*(delg312*ginv13 + delg322*ginv23 + delg323*ginv33) - - ginv13*(delg323*ginv23 + delg333*ginv33) - delg313*pow2(ginv13) -; - -dginv322 -= --2.*(delg323*ginv22*ginv23 + ginv12*(delg312*ginv22 + delg313*ginv23)) - - delg311*pow2(ginv12) - delg322*pow2(ginv22) - delg333*pow2(ginv23) -; - -dginv323 -= --(ginv13*(delg312*ginv22 + delg313*ginv23)) - delg333*ginv23*ginv33 - - ginv12*(delg311*ginv13 + delg312*ginv23 + delg313*ginv33) - - ginv22*(delg322*ginv23 + delg323*ginv33) - delg323*pow2(ginv23) -; - -dginv333 -= --2.*(delg323*ginv23*ginv33 + ginv13*(delg312*ginv23 + delg313*ginv33)) - - delg311*pow2(ginv13) - delg322*pow2(ginv23) - delg333*pow2(ginv33) -; - -dphi1 -= -(-0.25*dchi1)/chiguarded -; - -dphi2 -= -(-0.25*dchi2)/chiguarded -; - -dphi3 -= -(-0.25*dchi3)/chiguarded -; - -gammaF111 -= -gamma111 + dphi1*(4. - 2.*g11*ginv11) - 2.*g11*(dphi2*ginv12 + dphi3*ginv13) -; - -gammaF112 -= -gamma112 + dphi2*(2. - 2.*g12*ginv12) - 2.*g12*(dphi1*ginv11 + dphi3*ginv13) -; - -gammaF113 -= -gamma113 - 2.*g13*(dphi1*ginv11 + dphi2*ginv12) + dphi3*(2. - 2.*g13*ginv13) -; - -gammaF121 -= -gamma112 + dphi2*(2. - 2.*g12*ginv12) - 2.*g12*(dphi1*ginv11 + dphi3*ginv13) -; - -gammaF122 -= -gamma122 - 2.*g22*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) -; - -gammaF123 -= -gamma123 - 2.*g23*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) -; - -gammaF131 -= -gamma113 - 2.*g13*(dphi1*ginv11 + dphi2*ginv12) + dphi3*(2. - 2.*g13*ginv13) -; - -gammaF132 -= -gamma123 - 2.*g23*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) -; - -gammaF133 -= -gamma133 - 2.*g33*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) -; - -gammaF211 -= -gamma211 - 2.*g11*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) -; - -gammaF212 -= -gamma212 + dphi1*(2. - 2.*g12*ginv12) - 2.*g12*(dphi2*ginv22 + dphi3*ginv23) -; - -gammaF213 -= -gamma213 - 2.*g13*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) -; - -gammaF221 -= -gamma212 + dphi1*(2. - 2.*g12*ginv12) - 2.*g12*(dphi2*ginv22 + dphi3*ginv23) -; - -gammaF222 -= -gamma222 + dphi2*(4. - 2.*g22*ginv22) - 2.*g22*(dphi1*ginv12 + dphi3*ginv23) -; - -gammaF223 -= -gamma223 - 2.*g23*(dphi1*ginv12 + dphi2*ginv22) + dphi3*(2. - 2.*g23*ginv23) -; - -gammaF231 -= -gamma213 - 2.*g13*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) -; - -gammaF232 -= -gamma223 - 2.*g23*(dphi1*ginv12 + dphi2*ginv22) + dphi3*(2. - 2.*g23*ginv23) -; - -gammaF233 -= -gamma233 - 2.*g33*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) -; - -gammaF311 -= -gamma311 - 2.*g11*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) -; - -gammaF312 -= -gamma312 - 2.*g12*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) -; - -gammaF313 -= -gamma313 + dphi1*(2. - 2.*g13*ginv13) - 2.*g13*(dphi2*ginv23 + dphi3*ginv33) -; - -gammaF321 -= -gamma312 - 2.*g12*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) -; - -gammaF322 -= -gamma322 - 2.*g22*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) -; - -gammaF323 -= -gamma323 + dphi2*(2. - 2.*g23*ginv23) - 2.*g23*(dphi1*ginv13 + dphi3*ginv33) -; - -gammaF331 -= -gamma313 + dphi1*(2. - 2.*g13*ginv13) - 2.*g13*(dphi2*ginv23 + dphi3*ginv33) -; - -gammaF332 -= -gamma323 + dphi2*(2. - 2.*g23*ginv23) - 2.*g23*(dphi1*ginv13 + dphi3*ginv33) -; - -gammaF333 -= -gamma333 - 2.*g33*(dphi1*ginv13 + dphi2*ginv23) + dphi3*(4. - 2.*g33*ginv33) -; - -Gd1 -= -ginv11*((2.*delg112 + delg211)*ginv12 + (2.*delg113 + delg311)*ginv13 + - delg212*ginv22 + (delg213 + delg312)*ginv23 + delg313*ginv33) + - ginv12*((2.*delg123 + delg213 + delg312)*ginv13 + delg222*ginv22 + - (delg223 + delg322)*ginv23 + delg323*ginv33) + - ginv13*(delg223*ginv22 + (delg233 + delg323)*ginv23 + delg333*ginv33) + - delg111*pow2(ginv11) + (delg122 + delg212)*pow2(ginv12) + - (delg133 + delg313)*pow2(ginv13) -; - -Gd2 -= -ginv11*(delg111*ginv12 + delg112*ginv22 + delg113*ginv23) + - ginv13*((delg123 + delg312)*ginv22 + (delg133 + delg313)*ginv23) + - delg333*ginv23*ginv33 + ginv12* - ((delg113 + delg311)*ginv13 + (delg122 + 2.*delg212)*ginv22 + - (delg123 + 2.*delg213 + delg312)*ginv23 + delg313*ginv33) + - ginv22*((2.*delg223 + delg322)*ginv23 + delg323*ginv33) + - (delg112 + delg211)*pow2(ginv12) + delg222*pow2(ginv22) + - (delg233 + delg323)*pow2(ginv23) -; - -Gd3 -= -(delg233 + 2.*delg323)*ginv23*ginv33 + - ginv11*(delg111*ginv13 + delg112*ginv23 + delg113*ginv33) + - ginv12*((delg112 + delg211)*ginv13 + (delg122 + delg212)*ginv23 + - (delg123 + delg213)*ginv33) + - ginv22*(delg222*ginv23 + delg223*ginv33) + - ginv13*(delg212*ginv22 + (delg123 + delg213 + 2.*delg312)*ginv23 + - (delg133 + 2.*delg313)*ginv33) + (delg113 + delg311)*pow2(ginv13) + - (delg223 + delg322)*pow2(ginv23) + delg333*pow2(ginv33) -; - -dGd11 -= -(delg212*dginv111 + delg222*dginv112 + delg223*dginv113)*ginv22 + - ((delg213 + delg312)*dginv111 + (delg223 + delg322)*dginv112 + - (delg233 + delg323)*dginv113)*ginv23 + - (delg313*dginv111 + delg323*dginv112 + delg333*dginv113)*ginv33 + - ginv11*(delg211*dginv112 + delg311*dginv113 + - 2.*(delg111*dginv111 + delg112*dginv112 + delg113*dginv113) + - delg212*dginv122 + (delg213 + delg312)*dginv123 + delg313*dginv133 + - (2.*deldelg1112 + deldelg1211)*ginv12 + - (2.*deldelg1113 + deldelg1311)*ginv13 + deldelg1212*ginv22 + - (deldelg1213 + deldelg1312)*ginv23 + deldelg1313*ginv33) + - ginv12*((2.*delg112 + delg211)*dginv111 + (delg213 + delg312)*dginv113 + - 2.*((delg122 + delg212)*dginv112 + delg123*dginv113) + - delg222*dginv122 + (delg223 + delg322)*dginv123 + delg323*dginv133 + - (2.*deldelg1123 + deldelg1213 + deldelg1312)*ginv13 + - deldelg1222*ginv22 + (deldelg1223 + deldelg1322)*ginv23 + - deldelg1323*ginv33) + ginv13* - ((2.*delg113 + delg311)*dginv111 + - (2.*delg123 + delg213 + delg312)*dginv112 + - 2.*(delg133 + delg313)*dginv113 + delg223*dginv122 + - (delg233 + delg323)*dginv123 + delg333*dginv133 + deldelg1223*ginv22 + - (deldelg1233 + deldelg1323)*ginv23 + deldelg1333*ginv33) + - deldelg1111*pow2(ginv11) + (deldelg1122 + deldelg1212)*pow2(ginv12) + - (deldelg1133 + deldelg1313)*pow2(ginv13) -; - -dGd12 -= -ginv11*(delg111*dginv112 + delg112*dginv122 + delg113*dginv123 + - deldelg1111*ginv12 + deldelg1112*ginv22 + deldelg1113*ginv23) + - ginv13*((delg113 + delg311)*dginv112 + (delg123 + delg312)*dginv122 + - (delg133 + delg313)*dginv123 + (deldelg1123 + deldelg1312)*ginv22 + - (deldelg1133 + deldelg1313)*ginv23) + - (delg313*dginv112 + delg323*dginv122 + delg333*dginv123)*ginv33 + - ginv12*(delg111*dginv111 + (delg113 + delg311)*dginv113 + - delg122*dginv122 + (delg123 + delg312)*dginv123 + - 2.*((delg112 + delg211)*dginv112 + delg212*dginv122 + - delg213*dginv123) + delg313*dginv133 + - (deldelg1113 + deldelg1311)*ginv13 + - (deldelg1122 + 2.*deldelg1212)*ginv22 + - (deldelg1123 + 2.*deldelg1213 + deldelg1312)*ginv23 + - deldelg1313*ginv33) + ginv22* - (delg112*dginv111 + (delg122 + 2.*delg212)*dginv112 + - (delg123 + delg312)*dginv113 + delg322*dginv123 + - 2.*(delg222*dginv122 + delg223*dginv123) + delg323*dginv133 + - (2.*deldelg1223 + deldelg1322)*ginv23 + deldelg1323*ginv33) + - ginv23*(delg113*dginv111 + (delg123 + 2.*delg213 + delg312)*dginv112 + - (delg133 + delg313)*dginv113 + (2.*delg223 + delg322)*dginv122 + - 2.*(delg233 + delg323)*dginv123 + delg333*dginv133 + deldelg1333*ginv33\ -) + (deldelg1112 + deldelg1211)*pow2(ginv12) + deldelg1222*pow2(ginv22) + - (deldelg1233 + deldelg1323)*pow2(ginv23) -; - -dGd13 -= -(delg113*dginv111 + (delg123 + delg213)*dginv112 + - (delg133 + 2.*delg313)*dginv113 + delg223*dginv122 + - (delg233 + 2.*delg323)*dginv123 + 2.*delg333*dginv133)*ginv33 + - ginv11*(delg111*dginv113 + delg112*dginv123 + delg113*dginv133 + - deldelg1111*ginv13 + deldelg1112*ginv23 + deldelg1113*ginv33) + - ginv12*((delg112 + delg211)*dginv113 + (delg122 + delg212)*dginv123 + - (delg123 + delg213)*dginv133 + (deldelg1112 + deldelg1211)*ginv13 + - (deldelg1122 + deldelg1212)*ginv23 + (deldelg1123 + deldelg1213)*ginv33\ -) + ginv22*(delg212*dginv113 + delg222*dginv123 + delg223*dginv133 + - deldelg1222*ginv23 + deldelg1223*ginv33) + - ginv13*(delg111*dginv111 + (delg112 + delg211)*dginv112 + - delg212*dginv122 + (delg123 + delg213)*dginv123 + delg133*dginv133 + - 2.*((delg113 + delg311)*dginv113 + delg312*dginv123 + - delg313*dginv133) + deldelg1212*ginv22 + - (deldelg1123 + deldelg1213 + 2.*deldelg1312)*ginv23 + - (deldelg1133 + 2.*deldelg1313)*ginv33) + - ginv23*(delg112*dginv111 + (delg122 + delg212)*dginv112 + - (delg123 + delg213 + 2.*delg312)*dginv113 + delg222*dginv122 + - delg233*dginv133 + 2.*((delg223 + delg322)*dginv123 + - delg323*dginv133) + (deldelg1233 + 2.*deldelg1323)*ginv33) + - (deldelg1113 + deldelg1311)*pow2(ginv13) + - (deldelg1223 + deldelg1322)*pow2(ginv23) + deldelg1333*pow2(ginv33) -; - -dGd21 -= -(delg212*dginv211 + delg222*dginv212 + delg223*dginv213)*ginv22 + - ((delg213 + delg312)*dginv211 + (delg223 + delg322)*dginv212 + - (delg233 + delg323)*dginv213)*ginv23 + - (delg313*dginv211 + delg323*dginv212 + delg333*dginv213)*ginv33 + - ginv11*(delg211*dginv212 + delg311*dginv213 + - 2.*(delg111*dginv211 + delg112*dginv212 + delg113*dginv213) + - delg212*dginv222 + (delg213 + delg312)*dginv223 + delg313*dginv233 + - (2.*deldelg1212 + deldelg2211)*ginv12 + - (2.*deldelg1213 + deldelg2311)*ginv13 + deldelg2212*ginv22 + - (deldelg2213 + deldelg2312)*ginv23 + deldelg2313*ginv33) + - ginv12*((2.*delg112 + delg211)*dginv211 + (delg213 + delg312)*dginv213 + - 2.*((delg122 + delg212)*dginv212 + delg123*dginv213) + - delg222*dginv222 + (delg223 + delg322)*dginv223 + delg323*dginv233 + - (2.*deldelg1223 + deldelg2213 + deldelg2312)*ginv13 + - deldelg2222*ginv22 + (deldelg2223 + deldelg2322)*ginv23 + - deldelg2323*ginv33) + ginv13* - ((2.*delg113 + delg311)*dginv211 + - (2.*delg123 + delg213 + delg312)*dginv212 + - 2.*(delg133 + delg313)*dginv213 + delg223*dginv222 + - (delg233 + delg323)*dginv223 + delg333*dginv233 + deldelg2223*ginv22 + - (deldelg2233 + deldelg2323)*ginv23 + deldelg2333*ginv33) + - deldelg1211*pow2(ginv11) + (deldelg1222 + deldelg2212)*pow2(ginv12) + - (deldelg1233 + deldelg2313)*pow2(ginv13) -; - -dGd22 -= -ginv11*(delg111*dginv212 + delg112*dginv222 + delg113*dginv223 + - deldelg1211*ginv12 + deldelg1212*ginv22 + deldelg1213*ginv23) + - ginv13*((delg113 + delg311)*dginv212 + (delg123 + delg312)*dginv222 + - (delg133 + delg313)*dginv223 + (deldelg1223 + deldelg2312)*ginv22 + - (deldelg1233 + deldelg2313)*ginv23) + - (delg313*dginv212 + delg323*dginv222 + delg333*dginv223)*ginv33 + - ginv12*(delg111*dginv211 + (delg113 + delg311)*dginv213 + - delg122*dginv222 + (delg123 + delg312)*dginv223 + - 2.*((delg112 + delg211)*dginv212 + delg212*dginv222 + - delg213*dginv223) + delg313*dginv233 + - (deldelg1213 + deldelg2311)*ginv13 + - (deldelg1222 + 2.*deldelg2212)*ginv22 + - (deldelg1223 + 2.*deldelg2213 + deldelg2312)*ginv23 + - deldelg2313*ginv33) + ginv22* - (delg112*dginv211 + (delg122 + 2.*delg212)*dginv212 + - (delg123 + delg312)*dginv213 + delg322*dginv223 + - 2.*(delg222*dginv222 + delg223*dginv223) + delg323*dginv233 + - (2.*deldelg2223 + deldelg2322)*ginv23 + deldelg2323*ginv33) + - ginv23*(delg113*dginv211 + (delg123 + 2.*delg213 + delg312)*dginv212 + - (delg133 + delg313)*dginv213 + (2.*delg223 + delg322)*dginv222 + - 2.*(delg233 + delg323)*dginv223 + delg333*dginv233 + deldelg2333*ginv33\ -) + (deldelg1212 + deldelg2211)*pow2(ginv12) + deldelg2222*pow2(ginv22) + - (deldelg2233 + deldelg2323)*pow2(ginv23) -; - -dGd23 -= -(delg113*dginv211 + (delg123 + delg213)*dginv212 + - (delg133 + 2.*delg313)*dginv213 + delg223*dginv222 + - (delg233 + 2.*delg323)*dginv223 + 2.*delg333*dginv233)*ginv33 + - ginv11*(delg111*dginv213 + delg112*dginv223 + delg113*dginv233 + - deldelg1211*ginv13 + deldelg1212*ginv23 + deldelg1213*ginv33) + - ginv12*((delg112 + delg211)*dginv213 + (delg122 + delg212)*dginv223 + - (delg123 + delg213)*dginv233 + (deldelg1212 + deldelg2211)*ginv13 + - (deldelg1222 + deldelg2212)*ginv23 + (deldelg1223 + deldelg2213)*ginv33\ -) + ginv22*(delg212*dginv213 + delg222*dginv223 + delg223*dginv233 + - deldelg2222*ginv23 + deldelg2223*ginv33) + - ginv13*(delg111*dginv211 + (delg112 + delg211)*dginv212 + - delg212*dginv222 + (delg123 + delg213)*dginv223 + delg133*dginv233 + - 2.*((delg113 + delg311)*dginv213 + delg312*dginv223 + - delg313*dginv233) + deldelg2212*ginv22 + - (deldelg1223 + deldelg2213 + 2.*deldelg2312)*ginv23 + - (deldelg1233 + 2.*deldelg2313)*ginv33) + - ginv23*(delg112*dginv211 + (delg122 + delg212)*dginv212 + - (delg123 + delg213 + 2.*delg312)*dginv213 + delg222*dginv222 + - delg233*dginv233 + 2.*((delg223 + delg322)*dginv223 + - delg323*dginv233) + (deldelg2233 + 2.*deldelg2323)*ginv33) + - (deldelg1213 + deldelg2311)*pow2(ginv13) + - (deldelg2223 + deldelg2322)*pow2(ginv23) + deldelg2333*pow2(ginv33) -; - -dGd31 -= -(delg212*dginv311 + delg222*dginv312 + delg223*dginv313)*ginv22 + - ((delg213 + delg312)*dginv311 + (delg223 + delg322)*dginv312 + - (delg233 + delg323)*dginv313)*ginv23 + - (delg313*dginv311 + delg323*dginv312 + delg333*dginv313)*ginv33 + - ginv11*(delg211*dginv312 + delg311*dginv313 + - 2.*(delg111*dginv311 + delg112*dginv312 + delg113*dginv313) + - delg212*dginv322 + (delg213 + delg312)*dginv323 + delg313*dginv333 + - (2.*deldelg1312 + deldelg2311)*ginv12 + - (2.*deldelg1313 + deldelg3311)*ginv13 + deldelg2312*ginv22 + - (deldelg2313 + deldelg3312)*ginv23 + deldelg3313*ginv33) + - ginv12*((2.*delg112 + delg211)*dginv311 + (delg213 + delg312)*dginv313 + - 2.*((delg122 + delg212)*dginv312 + delg123*dginv313) + - delg222*dginv322 + (delg223 + delg322)*dginv323 + delg323*dginv333 + - (2.*deldelg1323 + deldelg2313 + deldelg3312)*ginv13 + - deldelg2322*ginv22 + (deldelg2323 + deldelg3322)*ginv23 + - deldelg3323*ginv33) + ginv13* - ((2.*delg113 + delg311)*dginv311 + - (2.*delg123 + delg213 + delg312)*dginv312 + - 2.*(delg133 + delg313)*dginv313 + delg223*dginv322 + - (delg233 + delg323)*dginv323 + delg333*dginv333 + deldelg2323*ginv22 + - (deldelg2333 + deldelg3323)*ginv23 + deldelg3333*ginv33) + - deldelg1311*pow2(ginv11) + (deldelg1322 + deldelg2312)*pow2(ginv12) + - (deldelg1333 + deldelg3313)*pow2(ginv13) -; - -dGd32 -= -ginv11*(delg111*dginv312 + delg112*dginv322 + delg113*dginv323 + - deldelg1311*ginv12 + deldelg1312*ginv22 + deldelg1313*ginv23) + - ginv13*((delg113 + delg311)*dginv312 + (delg123 + delg312)*dginv322 + - (delg133 + delg313)*dginv323 + (deldelg1323 + deldelg3312)*ginv22 + - (deldelg1333 + deldelg3313)*ginv23) + - (delg313*dginv312 + delg323*dginv322 + delg333*dginv323)*ginv33 + - ginv12*(delg111*dginv311 + (delg113 + delg311)*dginv313 + - delg122*dginv322 + (delg123 + delg312)*dginv323 + - 2.*((delg112 + delg211)*dginv312 + delg212*dginv322 + - delg213*dginv323) + delg313*dginv333 + - (deldelg1313 + deldelg3311)*ginv13 + - (deldelg1322 + 2.*deldelg2312)*ginv22 + - (deldelg1323 + 2.*deldelg2313 + deldelg3312)*ginv23 + - deldelg3313*ginv33) + ginv22* - (delg112*dginv311 + (delg122 + 2.*delg212)*dginv312 + - (delg123 + delg312)*dginv313 + delg322*dginv323 + - 2.*(delg222*dginv322 + delg223*dginv323) + delg323*dginv333 + - (2.*deldelg2323 + deldelg3322)*ginv23 + deldelg3323*ginv33) + - ginv23*(delg113*dginv311 + (delg123 + 2.*delg213 + delg312)*dginv312 + - (delg133 + delg313)*dginv313 + (2.*delg223 + delg322)*dginv322 + - 2.*(delg233 + delg323)*dginv323 + delg333*dginv333 + deldelg3333*ginv33\ -) + (deldelg1312 + deldelg2311)*pow2(ginv12) + deldelg2322*pow2(ginv22) + - (deldelg2333 + deldelg3323)*pow2(ginv23) -; - -dGd33 -= -(delg113*dginv311 + (delg123 + delg213)*dginv312 + - (delg133 + 2.*delg313)*dginv313 + delg223*dginv322 + - (delg233 + 2.*delg323)*dginv323 + 2.*delg333*dginv333)*ginv33 + - ginv11*(delg111*dginv313 + delg112*dginv323 + delg113*dginv333 + - deldelg1311*ginv13 + deldelg1312*ginv23 + deldelg1313*ginv33) + - ginv12*((delg112 + delg211)*dginv313 + (delg122 + delg212)*dginv323 + - (delg123 + delg213)*dginv333 + (deldelg1312 + deldelg2311)*ginv13 + - (deldelg1322 + deldelg2312)*ginv23 + (deldelg1323 + deldelg2313)*ginv33\ -) + ginv22*(delg212*dginv313 + delg222*dginv323 + delg223*dginv333 + - deldelg2322*ginv23 + deldelg2323*ginv33) + - ginv13*(delg111*dginv311 + (delg112 + delg211)*dginv312 + - delg212*dginv322 + (delg123 + delg213)*dginv323 + delg133*dginv333 + - 2.*((delg113 + delg311)*dginv313 + delg312*dginv323 + - delg313*dginv333) + deldelg2312*ginv22 + - (deldelg1323 + deldelg2313 + 2.*deldelg3312)*ginv23 + - (deldelg1333 + 2.*deldelg3313)*ginv33) + - ginv23*(delg112*dginv311 + (delg122 + delg212)*dginv312 + - (delg123 + delg213 + 2.*delg312)*dginv313 + delg222*dginv322 + - delg233*dginv333 + 2.*((delg223 + delg322)*dginv323 + - delg323*dginv333) + (deldelg2333 + 2.*deldelg3323)*ginv33) + - (deldelg1313 + deldelg3311)*pow2(ginv13) + - (deldelg2323 + deldelg3322)*pow2(ginv23) + deldelg3333*pow2(ginv33) -; - -Zinv1 -= -0.5*(G1 - Gd1) -; - -Zinv2 -= -0.5*(G2 - Gd2) -; - -Zinv3 -= -0.5*(G3 - Gd3) -; - -dZinv11 -= -0.5*(delG11 - dGd11) -; - -dZinv12 -= -0.5*(delG12 - dGd12) -; - -dZinv13 -= -0.5*(delG13 - dGd13) -; - -dZinv21 -= -0.5*(delG21 - dGd21) -; - -dZinv22 -= -0.5*(delG22 - dGd22) -; - -dZinv23 -= -0.5*(delG23 - dGd23) -; - -dZinv31 -= -0.5*(delG31 - dGd31) -; - -dZinv32 -= -0.5*(delG32 - dGd32) -; - -dZinv33 -= -0.5*(delG33 - dGd33) -; - -Z1 -= -g11*Zinv1 + g12*Zinv2 + g13*Zinv3 -; - -Z2 -= -g12*Zinv1 + g22*Zinv2 + g23*Zinv3 -; - -Z3 -= -g13*Zinv1 + g23*Zinv2 + g33*Zinv3 -; - -dZ11 -= -dZinv11*g11 + dZinv12*g12 + dZinv13*g13 + delg111*Zinv1 + delg112*Zinv2 + - delg113*Zinv3 -; - -dZ12 -= -dZinv11*g12 + dZinv12*g22 + dZinv13*g23 + delg112*Zinv1 + delg122*Zinv2 + - delg123*Zinv3 -; - -dZ13 -= -dZinv11*g13 + dZinv12*g23 + dZinv13*g33 + delg113*Zinv1 + delg123*Zinv2 + - delg133*Zinv3 -; - -dZ21 -= -dZinv21*g11 + dZinv22*g12 + dZinv23*g13 + delg211*Zinv1 + delg212*Zinv2 + - delg213*Zinv3 -; - -dZ22 -= -dZinv21*g12 + dZinv22*g22 + dZinv23*g23 + delg212*Zinv1 + delg222*Zinv2 + - delg223*Zinv3 -; - -dZ23 -= -dZinv21*g13 + dZinv22*g23 + dZinv23*g33 + delg213*Zinv1 + delg223*Zinv2 + - delg233*Zinv3 -; - -dZ31 -= -dZinv31*g11 + dZinv32*g12 + dZinv33*g13 + delg311*Zinv1 + delg312*Zinv2 + - delg313*Zinv3 -; - -dZ32 -= -dZinv31*g12 + dZinv32*g22 + dZinv33*g23 + delg312*Zinv1 + delg322*Zinv2 + - delg323*Zinv3 -; - -dZ33 -= -dZinv31*g13 + dZinv32*g23 + dZinv33*g33 + delg313*Zinv1 + delg323*Zinv2 + - delg333*Zinv3 -; - -DZinv11 -= -dZinv11 + gammaF111*Zinv1 + gammaF112*Zinv2 + gammaF113*Zinv3 -; - -DZinv12 -= -dZinv12 + gammaF211*Zinv1 + gammaF212*Zinv2 + gammaF213*Zinv3 -; - -DZinv13 -= -dZinv13 + gammaF311*Zinv1 + gammaF312*Zinv2 + gammaF313*Zinv3 -; - -DZinv21 -= -dZinv21 + gammaF121*Zinv1 + gammaF122*Zinv2 + gammaF123*Zinv3 -; - -DZinv22 -= -dZinv22 + gammaF221*Zinv1 + gammaF222*Zinv2 + gammaF223*Zinv3 -; - -DZinv23 -= -dZinv23 + gammaF321*Zinv1 + gammaF322*Zinv2 + gammaF323*Zinv3 -; - -DZinv31 -= -dZinv31 + gammaF131*Zinv1 + gammaF132*Zinv2 + gammaF133*Zinv3 -; - -DZinv32 -= -dZinv32 + gammaF231*Zinv1 + gammaF232*Zinv2 + gammaF233*Zinv3 -; - -DZinv33 -= -dZinv33 + gammaF331*Zinv1 + gammaF332*Zinv2 + gammaF333*Zinv3 -; - -DZ11 -= -dZ11 - gammaF111*Z1 - gammaF211*Z2 - gammaF311*Z3 -; - -DZ12 -= -dZ12 - gammaF112*Z1 - gammaF212*Z2 - gammaF312*Z3 -; - -DZ13 -= -dZ13 - gammaF113*Z1 - gammaF213*Z2 - gammaF313*Z3 -; - -DZ21 -= -dZ21 - gammaF121*Z1 - gammaF221*Z2 - gammaF321*Z3 -; - -DZ22 -= -dZ22 - gammaF122*Z1 - gammaF222*Z2 - gammaF322*Z3 -; - -DZ23 -= -dZ23 - gammaF123*Z1 - gammaF223*Z2 - gammaF323*Z3 -; - -DZ31 -= -dZ31 - gammaF131*Z1 - gammaF231*Z2 - gammaF331*Z3 -; - -DZ32 -= -dZ32 - gammaF132*Z1 - gammaF232*Z2 - gammaF332*Z3 -; - -DZ33 -= -dZ33 - gammaF133*Z1 - gammaF233*Z2 - gammaF333*Z3 -; - -DZsym11 -= -2.*DZ11 -; - -DZsym12 -= -DZ12 + DZ21 -; - -DZsym13 -= -DZ13 + DZ31 -; - -DZsym21 -= -DZ12 + DZ21 -; - -DZsym22 -= -2.*DZ22 -; - -DZsym23 -= -DZ23 + DZ32 -; - -DZsym31 -= -DZ13 + DZ31 -; - -DZsym32 -= -DZ23 + DZ32 -; - -DZsym33 -= -2.*DZ33 -; - -trDZsym -= -(DZsym11*ginv11 + (DZsym12 + DZsym21)*ginv12 + (DZsym13 + DZsym31)*ginv13 + - DZsym22*ginv22 + (DZsym23 + DZsym32)*ginv23 + DZsym33*ginv33)*psim4 -; - -rA11 -= -rA11 + alpha*(-2.*A11*Theta + chi* - (DZsym11 - 0.33333333333333333333*g11*trDZsym)) -; - -rA12 -= -rA12 + alpha*(-2.*A12*Theta + chi* - (DZsym21 - 0.33333333333333333333*g12*trDZsym)) -; - -rA13 -= -rA13 + alpha*(-2.*A13*Theta + chi* - (DZsym31 - 0.33333333333333333333*g13*trDZsym)) -; - -rA22 -= -rA22 + alpha*(-2.*A22*Theta + chi* - (DZsym22 - 0.33333333333333333333*g22*trDZsym)) -; - -rA23 -= -rA23 + alpha*(-2.*A23*Theta + chi* - (DZsym32 - 0.33333333333333333333*g23*trDZsym)) -; - -rA33 -= -rA33 + alpha*(-2.*A33*Theta + chi* - (DZsym33 - 0.33333333333333333333*g33*trDZsym)) -; - -rTheta -= -alpha*(DZinv11 + DZinv22 + DZinv33) + rTheta - da1*Zinv1 - da2*Zinv2 - - da3*Zinv3 -; - -rG1 -= -rG1 - ginv11*(1.3333333333333333333*alpha*K*Z1 + - 2.*(da1*Theta + alpha*kappa1*Z1)) - - ginv12*(1.3333333333333333333*alpha*K*Z2 + - 2.*(da2*Theta + alpha*kappa1*Z2)) - - ginv13*(1.3333333333333333333*alpha*K*Z3 + - 2.*(da3*Theta + alpha*kappa1*Z3)) -; - -rG2 -= -rG2 - ginv12*(1.3333333333333333333*alpha*K*Z1 + - 2.*(da1*Theta + alpha*kappa1*Z1)) - - ginv22*(1.3333333333333333333*alpha*K*Z2 + - 2.*(da2*Theta + alpha*kappa1*Z2)) - - ginv23*(1.3333333333333333333*alpha*K*Z3 + - 2.*(da3*Theta + alpha*kappa1*Z3)) -; - -rG3 -= -rG3 - ginv13*(1.3333333333333333333*alpha*K*Z1 + - 2.*(da1*Theta + alpha*kappa1*Z1)) - - ginv23*(1.3333333333333333333*alpha*K*Z2 + - 2.*(da2*Theta + alpha*kappa1*Z2)) - - ginv33*(1.3333333333333333333*alpha*K*Z3 + - 2.*(da3*Theta + alpha*kappa1*Z3)) -; -#endif - - } /* function */ -} + + +// Z4c rhs without advection term +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include "macrodef.fh" + +#define Power(x, y) (pow((double)(x), (double)(y))) +#define Sqrt(x) sqrt(x) +#define Log(x) log((double)(x)) +#define pow2(x) ((x) * (x)) +#define pow3(x) ((x) * (x) * (x)) +#define pow4(x) ((x) * (x) * (x) * (x)) +#define pow2inv(x) (1.0 / ((x) * (x))) + +#define Cal(x, y, z) ((x) ? (y) : (z)) + +#define Tan(x) tan(x) +#define ArcTan(x) atan(x) +#define Sin(x) sin(x) +#define Cos(x) cos(x) +#define Csc(x) (1. / sin(x)) +#define Abs(x) (fabs(x)) +#define sqrt2 (sqrt(2)) +#define Tanh(x) tanh(x) +#define Sech(x) (1 / cosh(x)) + +extern "C" +{ + +#ifdef fortran1 + void z4c_rhs_point +#endif +#ifdef fortran2 + void Z4C_RHS_POINT +#endif +#ifdef fortran3 + void + z4c_rhs_point_ +#endif + (double &A11, + double &A12, + double &A13, + double &A22, + double &A23, + double &A33, + double &alpha, + double &B1, + double &B2, + double &B3, + double &beta1, + double &beta2, + double &beta3, + double &chi, + double &chiDivFloor, + double &da1, + double &dA111, + double &dA112, + double &dA113, + double &dA122, + double &dA123, + double &dA133, + double &da2, + double &dA211, + double &dA212, + double &dA213, + double &dA222, + double &dA223, + double &dA233, + double &da3, + double &dA311, + double &dA312, + double &dA313, + double &dA322, + double &dA323, + double &dA333, + double &db11, + double &dB11, + double &db12, + double &dB12, + double &db13, + double &dB13, + double &db21, + double &dB21, + double &db22, + double &dB22, + double &db23, + double &dB23, + double &db31, + double &dB31, + double &db32, + double &dB32, + double &db33, + double &dB33, + double &dchi1, + double &dchi2, + double &dchi3, + double &dda11, + double &dda12, + double &dda13, + double &dda22, + double &dda23, + double &dda33, + double &ddb111, + double &ddb112, + double &ddb113, + double &ddb121, + double &ddb122, + double &ddb123, + double &ddb131, + double &ddb132, + double &ddb133, + double &ddb221, + double &ddb222, + double &ddb223, + double &ddb231, + double &ddb232, + double &ddb233, + double &ddb331, + double &ddb332, + double &ddb333, + double &ddchi11, + double &ddchi12, + double &ddchi13, + double &ddchi22, + double &ddchi23, + double &ddchi33, + double &deldelg1111, + double &deldelg1112, + double &deldelg1113, + double &deldelg1122, + double &deldelg1123, + double &deldelg1133, + double &deldelg1211, + double &deldelg1212, + double &deldelg1213, + double &deldelg1222, + double &deldelg1223, + double &deldelg1233, + double &deldelg1311, + double &deldelg1312, + double &deldelg1313, + double &deldelg1322, + double &deldelg1323, + double &deldelg1333, + double &deldelg2211, + double &deldelg2212, + double &deldelg2213, + double &deldelg2222, + double &deldelg2223, + double &deldelg2233, + double &deldelg2311, + double &deldelg2312, + double &deldelg2313, + double &deldelg2322, + double &deldelg2323, + double &deldelg2333, + double &deldelg3311, + double &deldelg3312, + double &deldelg3313, + double &deldelg3322, + double &deldelg3323, + double &deldelg3333, + double &delG11, + double &delg111, + double &delg112, + double &delg113, + double &delG12, + double &delg122, + double &delg123, + double &delG13, + double &delg133, + double &delG21, + double &delg211, + double &delg212, + double &delg213, + double &delG22, + double &delg222, + double &delg223, + double &delG23, + double &delg233, + double &delG31, + double &delg311, + double &delg312, + double &delg313, + double &delG32, + double &delg322, + double &delg323, + double &delG33, + double &delg333, + double &dKhat1, + double &dKhat2, + double &dKhat3, + double &dTheta1, + double &dTheta2, + double &dTheta3, + double &G1, + double &g11, + double &g12, + double &g13, + double &G2, + double &g22, + double &g23, + double &G3, + double &g33, + double &kappa1, + double &kappa2, + double &Khat, + double &rA11, + double &rA12, + double &rA13, + double &rA22, + double &rA23, + double &rA33, + double &rchi, + double &rG1, + double &rg11, + double &rg12, + double &rg13, + double &rG2, + double &rg22, + double &rg23, + double &rG3, + double &rg33, + double &rKhat, + double &rTheta, + double &Theta) + { + + double AA11; + double AA12; + double AA13; + double AA22; + double AA23; + double AA33; + double Ainv11; + double Ainv12; + double Ainv13; + double Ainv22; + double Ainv23; + double Ainv33; + double cAA; + double cdda11; + double cdda12; + double cdda13; + double cdda22; + double cdda23; + double cdda33; + double cddf11; + double cddf12; + double cddf13; + double cddf22; + double cddf23; + double cddf33; + double chiguard; + double chiguarded; + double chipsipower; + double ddf11; + double ddf12; + double ddf13; + double ddf22; + double ddf23; + double ddf33; + double detginv; + double df1; + double df2; + double df3; + double dGd11; + double dGd12; + double dGd13; + double dGd21; + double dGd22; + double dGd23; + double dGd31; + double dGd32; + double dGd33; + double dginv111; + double dginv112; + double dginv113; + double dginv122; + double dginv123; + double dginv133; + double dginv211; + double dginv212; + double dginv213; + double dginv222; + double dginv223; + double dginv233; + double dginv311; + double dginv312; + double dginv313; + double dginv322; + double dginv323; + double dginv333; + double divAinv1; + double divAinv2; + double divAinv3; + double divbeta; + double dK1; + double dK2; + double dK3; + double dphi1; + double dphi2; + double dphi3; + double dZ11; + double DZ11; + double dZ12; + double DZ12; + double dZ13; + double DZ13; + double dZ21; + double DZ21; + double dZ22; + double DZ22; + double dZ23; + double DZ23; + double dZ31; + double DZ31; + double dZ32; + double DZ32; + double dZ33; + double DZ33; + double dZinv11; + double DZinv11; + double dZinv12; + double DZinv12; + double dZinv13; + double DZinv13; + double dZinv21; + double DZinv21; + double dZinv22; + double DZinv22; + double dZinv23; + double DZinv23; + double dZinv31; + double DZinv31; + double dZinv32; + double DZinv32; + double dZinv33; + double DZinv33; + double DZsym11; + double DZsym12; + double DZsym13; + double DZsym21; + double DZsym22; + double DZsym23; + double DZsym31; + double DZsym32; + double DZsym33; + double f; + double ff; + double gamma111; + double gamma112; + double gamma113; + double gamma122; + double gamma123; + double gamma133; + double gamma211; + double gamma212; + double gamma213; + double gamma222; + double gamma223; + double gamma233; + double gamma311; + double gamma312; + double gamma313; + double gamma322; + double gamma323; + double gamma333; + double gammado111; + double gammado112; + double gammado113; + double gammado122; + double gammado123; + double gammado133; + double gammado211; + double gammado212; + double gammado213; + double gammado222; + double gammado223; + double gammado233; + double gammado311; + double gammado312; + double gammado313; + double gammado322; + double gammado323; + double gammado333; + double gammaF111; + double gammaF112; + double gammaF113; + double gammaF121; + double gammaF122; + double gammaF123; + double gammaF131; + double gammaF132; + double gammaF133; + double gammaF211; + double gammaF212; + double gammaF213; + double gammaF221; + double gammaF222; + double gammaF223; + double gammaF231; + double gammaF232; + double gammaF233; + double gammaF311; + double gammaF312; + double gammaF313; + double gammaF321; + double gammaF322; + double gammaF323; + double gammaF331; + double gammaF332; + double gammaF333; + double Gd1; + double Gd2; + double Gd3; + double Gfromg1; + double Gfromg2; + double Gfromg3; + double ginv11; + double ginv12; + double ginv13; + double ginv22; + double ginv23; + double ginv33; + double Hhat; + double K; + double lieA11; + double lieA12; + double lieA13; + double lieA22; + double lieA23; + double lieA33; + double liechi; + double lieg11; + double lieg12; + double lieg13; + double lieg22; + double lieg23; + double lieg33; + double oochipsipower; + double ootddivbeta1; + double ootddivbeta2; + double ootddivbeta3; + double pseudolieG1; + double pseudolieG2; + double pseudolieG3; + double psim4; + double R11; + double R12; + double R13; + double R22; + double R23; + double R33; + double Rhat; + double Rphi11; + double Rphi12; + double Rphi13; + double Rphi22; + double Rphi23; + double Rphi33; + double totdivbeta; + double trcdda; + double trcddf; + double trDZsym; + double Z1; + double Z2; + double Z3; + double Zinv1; + double Zinv2; + double Zinv3; + + chipsipower = + -4.; + + K = + Khat + 2. * Theta; + + dK1 = + dKhat1 + 2. * dTheta1; + + dK2 = + dKhat2 + 2. * dTheta2; + + dK3 = + dKhat3 + 2. * dTheta3; + + detginv = + 1 / (2. * g12 * g13 * g23 - g33 * pow2(g12) + g22 * (g11 * g33 - pow2(g13)) - + g11 * pow2(g23)); + + ginv11 = + detginv * (g22 * g33 - pow2(g23)); + + ginv12 = + detginv * (g13 * g23 - g12 * g33); + + ginv13 = + detginv * (-(g13 * g22) + g12 * g23); + + ginv22 = + detginv * (g11 * g33 - pow2(g13)); + + ginv23 = + detginv * (g12 * g13 - g11 * g23); + + ginv33 = + detginv * (g11 * g22 - pow2(g12)); + + dginv111 = + -2. * (delg123 * ginv12 * ginv13 + ginv11 * (delg112 * ginv12 + delg113 * ginv13)) - + delg111 * pow2(ginv11) - delg122 * pow2(ginv12) - delg133 * pow2(ginv13); + + dginv112 = + -(ginv11 * (delg111 * ginv12 + delg112 * ginv22 + delg113 * ginv23)) - + ginv12 * (delg113 * ginv13 + delg122 * ginv22 + delg123 * ginv23) - + ginv13 * (delg123 * ginv22 + delg133 * ginv23) - delg112 * pow2(ginv12); + + dginv113 = + -(ginv11 * (delg111 * ginv13 + delg112 * ginv23 + delg113 * ginv33)) - + ginv12 * (delg112 * ginv13 + delg122 * ginv23 + delg123 * ginv33) - + ginv13 * (delg123 * ginv23 + delg133 * ginv33) - delg113 * pow2(ginv13); + + dginv122 = + -2. * (delg123 * ginv22 * ginv23 + ginv12 * (delg112 * ginv22 + delg113 * ginv23)) - + delg111 * pow2(ginv12) - delg122 * pow2(ginv22) - delg133 * pow2(ginv23); + + dginv123 = + -(ginv13 * (delg112 * ginv22 + delg113 * ginv23)) - delg133 * ginv23 * ginv33 - + ginv12 * (delg111 * ginv13 + delg112 * ginv23 + delg113 * ginv33) - + ginv22 * (delg122 * ginv23 + delg123 * ginv33) - delg123 * pow2(ginv23); + + dginv133 = + -2. * (delg123 * ginv23 * ginv33 + ginv13 * (delg112 * ginv23 + delg113 * ginv33)) - + delg111 * pow2(ginv13) - delg122 * pow2(ginv23) - delg133 * pow2(ginv33); + + dginv211 = + -2. * (delg223 * ginv12 * ginv13 + ginv11 * (delg212 * ginv12 + delg213 * ginv13)) - + delg211 * pow2(ginv11) - delg222 * pow2(ginv12) - delg233 * pow2(ginv13); + + dginv212 = + -(ginv11 * (delg211 * ginv12 + delg212 * ginv22 + delg213 * ginv23)) - + ginv12 * (delg213 * ginv13 + delg222 * ginv22 + delg223 * ginv23) - + ginv13 * (delg223 * ginv22 + delg233 * ginv23) - delg212 * pow2(ginv12); + + dginv213 = + -(ginv11 * (delg211 * ginv13 + delg212 * ginv23 + delg213 * ginv33)) - + ginv12 * (delg212 * ginv13 + delg222 * ginv23 + delg223 * ginv33) - + ginv13 * (delg223 * ginv23 + delg233 * ginv33) - delg213 * pow2(ginv13); + + dginv222 = + -2. * (delg223 * ginv22 * ginv23 + ginv12 * (delg212 * ginv22 + delg213 * ginv23)) - + delg211 * pow2(ginv12) - delg222 * pow2(ginv22) - delg233 * pow2(ginv23); + + dginv223 = + -(ginv13 * (delg212 * ginv22 + delg213 * ginv23)) - delg233 * ginv23 * ginv33 - + ginv12 * (delg211 * ginv13 + delg212 * ginv23 + delg213 * ginv33) - + ginv22 * (delg222 * ginv23 + delg223 * ginv33) - delg223 * pow2(ginv23); + + dginv233 = + -2. * (delg223 * ginv23 * ginv33 + ginv13 * (delg212 * ginv23 + delg213 * ginv33)) - + delg211 * pow2(ginv13) - delg222 * pow2(ginv23) - delg233 * pow2(ginv33); + + dginv311 = + -2. * (delg323 * ginv12 * ginv13 + ginv11 * (delg312 * ginv12 + delg313 * ginv13)) - + delg311 * pow2(ginv11) - delg322 * pow2(ginv12) - delg333 * pow2(ginv13); + + dginv312 = + -(ginv11 * (delg311 * ginv12 + delg312 * ginv22 + delg313 * ginv23)) - + ginv12 * (delg313 * ginv13 + delg322 * ginv22 + delg323 * ginv23) - + ginv13 * (delg323 * ginv22 + delg333 * ginv23) - delg312 * pow2(ginv12); + + dginv313 = + -(ginv11 * (delg311 * ginv13 + delg312 * ginv23 + delg313 * ginv33)) - + ginv12 * (delg312 * ginv13 + delg322 * ginv23 + delg323 * ginv33) - + ginv13 * (delg323 * ginv23 + delg333 * ginv33) - delg313 * pow2(ginv13); + + dginv322 = + -2. * (delg323 * ginv22 * ginv23 + ginv12 * (delg312 * ginv22 + delg313 * ginv23)) - + delg311 * pow2(ginv12) - delg322 * pow2(ginv22) - delg333 * pow2(ginv23); + + dginv323 = + -(ginv13 * (delg312 * ginv22 + delg313 * ginv23)) - delg333 * ginv23 * ginv33 - + ginv12 * (delg311 * ginv13 + delg312 * ginv23 + delg313 * ginv33) - + ginv22 * (delg322 * ginv23 + delg323 * ginv33) - delg323 * pow2(ginv23); + + dginv333 = + -2. * (delg323 * ginv23 * ginv33 + ginv13 * (delg312 * ginv23 + delg313 * ginv33)) - + delg311 * pow2(ginv13) - delg322 * pow2(ginv23) - delg333 * pow2(ginv33); + + gammado111 = + 0.5 * delg111; + + gammado112 = + 0.5 * delg211; + + gammado113 = + 0.5 * delg311; + + gammado122 = + -0.5 * delg122 + delg212; + + gammado123 = + 0.5 * (-delg123 + delg213 + delg312); + + gammado133 = + -0.5 * delg133 + delg313; + + gammado211 = + delg112 - 0.5 * delg211; + + gammado212 = + 0.5 * delg122; + + gammado213 = + 0.5 * (delg123 - delg213 + delg312); + + gammado222 = + 0.5 * delg222; + + gammado223 = + 0.5 * delg322; + + gammado233 = + -0.5 * delg233 + delg323; + + gammado311 = + delg113 - 0.5 * delg311; + + gammado312 = + 0.5 * (delg123 + delg213 - delg312); + + gammado313 = + 0.5 * delg133; + + gammado322 = + delg223 - 0.5 * delg322; + + gammado323 = + 0.5 * delg233; + + gammado333 = + 0.5 * delg333; + + gamma111 = + gammado111 * ginv11 + gammado211 * ginv12 + gammado311 * ginv13; + + gamma112 = + gammado112 * ginv11 + gammado212 * ginv12 + gammado312 * ginv13; + + gamma113 = + gammado113 * ginv11 + gammado213 * ginv12 + gammado313 * ginv13; + + gamma122 = + gammado122 * ginv11 + gammado222 * ginv12 + gammado322 * ginv13; + + gamma123 = + gammado123 * ginv11 + gammado223 * ginv12 + gammado323 * ginv13; + + gamma133 = + gammado133 * ginv11 + gammado233 * ginv12 + gammado333 * ginv13; + + gamma211 = + gammado111 * ginv12 + gammado211 * ginv22 + gammado311 * ginv23; + + gamma212 = + gammado112 * ginv12 + gammado212 * ginv22 + gammado312 * ginv23; + + gamma213 = + gammado113 * ginv12 + gammado213 * ginv22 + gammado313 * ginv23; + + gamma222 = + gammado122 * ginv12 + gammado222 * ginv22 + gammado322 * ginv23; + + gamma223 = + gammado123 * ginv12 + gammado223 * ginv22 + gammado323 * ginv23; + + gamma233 = + gammado133 * ginv12 + gammado233 * ginv22 + gammado333 * ginv23; + + gamma311 = + gammado111 * ginv13 + gammado211 * ginv23 + gammado311 * ginv33; + + gamma312 = + gammado112 * ginv13 + gammado212 * ginv23 + gammado312 * ginv33; + + gamma313 = + gammado113 * ginv13 + gammado213 * ginv23 + gammado313 * ginv33; + + gamma322 = + gammado122 * ginv13 + gammado222 * ginv23 + gammado322 * ginv33; + + gamma323 = + gammado123 * ginv13 + gammado223 * ginv23 + gammado323 * ginv33; + + gamma333 = + gammado133 * ginv13 + gammado233 * ginv23 + gammado333 * ginv33; + + Gfromg1 = + gamma111 * ginv11 + gamma122 * ginv22 + + 2. * (gamma112 * ginv12 + gamma113 * ginv13 + gamma123 * ginv23) + gamma133 * ginv33; + + Gfromg2 = + gamma211 * ginv11 + gamma222 * ginv22 + + 2. * (gamma212 * ginv12 + gamma213 * ginv13 + gamma223 * ginv23) + gamma233 * ginv33; + + Gfromg3 = + gamma311 * ginv11 + gamma322 * ginv22 + + 2. * (gamma312 * ginv12 + gamma313 * ginv13 + gamma323 * ginv23) + gamma333 * ginv33; + + R11 = + delG11 * g11 + delG12 * g12 + delG13 * g13 + gammado111 * Gfromg1 + + gammado112 * Gfromg2 + gammado113 * Gfromg3 + + (-0.5 * deldelg1111 + 3. * gamma111 * gammado111 + + 2. * (gamma211 * gammado112 + gamma311 * gammado113) + + gamma211 * gammado211 + gamma311 * gammado311) * + ginv11 + + (-deldelg1211 + 3. * (gamma112 * gammado111 + gamma111 * gammado112) + + 2. * (gamma212 * gammado112 + gamma312 * gammado113 + + gamma211 * gammado122 + gamma311 * gammado123) + + gamma212 * gammado211 + + gamma211 * gammado212 + gamma312 * gammado311 + gamma311 * gammado312) * + ginv12 + + (-deldelg1311 + 3. * (gamma113 * gammado111 + gamma111 * gammado113) + + 2. * (gamma213 * gammado112 + gamma313 * gammado113 + + gamma211 * gammado123 + gamma311 * gammado133) + + gamma213 * gammado211 + + gamma211 * gammado213 + gamma313 * gammado311 + gamma311 * gammado313) * + ginv13 + + (-0.5 * deldelg2211 + 3. * gamma112 * gammado112 + + 2. * (gamma212 * gammado122 + gamma312 * gammado123) + + gamma212 * gammado212 + gamma312 * gammado312) * + ginv22 + + (-deldelg2311 + 3. * (gamma113 * gammado112 + gamma112 * gammado113) + + 2. * (gamma213 * gammado122 + (gamma212 + gamma313) * gammado123 + + gamma312 * gammado133) + + gamma213 * gammado212 + gamma212 * gammado213 + + gamma313 * gammado312 + gamma312 * gammado313) * + ginv23 + + (-0.5 * deldelg3311 + 3. * gamma113 * gammado113 + + 2. * (gamma213 * gammado123 + gamma313 * gammado133) + gamma213 * gammado213 + + gamma313 * gammado313) * + ginv33; + + R12 = + 0.5 * (delG21 * g11 + (delG11 + delG22) * g12 + delG23 * g13 + delG12 * g22 + + delG13 * g23 + (gammado112 + gammado211) * Gfromg1 + + (gammado122 + gammado212) * Gfromg2 + (gammado123 + gammado213) * Gfromg3) + + (-0.5 * deldelg1112 + gamma112 * gammado111 + + (gamma111 + gamma212) * gammado112 + gamma312 * gammado113 + + gamma111 * gammado211 + 2. * gamma211 * gammado212 + + gamma311 * (gammado213 + gammado312)) * + ginv11 + + (-deldelg1212 + gamma122 * gammado111 + + (2. * gamma112 + gamma222) * gammado112 + gamma322 * gammado113 + + (gamma111 + gamma212) * gammado122 + gamma112 * gammado211 + + (gamma111 + 2. * gamma212) * gammado212 + 2. * gamma211 * gammado222 + + gamma312 * (gammado123 + gammado213 + gammado312) + + gamma311 * (gammado223 + gammado322)) * + ginv12 + + (-deldelg1312 + gamma123 * gammado111 + (gamma113 + gamma223) * gammado112 + + (gamma112 + gamma323) * gammado113 + (gamma111 + gamma212) * gammado123 + + gamma312 * gammado133 + gamma113 * gammado211 + + (gamma111 + gamma313) * gammado213 + + 2. * (gamma213 * gammado212 + gamma211 * gammado223) + + gamma313 * gammado312 + gamma311 * (gammado233 + gammado323)) * + ginv13 + + (-0.5 * deldelg2212 + gamma122 * gammado112 + + (gamma112 + gamma222) * gammado122 + gamma322 * gammado123 + + gamma112 * gammado212 + 2. * gamma212 * gammado222 + + gamma312 * (gammado223 + gammado322)) * + ginv22 + + (-deldelg2312 + gamma123 * gammado112 + gamma122 * gammado113 + + (gamma113 + gamma223) * gammado122 + + (gamma112 + gamma222 + gamma323) * gammado123 + gamma322 * gammado133 + + gamma113 * gammado212 + gamma112 * gammado213 + + 2. * (gamma213 * gammado222 + gamma212 * gammado223) + + gamma313 * (gammado223 + gammado322) + + gamma312 * (gammado233 + gammado323)) * + ginv23 + + (-0.5 * deldelg3312 + gamma123 * gammado113 + + (gamma113 + gamma223) * gammado123 + gamma323 * gammado133 + + gamma113 * gammado213 + 2. * gamma213 * gammado223 + + gamma313 * (gammado233 + gammado323)) * + ginv33; + + R13 = + 0.5 * (delG31 * g11 + delG32 * g12 + (delG11 + delG33) * g13 + delG12 * g23 + + delG13 * g33 + (gammado113 + gammado311) * Gfromg1 + + (gammado123 + gammado312) * Gfromg2 + (gammado133 + gammado313) * Gfromg3) + + (-0.5 * deldelg1113 + gamma113 * gammado111 + gamma213 * gammado112 + + (gamma111 + gamma313) * gammado113 + gamma111 * gammado311 + + gamma211 * (gammado213 + gammado312) + 2. * gamma311 * gammado313) * + ginv11 + + (-deldelg1213 + gamma123 * gammado111 + (gamma113 + gamma223) * gammado112 + + (gamma112 + gamma323) * gammado113 + gamma213 * gammado122 + + (gamma111 + gamma313) * gammado123 + gamma112 * gammado311 + + gamma111 * gammado312 + gamma212 * (gammado213 + gammado312) + + gamma211 * (gammado223 + gammado322) + + 2. * (gamma312 * gammado313 + gamma311 * gammado323)) * + ginv12 + + (-deldelg1313 + gamma133 * gammado111 + gamma233 * gammado112 + + (2. * gamma113 + gamma333) * gammado113 + + (gamma111 + gamma313) * gammado133 + gamma113 * gammado311 + + gamma213 * (gammado123 + gammado213 + gammado312) + + (gamma111 + 2. * gamma313) * gammado313 + + gamma211 * (gammado233 + gammado323) + 2. * gamma311 * gammado333) * + ginv13 + + (-0.5 * deldelg2213 + gamma123 * gammado112 + gamma223 * gammado122 + + (gamma112 + gamma323) * gammado123 + gamma112 * gammado312 + + gamma212 * (gammado223 + gammado322) + 2. * gamma312 * gammado323) * + ginv22 + + (-deldelg2313 + gamma133 * gammado112 + gamma123 * gammado113 + + gamma233 * gammado122 + (gamma113 + gamma223 + gamma333) * gammado123 + + (gamma112 + gamma323) * gammado133 + gamma113 * gammado312 + + gamma112 * gammado313 + gamma213 * (gammado223 + gammado322) + + gamma212 * (gammado233 + gammado323) + + 2. * (gamma313 * gammado323 + gamma312 * gammado333)) * + ginv23 + + (-0.5 * deldelg3313 + gamma133 * gammado113 + gamma233 * gammado123 + + (gamma113 + gamma333) * gammado133 + gamma113 * gammado313 + + gamma213 * (gammado233 + gammado323) + 2. * gamma313 * gammado333) * + ginv33; + + R22 = + delG21 * g12 + delG22 * g22 + delG23 * g23 + gammado212 * Gfromg1 + + gammado222 * Gfromg2 + gammado223 * Gfromg3 + + (-0.5 * deldelg1122 + gamma112 * (gammado112 + 2. * gammado211) + + 3. * gamma212 * gammado212 + gamma312 * (2. * gammado213 + gammado312)) * + ginv11 + + (-deldelg1222 + gamma122 * (gammado112 + 2. * gammado211) + + gamma112 * (gammado122 + 2. * gammado212) + + 3. * (gamma222 * gammado212 + gamma212 * gammado222) + + 2. * (gamma322 * gammado213 + gamma312 * gammado223) + + gamma322 * gammado312 + gamma312 * gammado322) * + ginv12 + + (-deldelg1322 + gamma123 * (gammado112 + 2. * gammado211) + + gamma112 * (gammado123 + 2. * gammado213) + + 3. * (gamma223 * gammado212 + gamma212 * gammado223) + + 2. * (gamma323 * gammado213 + gamma312 * gammado233) + + gamma323 * gammado312 + gamma312 * gammado323) * + ginv13 + + (-0.5 * deldelg2222 + gamma122 * (gammado122 + 2. * gammado212) + + 3. * gamma222 * gammado222 + gamma322 * (2. * gammado223 + gammado322)) * + ginv22 + + (-deldelg2322 + gamma123 * (gammado122 + 2. * gammado212) + + gamma122 * (gammado123 + 2. * gammado213) + + 3. * (gamma223 * gammado222 + gamma222 * gammado223) + + 2. * (gamma323 * gammado223 + gamma322 * gammado233) + + gamma323 * gammado322 + gamma322 * gammado323) * + ginv23 + + (-0.5 * deldelg3322 + gamma123 * (gammado123 + 2. * gammado213) + + 3. * gamma223 * gammado223 + gamma323 * (2. * gammado233 + gammado323)) * + ginv33; + + R23 = + 0.5 * (delG31 * g12 + delG21 * g13 + delG32 * g22 + (delG22 + delG33) * g23 + + delG23 * g33 + (gammado213 + gammado312) * Gfromg1 + + (gammado223 + gammado322) * Gfromg2 + (gammado233 + gammado323) * Gfromg3) + + (-0.5 * deldelg1123 + gamma113 * gammado211 + gamma213 * gammado212 + + (gamma212 + gamma313) * gammado213 + + gamma112 * (gammado113 + gammado311) + gamma212 * gammado312 + + 2. * gamma312 * gammado313) * + ginv11 + + (-deldelg1223 + gamma123 * gammado211 + (gamma113 + gamma223) * gammado212 + + (gamma222 + gamma323) * gammado213 + gamma213 * gammado222 + + (gamma212 + gamma313) * gammado223 + + gamma122 * (gammado113 + gammado311) + gamma222 * gammado312 + + gamma112 * (gammado123 + gammado312) + gamma212 * gammado322 + + 2. * (gamma322 * gammado313 + gamma312 * gammado323)) * + ginv12 + + (-deldelg1323 + gamma133 * gammado211 + gamma233 * gammado212 + + (gamma113 + gamma223 + gamma333) * gammado213 + gamma213 * gammado223 + + (gamma212 + gamma313) * gammado233 + + gamma123 * (gammado113 + gammado311) + gamma223 * gammado312 + + gamma112 * (gammado133 + gammado313) + gamma212 * gammado323 + + 2. * (gamma323 * gammado313 + gamma312 * gammado333)) * + ginv13 + + (-0.5 * deldelg2223 + gamma123 * gammado212 + gamma223 * gammado222 + + (gamma222 + gamma323) * gammado223 + + gamma122 * (gammado123 + gammado312) + gamma222 * gammado322 + + 2. * gamma322 * gammado323) * + ginv22 + + (-deldelg2323 + gamma133 * gammado212 + gamma233 * gammado222 + + (2. * gamma223 + gamma333) * gammado223 + + (gamma222 + gamma323) * gammado233 + + gamma123 * (gammado123 + gammado213 + gammado312) + + gamma122 * (gammado133 + gammado313) + gamma223 * gammado322 + + (gamma222 + 2. * gamma323) * gammado323 + 2. * gamma322 * gammado333) * + ginv23 + + (-0.5 * deldelg3323 + gamma133 * gammado213 + gamma233 * gammado223 + + (gamma223 + gamma333) * gammado233 + + gamma123 * (gammado133 + gammado313) + gamma223 * gammado323 + + 2. * gamma323 * gammado333) * + ginv33; + + R33 = + delG31 * g13 + delG32 * g23 + delG33 * g33 + gammado313 * Gfromg1 + + gammado323 * Gfromg2 + gammado333 * Gfromg3 + + (-0.5 * deldelg1133 + gamma113 * (gammado113 + 2. * gammado311) + + gamma213 * (gammado213 + 2. * gammado312) + 3. * gamma313 * gammado313) * + ginv11 + + (-deldelg1233 + gamma123 * (gammado113 + 2. * gammado311) + + gamma113 * (gammado123 + 2. * gammado312) + + gamma223 * (gammado213 + 2. * gammado312) + + gamma213 * (gammado223 + 2. * gammado322) + + 3. * (gamma323 * gammado313 + gamma313 * gammado323)) * + ginv12 + + (-deldelg1333 + gamma133 * (gammado113 + 2. * gammado311) + + gamma233 * (gammado213 + 2. * gammado312) + + gamma113 * (gammado133 + 2. * gammado313) + + gamma213 * (gammado233 + 2. * gammado323) + + 3. * (gamma333 * gammado313 + gamma313 * gammado333)) * + ginv13 + + (-0.5 * deldelg2233 + gamma123 * (gammado123 + 2. * gammado312) + + gamma223 * (gammado223 + 2. * gammado322) + 3. * gamma323 * gammado323) * + ginv22 + + (-deldelg2333 + gamma133 * (gammado123 + 2. * gammado312) + + gamma123 * (gammado133 + 2. * gammado313) + + gamma233 * (gammado223 + 2. * gammado322) + + gamma223 * (gammado233 + 2. * gammado323) + + 3. * (gamma333 * gammado323 + gamma323 * gammado333)) * + ginv23 + + (-0.5 * deldelg3333 + gamma133 * (gammado133 + 2. * gammado313) + + gamma233 * (gammado233 + 2. * gammado323) + 3. * gamma333 * gammado333) * + ginv33; + + chiguard = + chiDivFloor; + + chiguarded = + chi; + + if (chiguarded < chiguard) + chiguarded = chiguard; + + ff = + chiguarded; + + oochipsipower = + 1 / chipsipower; + + f = + oochipsipower * log(ff); + + psim4 = + exp(-4. * f); + + df1 = + (dchi1 * oochipsipower) / chiguarded; + + df2 = + (dchi2 * oochipsipower) / chiguarded; + + df3 = + (dchi3 * oochipsipower) / chiguarded; + + ddf11 = + (ddchi11 * oochipsipower) / chiguarded - chipsipower * pow2(df1); + + ddf12 = + -(chipsipower * df1 * df2) + (ddchi12 * oochipsipower) / chiguarded; + + ddf13 = + -(chipsipower * df1 * df3) + (ddchi13 * oochipsipower) / chiguarded; + + ddf22 = + (ddchi22 * oochipsipower) / chiguarded - chipsipower * pow2(df2); + + ddf23 = + -(chipsipower * df2 * df3) + (ddchi23 * oochipsipower) / chiguarded; + + ddf33 = + (ddchi33 * oochipsipower) / chiguarded - chipsipower * pow2(df3); + + cddf11 = + ddf11 - df1 * gamma111 - df2 * gamma211 - df3 * gamma311; + + cddf12 = + ddf12 - df1 * gamma112 - df2 * gamma212 - df3 * gamma312; + + cddf13 = + ddf13 - df1 * gamma113 - df2 * gamma213 - df3 * gamma313; + + cddf22 = + ddf22 - df1 * gamma122 - df2 * gamma222 - df3 * gamma322; + + cddf23 = + ddf23 - df1 * gamma123 - df2 * gamma223 - df3 * gamma323; + + cddf33 = + ddf33 - df1 * gamma133 - df2 * gamma233 - df3 * gamma333; + + trcddf = + cddf11 * ginv11 + cddf22 * ginv22 + + 2. * (cddf12 * ginv12 + cddf13 * ginv13 + cddf23 * ginv23) + cddf33 * ginv33; + + Rphi11 = + -2. * (cddf11 + g11 * trcddf) + (4. - 4. * g11 * ginv11) * pow2(df1) - + g11 * (8. * (df1 * (df2 * ginv12 + df3 * ginv13) + df2 * df3 * ginv23) + + 4. * (ginv22 * pow2(df2) + ginv33 * pow2(df3))); + + Rphi12 = + df1 * df2 * (4. - 8. * g12 * ginv12) - 2. * (cddf12 + g12 * trcddf) - + g12 * (8. * df3 * (df1 * ginv13 + df2 * ginv23) + + 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2) + ginv33 * pow2(df3))); + + Rphi13 = + df1 * (4. * df3 - 8. * df2 * g13 * ginv12) - 2. * (cddf13 + g13 * trcddf) - + g13 * (8. * df3 * (df1 * ginv13 + df2 * ginv23) + + 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2) + ginv33 * pow2(df3))); + + Rphi22 = + -2. * (cddf22 + g22 * trcddf) + (4. - 4. * g22 * ginv22) * pow2(df2) - + g22 * (8. * (df1 * (df2 * ginv12 + df3 * ginv13) + df2 * df3 * ginv23) + + 4. * (ginv11 * pow2(df1) + ginv33 * pow2(df3))); + + Rphi23 = + df2 * (-8. * df1 * g23 * ginv12 + df3 * (4. - 8. * g23 * ginv23)) - + 2. * (cddf23 + g23 * trcddf) - g23 * (8. * df1 * df3 * ginv13 + 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2) + ginv33 * pow2(df3))); + + Rphi33 = + -2. * (cddf33 + g33 * trcddf) - g33 * (8. * (df1 * (df2 * ginv12 + df3 * ginv13) + df2 * df3 * ginv23) + 4. * (ginv11 * pow2(df1) + ginv22 * pow2(df2))) + + (4. - 4. * g33 * ginv33) * pow2(df3); + + cdda11 = + dda11 - da2 * gamma211 - da3 * gamma311 + + da1 * (-gamma111 + df1 * (-4. + 2. * g11 * ginv11)) + + 2. * g11 * ((da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33); + + cdda12 = + dda12 - da1 * gamma112 - da2 * gamma212 - da3 * gamma312 + + 2. * (-(da2 * df1) - da1 * df2 + g12 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33)); + + cdda13 = + dda13 - da1 * gamma113 - da2 * gamma213 - da3 * gamma313 + + 2. * (-(da3 * df1) - da1 * df3 + g13 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33)); + + cdda22 = + dda22 - da1 * gamma122 - da2 * (4. * df2 + gamma222) - da3 * gamma322 + + 2. * g22 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33); + + cdda23 = + dda23 - da1 * gamma123 - da2 * gamma223 - da3 * gamma323 + + 2. * (-(da3 * df2) - da2 * df3 + g23 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33)); + + cdda33 = + dda33 - da1 * gamma133 - da2 * gamma233 - da3 * (4. * df3 + gamma333) + + 2. * g33 * (da1 * df1 * ginv11 + (da2 * df1 + da1 * df2) * ginv12 + (da3 * df1 + da1 * df3) * ginv13 + da2 * df2 * ginv22 + (da3 * df2 + da2 * df3) * ginv23 + da3 * df3 * ginv33); + + trcdda = + (cdda11 * ginv11 + cdda22 * ginv22 + + 2. * (cdda12 * ginv12 + cdda13 * ginv13 + cdda23 * ginv23) + cdda33 * ginv33) * + psim4; + + AA11 = + 2. * (A11 * (A12 * ginv12 + A13 * ginv13) + A12 * A13 * ginv23) + ginv11 * pow2(A11) + + ginv22 * pow2(A12) + ginv33 * pow2(A13); + + AA12 = + (A12 * A13 + A11 * A23) * ginv13 + A12 * (A11 * ginv11 + A22 * ginv22) + + (A13 * A22 + A12 * A23) * ginv23 + A13 * A23 * ginv33 + ginv12 * (A11 * A22 + pow2(A12)); + + AA13 = + (A12 * A13 + A11 * A23) * ginv12 + A12 * A23 * ginv22 + (A13 * A23 + A12 * A33) * ginv23 + + A13 * (A11 * ginv11 + A33 * ginv33) + ginv13 * (A11 * A33 + pow2(A13)); + + AA22 = + 2. * (A12 * (A22 * ginv12 + A23 * ginv13) + A22 * A23 * ginv23) + ginv11 * pow2(A12) + + ginv22 * pow2(A22) + ginv33 * pow2(A23); + + AA23 = + A12 * A13 * ginv11 + (A13 * A22 + A12 * A23) * ginv12 + (A13 * A23 + A12 * A33) * ginv13 + + A23 * (A22 * ginv22 + A33 * ginv33) + ginv23 * (A22 * A33 + pow2(A23)); + + AA33 = + 2. * (A13 * (A23 * ginv12 + A33 * ginv13) + A23 * A33 * ginv23) + ginv11 * pow2(A13) + + ginv22 * pow2(A23) + ginv33 * pow2(A33); + + cAA = + AA11 * ginv11 + AA22 * ginv22 + 2. * (AA12 * ginv12 + AA13 * ginv13 + AA23 * ginv23) + + AA33 * ginv33; + + Ainv11 = + 2. * (A23 * ginv12 * ginv13 + ginv11 * (A12 * ginv12 + A13 * ginv13)) + + A11 * pow2(ginv11) + A22 * pow2(ginv12) + A33 * pow2(ginv13); + + Ainv12 = + ginv11 * (A11 * ginv12 + A12 * ginv22 + A13 * ginv23) + + ginv12 * (A13 * ginv13 + A22 * ginv22 + A23 * ginv23) + + ginv13 * (A23 * ginv22 + A33 * ginv23) + A12 * pow2(ginv12); + + Ainv13 = + ginv11 * (A11 * ginv13 + A12 * ginv23 + A13 * ginv33) + + ginv12 * (A12 * ginv13 + A22 * ginv23 + A23 * ginv33) + + ginv13 * (A23 * ginv23 + A33 * ginv33) + A13 * pow2(ginv13); + + Ainv22 = + 2. * (A23 * ginv22 * ginv23 + ginv12 * (A12 * ginv22 + A13 * ginv23)) + + A11 * pow2(ginv12) + A22 * pow2(ginv22) + A33 * pow2(ginv23); + + Ainv23 = + ginv13 * (A12 * ginv22 + A13 * ginv23) + A33 * ginv23 * ginv33 + + ginv12 * (A11 * ginv13 + A12 * ginv23 + A13 * ginv33) + + ginv22 * (A22 * ginv23 + A23 * ginv33) + A23 * pow2(ginv23); + + Ainv33 = + 2. * (A23 * ginv23 * ginv33 + ginv13 * (A12 * ginv23 + A13 * ginv33)) + + A11 * pow2(ginv13) + A22 * pow2(ginv23) + A33 * pow2(ginv33); + + divAinv1 = + (-1.5 * (Ainv11 * dchi1 + Ainv12 * dchi2 + Ainv13 * dchi3)) / chiguarded + + Ainv11 * gamma111 + Ainv22 * gamma122 + + 2. * (Ainv12 * gamma112 + Ainv13 * gamma113 + Ainv23 * gamma123) + + Ainv33 * gamma133 - (0.66666666666666666667 * dKhat1 + 0.33333333333333333333 * dTheta1) * ginv11 - + (0.66666666666666666667 * dKhat2 + 0.33333333333333333333 * dTheta2) * ginv12 - + (0.66666666666666666667 * dKhat3 + 0.33333333333333333333 * dTheta3) * ginv13; + + divAinv2 = + (-1.5 * (Ainv12 * dchi1 + Ainv22 * dchi2 + Ainv23 * dchi3)) / chiguarded + + Ainv11 * gamma211 + Ainv22 * gamma222 + + 2. * (Ainv12 * gamma212 + Ainv13 * gamma213 + Ainv23 * gamma223) + + Ainv33 * gamma233 - (0.66666666666666666667 * dKhat1 + 0.33333333333333333333 * dTheta1) * ginv12 - + (0.66666666666666666667 * dKhat2 + 0.33333333333333333333 * dTheta2) * ginv22 - + (0.66666666666666666667 * dKhat3 + 0.33333333333333333333 * dTheta3) * ginv23; + + divAinv3 = + (-1.5 * (Ainv13 * dchi1 + Ainv23 * dchi2 + Ainv33 * dchi3)) / chiguarded + + Ainv11 * gamma311 + Ainv22 * gamma322 + + 2. * (Ainv12 * gamma312 + Ainv13 * gamma313 + Ainv23 * gamma323) + + Ainv33 * gamma333 - (0.66666666666666666667 * dKhat1 + 0.33333333333333333333 * dTheta1) * ginv13 - + (0.66666666666666666667 * dKhat2 + 0.33333333333333333333 * dTheta2) * ginv23 - + (0.66666666666666666667 * dKhat3 + 0.33333333333333333333 * dTheta3) * ginv33; + + Rhat = + psim4 * (ginv11 * (R11 + Rphi11) + ginv22 * (R22 + Rphi22) + + 2. * (ginv12 * (R12 + Rphi12) + ginv13 * (R13 + Rphi13) + + ginv23 * (R23 + Rphi23)) + + ginv33 * (R33 + Rphi33)); + + Hhat = + -cAA + Rhat + 0.66666666666666666667 * pow2(K); + + divbeta = + db11 + db22 + db33; + + totdivbeta = + 0.66666666666666666667 * divbeta; + + ootddivbeta1 = + 0.33333333333333333333 * (ddb111 + ddb122 + ddb133); + + ootddivbeta2 = + 0.33333333333333333333 * (ddb121 + ddb222 + ddb233); + + ootddivbeta3 = + 0.33333333333333333333 * (ddb131 + ddb232 + ddb333); + + lieg11 = + 2. * (db11 * g11 + db12 * g12 + db13 * g13) - g11 * totdivbeta; + + lieg12 = + db21 * g11 + db23 * g13 + db12 * g22 + db13 * g23 + g12 * (db11 + db22 - totdivbeta); + + lieg13 = + db31 * g11 + db32 * g12 + db12 * g23 + db13 * g33 + g13 * (db11 + db33 - totdivbeta); + + lieg22 = + 2. * (db21 * g12 + db22 * g22 + db23 * g23) - g22 * totdivbeta; + + lieg23 = + db31 * g12 + db21 * g13 + db32 * g22 + db23 * g33 + g23 * (db22 + db33 - totdivbeta); + + lieg33 = + 2. * (db31 * g13 + db32 * g23 + db33 * g33) - g33 * totdivbeta; + + lieA11 = + 2. * (A11 * db11 + A12 * db12 + A13 * db13) - A11 * totdivbeta; + + lieA12 = + A22 * db12 + A23 * db13 + A11 * db21 + A13 * db23 + A12 * (db11 + db22 - totdivbeta); + + lieA13 = + A23 * db12 + A33 * db13 + A11 * db31 + A12 * db32 + A13 * (db11 + db33 - totdivbeta); + + lieA22 = + 2. * (A12 * db21 + A22 * db22 + A23 * db23) - A22 * totdivbeta; + + lieA23 = + A13 * db21 + A33 * db23 + A12 * db31 + A22 * db32 + A23 * (db22 + db33 - totdivbeta); + + lieA33 = + 2. * (A13 * db31 + A23 * db32 + A33 * db33) - A33 * totdivbeta; + + liechi = + 0.16666666666666666667 * chiguarded * chipsipower * divbeta; + + pseudolieG1 = + -(db11 * Gfromg1) - db21 * Gfromg2 - db31 * Gfromg3 + ddb221 * ginv22 + + 2. * ddb231 * ginv23 + ddb331 * ginv33 + ginv11 * (ddb111 + ootddivbeta1) + + ginv12 * (2. * ddb121 + ootddivbeta2) + ginv13 * (2. * ddb131 + ootddivbeta3) + + Gfromg1 * totdivbeta; + + pseudolieG2 = + -(db12 * Gfromg1) - db22 * Gfromg2 - db32 * Gfromg3 + ddb112 * ginv11 + + 2. * ddb132 * ginv13 + ddb332 * ginv33 + ginv12 * (2. * ddb122 + ootddivbeta1) + + ginv22 * (ddb222 + ootddivbeta2) + ginv23 * (2. * ddb232 + ootddivbeta3) + + Gfromg2 * totdivbeta; + + pseudolieG3 = + -(db13 * Gfromg1) - db23 * Gfromg2 - db33 * Gfromg3 + ddb113 * ginv11 + + 2. * ddb123 * ginv12 + ddb223 * ginv22 + ginv13 * (2. * ddb133 + ootddivbeta1) + + ginv23 * (2. * ddb233 + ootddivbeta2) + ginv33 * (ddb333 + ootddivbeta3) + + Gfromg3 * totdivbeta; + + rg11 = + -2. * A11 * alpha + lieg11; + + rg12 = + -2. * A12 * alpha + lieg12; + + rg13 = + -2. * A13 * alpha + lieg13; + + rg22 = + -2. * A22 * alpha + lieg22; + + rg23 = + -2. * A23 * alpha + lieg23; + + rg33 = + -2. * A33 * alpha + lieg33; + + rA11 = + lieA11 + alpha * (-2. * AA11 + A11 * K + psim4 * R11 - 0.33333333333333333333 * g11 * Rhat) + psim4 * (-cdda11 + alpha * Rphi11) + + 0.33333333333333333333 * g11 * trcdda; + + rA12 = + lieA12 + alpha * (-2. * AA12 + A12 * K + psim4 * R12 - 0.33333333333333333333 * g12 * Rhat) + psim4 * (-cdda12 + alpha * Rphi12) + + 0.33333333333333333333 * g12 * trcdda; + + rA13 = + lieA13 + alpha * (-2. * AA13 + A13 * K + psim4 * R13 - 0.33333333333333333333 * g13 * Rhat) + psim4 * (-cdda13 + alpha * Rphi13) + + 0.33333333333333333333 * g13 * trcdda; + + rA22 = + lieA22 + alpha * (-2. * AA22 + A22 * K + psim4 * R22 - 0.33333333333333333333 * g22 * Rhat) + psim4 * (-cdda22 + alpha * Rphi22) + + 0.33333333333333333333 * g22 * trcdda; + + rA23 = + lieA23 + alpha * (-2. * AA23 + A23 * K + psim4 * R23 - 0.33333333333333333333 * g23 * Rhat) + psim4 * (-cdda23 + alpha * Rphi23) + + 0.33333333333333333333 * g23 * trcdda; + + rA33 = + lieA33 + alpha * (-2. * AA33 + A33 * K + psim4 * R33 - 0.33333333333333333333 * g33 * Rhat) + psim4 * (-cdda33 + alpha * Rphi33) + + 0.33333333333333333333 * g33 * trcdda; + + rG1 = + -2. * (Ainv11 * da1 + Ainv12 * da2 + Ainv13 * da3) + + alpha * (2. * divAinv1 + 2. * (-G1 + Gfromg1) * kappa1) + pseudolieG1; + + rG2 = + -2. * (Ainv12 * da1 + Ainv22 * da2 + Ainv23 * da3) + + alpha * (2. * divAinv2 + 2. * (-G2 + Gfromg2) * kappa1) + pseudolieG2; + + rG3 = + -2. * (Ainv13 * da1 + Ainv23 * da2 + Ainv33 * da3) + + alpha * (2. * divAinv3 + 2. * (-G3 + Gfromg3) * kappa1) + pseudolieG3; + + rKhat = + -trcdda + alpha * (cAA + kappa1 * (Theta - kappa2 * Theta) + + 0.33333333333333333333 * pow2(K)); + + rchi = + -0.16666666666666666667 * alpha * chiguarded * chipsipower * K + liechi; + + rTheta = + alpha * (0.5 * Hhat - kappa1 * (2. + kappa2) * Theta); + +#if 0 +// this part is for CCZ4 +dginv111 += +-2.*(delg123*ginv12*ginv13 + ginv11*(delg112*ginv12 + delg113*ginv13)) - + delg111*pow2(ginv11) - delg122*pow2(ginv12) - delg133*pow2(ginv13) +; + +dginv112 += +-(ginv11*(delg111*ginv12 + delg112*ginv22 + delg113*ginv23)) - + ginv12*(delg113*ginv13 + delg122*ginv22 + delg123*ginv23) - + ginv13*(delg123*ginv22 + delg133*ginv23) - delg112*pow2(ginv12) +; + +dginv113 += +-(ginv11*(delg111*ginv13 + delg112*ginv23 + delg113*ginv33)) - + ginv12*(delg112*ginv13 + delg122*ginv23 + delg123*ginv33) - + ginv13*(delg123*ginv23 + delg133*ginv33) - delg113*pow2(ginv13) +; + +dginv122 += +-2.*(delg123*ginv22*ginv23 + ginv12*(delg112*ginv22 + delg113*ginv23)) - + delg111*pow2(ginv12) - delg122*pow2(ginv22) - delg133*pow2(ginv23) +; + +dginv123 += +-(ginv13*(delg112*ginv22 + delg113*ginv23)) - delg133*ginv23*ginv33 - + ginv12*(delg111*ginv13 + delg112*ginv23 + delg113*ginv33) - + ginv22*(delg122*ginv23 + delg123*ginv33) - delg123*pow2(ginv23) +; + +dginv133 += +-2.*(delg123*ginv23*ginv33 + ginv13*(delg112*ginv23 + delg113*ginv33)) - + delg111*pow2(ginv13) - delg122*pow2(ginv23) - delg133*pow2(ginv33) +; + +dginv211 += +-2.*(delg223*ginv12*ginv13 + ginv11*(delg212*ginv12 + delg213*ginv13)) - + delg211*pow2(ginv11) - delg222*pow2(ginv12) - delg233*pow2(ginv13) +; + +dginv212 += +-(ginv11*(delg211*ginv12 + delg212*ginv22 + delg213*ginv23)) - + ginv12*(delg213*ginv13 + delg222*ginv22 + delg223*ginv23) - + ginv13*(delg223*ginv22 + delg233*ginv23) - delg212*pow2(ginv12) +; + +dginv213 += +-(ginv11*(delg211*ginv13 + delg212*ginv23 + delg213*ginv33)) - + ginv12*(delg212*ginv13 + delg222*ginv23 + delg223*ginv33) - + ginv13*(delg223*ginv23 + delg233*ginv33) - delg213*pow2(ginv13) +; + +dginv222 += +-2.*(delg223*ginv22*ginv23 + ginv12*(delg212*ginv22 + delg213*ginv23)) - + delg211*pow2(ginv12) - delg222*pow2(ginv22) - delg233*pow2(ginv23) +; + +dginv223 += +-(ginv13*(delg212*ginv22 + delg213*ginv23)) - delg233*ginv23*ginv33 - + ginv12*(delg211*ginv13 + delg212*ginv23 + delg213*ginv33) - + ginv22*(delg222*ginv23 + delg223*ginv33) - delg223*pow2(ginv23) +; + +dginv233 += +-2.*(delg223*ginv23*ginv33 + ginv13*(delg212*ginv23 + delg213*ginv33)) - + delg211*pow2(ginv13) - delg222*pow2(ginv23) - delg233*pow2(ginv33) +; + +dginv311 += +-2.*(delg323*ginv12*ginv13 + ginv11*(delg312*ginv12 + delg313*ginv13)) - + delg311*pow2(ginv11) - delg322*pow2(ginv12) - delg333*pow2(ginv13) +; + +dginv312 += +-(ginv11*(delg311*ginv12 + delg312*ginv22 + delg313*ginv23)) - + ginv12*(delg313*ginv13 + delg322*ginv22 + delg323*ginv23) - + ginv13*(delg323*ginv22 + delg333*ginv23) - delg312*pow2(ginv12) +; + +dginv313 += +-(ginv11*(delg311*ginv13 + delg312*ginv23 + delg313*ginv33)) - + ginv12*(delg312*ginv13 + delg322*ginv23 + delg323*ginv33) - + ginv13*(delg323*ginv23 + delg333*ginv33) - delg313*pow2(ginv13) +; + +dginv322 += +-2.*(delg323*ginv22*ginv23 + ginv12*(delg312*ginv22 + delg313*ginv23)) - + delg311*pow2(ginv12) - delg322*pow2(ginv22) - delg333*pow2(ginv23) +; + +dginv323 += +-(ginv13*(delg312*ginv22 + delg313*ginv23)) - delg333*ginv23*ginv33 - + ginv12*(delg311*ginv13 + delg312*ginv23 + delg313*ginv33) - + ginv22*(delg322*ginv23 + delg323*ginv33) - delg323*pow2(ginv23) +; + +dginv333 += +-2.*(delg323*ginv23*ginv33 + ginv13*(delg312*ginv23 + delg313*ginv33)) - + delg311*pow2(ginv13) - delg322*pow2(ginv23) - delg333*pow2(ginv33) +; + +dphi1 += +(-0.25*dchi1)/chiguarded +; + +dphi2 += +(-0.25*dchi2)/chiguarded +; + +dphi3 += +(-0.25*dchi3)/chiguarded +; + +gammaF111 += +gamma111 + dphi1*(4. - 2.*g11*ginv11) - 2.*g11*(dphi2*ginv12 + dphi3*ginv13) +; + +gammaF112 += +gamma112 + dphi2*(2. - 2.*g12*ginv12) - 2.*g12*(dphi1*ginv11 + dphi3*ginv13) +; + +gammaF113 += +gamma113 - 2.*g13*(dphi1*ginv11 + dphi2*ginv12) + dphi3*(2. - 2.*g13*ginv13) +; + +gammaF121 += +gamma112 + dphi2*(2. - 2.*g12*ginv12) - 2.*g12*(dphi1*ginv11 + dphi3*ginv13) +; + +gammaF122 += +gamma122 - 2.*g22*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) +; + +gammaF123 += +gamma123 - 2.*g23*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) +; + +gammaF131 += +gamma113 - 2.*g13*(dphi1*ginv11 + dphi2*ginv12) + dphi3*(2. - 2.*g13*ginv13) +; + +gammaF132 += +gamma123 - 2.*g23*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) +; + +gammaF133 += +gamma133 - 2.*g33*(dphi1*ginv11 + dphi2*ginv12 + dphi3*ginv13) +; + +gammaF211 += +gamma211 - 2.*g11*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) +; + +gammaF212 += +gamma212 + dphi1*(2. - 2.*g12*ginv12) - 2.*g12*(dphi2*ginv22 + dphi3*ginv23) +; + +gammaF213 += +gamma213 - 2.*g13*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) +; + +gammaF221 += +gamma212 + dphi1*(2. - 2.*g12*ginv12) - 2.*g12*(dphi2*ginv22 + dphi3*ginv23) +; + +gammaF222 += +gamma222 + dphi2*(4. - 2.*g22*ginv22) - 2.*g22*(dphi1*ginv12 + dphi3*ginv23) +; + +gammaF223 += +gamma223 - 2.*g23*(dphi1*ginv12 + dphi2*ginv22) + dphi3*(2. - 2.*g23*ginv23) +; + +gammaF231 += +gamma213 - 2.*g13*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) +; + +gammaF232 += +gamma223 - 2.*g23*(dphi1*ginv12 + dphi2*ginv22) + dphi3*(2. - 2.*g23*ginv23) +; + +gammaF233 += +gamma233 - 2.*g33*(dphi1*ginv12 + dphi2*ginv22 + dphi3*ginv23) +; + +gammaF311 += +gamma311 - 2.*g11*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) +; + +gammaF312 += +gamma312 - 2.*g12*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) +; + +gammaF313 += +gamma313 + dphi1*(2. - 2.*g13*ginv13) - 2.*g13*(dphi2*ginv23 + dphi3*ginv33) +; + +gammaF321 += +gamma312 - 2.*g12*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) +; + +gammaF322 += +gamma322 - 2.*g22*(dphi1*ginv13 + dphi2*ginv23 + dphi3*ginv33) +; + +gammaF323 += +gamma323 + dphi2*(2. - 2.*g23*ginv23) - 2.*g23*(dphi1*ginv13 + dphi3*ginv33) +; + +gammaF331 += +gamma313 + dphi1*(2. - 2.*g13*ginv13) - 2.*g13*(dphi2*ginv23 + dphi3*ginv33) +; + +gammaF332 += +gamma323 + dphi2*(2. - 2.*g23*ginv23) - 2.*g23*(dphi1*ginv13 + dphi3*ginv33) +; + +gammaF333 += +gamma333 - 2.*g33*(dphi1*ginv13 + dphi2*ginv23) + dphi3*(4. - 2.*g33*ginv33) +; + +Gd1 += +ginv11*((2.*delg112 + delg211)*ginv12 + (2.*delg113 + delg311)*ginv13 + + delg212*ginv22 + (delg213 + delg312)*ginv23 + delg313*ginv33) + + ginv12*((2.*delg123 + delg213 + delg312)*ginv13 + delg222*ginv22 + + (delg223 + delg322)*ginv23 + delg323*ginv33) + + ginv13*(delg223*ginv22 + (delg233 + delg323)*ginv23 + delg333*ginv33) + + delg111*pow2(ginv11) + (delg122 + delg212)*pow2(ginv12) + + (delg133 + delg313)*pow2(ginv13) +; + +Gd2 += +ginv11*(delg111*ginv12 + delg112*ginv22 + delg113*ginv23) + + ginv13*((delg123 + delg312)*ginv22 + (delg133 + delg313)*ginv23) + + delg333*ginv23*ginv33 + ginv12* + ((delg113 + delg311)*ginv13 + (delg122 + 2.*delg212)*ginv22 + + (delg123 + 2.*delg213 + delg312)*ginv23 + delg313*ginv33) + + ginv22*((2.*delg223 + delg322)*ginv23 + delg323*ginv33) + + (delg112 + delg211)*pow2(ginv12) + delg222*pow2(ginv22) + + (delg233 + delg323)*pow2(ginv23) +; + +Gd3 += +(delg233 + 2.*delg323)*ginv23*ginv33 + + ginv11*(delg111*ginv13 + delg112*ginv23 + delg113*ginv33) + + ginv12*((delg112 + delg211)*ginv13 + (delg122 + delg212)*ginv23 + + (delg123 + delg213)*ginv33) + + ginv22*(delg222*ginv23 + delg223*ginv33) + + ginv13*(delg212*ginv22 + (delg123 + delg213 + 2.*delg312)*ginv23 + + (delg133 + 2.*delg313)*ginv33) + (delg113 + delg311)*pow2(ginv13) + + (delg223 + delg322)*pow2(ginv23) + delg333*pow2(ginv33) +; + +dGd11 += +(delg212*dginv111 + delg222*dginv112 + delg223*dginv113)*ginv22 + + ((delg213 + delg312)*dginv111 + (delg223 + delg322)*dginv112 + + (delg233 + delg323)*dginv113)*ginv23 + + (delg313*dginv111 + delg323*dginv112 + delg333*dginv113)*ginv33 + + ginv11*(delg211*dginv112 + delg311*dginv113 + + 2.*(delg111*dginv111 + delg112*dginv112 + delg113*dginv113) + + delg212*dginv122 + (delg213 + delg312)*dginv123 + delg313*dginv133 + + (2.*deldelg1112 + deldelg1211)*ginv12 + + (2.*deldelg1113 + deldelg1311)*ginv13 + deldelg1212*ginv22 + + (deldelg1213 + deldelg1312)*ginv23 + deldelg1313*ginv33) + + ginv12*((2.*delg112 + delg211)*dginv111 + (delg213 + delg312)*dginv113 + + 2.*((delg122 + delg212)*dginv112 + delg123*dginv113) + + delg222*dginv122 + (delg223 + delg322)*dginv123 + delg323*dginv133 + + (2.*deldelg1123 + deldelg1213 + deldelg1312)*ginv13 + + deldelg1222*ginv22 + (deldelg1223 + deldelg1322)*ginv23 + + deldelg1323*ginv33) + ginv13* + ((2.*delg113 + delg311)*dginv111 + + (2.*delg123 + delg213 + delg312)*dginv112 + + 2.*(delg133 + delg313)*dginv113 + delg223*dginv122 + + (delg233 + delg323)*dginv123 + delg333*dginv133 + deldelg1223*ginv22 + + (deldelg1233 + deldelg1323)*ginv23 + deldelg1333*ginv33) + + deldelg1111*pow2(ginv11) + (deldelg1122 + deldelg1212)*pow2(ginv12) + + (deldelg1133 + deldelg1313)*pow2(ginv13) +; + +dGd12 += +ginv11*(delg111*dginv112 + delg112*dginv122 + delg113*dginv123 + + deldelg1111*ginv12 + deldelg1112*ginv22 + deldelg1113*ginv23) + + ginv13*((delg113 + delg311)*dginv112 + (delg123 + delg312)*dginv122 + + (delg133 + delg313)*dginv123 + (deldelg1123 + deldelg1312)*ginv22 + + (deldelg1133 + deldelg1313)*ginv23) + + (delg313*dginv112 + delg323*dginv122 + delg333*dginv123)*ginv33 + + ginv12*(delg111*dginv111 + (delg113 + delg311)*dginv113 + + delg122*dginv122 + (delg123 + delg312)*dginv123 + + 2.*((delg112 + delg211)*dginv112 + delg212*dginv122 + + delg213*dginv123) + delg313*dginv133 + + (deldelg1113 + deldelg1311)*ginv13 + + (deldelg1122 + 2.*deldelg1212)*ginv22 + + (deldelg1123 + 2.*deldelg1213 + deldelg1312)*ginv23 + + deldelg1313*ginv33) + ginv22* + (delg112*dginv111 + (delg122 + 2.*delg212)*dginv112 + + (delg123 + delg312)*dginv113 + delg322*dginv123 + + 2.*(delg222*dginv122 + delg223*dginv123) + delg323*dginv133 + + (2.*deldelg1223 + deldelg1322)*ginv23 + deldelg1323*ginv33) + + ginv23*(delg113*dginv111 + (delg123 + 2.*delg213 + delg312)*dginv112 + + (delg133 + delg313)*dginv113 + (2.*delg223 + delg322)*dginv122 + + 2.*(delg233 + delg323)*dginv123 + delg333*dginv133 + deldelg1333*ginv33\ +) + (deldelg1112 + deldelg1211)*pow2(ginv12) + deldelg1222*pow2(ginv22) + + (deldelg1233 + deldelg1323)*pow2(ginv23) +; + +dGd13 += +(delg113*dginv111 + (delg123 + delg213)*dginv112 + + (delg133 + 2.*delg313)*dginv113 + delg223*dginv122 + + (delg233 + 2.*delg323)*dginv123 + 2.*delg333*dginv133)*ginv33 + + ginv11*(delg111*dginv113 + delg112*dginv123 + delg113*dginv133 + + deldelg1111*ginv13 + deldelg1112*ginv23 + deldelg1113*ginv33) + + ginv12*((delg112 + delg211)*dginv113 + (delg122 + delg212)*dginv123 + + (delg123 + delg213)*dginv133 + (deldelg1112 + deldelg1211)*ginv13 + + (deldelg1122 + deldelg1212)*ginv23 + (deldelg1123 + deldelg1213)*ginv33\ +) + ginv22*(delg212*dginv113 + delg222*dginv123 + delg223*dginv133 + + deldelg1222*ginv23 + deldelg1223*ginv33) + + ginv13*(delg111*dginv111 + (delg112 + delg211)*dginv112 + + delg212*dginv122 + (delg123 + delg213)*dginv123 + delg133*dginv133 + + 2.*((delg113 + delg311)*dginv113 + delg312*dginv123 + + delg313*dginv133) + deldelg1212*ginv22 + + (deldelg1123 + deldelg1213 + 2.*deldelg1312)*ginv23 + + (deldelg1133 + 2.*deldelg1313)*ginv33) + + ginv23*(delg112*dginv111 + (delg122 + delg212)*dginv112 + + (delg123 + delg213 + 2.*delg312)*dginv113 + delg222*dginv122 + + delg233*dginv133 + 2.*((delg223 + delg322)*dginv123 + + delg323*dginv133) + (deldelg1233 + 2.*deldelg1323)*ginv33) + + (deldelg1113 + deldelg1311)*pow2(ginv13) + + (deldelg1223 + deldelg1322)*pow2(ginv23) + deldelg1333*pow2(ginv33) +; + +dGd21 += +(delg212*dginv211 + delg222*dginv212 + delg223*dginv213)*ginv22 + + ((delg213 + delg312)*dginv211 + (delg223 + delg322)*dginv212 + + (delg233 + delg323)*dginv213)*ginv23 + + (delg313*dginv211 + delg323*dginv212 + delg333*dginv213)*ginv33 + + ginv11*(delg211*dginv212 + delg311*dginv213 + + 2.*(delg111*dginv211 + delg112*dginv212 + delg113*dginv213) + + delg212*dginv222 + (delg213 + delg312)*dginv223 + delg313*dginv233 + + (2.*deldelg1212 + deldelg2211)*ginv12 + + (2.*deldelg1213 + deldelg2311)*ginv13 + deldelg2212*ginv22 + + (deldelg2213 + deldelg2312)*ginv23 + deldelg2313*ginv33) + + ginv12*((2.*delg112 + delg211)*dginv211 + (delg213 + delg312)*dginv213 + + 2.*((delg122 + delg212)*dginv212 + delg123*dginv213) + + delg222*dginv222 + (delg223 + delg322)*dginv223 + delg323*dginv233 + + (2.*deldelg1223 + deldelg2213 + deldelg2312)*ginv13 + + deldelg2222*ginv22 + (deldelg2223 + deldelg2322)*ginv23 + + deldelg2323*ginv33) + ginv13* + ((2.*delg113 + delg311)*dginv211 + + (2.*delg123 + delg213 + delg312)*dginv212 + + 2.*(delg133 + delg313)*dginv213 + delg223*dginv222 + + (delg233 + delg323)*dginv223 + delg333*dginv233 + deldelg2223*ginv22 + + (deldelg2233 + deldelg2323)*ginv23 + deldelg2333*ginv33) + + deldelg1211*pow2(ginv11) + (deldelg1222 + deldelg2212)*pow2(ginv12) + + (deldelg1233 + deldelg2313)*pow2(ginv13) +; + +dGd22 += +ginv11*(delg111*dginv212 + delg112*dginv222 + delg113*dginv223 + + deldelg1211*ginv12 + deldelg1212*ginv22 + deldelg1213*ginv23) + + ginv13*((delg113 + delg311)*dginv212 + (delg123 + delg312)*dginv222 + + (delg133 + delg313)*dginv223 + (deldelg1223 + deldelg2312)*ginv22 + + (deldelg1233 + deldelg2313)*ginv23) + + (delg313*dginv212 + delg323*dginv222 + delg333*dginv223)*ginv33 + + ginv12*(delg111*dginv211 + (delg113 + delg311)*dginv213 + + delg122*dginv222 + (delg123 + delg312)*dginv223 + + 2.*((delg112 + delg211)*dginv212 + delg212*dginv222 + + delg213*dginv223) + delg313*dginv233 + + (deldelg1213 + deldelg2311)*ginv13 + + (deldelg1222 + 2.*deldelg2212)*ginv22 + + (deldelg1223 + 2.*deldelg2213 + deldelg2312)*ginv23 + + deldelg2313*ginv33) + ginv22* + (delg112*dginv211 + (delg122 + 2.*delg212)*dginv212 + + (delg123 + delg312)*dginv213 + delg322*dginv223 + + 2.*(delg222*dginv222 + delg223*dginv223) + delg323*dginv233 + + (2.*deldelg2223 + deldelg2322)*ginv23 + deldelg2323*ginv33) + + ginv23*(delg113*dginv211 + (delg123 + 2.*delg213 + delg312)*dginv212 + + (delg133 + delg313)*dginv213 + (2.*delg223 + delg322)*dginv222 + + 2.*(delg233 + delg323)*dginv223 + delg333*dginv233 + deldelg2333*ginv33\ +) + (deldelg1212 + deldelg2211)*pow2(ginv12) + deldelg2222*pow2(ginv22) + + (deldelg2233 + deldelg2323)*pow2(ginv23) +; + +dGd23 += +(delg113*dginv211 + (delg123 + delg213)*dginv212 + + (delg133 + 2.*delg313)*dginv213 + delg223*dginv222 + + (delg233 + 2.*delg323)*dginv223 + 2.*delg333*dginv233)*ginv33 + + ginv11*(delg111*dginv213 + delg112*dginv223 + delg113*dginv233 + + deldelg1211*ginv13 + deldelg1212*ginv23 + deldelg1213*ginv33) + + ginv12*((delg112 + delg211)*dginv213 + (delg122 + delg212)*dginv223 + + (delg123 + delg213)*dginv233 + (deldelg1212 + deldelg2211)*ginv13 + + (deldelg1222 + deldelg2212)*ginv23 + (deldelg1223 + deldelg2213)*ginv33\ +) + ginv22*(delg212*dginv213 + delg222*dginv223 + delg223*dginv233 + + deldelg2222*ginv23 + deldelg2223*ginv33) + + ginv13*(delg111*dginv211 + (delg112 + delg211)*dginv212 + + delg212*dginv222 + (delg123 + delg213)*dginv223 + delg133*dginv233 + + 2.*((delg113 + delg311)*dginv213 + delg312*dginv223 + + delg313*dginv233) + deldelg2212*ginv22 + + (deldelg1223 + deldelg2213 + 2.*deldelg2312)*ginv23 + + (deldelg1233 + 2.*deldelg2313)*ginv33) + + ginv23*(delg112*dginv211 + (delg122 + delg212)*dginv212 + + (delg123 + delg213 + 2.*delg312)*dginv213 + delg222*dginv222 + + delg233*dginv233 + 2.*((delg223 + delg322)*dginv223 + + delg323*dginv233) + (deldelg2233 + 2.*deldelg2323)*ginv33) + + (deldelg1213 + deldelg2311)*pow2(ginv13) + + (deldelg2223 + deldelg2322)*pow2(ginv23) + deldelg2333*pow2(ginv33) +; + +dGd31 += +(delg212*dginv311 + delg222*dginv312 + delg223*dginv313)*ginv22 + + ((delg213 + delg312)*dginv311 + (delg223 + delg322)*dginv312 + + (delg233 + delg323)*dginv313)*ginv23 + + (delg313*dginv311 + delg323*dginv312 + delg333*dginv313)*ginv33 + + ginv11*(delg211*dginv312 + delg311*dginv313 + + 2.*(delg111*dginv311 + delg112*dginv312 + delg113*dginv313) + + delg212*dginv322 + (delg213 + delg312)*dginv323 + delg313*dginv333 + + (2.*deldelg1312 + deldelg2311)*ginv12 + + (2.*deldelg1313 + deldelg3311)*ginv13 + deldelg2312*ginv22 + + (deldelg2313 + deldelg3312)*ginv23 + deldelg3313*ginv33) + + ginv12*((2.*delg112 + delg211)*dginv311 + (delg213 + delg312)*dginv313 + + 2.*((delg122 + delg212)*dginv312 + delg123*dginv313) + + delg222*dginv322 + (delg223 + delg322)*dginv323 + delg323*dginv333 + + (2.*deldelg1323 + deldelg2313 + deldelg3312)*ginv13 + + deldelg2322*ginv22 + (deldelg2323 + deldelg3322)*ginv23 + + deldelg3323*ginv33) + ginv13* + ((2.*delg113 + delg311)*dginv311 + + (2.*delg123 + delg213 + delg312)*dginv312 + + 2.*(delg133 + delg313)*dginv313 + delg223*dginv322 + + (delg233 + delg323)*dginv323 + delg333*dginv333 + deldelg2323*ginv22 + + (deldelg2333 + deldelg3323)*ginv23 + deldelg3333*ginv33) + + deldelg1311*pow2(ginv11) + (deldelg1322 + deldelg2312)*pow2(ginv12) + + (deldelg1333 + deldelg3313)*pow2(ginv13) +; + +dGd32 += +ginv11*(delg111*dginv312 + delg112*dginv322 + delg113*dginv323 + + deldelg1311*ginv12 + deldelg1312*ginv22 + deldelg1313*ginv23) + + ginv13*((delg113 + delg311)*dginv312 + (delg123 + delg312)*dginv322 + + (delg133 + delg313)*dginv323 + (deldelg1323 + deldelg3312)*ginv22 + + (deldelg1333 + deldelg3313)*ginv23) + + (delg313*dginv312 + delg323*dginv322 + delg333*dginv323)*ginv33 + + ginv12*(delg111*dginv311 + (delg113 + delg311)*dginv313 + + delg122*dginv322 + (delg123 + delg312)*dginv323 + + 2.*((delg112 + delg211)*dginv312 + delg212*dginv322 + + delg213*dginv323) + delg313*dginv333 + + (deldelg1313 + deldelg3311)*ginv13 + + (deldelg1322 + 2.*deldelg2312)*ginv22 + + (deldelg1323 + 2.*deldelg2313 + deldelg3312)*ginv23 + + deldelg3313*ginv33) + ginv22* + (delg112*dginv311 + (delg122 + 2.*delg212)*dginv312 + + (delg123 + delg312)*dginv313 + delg322*dginv323 + + 2.*(delg222*dginv322 + delg223*dginv323) + delg323*dginv333 + + (2.*deldelg2323 + deldelg3322)*ginv23 + deldelg3323*ginv33) + + ginv23*(delg113*dginv311 + (delg123 + 2.*delg213 + delg312)*dginv312 + + (delg133 + delg313)*dginv313 + (2.*delg223 + delg322)*dginv322 + + 2.*(delg233 + delg323)*dginv323 + delg333*dginv333 + deldelg3333*ginv33\ +) + (deldelg1312 + deldelg2311)*pow2(ginv12) + deldelg2322*pow2(ginv22) + + (deldelg2333 + deldelg3323)*pow2(ginv23) +; + +dGd33 += +(delg113*dginv311 + (delg123 + delg213)*dginv312 + + (delg133 + 2.*delg313)*dginv313 + delg223*dginv322 + + (delg233 + 2.*delg323)*dginv323 + 2.*delg333*dginv333)*ginv33 + + ginv11*(delg111*dginv313 + delg112*dginv323 + delg113*dginv333 + + deldelg1311*ginv13 + deldelg1312*ginv23 + deldelg1313*ginv33) + + ginv12*((delg112 + delg211)*dginv313 + (delg122 + delg212)*dginv323 + + (delg123 + delg213)*dginv333 + (deldelg1312 + deldelg2311)*ginv13 + + (deldelg1322 + deldelg2312)*ginv23 + (deldelg1323 + deldelg2313)*ginv33\ +) + ginv22*(delg212*dginv313 + delg222*dginv323 + delg223*dginv333 + + deldelg2322*ginv23 + deldelg2323*ginv33) + + ginv13*(delg111*dginv311 + (delg112 + delg211)*dginv312 + + delg212*dginv322 + (delg123 + delg213)*dginv323 + delg133*dginv333 + + 2.*((delg113 + delg311)*dginv313 + delg312*dginv323 + + delg313*dginv333) + deldelg2312*ginv22 + + (deldelg1323 + deldelg2313 + 2.*deldelg3312)*ginv23 + + (deldelg1333 + 2.*deldelg3313)*ginv33) + + ginv23*(delg112*dginv311 + (delg122 + delg212)*dginv312 + + (delg123 + delg213 + 2.*delg312)*dginv313 + delg222*dginv322 + + delg233*dginv333 + 2.*((delg223 + delg322)*dginv323 + + delg323*dginv333) + (deldelg2333 + 2.*deldelg3323)*ginv33) + + (deldelg1313 + deldelg3311)*pow2(ginv13) + + (deldelg2323 + deldelg3322)*pow2(ginv23) + deldelg3333*pow2(ginv33) +; + +Zinv1 += +0.5*(G1 - Gd1) +; + +Zinv2 += +0.5*(G2 - Gd2) +; + +Zinv3 += +0.5*(G3 - Gd3) +; + +dZinv11 += +0.5*(delG11 - dGd11) +; + +dZinv12 += +0.5*(delG12 - dGd12) +; + +dZinv13 += +0.5*(delG13 - dGd13) +; + +dZinv21 += +0.5*(delG21 - dGd21) +; + +dZinv22 += +0.5*(delG22 - dGd22) +; + +dZinv23 += +0.5*(delG23 - dGd23) +; + +dZinv31 += +0.5*(delG31 - dGd31) +; + +dZinv32 += +0.5*(delG32 - dGd32) +; + +dZinv33 += +0.5*(delG33 - dGd33) +; + +Z1 += +g11*Zinv1 + g12*Zinv2 + g13*Zinv3 +; + +Z2 += +g12*Zinv1 + g22*Zinv2 + g23*Zinv3 +; + +Z3 += +g13*Zinv1 + g23*Zinv2 + g33*Zinv3 +; + +dZ11 += +dZinv11*g11 + dZinv12*g12 + dZinv13*g13 + delg111*Zinv1 + delg112*Zinv2 + + delg113*Zinv3 +; + +dZ12 += +dZinv11*g12 + dZinv12*g22 + dZinv13*g23 + delg112*Zinv1 + delg122*Zinv2 + + delg123*Zinv3 +; + +dZ13 += +dZinv11*g13 + dZinv12*g23 + dZinv13*g33 + delg113*Zinv1 + delg123*Zinv2 + + delg133*Zinv3 +; + +dZ21 += +dZinv21*g11 + dZinv22*g12 + dZinv23*g13 + delg211*Zinv1 + delg212*Zinv2 + + delg213*Zinv3 +; + +dZ22 += +dZinv21*g12 + dZinv22*g22 + dZinv23*g23 + delg212*Zinv1 + delg222*Zinv2 + + delg223*Zinv3 +; + +dZ23 += +dZinv21*g13 + dZinv22*g23 + dZinv23*g33 + delg213*Zinv1 + delg223*Zinv2 + + delg233*Zinv3 +; + +dZ31 += +dZinv31*g11 + dZinv32*g12 + dZinv33*g13 + delg311*Zinv1 + delg312*Zinv2 + + delg313*Zinv3 +; + +dZ32 += +dZinv31*g12 + dZinv32*g22 + dZinv33*g23 + delg312*Zinv1 + delg322*Zinv2 + + delg323*Zinv3 +; + +dZ33 += +dZinv31*g13 + dZinv32*g23 + dZinv33*g33 + delg313*Zinv1 + delg323*Zinv2 + + delg333*Zinv3 +; + +DZinv11 += +dZinv11 + gammaF111*Zinv1 + gammaF112*Zinv2 + gammaF113*Zinv3 +; + +DZinv12 += +dZinv12 + gammaF211*Zinv1 + gammaF212*Zinv2 + gammaF213*Zinv3 +; + +DZinv13 += +dZinv13 + gammaF311*Zinv1 + gammaF312*Zinv2 + gammaF313*Zinv3 +; + +DZinv21 += +dZinv21 + gammaF121*Zinv1 + gammaF122*Zinv2 + gammaF123*Zinv3 +; + +DZinv22 += +dZinv22 + gammaF221*Zinv1 + gammaF222*Zinv2 + gammaF223*Zinv3 +; + +DZinv23 += +dZinv23 + gammaF321*Zinv1 + gammaF322*Zinv2 + gammaF323*Zinv3 +; + +DZinv31 += +dZinv31 + gammaF131*Zinv1 + gammaF132*Zinv2 + gammaF133*Zinv3 +; + +DZinv32 += +dZinv32 + gammaF231*Zinv1 + gammaF232*Zinv2 + gammaF233*Zinv3 +; + +DZinv33 += +dZinv33 + gammaF331*Zinv1 + gammaF332*Zinv2 + gammaF333*Zinv3 +; + +DZ11 += +dZ11 - gammaF111*Z1 - gammaF211*Z2 - gammaF311*Z3 +; + +DZ12 += +dZ12 - gammaF112*Z1 - gammaF212*Z2 - gammaF312*Z3 +; + +DZ13 += +dZ13 - gammaF113*Z1 - gammaF213*Z2 - gammaF313*Z3 +; + +DZ21 += +dZ21 - gammaF121*Z1 - gammaF221*Z2 - gammaF321*Z3 +; + +DZ22 += +dZ22 - gammaF122*Z1 - gammaF222*Z2 - gammaF322*Z3 +; + +DZ23 += +dZ23 - gammaF123*Z1 - gammaF223*Z2 - gammaF323*Z3 +; + +DZ31 += +dZ31 - gammaF131*Z1 - gammaF231*Z2 - gammaF331*Z3 +; + +DZ32 += +dZ32 - gammaF132*Z1 - gammaF232*Z2 - gammaF332*Z3 +; + +DZ33 += +dZ33 - gammaF133*Z1 - gammaF233*Z2 - gammaF333*Z3 +; + +DZsym11 += +2.*DZ11 +; + +DZsym12 += +DZ12 + DZ21 +; + +DZsym13 += +DZ13 + DZ31 +; + +DZsym21 += +DZ12 + DZ21 +; + +DZsym22 += +2.*DZ22 +; + +DZsym23 += +DZ23 + DZ32 +; + +DZsym31 += +DZ13 + DZ31 +; + +DZsym32 += +DZ23 + DZ32 +; + +DZsym33 += +2.*DZ33 +; + +trDZsym += +(DZsym11*ginv11 + (DZsym12 + DZsym21)*ginv12 + (DZsym13 + DZsym31)*ginv13 + + DZsym22*ginv22 + (DZsym23 + DZsym32)*ginv23 + DZsym33*ginv33)*psim4 +; + +rA11 += +rA11 + alpha*(-2.*A11*Theta + chi* + (DZsym11 - 0.33333333333333333333*g11*trDZsym)) +; + +rA12 += +rA12 + alpha*(-2.*A12*Theta + chi* + (DZsym21 - 0.33333333333333333333*g12*trDZsym)) +; + +rA13 += +rA13 + alpha*(-2.*A13*Theta + chi* + (DZsym31 - 0.33333333333333333333*g13*trDZsym)) +; + +rA22 += +rA22 + alpha*(-2.*A22*Theta + chi* + (DZsym22 - 0.33333333333333333333*g22*trDZsym)) +; + +rA23 += +rA23 + alpha*(-2.*A23*Theta + chi* + (DZsym32 - 0.33333333333333333333*g23*trDZsym)) +; + +rA33 += +rA33 + alpha*(-2.*A33*Theta + chi* + (DZsym33 - 0.33333333333333333333*g33*trDZsym)) +; + +rTheta += +alpha*(DZinv11 + DZinv22 + DZinv33) + rTheta - da1*Zinv1 - da2*Zinv2 - + da3*Zinv3 +; + +rG1 += +rG1 - ginv11*(1.3333333333333333333*alpha*K*Z1 + + 2.*(da1*Theta + alpha*kappa1*Z1)) - + ginv12*(1.3333333333333333333*alpha*K*Z2 + + 2.*(da2*Theta + alpha*kappa1*Z2)) - + ginv13*(1.3333333333333333333*alpha*K*Z3 + + 2.*(da3*Theta + alpha*kappa1*Z3)) +; + +rG2 += +rG2 - ginv12*(1.3333333333333333333*alpha*K*Z1 + + 2.*(da1*Theta + alpha*kappa1*Z1)) - + ginv22*(1.3333333333333333333*alpha*K*Z2 + + 2.*(da2*Theta + alpha*kappa1*Z2)) - + ginv23*(1.3333333333333333333*alpha*K*Z3 + + 2.*(da3*Theta + alpha*kappa1*Z3)) +; + +rG3 += +rG3 - ginv13*(1.3333333333333333333*alpha*K*Z1 + + 2.*(da1*Theta + alpha*kappa1*Z1)) - + ginv23*(1.3333333333333333333*alpha*K*Z2 + + 2.*(da2*Theta + alpha*kappa1*Z2)) - + ginv33*(1.3333333333333333333*alpha*K*Z3 + + 2.*(da3*Theta + alpha*kappa1*Z3)) +; +#endif + + } /* function */ +} diff --git a/AMSS_NCKU_source/Block.C b/AMSS_NCKU_source/cgh/Block.C similarity index 96% rename from AMSS_NCKU_source/Block.C rename to AMSS_NCKU_source/cgh/Block.C index fcae198..f76dec0 100644 --- a/AMSS_NCKU_source/Block.C +++ b/AMSS_NCKU_source/cgh/Block.C @@ -1,199 +1,199 @@ - -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; - -#include "Block.h" -#include "misc.h" - -Block::Block(int DIM, int *shapei, double *bboxi, int ranki, int ingfsi, int fngfsi, int levi, const int cgpui) : rank(ranki), ingfs(ingfsi), fngfs(fngfsi), lev(levi), cgpu(cgpui) -{ - for (int i = 0; i < dim; i++) - X[i] = 0; - - if (DIM != dim) - { - cout << "dimension is not consistent in Block construction" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - bool flag = false; - for (int i = 0; i < dim; i++) - { - shape[i] = shapei[i]; - if (shape[i] <= 0) - flag = true; - bbox[i] = bboxi[i]; - bbox[dim + i] = bboxi[dim + i]; - } - - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (flag) - { - cout << "myrank: " << myrank << ", on rank: " << rank << endl; - cout << "error shape in Block construction: (" << shape[0] << "," << shape[1] << "," << shape[2] << ")" << endl; - cout << "box boundary: (" << bbox[0] << ":" << bbox[3] << "," << bbox[1] << ":" << bbox[4] << "," << bbox[2] << ":" << bbox[5] << ")" << endl; - cout << "belong to level " << lev << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - -#ifndef FAKECHECK - if (myrank == rank) - { - for (int i = 0; i < dim; i++) - { - X[i] = new double[shape[i]]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - double h = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); - for (int j = 0; j < shape[i]; j++) - X[i][j] = bbox[i] + j * h; -#else -#ifdef Cell - double h = (bbox[dim + i] - bbox[i]) / shape[i]; - for (int j = 0; j < shape[i]; j++) - X[i][j] = bbox[i] + (j + 0.5) * h; -#else -#error Not define Vertex nor Cell -#endif -#endif - } - - int nn = shape[0] * shape[1] * shape[2]; - fgfs = new double *[fngfs]; - for (int i = 0; i < fngfs; i++) - { - fgfs[i] = (double *)malloc(sizeof(double) * nn); - if (!(fgfs[i])) - { - cout << "on node#" << rank << ", out of memory when constructing Block." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - memset(fgfs[i], 0, sizeof(double) * nn); - } - - igfs = new int *[ingfs]; - for (int i = 0; i < ingfs; i++) - { - igfs[i] = (int *)malloc(sizeof(int) * nn); - if (!(igfs[i])) - { - cout << "on node#" << rank << ", out of memory when constructing Block." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - memset(igfs[i], 0, sizeof(int) * nn); - } - } -#endif -} -Block::~Block() -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == rank) - { - for (int i = 0; i < dim; i++) - delete[] X[i]; - for (int i = 0; i < ingfs; i++) - free(igfs[i]); - delete[] igfs; - for (int i = 0; i < fngfs; i++) - free(fgfs[i]); - delete[] fgfs; - X[0] = X[1] = X[2] = 0; - igfs = 0; - fgfs = 0; - } -} -void Block::checkBlock() -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << "belong to level " << lev << endl; - cout << "shape: ["; - for (int i = 0; i < dim; i++) - { - cout << shape[i]; - if (i < dim - 1) - cout << ","; - else - cout << "]"; - } - cout << " resolution: ["; - for (int i = 0; i < dim; i++) - { - cout << getdX(i); - if (i < dim - 1) - cout << ","; - else - cout << "]" << endl; - } - cout << "locate on node " << rank << ", at (includes ghost zone):" << endl; - cout << "("; - for (int i = 0; i < dim; i++) - { - cout << bbox[i] << ":" << bbox[dim + i]; - if (i < dim - 1) - cout << ","; - else - cout << ")" << endl; - } - cout << "has " << ingfs << " int type grids functions," << fngfs << " double type grids functions" << endl; - } -} -double Block::getdX(int dir) -{ - if (dir < 0 || dir >= dim) - { - cout << "Block::getdX: error input dir = " << dir << ", this Block has direction (0," << dim - 1 << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - double h; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - if (shape[dir] == 1) - { - cout << "Block::getdX: for direction " << dir << ", this Block has only one point. Can not determine dX for vertex center grid." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - h = (bbox[dim + dir] - bbox[dir]) / (shape[dir] - 1); -#else -#ifdef Cell - h = (bbox[dim + dir] - bbox[dir]) / shape[dir]; -#else -#error Not define Vertex nor Cell -#endif -#endif - return h; -} -void Block::swapList(MyList *VarList1, MyList *VarList2, int myrank) -{ - if (rank == myrank) - { - MyList *varl1 = VarList1, *varl2 = VarList2; - while (varl1 && varl2) - { - misc::swap(fgfs[varl1->data->sgfn], fgfs[varl2->data->sgfn]); - varl1 = varl1->next; - varl2 = varl2->next; - } - if (varl1 || varl2) - { - cout << "error in Block::swaplist, var lists does not match." << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - } -} + +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; + +#include "Block.h" +#include "misc.h" + +Block::Block(int DIM, int *shapei, double *bboxi, int ranki, int ingfsi, int fngfsi, int levi, const int cgpui) : rank(ranki), ingfs(ingfsi), fngfs(fngfsi), lev(levi), cgpu(cgpui) +{ + for (int i = 0; i < dim; i++) + X[i] = 0; + + if (DIM != dim) + { + cout << "dimension is not consistent in Block construction" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + bool flag = false; + for (int i = 0; i < dim; i++) + { + shape[i] = shapei[i]; + if (shape[i] <= 0) + flag = true; + bbox[i] = bboxi[i]; + bbox[dim + i] = bboxi[dim + i]; + } + + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (flag) + { + cout << "myrank: " << myrank << ", on rank: " << rank << endl; + cout << "error shape in Block construction: (" << shape[0] << "," << shape[1] << "," << shape[2] << ")" << endl; + cout << "box boundary: (" << bbox[0] << ":" << bbox[3] << "," << bbox[1] << ":" << bbox[4] << "," << bbox[2] << ":" << bbox[5] << ")" << endl; + cout << "belong to level " << lev << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + +#ifndef FAKECHECK + if (myrank == rank) + { + for (int i = 0; i < dim; i++) + { + X[i] = new double[shape[i]]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + double h = (bbox[dim + i] - bbox[i]) / (shape[i] - 1); + for (int j = 0; j < shape[i]; j++) + X[i][j] = bbox[i] + j * h; +#else +#ifdef Cell + double h = (bbox[dim + i] - bbox[i]) / shape[i]; + for (int j = 0; j < shape[i]; j++) + X[i][j] = bbox[i] + (j + 0.5) * h; +#else +#error Not define Vertex nor Cell +#endif +#endif + } + + int nn = shape[0] * shape[1] * shape[2]; + fgfs = new double *[fngfs]; + for (int i = 0; i < fngfs; i++) + { + fgfs[i] = (double *)malloc(sizeof(double) * nn); + if (!(fgfs[i])) + { + cout << "on node#" << rank << ", out of memory when constructing Block." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + memset(fgfs[i], 0, sizeof(double) * nn); + } + + igfs = new int *[ingfs]; + for (int i = 0; i < ingfs; i++) + { + igfs[i] = (int *)malloc(sizeof(int) * nn); + if (!(igfs[i])) + { + cout << "on node#" << rank << ", out of memory when constructing Block." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + memset(igfs[i], 0, sizeof(int) * nn); + } + } +#endif +} +Block::~Block() +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == rank) + { + for (int i = 0; i < dim; i++) + delete[] X[i]; + for (int i = 0; i < ingfs; i++) + free(igfs[i]); + delete[] igfs; + for (int i = 0; i < fngfs; i++) + free(fgfs[i]); + delete[] fgfs; + X[0] = X[1] = X[2] = 0; + igfs = 0; + fgfs = 0; + } +} +void Block::checkBlock() +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << "belong to level " << lev << endl; + cout << "shape: ["; + for (int i = 0; i < dim; i++) + { + cout << shape[i]; + if (i < dim - 1) + cout << ","; + else + cout << "]"; + } + cout << " resolution: ["; + for (int i = 0; i < dim; i++) + { + cout << getdX(i); + if (i < dim - 1) + cout << ","; + else + cout << "]" << endl; + } + cout << "locate on node " << rank << ", at (includes ghost zone):" << endl; + cout << "("; + for (int i = 0; i < dim; i++) + { + cout << bbox[i] << ":" << bbox[dim + i]; + if (i < dim - 1) + cout << ","; + else + cout << ")" << endl; + } + cout << "has " << ingfs << " int type grids functions," << fngfs << " double type grids functions" << endl; + } +} +double Block::getdX(int dir) +{ + if (dir < 0 || dir >= dim) + { + cout << "Block::getdX: error input dir = " << dir << ", this Block has direction (0," << dim - 1 << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + double h; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + if (shape[dir] == 1) + { + cout << "Block::getdX: for direction " << dir << ", this Block has only one point. Can not determine dX for vertex center grid." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + h = (bbox[dim + dir] - bbox[dir]) / (shape[dir] - 1); +#else +#ifdef Cell + h = (bbox[dim + dir] - bbox[dir]) / shape[dir]; +#else +#error Not define Vertex nor Cell +#endif +#endif + return h; +} +void Block::swapList(MyList *VarList1, MyList *VarList2, int myrank) +{ + if (rank == myrank) + { + MyList *varl1 = VarList1, *varl2 = VarList2; + while (varl1 && varl2) + { + misc::swap(fgfs[varl1->data->sgfn], fgfs[varl2->data->sgfn]); + varl1 = varl1->next; + varl2 = varl2->next; + } + if (varl1 || varl2) + { + cout << "error in Block::swaplist, var lists does not match." << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + } +} diff --git a/AMSS_NCKU_source/Block.h b/AMSS_NCKU_source/cgh/Block.h similarity index 95% rename from AMSS_NCKU_source/Block.h rename to AMSS_NCKU_source/cgh/Block.h index 28193fd..3c2e274 100644 --- a/AMSS_NCKU_source/Block.h +++ b/AMSS_NCKU_source/cgh/Block.h @@ -1,34 +1,34 @@ - -#ifndef BLOCK_H -#define BLOCK_H - -#include -#include "macrodef.h" //need dim here; Vertex or Cell -#include "var.h" -#include "MyList.h" -class Block -{ - -public: - int shape[dim]; - double bbox[2 * dim]; - double *X[dim]; - int rank; // where the real data locate in - int lev, cgpu; - int ingfs, fngfs; - int *(*igfs); - double *(*fgfs); - -public: - Block() {}; - Block(int DIM, int *shapei, double *bboxi, int ranki, int ingfsi, int fngfs, int levi, const int cgpui = 0); - - ~Block(); - - void checkBlock(); - - double getdX(int dir); - void swapList(MyList *VarList1, MyList *VarList2, int myrank); -}; - -#endif /* BLOCK_H */ + +#ifndef BLOCK_H +#define BLOCK_H + +#include +#include "macrodef.h" //need dim here; Vertex or Cell +#include "var.h" +#include "MyList.h" +class Block +{ + +public: + int shape[dim]; + double bbox[2 * dim]; + double *X[dim]; + int rank; // where the real data locate in + int lev, cgpu; + int ingfs, fngfs; + int *(*igfs); + double *(*fgfs); + +public: + Block() {}; + Block(int DIM, int *shapei, double *bboxi, int ranki, int ingfsi, int fngfs, int levi, const int cgpui = 0); + + ~Block(); + + void checkBlock(); + + double getdX(int dir); + void swapList(MyList *VarList1, MyList *VarList2, int myrank); +}; + +#endif /* BLOCK_H */ diff --git a/AMSS_NCKU_source/cgh.C b/AMSS_NCKU_source/cgh/cgh.C similarity index 96% rename from AMSS_NCKU_source/cgh.C rename to AMSS_NCKU_source/cgh/cgh.C index 6e60f68..e13cfe8 100644 --- a/AMSS_NCKU_source/cgh.C +++ b/AMSS_NCKU_source/cgh/cgh.C @@ -1,1712 +1,1712 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#include -#endif - -#include - -#include "macrodef.h" -#include "misc.h" -#include "cgh.h" -#include "Parallel.h" -#include "parameters.h" - -//================================================================================================ - -// define cgh class - -//================================================================================================ - -cgh::cgh(int ingfsi, int fngfsi, int Symmetry, char *filename, int checkrun, - monitor *ErrorMonitor) : ingfs(ingfsi), fngfs(fngfsi), trfls(0) -{ -#if (PSTR == 1 || PSTR == 2 || PSTR == 3) - Commlev = 0; - start_rank = 0; - end_rank = 0; -#endif - - if (!checkrun) - { - read_bbox(Symmetry, filename); - sethandle(ErrorMonitor); - for (int lev = 0; lev < levels; lev++) - PatL[lev] = construct_patchlist(lev, Symmetry); - } -} - -//================================================================================================ - - - -//================================================================================================ - -// This member function is the destructor; it releases allocated resources and deletes variables - -//================================================================================================ - -cgh::~cgh() -{ - for (int lev = 0; lev < levels; lev++) - { - for (int grd = 0; grd < grids[lev]; grd++) - { - delete[] bbox[lev][grd]; - delete[] shape[lev][grd]; - delete[] handle[lev][grd]; - } - delete[] bbox[lev]; - delete[] shape[lev]; - delete[] handle[lev]; - Parallel::KillBlocks(PatL[lev]); - PatL[lev]->destroyList(); -#if (RPB == 1) - Parallel::destroypsuList_bam(bdsul[lev]); - Parallel::destroypsuList_bam(rsul[lev]); -#endif - } - delete[] grids; - delete[] Lt; - delete[] bbox; - delete[] shape; - delete[] handle; - delete[] PatL; -#if (RPB == 1) - delete[] bdsul; - delete[] rsul; -#endif - -#if (PSTR == 1 || PSTR == 2 || PSTR == 3) - for (int lev = 0; lev < levels; lev++) - { - MPI_Comm_free(&Commlev[lev]); - } - - if (Commlev) - delete[] Commlev; - if (start_rank) - delete[] start_rank; - if (end_rank) - delete[] end_rank; -#endif - for (int lev = 0; lev < levels; lev++) - { - for (int ibh = 0; ibh < BH_num_in; ibh++) - delete[] Porgls[lev][ibh]; - delete[] Porgls[lev]; - } - delete[] Porgls; -} - -//================================================================================================ - - -//================================================================================================ - -// This member function constructs the computational grid - -//================================================================================================ - -#if (PSTR == 0) -void cgh::compose_cgh(int nprocs) -{ - for (int lev = 0; lev < levels; lev++) - { - checkPatchList(PatL[lev], false); -#ifdef INTERP_LB_OPTIMIZE - Parallel::distribute_optimize(PatL[lev], nprocs, ingfs, fngfs, false); -#else - Parallel::distribute(PatL[lev], nprocs, ingfs, fngfs, false); -#endif -#if (RPB == 1) - // we need distributed box of PatL[lev] and PatL[lev-1] - if (lev > 0) - { - Parallel::Constr_pointstr_OutBdLow2Hi(PatL[lev], PatL[lev - 1], bdsul[lev]); - Parallel::Constr_pointstr_Restrict(PatL[lev], PatL[lev - 1], rsul[lev]); - } - else - { - bdsul[lev] = 0; - rsul[lev] = 0; - } -#endif - } -} - -//================================================================================================ - - -//================================================================================================ - -// This member function constructs the computational grid -// For the cases PSTR == 1 and PSTR == 2 - -//================================================================================================ - -#elif (PSTR == 1 || PSTR == 2) -void cgh::compose_cgh(int nprocs) -{ - Commlev = new MPI_Comm[levels]; - construct_mylev(nprocs); - for (int lev = 0; lev < levels; lev++) - { - MPI_Comm_split(MPI_COMM_WORLD, mylev, lev, &Commlev[lev]); - checkPatchList(PatL[lev], false); - Parallel::distribute(PatL[lev], end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); -#if (RPB == 1) -#error "not support yet" -#endif - } - /* note different comm field has its own rank index - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD,&myrank); - if(myrank==nprocs-1) - { - cout<<"myrank = "<= start_rank[lev] && myrank <= end_rank[lev]) - mylev = lev; - } -} -#elif (PSTR == 2) -void cgh::construct_mylev(int nprocs) -{ - if (nprocs < levels) - { - cout << "Too few procs to use parallel level methods!" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - start_rank = new int[levels]; - end_rank = new int[levels]; - - int myrank; - - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int mp; - mp = nprocs / levels; - - start_rank[levels - 1] = 0; - end_rank[levels - 1] = mp - 1; - for (int lev = levels - 2; lev > 0; lev--) - { - start_rank[lev] = end_rank[lev - 1] + 1; - end_rank[lev] = end_rank[lev - 1] + mp; - } - start_rank[0] = end_rank[1] + 1; - end_rank[0] = nprocs - 1; - - for (int lev = levels - 1; lev >= 0; lev--) - { - if (myrank >= start_rank[lev] && myrank <= end_rank[lev]) - mylev = lev; - } -} -#endif - -#elif (PSTR == 3) -void cgh::construct_mylev(int nprocs) -{ - if (nprocs <= 1) - { - cout << " cgh::construct_mylev requires at least 2 procs" << endl; - exit(0); - } - - start_rank = new int[2]; - end_rank = new int[2]; - - int myrank; - - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - - int mp; - mp = nprocs / 2; - - // for other levels - for (int lev = 0; lev < levels - 1; lev++) - { - start_rank[lev] = 0; - end_rank[lev] = mp - 1; - } - // for finest level - start_rank[levels - 1] = end_rank[0] + 1; - end_rank[levels - 1] = nprocs - 1; - - if (myrank >= start_rank[0] && myrank <= end_rank[0]) - mylev = -1; // for other levels - else - mylev = 1; // for finest level -} - - -//----------------------------------------------------------------------- - - -void cgh::compose_cgh(int nprocs) -{ - Commlev = new MPI_Comm[levels]; - construct_mylev(nprocs); - - for (int lev = 0; lev < levels - 1; lev++) - { - MPI_Comm_split(MPI_COMM_WORLD, mylev, -1, &Commlev[lev]); - } - MPI_Comm_split(MPI_COMM_WORLD, mylev, 1, &Commlev[levels - 1]); - - for (int lev = 0; lev < levels; lev++) - { - checkPatchList(PatL[lev], false); - Parallel::distribute(PatL[lev], end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); -#if (RPB == 1) -#error "not support yet" -#endif - } -} -#endif - - -void cgh::sethandle(monitor *ErrorMonitor) -{ - int BH_num; - Porgls = new double **[levels]; - char filename[100]; - { - map::iterator iter = parameters::str_par.find("inputpar"); - if (iter != parameters::str_par.end()) - { - strcpy(filename, (iter->second).c_str()); - } - else - { - cout << "Error inputpar" << endl; - exit(0); - } - } - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && ErrorMonitor && ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "Can not open parameter file " << filename << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && skey == "BH_num") - BH_num = atoi(sval.c_str()); - else if (sgrp == "cgh" && skey == "moving levels start from") - { - movls = atoi(sval.c_str()); - movls = Mymin(movls, levels); - movls = Mymax(0, movls); - } - } - inf.close(); - } - for (int lev = 0; lev < levels; lev++) - { - Porgls[lev] = new double *[BH_num]; - for (int i = 0; i < BH_num; i++) - Porgls[lev][i] = new double[dim]; - } - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind; - ifstream inf(filename, ifstream::in); - if (!inf.good() && ErrorMonitor && ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "Can not open parameter file " << filename - << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind); - if (status == -1) - { - if (ErrorMonitor && ErrorMonitor->outfile) - ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "BSSN" && sind < BH_num) - { - if (skey == "Porgx") - { - for (int lev = 0; lev < levels; lev++) - Porgls[lev][sind][0] = atof(sval.c_str()); - } - else if (skey == "Porgy") - { - for (int lev = 0; lev < levels; lev++) - Porgls[lev][sind][1] = atof(sval.c_str()); - } - else if (skey == "Porgz") - { - for (int lev = 0; lev < levels; lev++) - Porgls[lev][sind][2] = atof(sval.c_str()); - } - } - } - inf.close(); - } - - for (int lev = 0; lev < movls; lev++) - for (int grd = 0; grd < grids[lev]; grd++) - for (int i = 0; i < dim; i++) - handle[lev][grd][i] = 0; - - if (movls < levels) - { - if (ErrorMonitor && ErrorMonitor->I_Print) - { - cout << endl; - cout << " moving levels are lev #" << movls << "--" << levels - 1 << endl; - cout << endl; - } - - for (int lev = movls; lev < levels; lev++) - for (int grd = 0; grd < grids[lev]; grd++) - { -#if 0 - int bht=0; - for(int bhi=0;bhi bbox[lev][grd][i+dim]) {flag=true; break;} - if(flag) continue; - bht++; - if(bht==1) for(int i=0;ioutfile) - { - ErrorMonitor->outfile<<"cgh::sethandle: lev#"< dis1) - { - bht = bhi; - dis0 = dis1; - } // chose nearest one - } - } - for (int i = 0; i < dim; i++) - handle[lev][grd][i] = Porgls[0][bht][i]; -#endif - } - } - else if (ErrorMonitor && ErrorMonitor->I_Print) - { - if (levels > 1) - cout << "fixed mesh refinement!" << endl; - else - cout << "unigrid simulation!" << endl; - } - - BH_num_in = BH_num; -} -void cgh::checkPatchList(MyList *PatL, bool buflog) -{ - while (PatL) - { - PatL->data->checkPatch(buflog); - PatL = PatL->next; - } -} - - -//================================================================================================ - -// This member function moves the grid - -//================================================================================================ - -void cgh::Regrid(int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor) -{ - // for moving part - if (movls < levels) - { - bool tot_flag = false; - bool *lev_flag; - double **tmpPorg; - tmpPorg = new double *[BH_num]; - for (int bhi = 0; bhi < BH_num; bhi++) - { - tmpPorg[bhi] = new double[dim]; - for (int i = 0; i < dim; i++) - tmpPorg[bhi][i] = Porgbr[bhi][i]; - } - lev_flag = new bool[levels - movls]; - for (int lev = movls; lev < levels; lev++) - { - lev_flag[lev - movls] = false; - for (int grd = 0; grd < grids[lev]; grd++) - { - int flag; - int do_every = 2; - double dX = PatL[lev]->data->blb->data->getdX(0); - double dY = PatL[lev]->data->blb->data->getdX(1); - double dZ = PatL[lev]->data->blb->data->getdX(2); - double rr; - // make sure that the grid corresponds to the black hole - int bhi = 0; - for (bhi = 0; bhi < BH_num; bhi++) - { - // because finner level may also change Porgbr, so we need factor 2 - if (feq(Porgbr[bhi][0], handle[lev][grd][0], 2 * do_every * dX) && - feq(Porgbr[bhi][1], handle[lev][grd][1], 2 * do_every * dY) && - feq(Porgbr[bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) - break; - } - if (bhi == BH_num) - { - // if the box has already touched the original point - if (feq(0, bbox[lev][grd][0], dX / 2) && - feq(0, bbox[lev][grd][1], dY / 2) && - feq(0, bbox[lev][grd][2], dZ / 2)) - break; - - if (BH_num == 1) - { - bhi = 0; - break; - } // if only one black hole, it definitely match! - - if (ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd - << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; - ErrorMonitor->outfile << "black holes' old positions:" << endl; - for (bhi = 0; bhi < BH_num; bhi++) - ErrorMonitor->outfile << "#" << bhi << ": (" << Porgbr[bhi][0] << "," << Porgbr[bhi][1] << "," << Porgbr[bhi][2] << ")" << endl; - ErrorMonitor->outfile << "tolerance:" << endl; - ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; - ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - delete[] lev_flag; - for (bhi = 0; bhi < BH_num; bhi++) - delete[] tmpPorg[bhi]; - delete[] tmpPorg; - return; - } - // x direction - rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][0] + flag * dX; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][0]; - else - rr = flag * dX; - - if (fabs(rr) > dX / 2) - { - lev_flag[lev - movls] = tot_flag = true; - bbox[lev][grd][0] = bbox[lev][grd][0] + rr; - bbox[lev][grd][3] = bbox[lev][grd][3] + rr; - handle[lev][grd][0] += rr; - tmpPorg[bhi][0] = Porg0[bhi][0]; - } - - // y direction - rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][1] + flag * dY; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dY; - - if (fabs(rr) > dY / 2) - { - lev_flag[lev - movls] = tot_flag = true; - bbox[lev][grd][1] = bbox[lev][grd][1] + rr; - bbox[lev][grd][4] = bbox[lev][grd][4] + rr; - handle[lev][grd][1] += rr; - tmpPorg[bhi][1] = Porg0[bhi][1]; - } - - // z direction - rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][2] + flag * dZ; - // pay attention to the symmetric case - if (Symmetry > 0 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dZ; - - if (fabs(rr) > dZ / 2) - { - lev_flag[lev - movls] = tot_flag = true; - bbox[lev][grd][2] = bbox[lev][grd][2] + rr; - bbox[lev][grd][5] = bbox[lev][grd][5] + rr; - handle[lev][grd][2] += rr; - tmpPorg[bhi][2] = Porg0[bhi][2]; - } - } - // if(ErrorMonitor->outfile && lev_flag[lev-movls]) cout<<"lev#"< *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor) -{ - // for moving part - if (movls < levels) - { - bool tot_flag = false; - bool *lev_flag; - double **tmpPorg; - tmpPorg = new double *[BH_num]; - for (int bhi = 0; bhi < BH_num; bhi++) - { - tmpPorg[bhi] = new double[dim]; - for (int i = 0; i < dim; i++) - tmpPorg[bhi][i] = Porgbr[bhi][i]; - } - lev_flag = new bool[levels - movls]; - for (int lev = movls; lev < levels; lev++) - { - lev_flag[lev - movls] = false; - for (int grd = 0; grd < grids[lev]; grd++) - { - int flag; - int do_every = 2; - double dX = PatL[lev]->data->blb->data->getdX(0); - double dY = PatL[lev]->data->blb->data->getdX(1); - double dZ = PatL[lev]->data->blb->data->getdX(2); - double rr; - // make sure that the grid corresponds to the black hole - int bhi = 0; - for (bhi = 0; bhi < BH_num; bhi++) - { - // because finner level may also change Porgbr, so we need factor 2 - if (feq(Porgbr[bhi][0], handle[lev][grd][0], 2 * do_every * dX) && - feq(Porgbr[bhi][1], handle[lev][grd][1], 2 * do_every * dY) && - feq(Porgbr[bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) - break; - } - if (bhi == BH_num) - { - // if the box has already touched the original point - if (feq(0, bbox[lev][grd][0], dX / 2) && - feq(0, bbox[lev][grd][1], dY / 2) && - feq(0, bbox[lev][grd][2], dZ / 2)) - break; - - if (BH_num == 1) - { - bhi = 0; - break; - } // if only one black hole, it definitely match! - - if (ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd - << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; - ErrorMonitor->outfile << "black holes' old positions:" << endl; - for (bhi = 0; bhi < BH_num; bhi++) - ErrorMonitor->outfile << "#" << bhi << ": (" << Porgbr[bhi][0] << "," << Porgbr[bhi][1] << "," << Porgbr[bhi][2] << ")" << endl; - ErrorMonitor->outfile << "tolerance:" << endl; - ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; - ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - delete[] lev_flag; - for (bhi = 0; bhi < BH_num; bhi++) - delete[] tmpPorg[bhi]; - delete[] tmpPorg; - return; - } - // x direction - rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][0] + flag * dX; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][0]; - else - rr = flag * dX; - - if (fabs(rr) > dX / 2) - { - lev_flag[lev - movls] = tot_flag = true; - bbox[lev][grd][0] = bbox[lev][grd][0] + rr; - bbox[lev][grd][3] = bbox[lev][grd][3] + rr; - handle[lev][grd][0] += rr; - tmpPorg[bhi][0] = Porg0[bhi][0]; - } - - // y direction - rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][1] + flag * dY; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dY; - - if (fabs(rr) > dY / 2) - { - lev_flag[lev - movls] = tot_flag = true; - bbox[lev][grd][1] = bbox[lev][grd][1] + rr; - bbox[lev][grd][4] = bbox[lev][grd][4] + rr; - handle[lev][grd][1] += rr; - tmpPorg[bhi][1] = Porg0[bhi][1]; - } - - // z direction - rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][2] + flag * dZ; - // pay attention to the symmetric case - if (Symmetry > 0 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dZ; - - if (fabs(rr) > dZ / 2) - { - lev_flag[lev - movls] = tot_flag = true; - bbox[lev][grd][2] = bbox[lev][grd][2] + rr; - bbox[lev][grd][5] = bbox[lev][grd][5] + rr; - handle[lev][grd][2] += rr; - tmpPorg[bhi][2] = Porg0[bhi][2]; - } - } - // if(ErrorMonitor->outfile && lev_flag[lev-movls]) cout<<"lev#"< *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB) -{ - for (int lev = movls; lev < levels; lev++) - if (lev_flag[lev - movls]) - { - MyList *tmPat = 0; - tmPat = construct_patchlist(lev, Symmetry); - // tmPat construction completes - Parallel::distribute(tmPat, nprocs, ingfs, fngfs, false); - // checkPatchList(tmPat,true); - bool CC = (lev > trfls); - Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); - - Parallel::KillBlocks(PatL[lev]); - PatL[lev]->destroyList(); - PatL[lev] = tmPat; -#if (RPB == 1) - Parallel::destroypsuList_bam(bdsul[lev]); - Parallel::destroypsuList_bam(rsul[lev]); - Parallel::Constr_pointstr_OutBdLow2Hi(PatL[lev], PatL[lev - 1], bdsul[lev]); - Parallel::Constr_pointstr_Restrict(PatL[lev], PatL[lev - 1], rsul[lev]); -#endif - } -} -#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) -#warning "recompose_cgh is not implimented yet" -void cgh::recompose_cgh(int nprocs, bool *lev_flag, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB) -{ - for (int lev = movls; lev < levels; lev++) - if (lev_flag[lev - movls]) - { - MyList *tmPat = 0; - tmPat = construct_patchlist(lev, Symmetry); - // tmPat construction completes - Parallel::distribute(tmPat, end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); - // checkPatchList(tmPat,true); - bool CC = (lev > trfls); - Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); - - Parallel::KillBlocks(PatL[lev]); - PatL[lev]->destroyList(); - PatL[lev] = tmPat; -#if (RPB == 1) -#error "not support yet" -#endif - } -} - -//================================================================================================ - -void cgh::recompose_cgh_fake(int nprocs, bool *lev_flag, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB) -{ - for (int lev = movls; lev < levels; lev++) - if (lev_flag[lev - movls] && lev != mylev) - { - MyList *tmPat = 0; - tmPat = construct_patchlist(lev, Symmetry); - // tmPat construction completes - Parallel::distribute(tmPat, end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); - - Parallel::KillBlocks(PatL[lev]); - PatL[lev]->destroyList(); - PatL[lev] = tmPat; - } -} -#endif - -//================================================================================================ - -// This member function reads grid information from input files - -//================================================================================================ - -void cgh::read_bbox(int Symmetry, char *filename) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "cgh::cgh: Can not open parameter file " << filename << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && skey == "levels") - { - levels = atoi(sval.c_str()); - break; - } - } - inf.close(); - } - - grids = new int[levels]; - shape = new int **[levels]; - handle = new double **[levels]; - bbox = new double **[levels]; - PatL = new MyList *[levels]; - Lt = new double[levels]; -#if (RPB == 1) - bdsul = new MyList *[levels]; - rsul = new MyList *[levels]; -#endif - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "cgh::cgh: Can not open parameter file " << filename << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && skey == "grids" && sind1 < levels) - grids[sind1] = atoi(sval.c_str()); - } - inf.close(); - } - - for (int sind1 = 0; sind1 < levels; sind1++) - { - shape[sind1] = new int *[grids[sind1]]; - handle[sind1] = new double *[grids[sind1]]; - bbox[sind1] = new double *[grids[sind1]]; - for (int sind2 = 0; sind2 < grids[sind1]; sind2++) - { - shape[sind1][sind2] = new int[dim]; - handle[sind1][sind2] = new double[dim]; - bbox[sind1][sind2] = new double[2 * dim]; - } - } - // read parameter from file - { - const int LEN = 256; - char pline[LEN]; - string str, sgrp, skey, sval; - int sind1, sind2, sind3; - ifstream inf(filename, ifstream::in); - if (!inf.good() && myrank == 0) - { - cout << "cgh::cgh: Can not open parameter file " << filename << " for inputing information of black holes" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (int i = 1; inf.good(); i++) - { - inf.getline(pline, LEN); - str = pline; - - int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); - - if (status == -1) - { - cout << "error reading parameter file " << filename << " in line " << i << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - else if (status == 0) - continue; - - if (sgrp == "cgh" && sind1 < levels && sind2 < grids[sind1]) - { - if (skey == "bbox") - bbox[sind1][sind2][sind3] = atof(sval.c_str()); - else if (skey == "shape") - shape[sind1][sind2][sind3] = atoi(sval.c_str()); - } - } - inf.close(); - } -// we always assume the input parameter is in cell center style -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - for (int lev = 0; lev < levels; lev++) - for (int grd = 0; grd < grids[lev]; grd++) - { - for (int i = 0; i < dim; i++) - { - - shape[lev][grd][i] = shape[lev][grd][i] + 1; - } - } -#endif - - { - - // boxes align check - double DH0[dim]; - for (int i = 0; i < dim; i++) -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - DH0[i] = (bbox[0][0][i + dim] - bbox[0][0][i]) / (shape[0][0][i] - 1); -#else -#ifdef Cell - DH0[i] = (bbox[0][0][i + dim] - bbox[0][0][i]) / shape[0][0][i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - for (int lev = 0; lev < levels; lev++) - for (int grd = 0; grd < grids[lev]; grd++) - Parallel::aligncheck(bbox[0][0], bbox[lev][grd], lev, DH0, shape[lev][grd]); - -#if 0 // we do not need it here, because we do it in construct_patchlist -// extend buffer points for shell overlap -#ifdef WithShell - for(int i=0;i *cgh::construct_patchlist(int lev, int Symmetry) -{ - // Construct Patches - MyList *tmPat = 0; - // construct box list - MyList *boxes = 0, *gs; - - /* - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == 0) - { - cout << " construct patchlist: " << " level = " << lev << ", grids in this level = " << grids[lev] << endl; - } - */ - - for (int grd = 0; grd < grids[lev]; grd++) - { - if (boxes) - { - gs->next = new MyList; - gs = gs->next; - gs->data = new Parallel::gridseg; - } - else - { - boxes = gs = new MyList; - gs->data = new Parallel::gridseg; - } - for (int i = 0; i < dim; i++) - { - gs->data->llb[i] = bbox[lev][grd][i]; - gs->data->uub[i] = bbox[lev][grd][dim + i]; - gs->data->shape[i] = shape[lev][grd][i]; - } - gs->data->Bg = 0; - gs->next = 0; - } - - // Merge grid boxes (merging more than three boxes may cause bugs) - // Parallel::merge_gsl(boxes, ratio); - if (grids[lev] < 3) - { - Parallel::merge_gsl(boxes, ratio); - } - - // When grid boxes overlap, re-split the boxes - // Parallel::cut_gsl(boxes); - if (grids[lev] < 3) - { - Parallel::cut_gsl(boxes); - } - - // After splitting, add new ghost regions? - // Parallel::add_ghost_touch(boxes); - if (grids[lev] < 3) - { - Parallel::add_ghost_touch(boxes); - } - - MyList *gp; - gs = boxes; - while (gs) - { - double tbb[2 * dim]; - if (tmPat) - { - gp->next = new MyList; - gp = gp->next; - for (int i = 0; i < dim; i++) - { - tbb[i] = gs->data->llb[i]; - tbb[dim + i] = gs->data->uub[i]; - } -#ifdef WithShell - gp->data = new Patch(3, gs->data->shape, tbb, lev, true, Symmetry); -#else - gp->data = new Patch(3, gs->data->shape, tbb, lev, (lev > 0), Symmetry); -#endif - } - else - { - tmPat = gp = new MyList; - for (int i = 0; i < dim; i++) - { - tbb[i] = gs->data->llb[i]; - tbb[dim + i] = gs->data->uub[i]; - } -#ifdef WithShell - gp->data = new Patch(3, gs->data->shape, tbb, lev, true, Symmetry); -#else - gp->data = new Patch(3, gs->data->shape, tbb, lev, (lev > 0), Symmetry); -#endif - } - gp->next = 0; - - gs = gs->next; - } - - boxes->destroyList(); - - return tmPat; -} - -//================================================================================================ - - -bool cgh::Interp_One_Point(MyList *VarList, - double *XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry) -{ - int lev = levels - 1; - while (lev >= 0) - { - MyList *Pp = PatL[lev]; - while (Pp) - { -#if (PSTR == 0) - if (Pp->data->Interp_ONE_Point(VarList, XX, Shellf, Symmetry)) - return true; -#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) - if (Pp->data->Interp_ONE_Point(VarList, XX, Shellf, Symmetry, Commlev[lev])) - return true; -#endif - Pp = Pp->next; - } - lev--; - } - return false; -} - - -bool cgh::Regrid_Onelevel(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor) -{ - if (lev < movls) - return false; - -#if (0) - // #if (PSTR == 1 || PSTR == 2) - MyList *Pp = PatL[lev]; - while (Pp) - { - Pp->data->checkPatch(0, start_rank[mylev]); - Pp = Pp->next; - } - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - if (myrank == start_rank[mylev]) - { - cout << "out_rank = " << myrank << endl; - for (int grd = 0; grd < grids[lev]; grd++) - { - cout << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << endl; - } - for (int bhi = 0; bhi < BH_num; bhi++) - { - cout << Porgls[lev][bhi][0] << "," << Porgls[lev][bhi][1] << "," << Porgls[lev][bhi][2] << endl; - cout << Porg0[bhi][0] << "," << Porg0[bhi][1] << "," << Porg0[bhi][2] << endl; - } - } -#endif - - // misc::tillherecheck(Commlev[lev],start_rank[lev],"start Regrid_Onelevel"); - // for moving part - bool tot_flag = false; - double **tmpPorg; - tmpPorg = new double *[BH_num]; - for (int bhi = 0; bhi < BH_num; bhi++) - { - tmpPorg[bhi] = new double[dim]; - for (int i = 0; i < dim; i++) - tmpPorg[bhi][i] = Porgls[lev][bhi][i]; - } - - for (int grd = 0; grd < grids[lev]; grd++) - { - int flag; - int do_every = 2; - double dX = PatL[lev]->data->blb->data->getdX(0); - double dY = PatL[lev]->data->blb->data->getdX(1); - double dZ = PatL[lev]->data->blb->data->getdX(2); - double rr; - // make sure that the grid corresponds to the black hole - int bhi = 0; - for (bhi = 0; bhi < BH_num; bhi++) - { - // because finner level may also change Porgbr, so we need factor 2 - // now I used Porgls - if (feq(Porgls[lev][bhi][0], handle[lev][grd][0], 2 * do_every * dX) && - feq(Porgls[lev][bhi][1], handle[lev][grd][1], 2 * do_every * dY) && - feq(Porgls[lev][bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) - break; - } - if (bhi == BH_num) - { - // if the box has already touched the original point - if (feq(0, bbox[lev][grd][0], dX / 2) && - feq(0, bbox[lev][grd][1], dY / 2) && - feq(0, bbox[lev][grd][2], dZ / 2)) - break; - - if (BH_num == 1) - { - bhi = 0; - break; - } // if only one black hole, it definitely match! - - if (ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd - << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; - ErrorMonitor->outfile << "black holes' old positions:" << endl; - for (bhi = 0; bhi < BH_num; bhi++) - ErrorMonitor->outfile << "#" << bhi << ": (" << Porgls[lev][bhi][0] << "," << Porgls[lev][bhi][1] << "," - << Porgls[lev][bhi][2] << ")" << endl; - ErrorMonitor->outfile << "tolerance:" << endl; - ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; - ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (bhi = 0; bhi < BH_num; bhi++) - delete[] tmpPorg[bhi]; - delete[] tmpPorg; - return false; - } - // x direction - rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][0] + flag * dX; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][0]; - else - rr = flag * dX; - - if (fabs(rr) > dX / 2) - { - tot_flag = true; - bbox[lev][grd][0] = bbox[lev][grd][0] + rr; - bbox[lev][grd][3] = bbox[lev][grd][3] + rr; - handle[lev][grd][0] += rr; - tmpPorg[bhi][0] = Porg0[bhi][0]; - } - - // y direction - rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][1] + flag * dY; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dY; - - if (fabs(rr) > dY / 2) - { - tot_flag = true; - bbox[lev][grd][1] = bbox[lev][grd][1] + rr; - bbox[lev][grd][4] = bbox[lev][grd][4] + rr; - handle[lev][grd][1] += rr; - tmpPorg[bhi][1] = Porg0[bhi][1]; - } - - // z direction - rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][2] + flag * dZ; - // pay attention to the symmetric case - if (Symmetry > 0 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dZ; - - if (fabs(rr) > dZ / 2) - { - tot_flag = true; - bbox[lev][grd][2] = bbox[lev][grd][2] + rr; - bbox[lev][grd][5] = bbox[lev][grd][5] + rr; - handle[lev][grd][2] += rr; - tmpPorg[bhi][2] = Porg0[bhi][2]; - } - } - - // misc::tillherecheck(Commlev[lev],start_rank[lev],"after tot_flag check"); - - if (tot_flag) - { - int nprocs; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - - // misc::tillherecheck(Commlev[lev],start_rank[lev],"before recompose_cgh_Onelevel"); - - recompose_cgh_Onelevel(nprocs, lev, OldList, StateList, FutureList, tmList, Symmetry, BB); - - // misc::tillherecheck(Commlev[lev],start_rank[lev],"after recompose_cgh_Onelevel"); - - for (int bhi = 0; bhi < BH_num; bhi++) - { - for (int i = 0; i < dim; i++) - Porgls[lev][bhi][i] = tmpPorg[bhi][i]; - } - -#if (PSTR == 1 || PSTR == 2) -// MyList *Pp=PatL[lev]; -// while(Pp) -// { -// Pp->data->checkPatch(0,start_rank[mylev]); -// Pp=Pp->next; -// } -#endif - } - - for (int bhi = 0; bhi < BH_num; bhi++) - delete[] tmpPorg[bhi]; - delete[] tmpPorg; - return tot_flag; -} - - -#if (PSTR == 0) -void cgh::recompose_cgh_Onelevel(int nprocs, int lev, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB) -{ - MyList *tmPat = 0; - tmPat = construct_patchlist(lev, Symmetry); - // tmPat construction completes - Parallel::distribute(tmPat, nprocs, ingfs, fngfs, false); - // checkPatchList(tmPat,true); - bool CC = (lev > trfls); - Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); - - Parallel::KillBlocks(PatL[lev]); - PatL[lev]->destroyList(); - PatL[lev] = tmPat; -} -#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) -#warning "recompose_cgh_Onelevel is not implimented yet" -void cgh::recompose_cgh_Onelevel(int nprocs, int lev, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB) -{ - MyList *tmPat = 0; - misc::tillherecheck(Commlev[lev], start_rank[lev], "before construct_patchlist"); - tmPat = construct_patchlist(lev, Symmetry); - misc::tillherecheck(Commlev[lev], start_rank[lev], "after construct_patchlist"); - // tmPat construction completes - Parallel::distribute(tmPat, end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); - misc::tillherecheck(Commlev[lev], start_rank[lev], "after distribute"); - // checkPatchList(tmPat,true); - bool CC = (lev > trfls); - Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); - misc::tillherecheck(Commlev[lev], start_rank[lev], "after fill_level_data"); - - Parallel::KillBlocks(PatL[lev]); - PatL[lev]->destroyList(); - PatL[lev] = tmPat; -} - - -// the input lev is lower level for regrid -void cgh::Regrid_Onelevel_aux(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor) -{ - lev++; - if (lev < movls) - return; - - // for moving part - bool tot_flag = false; - double **tmpPorg; - tmpPorg = new double *[BH_num]; - for (int bhi = 0; bhi < BH_num; bhi++) - { - tmpPorg[bhi] = new double[dim]; - for (int i = 0; i < dim; i++) - tmpPorg[bhi][i] = Porgbr[bhi][i]; - } - - for (int grd = 0; grd < grids[lev]; grd++) - { - int flag; - int do_every = 2; - double dX = PatL[lev]->data->blb->data->getdX(0); - double dY = PatL[lev]->data->blb->data->getdX(1); - double dZ = PatL[lev]->data->blb->data->getdX(2); - double rr; - // make sure that the grid corresponds to the black hole - int bhi = 0; - for (bhi = 0; bhi < BH_num; bhi++) - { - // because finner level may also change Porgbr, so we need factor 2 - if (feq(Porgbr[bhi][0], handle[lev][grd][0], 2 * do_every * dX) && - feq(Porgbr[bhi][1], handle[lev][grd][1], 2 * do_every * dY) && - feq(Porgbr[bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) - break; - } - if (bhi == BH_num) - { - // if the box has already touched the original point - if (feq(0, bbox[lev][grd][0], dX / 2) && - feq(0, bbox[lev][grd][1], dY / 2) && - feq(0, bbox[lev][grd][2], dZ / 2)) - break; - - if (BH_num == 1) - { - bhi = 0; - break; - } // if only one black hole, it definitely match! - - if (ErrorMonitor->outfile) - { - ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd - << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; - ErrorMonitor->outfile << "black holes' old positions:" << endl; - for (bhi = 0; bhi < BH_num; bhi++) - ErrorMonitor->outfile << "#" << bhi << ": (" << Porgbr[bhi][0] << "," << Porgbr[bhi][1] << "," << Porgbr[bhi][2] << ")" << endl; - ErrorMonitor->outfile << "tolerance:" << endl; - ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; - ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - for (bhi = 0; bhi < BH_num; bhi++) - delete[] tmpPorg[bhi]; - delete[] tmpPorg; - return; - } - // x direction - rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][0] + flag * dX; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][0]; - else - rr = flag * dX; - - if (fabs(rr) > dX / 2) - { - tot_flag = true; - bbox[lev][grd][0] = bbox[lev][grd][0] + rr; - bbox[lev][grd][3] = bbox[lev][grd][3] + rr; - handle[lev][grd][0] += rr; - tmpPorg[bhi][0] = Porg0[bhi][0]; - } - - // y direction - rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][1] + flag * dY; - // pay attention to the symmetric case - if (Symmetry == 2 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dY; - - if (fabs(rr) > dY / 2) - { - tot_flag = true; - bbox[lev][grd][1] = bbox[lev][grd][1] + rr; - bbox[lev][grd][4] = bbox[lev][grd][4] + rr; - handle[lev][grd][1] += rr; - tmpPorg[bhi][1] = Porg0[bhi][1]; - } - - // z direction - rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; - if (rr > 0) - flag = int(rr + 0.5) / do_every; - else - flag = int(rr - 0.5) / do_every; - flag = flag * do_every; - rr = bbox[lev][grd][2] + flag * dZ; - // pay attention to the symmetric case - if (Symmetry > 0 && rr < 0) - rr = -bbox[lev][grd][1]; - else - rr = flag * dZ; - - if (fabs(rr) > dZ / 2) - { - tot_flag = true; - bbox[lev][grd][2] = bbox[lev][grd][2] + rr; - bbox[lev][grd][5] = bbox[lev][grd][5] + rr; - handle[lev][grd][2] += rr; - tmpPorg[bhi][2] = Porg0[bhi][2]; - } - } - - if (tot_flag) - { - int nprocs; - MPI_Comm_size(MPI_COMM_WORLD, &nprocs); - recompose_cgh_Onelevel(nprocs, lev, OldList, StateList, FutureList, tmList, Symmetry, BB); - } - - for (int bhi = 0; bhi < BH_num; bhi++) - delete[] tmpPorg[bhi]; - delete[] tmpPorg; -} -#endif - - -void cgh::settrfls(const int lev) -{ - trfls = lev; -} + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#include + +#include "macrodef.h" +#include "misc.h" +#include "cgh.h" +#include "Parallel.h" +#include "parameters.h" + +//================================================================================================ + +// define cgh class + +//================================================================================================ + +cgh::cgh(int ingfsi, int fngfsi, int Symmetry, char *filename, int checkrun, + monitor *ErrorMonitor) : ingfs(ingfsi), fngfs(fngfsi), trfls(0) +{ +#if (PSTR == 1 || PSTR == 2 || PSTR == 3) + Commlev = 0; + start_rank = 0; + end_rank = 0; +#endif + + if (!checkrun) + { + read_bbox(Symmetry, filename); + sethandle(ErrorMonitor); + for (int lev = 0; lev < levels; lev++) + PatL[lev] = construct_patchlist(lev, Symmetry); + } +} + +//================================================================================================ + + + +//================================================================================================ + +// This member function is the destructor; it releases allocated resources and deletes variables + +//================================================================================================ + +cgh::~cgh() +{ + for (int lev = 0; lev < levels; lev++) + { + for (int grd = 0; grd < grids[lev]; grd++) + { + delete[] bbox[lev][grd]; + delete[] shape[lev][grd]; + delete[] handle[lev][grd]; + } + delete[] bbox[lev]; + delete[] shape[lev]; + delete[] handle[lev]; + Parallel::KillBlocks(PatL[lev]); + PatL[lev]->destroyList(); +#if (RPB == 1) + Parallel::destroypsuList_bam(bdsul[lev]); + Parallel::destroypsuList_bam(rsul[lev]); +#endif + } + delete[] grids; + delete[] Lt; + delete[] bbox; + delete[] shape; + delete[] handle; + delete[] PatL; +#if (RPB == 1) + delete[] bdsul; + delete[] rsul; +#endif + +#if (PSTR == 1 || PSTR == 2 || PSTR == 3) + for (int lev = 0; lev < levels; lev++) + { + MPI_Comm_free(&Commlev[lev]); + } + + if (Commlev) + delete[] Commlev; + if (start_rank) + delete[] start_rank; + if (end_rank) + delete[] end_rank; +#endif + for (int lev = 0; lev < levels; lev++) + { + for (int ibh = 0; ibh < BH_num_in; ibh++) + delete[] Porgls[lev][ibh]; + delete[] Porgls[lev]; + } + delete[] Porgls; +} + +//================================================================================================ + + +//================================================================================================ + +// This member function constructs the computational grid + +//================================================================================================ + +#if (PSTR == 0) +void cgh::compose_cgh(int nprocs) +{ + for (int lev = 0; lev < levels; lev++) + { + checkPatchList(PatL[lev], false); +#ifdef INTERP_LB_OPTIMIZE + Parallel::distribute_optimize(PatL[lev], nprocs, ingfs, fngfs, false); +#else + Parallel::distribute(PatL[lev], nprocs, ingfs, fngfs, false); +#endif +#if (RPB == 1) + // we need distributed box of PatL[lev] and PatL[lev-1] + if (lev > 0) + { + Parallel::Constr_pointstr_OutBdLow2Hi(PatL[lev], PatL[lev - 1], bdsul[lev]); + Parallel::Constr_pointstr_Restrict(PatL[lev], PatL[lev - 1], rsul[lev]); + } + else + { + bdsul[lev] = 0; + rsul[lev] = 0; + } +#endif + } +} + +//================================================================================================ + + +//================================================================================================ + +// This member function constructs the computational grid +// For the cases PSTR == 1 and PSTR == 2 + +//================================================================================================ + +#elif (PSTR == 1 || PSTR == 2) +void cgh::compose_cgh(int nprocs) +{ + Commlev = new MPI_Comm[levels]; + construct_mylev(nprocs); + for (int lev = 0; lev < levels; lev++) + { + MPI_Comm_split(MPI_COMM_WORLD, mylev, lev, &Commlev[lev]); + checkPatchList(PatL[lev], false); + Parallel::distribute(PatL[lev], end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); +#if (RPB == 1) +#error "not support yet" +#endif + } + /* note different comm field has its own rank index + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD,&myrank); + if(myrank==nprocs-1) + { + cout<<"myrank = "<= start_rank[lev] && myrank <= end_rank[lev]) + mylev = lev; + } +} +#elif (PSTR == 2) +void cgh::construct_mylev(int nprocs) +{ + if (nprocs < levels) + { + cout << "Too few procs to use parallel level methods!" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + start_rank = new int[levels]; + end_rank = new int[levels]; + + int myrank; + + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int mp; + mp = nprocs / levels; + + start_rank[levels - 1] = 0; + end_rank[levels - 1] = mp - 1; + for (int lev = levels - 2; lev > 0; lev--) + { + start_rank[lev] = end_rank[lev - 1] + 1; + end_rank[lev] = end_rank[lev - 1] + mp; + } + start_rank[0] = end_rank[1] + 1; + end_rank[0] = nprocs - 1; + + for (int lev = levels - 1; lev >= 0; lev--) + { + if (myrank >= start_rank[lev] && myrank <= end_rank[lev]) + mylev = lev; + } +} +#endif + +#elif (PSTR == 3) +void cgh::construct_mylev(int nprocs) +{ + if (nprocs <= 1) + { + cout << " cgh::construct_mylev requires at least 2 procs" << endl; + exit(0); + } + + start_rank = new int[2]; + end_rank = new int[2]; + + int myrank; + + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + + int mp; + mp = nprocs / 2; + + // for other levels + for (int lev = 0; lev < levels - 1; lev++) + { + start_rank[lev] = 0; + end_rank[lev] = mp - 1; + } + // for finest level + start_rank[levels - 1] = end_rank[0] + 1; + end_rank[levels - 1] = nprocs - 1; + + if (myrank >= start_rank[0] && myrank <= end_rank[0]) + mylev = -1; // for other levels + else + mylev = 1; // for finest level +} + + +//----------------------------------------------------------------------- + + +void cgh::compose_cgh(int nprocs) +{ + Commlev = new MPI_Comm[levels]; + construct_mylev(nprocs); + + for (int lev = 0; lev < levels - 1; lev++) + { + MPI_Comm_split(MPI_COMM_WORLD, mylev, -1, &Commlev[lev]); + } + MPI_Comm_split(MPI_COMM_WORLD, mylev, 1, &Commlev[levels - 1]); + + for (int lev = 0; lev < levels; lev++) + { + checkPatchList(PatL[lev], false); + Parallel::distribute(PatL[lev], end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); +#if (RPB == 1) +#error "not support yet" +#endif + } +} +#endif + + +void cgh::sethandle(monitor *ErrorMonitor) +{ + int BH_num; + Porgls = new double **[levels]; + char filename[100]; + { + map::iterator iter = parameters::str_par.find("inputpar"); + if (iter != parameters::str_par.end()) + { + strcpy(filename, (iter->second).c_str()); + } + else + { + cout << "Error inputpar" << endl; + exit(0); + } + } + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && ErrorMonitor && ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "Can not open parameter file " << filename << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && skey == "BH_num") + BH_num = atoi(sval.c_str()); + else if (sgrp == "cgh" && skey == "moving levels start from") + { + movls = atoi(sval.c_str()); + movls = Mymin(movls, levels); + movls = Mymax(0, movls); + } + } + inf.close(); + } + for (int lev = 0; lev < levels; lev++) + { + Porgls[lev] = new double *[BH_num]; + for (int i = 0; i < BH_num; i++) + Porgls[lev][i] = new double[dim]; + } + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind; + ifstream inf(filename, ifstream::in); + if (!inf.good() && ErrorMonitor && ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "Can not open parameter file " << filename + << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind); + if (status == -1) + { + if (ErrorMonitor && ErrorMonitor->outfile) + ErrorMonitor->outfile << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "BSSN" && sind < BH_num) + { + if (skey == "Porgx") + { + for (int lev = 0; lev < levels; lev++) + Porgls[lev][sind][0] = atof(sval.c_str()); + } + else if (skey == "Porgy") + { + for (int lev = 0; lev < levels; lev++) + Porgls[lev][sind][1] = atof(sval.c_str()); + } + else if (skey == "Porgz") + { + for (int lev = 0; lev < levels; lev++) + Porgls[lev][sind][2] = atof(sval.c_str()); + } + } + } + inf.close(); + } + + for (int lev = 0; lev < movls; lev++) + for (int grd = 0; grd < grids[lev]; grd++) + for (int i = 0; i < dim; i++) + handle[lev][grd][i] = 0; + + if (movls < levels) + { + if (ErrorMonitor && ErrorMonitor->I_Print) + { + cout << endl; + cout << " moving levels are lev #" << movls << "--" << levels - 1 << endl; + cout << endl; + } + + for (int lev = movls; lev < levels; lev++) + for (int grd = 0; grd < grids[lev]; grd++) + { +#if 0 + int bht=0; + for(int bhi=0;bhi bbox[lev][grd][i+dim]) {flag=true; break;} + if(flag) continue; + bht++; + if(bht==1) for(int i=0;ioutfile) + { + ErrorMonitor->outfile<<"cgh::sethandle: lev#"< dis1) + { + bht = bhi; + dis0 = dis1; + } // chose nearest one + } + } + for (int i = 0; i < dim; i++) + handle[lev][grd][i] = Porgls[0][bht][i]; +#endif + } + } + else if (ErrorMonitor && ErrorMonitor->I_Print) + { + if (levels > 1) + cout << "fixed mesh refinement!" << endl; + else + cout << "unigrid simulation!" << endl; + } + + BH_num_in = BH_num; +} +void cgh::checkPatchList(MyList *PatL, bool buflog) +{ + while (PatL) + { + PatL->data->checkPatch(buflog); + PatL = PatL->next; + } +} + + +//================================================================================================ + +// This member function moves the grid + +//================================================================================================ + +void cgh::Regrid(int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor) +{ + // for moving part + if (movls < levels) + { + bool tot_flag = false; + bool *lev_flag; + double **tmpPorg; + tmpPorg = new double *[BH_num]; + for (int bhi = 0; bhi < BH_num; bhi++) + { + tmpPorg[bhi] = new double[dim]; + for (int i = 0; i < dim; i++) + tmpPorg[bhi][i] = Porgbr[bhi][i]; + } + lev_flag = new bool[levels - movls]; + for (int lev = movls; lev < levels; lev++) + { + lev_flag[lev - movls] = false; + for (int grd = 0; grd < grids[lev]; grd++) + { + int flag; + int do_every = 2; + double dX = PatL[lev]->data->blb->data->getdX(0); + double dY = PatL[lev]->data->blb->data->getdX(1); + double dZ = PatL[lev]->data->blb->data->getdX(2); + double rr; + // make sure that the grid corresponds to the black hole + int bhi = 0; + for (bhi = 0; bhi < BH_num; bhi++) + { + // because finner level may also change Porgbr, so we need factor 2 + if (feq(Porgbr[bhi][0], handle[lev][grd][0], 2 * do_every * dX) && + feq(Porgbr[bhi][1], handle[lev][grd][1], 2 * do_every * dY) && + feq(Porgbr[bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) + break; + } + if (bhi == BH_num) + { + // if the box has already touched the original point + if (feq(0, bbox[lev][grd][0], dX / 2) && + feq(0, bbox[lev][grd][1], dY / 2) && + feq(0, bbox[lev][grd][2], dZ / 2)) + break; + + if (BH_num == 1) + { + bhi = 0; + break; + } // if only one black hole, it definitely match! + + if (ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd + << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; + ErrorMonitor->outfile << "black holes' old positions:" << endl; + for (bhi = 0; bhi < BH_num; bhi++) + ErrorMonitor->outfile << "#" << bhi << ": (" << Porgbr[bhi][0] << "," << Porgbr[bhi][1] << "," << Porgbr[bhi][2] << ")" << endl; + ErrorMonitor->outfile << "tolerance:" << endl; + ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; + ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + delete[] lev_flag; + for (bhi = 0; bhi < BH_num; bhi++) + delete[] tmpPorg[bhi]; + delete[] tmpPorg; + return; + } + // x direction + rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][0] + flag * dX; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][0]; + else + rr = flag * dX; + + if (fabs(rr) > dX / 2) + { + lev_flag[lev - movls] = tot_flag = true; + bbox[lev][grd][0] = bbox[lev][grd][0] + rr; + bbox[lev][grd][3] = bbox[lev][grd][3] + rr; + handle[lev][grd][0] += rr; + tmpPorg[bhi][0] = Porg0[bhi][0]; + } + + // y direction + rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][1] + flag * dY; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dY; + + if (fabs(rr) > dY / 2) + { + lev_flag[lev - movls] = tot_flag = true; + bbox[lev][grd][1] = bbox[lev][grd][1] + rr; + bbox[lev][grd][4] = bbox[lev][grd][4] + rr; + handle[lev][grd][1] += rr; + tmpPorg[bhi][1] = Porg0[bhi][1]; + } + + // z direction + rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][2] + flag * dZ; + // pay attention to the symmetric case + if (Symmetry > 0 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dZ; + + if (fabs(rr) > dZ / 2) + { + lev_flag[lev - movls] = tot_flag = true; + bbox[lev][grd][2] = bbox[lev][grd][2] + rr; + bbox[lev][grd][5] = bbox[lev][grd][5] + rr; + handle[lev][grd][2] += rr; + tmpPorg[bhi][2] = Porg0[bhi][2]; + } + } + // if(ErrorMonitor->outfile && lev_flag[lev-movls]) cout<<"lev#"< *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor) +{ + // for moving part + if (movls < levels) + { + bool tot_flag = false; + bool *lev_flag; + double **tmpPorg; + tmpPorg = new double *[BH_num]; + for (int bhi = 0; bhi < BH_num; bhi++) + { + tmpPorg[bhi] = new double[dim]; + for (int i = 0; i < dim; i++) + tmpPorg[bhi][i] = Porgbr[bhi][i]; + } + lev_flag = new bool[levels - movls]; + for (int lev = movls; lev < levels; lev++) + { + lev_flag[lev - movls] = false; + for (int grd = 0; grd < grids[lev]; grd++) + { + int flag; + int do_every = 2; + double dX = PatL[lev]->data->blb->data->getdX(0); + double dY = PatL[lev]->data->blb->data->getdX(1); + double dZ = PatL[lev]->data->blb->data->getdX(2); + double rr; + // make sure that the grid corresponds to the black hole + int bhi = 0; + for (bhi = 0; bhi < BH_num; bhi++) + { + // because finner level may also change Porgbr, so we need factor 2 + if (feq(Porgbr[bhi][0], handle[lev][grd][0], 2 * do_every * dX) && + feq(Porgbr[bhi][1], handle[lev][grd][1], 2 * do_every * dY) && + feq(Porgbr[bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) + break; + } + if (bhi == BH_num) + { + // if the box has already touched the original point + if (feq(0, bbox[lev][grd][0], dX / 2) && + feq(0, bbox[lev][grd][1], dY / 2) && + feq(0, bbox[lev][grd][2], dZ / 2)) + break; + + if (BH_num == 1) + { + bhi = 0; + break; + } // if only one black hole, it definitely match! + + if (ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd + << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; + ErrorMonitor->outfile << "black holes' old positions:" << endl; + for (bhi = 0; bhi < BH_num; bhi++) + ErrorMonitor->outfile << "#" << bhi << ": (" << Porgbr[bhi][0] << "," << Porgbr[bhi][1] << "," << Porgbr[bhi][2] << ")" << endl; + ErrorMonitor->outfile << "tolerance:" << endl; + ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; + ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + delete[] lev_flag; + for (bhi = 0; bhi < BH_num; bhi++) + delete[] tmpPorg[bhi]; + delete[] tmpPorg; + return; + } + // x direction + rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][0] + flag * dX; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][0]; + else + rr = flag * dX; + + if (fabs(rr) > dX / 2) + { + lev_flag[lev - movls] = tot_flag = true; + bbox[lev][grd][0] = bbox[lev][grd][0] + rr; + bbox[lev][grd][3] = bbox[lev][grd][3] + rr; + handle[lev][grd][0] += rr; + tmpPorg[bhi][0] = Porg0[bhi][0]; + } + + // y direction + rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][1] + flag * dY; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dY; + + if (fabs(rr) > dY / 2) + { + lev_flag[lev - movls] = tot_flag = true; + bbox[lev][grd][1] = bbox[lev][grd][1] + rr; + bbox[lev][grd][4] = bbox[lev][grd][4] + rr; + handle[lev][grd][1] += rr; + tmpPorg[bhi][1] = Porg0[bhi][1]; + } + + // z direction + rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][2] + flag * dZ; + // pay attention to the symmetric case + if (Symmetry > 0 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dZ; + + if (fabs(rr) > dZ / 2) + { + lev_flag[lev - movls] = tot_flag = true; + bbox[lev][grd][2] = bbox[lev][grd][2] + rr; + bbox[lev][grd][5] = bbox[lev][grd][5] + rr; + handle[lev][grd][2] += rr; + tmpPorg[bhi][2] = Porg0[bhi][2]; + } + } + // if(ErrorMonitor->outfile && lev_flag[lev-movls]) cout<<"lev#"< *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB) +{ + for (int lev = movls; lev < levels; lev++) + if (lev_flag[lev - movls]) + { + MyList *tmPat = 0; + tmPat = construct_patchlist(lev, Symmetry); + // tmPat construction completes + Parallel::distribute(tmPat, nprocs, ingfs, fngfs, false); + // checkPatchList(tmPat,true); + bool CC = (lev > trfls); + Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); + + Parallel::KillBlocks(PatL[lev]); + PatL[lev]->destroyList(); + PatL[lev] = tmPat; +#if (RPB == 1) + Parallel::destroypsuList_bam(bdsul[lev]); + Parallel::destroypsuList_bam(rsul[lev]); + Parallel::Constr_pointstr_OutBdLow2Hi(PatL[lev], PatL[lev - 1], bdsul[lev]); + Parallel::Constr_pointstr_Restrict(PatL[lev], PatL[lev - 1], rsul[lev]); +#endif + } +} +#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) +#warning "recompose_cgh is not implimented yet" +void cgh::recompose_cgh(int nprocs, bool *lev_flag, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB) +{ + for (int lev = movls; lev < levels; lev++) + if (lev_flag[lev - movls]) + { + MyList *tmPat = 0; + tmPat = construct_patchlist(lev, Symmetry); + // tmPat construction completes + Parallel::distribute(tmPat, end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); + // checkPatchList(tmPat,true); + bool CC = (lev > trfls); + Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); + + Parallel::KillBlocks(PatL[lev]); + PatL[lev]->destroyList(); + PatL[lev] = tmPat; +#if (RPB == 1) +#error "not support yet" +#endif + } +} + +//================================================================================================ + +void cgh::recompose_cgh_fake(int nprocs, bool *lev_flag, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB) +{ + for (int lev = movls; lev < levels; lev++) + if (lev_flag[lev - movls] && lev != mylev) + { + MyList *tmPat = 0; + tmPat = construct_patchlist(lev, Symmetry); + // tmPat construction completes + Parallel::distribute(tmPat, end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); + + Parallel::KillBlocks(PatL[lev]); + PatL[lev]->destroyList(); + PatL[lev] = tmPat; + } +} +#endif + +//================================================================================================ + +// This member function reads grid information from input files + +//================================================================================================ + +void cgh::read_bbox(int Symmetry, char *filename) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "cgh::cgh: Can not open parameter file " << filename << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && skey == "levels") + { + levels = atoi(sval.c_str()); + break; + } + } + inf.close(); + } + + grids = new int[levels]; + shape = new int **[levels]; + handle = new double **[levels]; + bbox = new double **[levels]; + PatL = new MyList *[levels]; + Lt = new double[levels]; +#if (RPB == 1) + bdsul = new MyList *[levels]; + rsul = new MyList *[levels]; +#endif + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "cgh::cgh: Can not open parameter file " << filename << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && skey == "grids" && sind1 < levels) + grids[sind1] = atoi(sval.c_str()); + } + inf.close(); + } + + for (int sind1 = 0; sind1 < levels; sind1++) + { + shape[sind1] = new int *[grids[sind1]]; + handle[sind1] = new double *[grids[sind1]]; + bbox[sind1] = new double *[grids[sind1]]; + for (int sind2 = 0; sind2 < grids[sind1]; sind2++) + { + shape[sind1][sind2] = new int[dim]; + handle[sind1][sind2] = new double[dim]; + bbox[sind1][sind2] = new double[2 * dim]; + } + } + // read parameter from file + { + const int LEN = 256; + char pline[LEN]; + string str, sgrp, skey, sval; + int sind1, sind2, sind3; + ifstream inf(filename, ifstream::in); + if (!inf.good() && myrank == 0) + { + cout << "cgh::cgh: Can not open parameter file " << filename << " for inputing information of black holes" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (int i = 1; inf.good(); i++) + { + inf.getline(pline, LEN); + str = pline; + + int status = misc::parse_parts(str, sgrp, skey, sval, sind1, sind2, sind3); + + if (status == -1) + { + cout << "error reading parameter file " << filename << " in line " << i << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + else if (status == 0) + continue; + + if (sgrp == "cgh" && sind1 < levels && sind2 < grids[sind1]) + { + if (skey == "bbox") + bbox[sind1][sind2][sind3] = atof(sval.c_str()); + else if (skey == "shape") + shape[sind1][sind2][sind3] = atoi(sval.c_str()); + } + } + inf.close(); + } +// we always assume the input parameter is in cell center style +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + for (int lev = 0; lev < levels; lev++) + for (int grd = 0; grd < grids[lev]; grd++) + { + for (int i = 0; i < dim; i++) + { + + shape[lev][grd][i] = shape[lev][grd][i] + 1; + } + } +#endif + + { + + // boxes align check + double DH0[dim]; + for (int i = 0; i < dim; i++) +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + DH0[i] = (bbox[0][0][i + dim] - bbox[0][0][i]) / (shape[0][0][i] - 1); +#else +#ifdef Cell + DH0[i] = (bbox[0][0][i + dim] - bbox[0][0][i]) / shape[0][0][i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + for (int lev = 0; lev < levels; lev++) + for (int grd = 0; grd < grids[lev]; grd++) + Parallel::aligncheck(bbox[0][0], bbox[lev][grd], lev, DH0, shape[lev][grd]); + +#if 0 // we do not need it here, because we do it in construct_patchlist +// extend buffer points for shell overlap +#ifdef WithShell + for(int i=0;i *cgh::construct_patchlist(int lev, int Symmetry) +{ + // Construct Patches + MyList *tmPat = 0; + // construct box list + MyList *boxes = 0, *gs; + + /* + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == 0) + { + cout << " construct patchlist: " << " level = " << lev << ", grids in this level = " << grids[lev] << endl; + } + */ + + for (int grd = 0; grd < grids[lev]; grd++) + { + if (boxes) + { + gs->next = new MyList; + gs = gs->next; + gs->data = new Parallel::gridseg; + } + else + { + boxes = gs = new MyList; + gs->data = new Parallel::gridseg; + } + for (int i = 0; i < dim; i++) + { + gs->data->llb[i] = bbox[lev][grd][i]; + gs->data->uub[i] = bbox[lev][grd][dim + i]; + gs->data->shape[i] = shape[lev][grd][i]; + } + gs->data->Bg = 0; + gs->next = 0; + } + + // Merge grid boxes (merging more than three boxes may cause bugs) + // Parallel::merge_gsl(boxes, ratio); + if (grids[lev] < 3) + { + Parallel::merge_gsl(boxes, ratio); + } + + // When grid boxes overlap, re-split the boxes + // Parallel::cut_gsl(boxes); + if (grids[lev] < 3) + { + Parallel::cut_gsl(boxes); + } + + // After splitting, add new ghost regions? + // Parallel::add_ghost_touch(boxes); + if (grids[lev] < 3) + { + Parallel::add_ghost_touch(boxes); + } + + MyList *gp; + gs = boxes; + while (gs) + { + double tbb[2 * dim]; + if (tmPat) + { + gp->next = new MyList; + gp = gp->next; + for (int i = 0; i < dim; i++) + { + tbb[i] = gs->data->llb[i]; + tbb[dim + i] = gs->data->uub[i]; + } +#ifdef WithShell + gp->data = new Patch(3, gs->data->shape, tbb, lev, true, Symmetry); +#else + gp->data = new Patch(3, gs->data->shape, tbb, lev, (lev > 0), Symmetry); +#endif + } + else + { + tmPat = gp = new MyList; + for (int i = 0; i < dim; i++) + { + tbb[i] = gs->data->llb[i]; + tbb[dim + i] = gs->data->uub[i]; + } +#ifdef WithShell + gp->data = new Patch(3, gs->data->shape, tbb, lev, true, Symmetry); +#else + gp->data = new Patch(3, gs->data->shape, tbb, lev, (lev > 0), Symmetry); +#endif + } + gp->next = 0; + + gs = gs->next; + } + + boxes->destroyList(); + + return tmPat; +} + +//================================================================================================ + + +bool cgh::Interp_One_Point(MyList *VarList, + double *XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry) +{ + int lev = levels - 1; + while (lev >= 0) + { + MyList *Pp = PatL[lev]; + while (Pp) + { +#if (PSTR == 0) + if (Pp->data->Interp_ONE_Point(VarList, XX, Shellf, Symmetry)) + return true; +#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) + if (Pp->data->Interp_ONE_Point(VarList, XX, Shellf, Symmetry, Commlev[lev])) + return true; +#endif + Pp = Pp->next; + } + lev--; + } + return false; +} + + +bool cgh::Regrid_Onelevel(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor) +{ + if (lev < movls) + return false; + +#if (0) + // #if (PSTR == 1 || PSTR == 2) + MyList *Pp = PatL[lev]; + while (Pp) + { + Pp->data->checkPatch(0, start_rank[mylev]); + Pp = Pp->next; + } + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + if (myrank == start_rank[mylev]) + { + cout << "out_rank = " << myrank << endl; + for (int grd = 0; grd < grids[lev]; grd++) + { + cout << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << endl; + } + for (int bhi = 0; bhi < BH_num; bhi++) + { + cout << Porgls[lev][bhi][0] << "," << Porgls[lev][bhi][1] << "," << Porgls[lev][bhi][2] << endl; + cout << Porg0[bhi][0] << "," << Porg0[bhi][1] << "," << Porg0[bhi][2] << endl; + } + } +#endif + + // misc::tillherecheck(Commlev[lev],start_rank[lev],"start Regrid_Onelevel"); + // for moving part + bool tot_flag = false; + double **tmpPorg; + tmpPorg = new double *[BH_num]; + for (int bhi = 0; bhi < BH_num; bhi++) + { + tmpPorg[bhi] = new double[dim]; + for (int i = 0; i < dim; i++) + tmpPorg[bhi][i] = Porgls[lev][bhi][i]; + } + + for (int grd = 0; grd < grids[lev]; grd++) + { + int flag; + int do_every = 2; + double dX = PatL[lev]->data->blb->data->getdX(0); + double dY = PatL[lev]->data->blb->data->getdX(1); + double dZ = PatL[lev]->data->blb->data->getdX(2); + double rr; + // make sure that the grid corresponds to the black hole + int bhi = 0; + for (bhi = 0; bhi < BH_num; bhi++) + { + // because finner level may also change Porgbr, so we need factor 2 + // now I used Porgls + if (feq(Porgls[lev][bhi][0], handle[lev][grd][0], 2 * do_every * dX) && + feq(Porgls[lev][bhi][1], handle[lev][grd][1], 2 * do_every * dY) && + feq(Porgls[lev][bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) + break; + } + if (bhi == BH_num) + { + // if the box has already touched the original point + if (feq(0, bbox[lev][grd][0], dX / 2) && + feq(0, bbox[lev][grd][1], dY / 2) && + feq(0, bbox[lev][grd][2], dZ / 2)) + break; + + if (BH_num == 1) + { + bhi = 0; + break; + } // if only one black hole, it definitely match! + + if (ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd + << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; + ErrorMonitor->outfile << "black holes' old positions:" << endl; + for (bhi = 0; bhi < BH_num; bhi++) + ErrorMonitor->outfile << "#" << bhi << ": (" << Porgls[lev][bhi][0] << "," << Porgls[lev][bhi][1] << "," + << Porgls[lev][bhi][2] << ")" << endl; + ErrorMonitor->outfile << "tolerance:" << endl; + ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; + ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (bhi = 0; bhi < BH_num; bhi++) + delete[] tmpPorg[bhi]; + delete[] tmpPorg; + return false; + } + // x direction + rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][0] + flag * dX; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][0]; + else + rr = flag * dX; + + if (fabs(rr) > dX / 2) + { + tot_flag = true; + bbox[lev][grd][0] = bbox[lev][grd][0] + rr; + bbox[lev][grd][3] = bbox[lev][grd][3] + rr; + handle[lev][grd][0] += rr; + tmpPorg[bhi][0] = Porg0[bhi][0]; + } + + // y direction + rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][1] + flag * dY; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dY; + + if (fabs(rr) > dY / 2) + { + tot_flag = true; + bbox[lev][grd][1] = bbox[lev][grd][1] + rr; + bbox[lev][grd][4] = bbox[lev][grd][4] + rr; + handle[lev][grd][1] += rr; + tmpPorg[bhi][1] = Porg0[bhi][1]; + } + + // z direction + rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][2] + flag * dZ; + // pay attention to the symmetric case + if (Symmetry > 0 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dZ; + + if (fabs(rr) > dZ / 2) + { + tot_flag = true; + bbox[lev][grd][2] = bbox[lev][grd][2] + rr; + bbox[lev][grd][5] = bbox[lev][grd][5] + rr; + handle[lev][grd][2] += rr; + tmpPorg[bhi][2] = Porg0[bhi][2]; + } + } + + // misc::tillherecheck(Commlev[lev],start_rank[lev],"after tot_flag check"); + + if (tot_flag) + { + int nprocs; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + + // misc::tillherecheck(Commlev[lev],start_rank[lev],"before recompose_cgh_Onelevel"); + + recompose_cgh_Onelevel(nprocs, lev, OldList, StateList, FutureList, tmList, Symmetry, BB); + + // misc::tillherecheck(Commlev[lev],start_rank[lev],"after recompose_cgh_Onelevel"); + + for (int bhi = 0; bhi < BH_num; bhi++) + { + for (int i = 0; i < dim; i++) + Porgls[lev][bhi][i] = tmpPorg[bhi][i]; + } + +#if (PSTR == 1 || PSTR == 2) +// MyList *Pp=PatL[lev]; +// while(Pp) +// { +// Pp->data->checkPatch(0,start_rank[mylev]); +// Pp=Pp->next; +// } +#endif + } + + for (int bhi = 0; bhi < BH_num; bhi++) + delete[] tmpPorg[bhi]; + delete[] tmpPorg; + return tot_flag; +} + + +#if (PSTR == 0) +void cgh::recompose_cgh_Onelevel(int nprocs, int lev, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB) +{ + MyList *tmPat = 0; + tmPat = construct_patchlist(lev, Symmetry); + // tmPat construction completes + Parallel::distribute(tmPat, nprocs, ingfs, fngfs, false); + // checkPatchList(tmPat,true); + bool CC = (lev > trfls); + Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); + + Parallel::KillBlocks(PatL[lev]); + PatL[lev]->destroyList(); + PatL[lev] = tmPat; +} +#elif (PSTR == 1 || PSTR == 2 || PSTR == 3) +#warning "recompose_cgh_Onelevel is not implimented yet" +void cgh::recompose_cgh_Onelevel(int nprocs, int lev, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB) +{ + MyList *tmPat = 0; + misc::tillherecheck(Commlev[lev], start_rank[lev], "before construct_patchlist"); + tmPat = construct_patchlist(lev, Symmetry); + misc::tillherecheck(Commlev[lev], start_rank[lev], "after construct_patchlist"); + // tmPat construction completes + Parallel::distribute(tmPat, end_rank[lev] - start_rank[lev] + 1, ingfs, fngfs, false, start_rank[lev], end_rank[lev]); + misc::tillherecheck(Commlev[lev], start_rank[lev], "after distribute"); + // checkPatchList(tmPat,true); + bool CC = (lev > trfls); + Parallel::fill_level_data(tmPat, PatL[lev], PatL[lev - 1], OldList, StateList, FutureList, tmList, Symmetry, BB, CC); + misc::tillherecheck(Commlev[lev], start_rank[lev], "after fill_level_data"); + + Parallel::KillBlocks(PatL[lev]); + PatL[lev]->destroyList(); + PatL[lev] = tmPat; +} + + +// the input lev is lower level for regrid +void cgh::Regrid_Onelevel_aux(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor) +{ + lev++; + if (lev < movls) + return; + + // for moving part + bool tot_flag = false; + double **tmpPorg; + tmpPorg = new double *[BH_num]; + for (int bhi = 0; bhi < BH_num; bhi++) + { + tmpPorg[bhi] = new double[dim]; + for (int i = 0; i < dim; i++) + tmpPorg[bhi][i] = Porgbr[bhi][i]; + } + + for (int grd = 0; grd < grids[lev]; grd++) + { + int flag; + int do_every = 2; + double dX = PatL[lev]->data->blb->data->getdX(0); + double dY = PatL[lev]->data->blb->data->getdX(1); + double dZ = PatL[lev]->data->blb->data->getdX(2); + double rr; + // make sure that the grid corresponds to the black hole + int bhi = 0; + for (bhi = 0; bhi < BH_num; bhi++) + { + // because finner level may also change Porgbr, so we need factor 2 + if (feq(Porgbr[bhi][0], handle[lev][grd][0], 2 * do_every * dX) && + feq(Porgbr[bhi][1], handle[lev][grd][1], 2 * do_every * dY) && + feq(Porgbr[bhi][2], handle[lev][grd][2], 2 * do_every * dZ)) + break; + } + if (bhi == BH_num) + { + // if the box has already touched the original point + if (feq(0, bbox[lev][grd][0], dX / 2) && + feq(0, bbox[lev][grd][1], dY / 2) && + feq(0, bbox[lev][grd][2], dZ / 2)) + break; + + if (BH_num == 1) + { + bhi = 0; + break; + } // if only one black hole, it definitely match! + + if (ErrorMonitor->outfile) + { + ErrorMonitor->outfile << "cgh::Regrid: no black hole matches with grid lev#" << lev << " grd#" << grd + << " with handle (" << handle[lev][grd][0] << "," << handle[lev][grd][1] << "," << handle[lev][grd][2] << ")" << endl; + ErrorMonitor->outfile << "black holes' old positions:" << endl; + for (bhi = 0; bhi < BH_num; bhi++) + ErrorMonitor->outfile << "#" << bhi << ": (" << Porgbr[bhi][0] << "," << Porgbr[bhi][1] << "," << Porgbr[bhi][2] << ")" << endl; + ErrorMonitor->outfile << "tolerance:" << endl; + ErrorMonitor->outfile << "(" << 2 * do_every * dX << "," << 2 * do_every * dY << "," << 2 * do_every * dZ << ")" << endl; + ErrorMonitor->outfile << "box lower boundary: (" << bbox[lev][grd][0] << "," << bbox[lev][grd][1] << "," << bbox[lev][grd][2] << ")" << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + for (bhi = 0; bhi < BH_num; bhi++) + delete[] tmpPorg[bhi]; + delete[] tmpPorg; + return; + } + // x direction + rr = (Porg0[bhi][0] - handle[lev][grd][0]) / dX; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][0] + flag * dX; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][0]; + else + rr = flag * dX; + + if (fabs(rr) > dX / 2) + { + tot_flag = true; + bbox[lev][grd][0] = bbox[lev][grd][0] + rr; + bbox[lev][grd][3] = bbox[lev][grd][3] + rr; + handle[lev][grd][0] += rr; + tmpPorg[bhi][0] = Porg0[bhi][0]; + } + + // y direction + rr = (Porg0[bhi][1] - handle[lev][grd][1]) / dY; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][1] + flag * dY; + // pay attention to the symmetric case + if (Symmetry == 2 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dY; + + if (fabs(rr) > dY / 2) + { + tot_flag = true; + bbox[lev][grd][1] = bbox[lev][grd][1] + rr; + bbox[lev][grd][4] = bbox[lev][grd][4] + rr; + handle[lev][grd][1] += rr; + tmpPorg[bhi][1] = Porg0[bhi][1]; + } + + // z direction + rr = (Porg0[bhi][2] - handle[lev][grd][2]) / dZ; + if (rr > 0) + flag = int(rr + 0.5) / do_every; + else + flag = int(rr - 0.5) / do_every; + flag = flag * do_every; + rr = bbox[lev][grd][2] + flag * dZ; + // pay attention to the symmetric case + if (Symmetry > 0 && rr < 0) + rr = -bbox[lev][grd][1]; + else + rr = flag * dZ; + + if (fabs(rr) > dZ / 2) + { + tot_flag = true; + bbox[lev][grd][2] = bbox[lev][grd][2] + rr; + bbox[lev][grd][5] = bbox[lev][grd][5] + rr; + handle[lev][grd][2] += rr; + tmpPorg[bhi][2] = Porg0[bhi][2]; + } + } + + if (tot_flag) + { + int nprocs; + MPI_Comm_size(MPI_COMM_WORLD, &nprocs); + recompose_cgh_Onelevel(nprocs, lev, OldList, StateList, FutureList, tmList, Symmetry, BB); + } + + for (int bhi = 0; bhi < BH_num; bhi++) + delete[] tmpPorg[bhi]; + delete[] tmpPorg; +} +#endif + + +void cgh::settrfls(const int lev) +{ + trfls = lev; +} diff --git a/AMSS_NCKU_source/cgh.h b/AMSS_NCKU_source/cgh/cgh.h similarity index 97% rename from AMSS_NCKU_source/cgh.h rename to AMSS_NCKU_source/cgh/cgh.h index 57e489a..1bbd24d 100644 --- a/AMSS_NCKU_source/cgh.h +++ b/AMSS_NCKU_source/cgh/cgh.h @@ -1,92 +1,92 @@ - -#ifndef CGH_H -#define CGH_H - -#include -#include "MyList.h" -#include "MPatch.h" -#include "macrodef.h" -#include "monitor.h" -#include "Parallel.h" - -class cgh -{ - -public: - int levels, movls, BH_num_in; - // information of boxes - int *grids; - double ***bbox; - int ***shape; - double ***handle; - double ***Porgls; - double *Lt; - - // information of Patch list - MyList **PatL; - -// information of OutBdLow2Hi point list and Restrict point list -#if (RPB == 1) - MyList **bdsul, **rsul; -#endif - -#if (PSTR == 1 || PSTR == 2 || PSTR == 3) - int mylev; - int *start_rank, *end_rank; - MPI_Comm *Commlev; -#endif - -protected: - int ingfs, fngfs; - static constexpr double ratio = 0.75; - int trfls; - -public: - cgh(int ingfsi, int fngfsi, int Symmetry, char *filename, int checkrun, monitor *ErrorMonitor); - - ~cgh(); - - void compose_cgh(int nprocs); - void sethandle(monitor *ErrorMonitor); - void checkPatchList(MyList *PatL, bool buflog); - void Regrid(int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor); - void Regrid_fake(int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor); - void recompose_cgh(int nprocs, bool *lev_flag, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB); - void recompose_cgh_fake(int nprocs, bool *lev_flag, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB); - void read_bbox(int Symmetry, char *filename); - MyList *construct_patchlist(int lev, int Symmetry); - bool Interp_One_Point(MyList *VarList, - double *XX, /*input global Cartesian coordinate*/ - double *Shellf, int Symmetry); - void recompose_cgh_Onelevel(int nprocs, int lev, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, - int Symmetry, bool BB); - bool Regrid_Onelevel(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor); - void Regrid_Onelevel_aux(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, - MyList *OldList, MyList *StateList, - MyList *FutureList, MyList *tmList, bool BB, - monitor *ErrorMonitor); - void settrfls(const int lev); - -#if (PSTR == 1 || PSTR == 2 || PSTR == 3) - void construct_mylev(int nprocs); -#endif -}; - -#endif /* CGH_H */ + +#ifndef CGH_H +#define CGH_H + +#include +#include "MyList.h" +#include "MPatch.h" +#include "macrodef.h" +#include "monitor.h" +#include "Parallel.h" + +class cgh +{ + +public: + int levels, movls, BH_num_in; + // information of boxes + int *grids; + double ***bbox; + int ***shape; + double ***handle; + double ***Porgls; + double *Lt; + + // information of Patch list + MyList **PatL; + +// information of OutBdLow2Hi point list and Restrict point list +#if (RPB == 1) + MyList **bdsul, **rsul; +#endif + +#if (PSTR == 1 || PSTR == 2 || PSTR == 3) + int mylev; + int *start_rank, *end_rank; + MPI_Comm *Commlev; +#endif + +protected: + int ingfs, fngfs; + static constexpr double ratio = 0.75; + int trfls; + +public: + cgh(int ingfsi, int fngfsi, int Symmetry, char *filename, int checkrun, monitor *ErrorMonitor); + + ~cgh(); + + void compose_cgh(int nprocs); + void sethandle(monitor *ErrorMonitor); + void checkPatchList(MyList *PatL, bool buflog); + void Regrid(int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor); + void Regrid_fake(int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor); + void recompose_cgh(int nprocs, bool *lev_flag, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB); + void recompose_cgh_fake(int nprocs, bool *lev_flag, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB); + void read_bbox(int Symmetry, char *filename); + MyList *construct_patchlist(int lev, int Symmetry); + bool Interp_One_Point(MyList *VarList, + double *XX, /*input global Cartesian coordinate*/ + double *Shellf, int Symmetry); + void recompose_cgh_Onelevel(int nprocs, int lev, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, + int Symmetry, bool BB); + bool Regrid_Onelevel(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor); + void Regrid_Onelevel_aux(int lev, int Symmetry, int BH_num, double **Porgbr, double **Porg0, + MyList *OldList, MyList *StateList, + MyList *FutureList, MyList *tmList, bool BB, + monitor *ErrorMonitor); + void settrfls(const int lev); + +#if (PSTR == 1 || PSTR == 2 || PSTR == 3) + void construct_mylev(int nprocs); +#endif +}; + +#endif /* CGH_H */ diff --git a/AMSS_NCKU_source/makefile b/AMSS_NCKU_source/makefile index 72b9cbd..dea91bd 100644 --- a/AMSS_NCKU_source/makefile +++ b/AMSS_NCKU_source/makefile @@ -18,7 +18,7 @@ ifeq ($(PGO_MODE),instrument) CXXAPPFLAGS = -O3 -xHost -fma -fprofile-instr-generate -ipo \ -Dfortran3 -Dnewc -I${MKLROOT}/include $(INTERP_LB_FLAGS) f90appflags = -O3 -xHost -fma -fprofile-instr-generate -ipo \ - -align array64byte -fpp -I${MKLROOT}/include $(POLINT6_FLAG) + -align array64byte -fpp -I${MKLROOT}/include $(SRC_INC_FLAGS) $(POLINT6_FLAG) else ## opt (default): maximum performance with PGO profile data -fprofile-instr-use=$(PROFDATA) \ ## PGO has been turned off, now tested and found to be negative optimization @@ -28,7 +28,7 @@ else CXXAPPFLAGS = -O3 -xHost -fp-model fast=2 -fma -ipo \ -Dfortran3 -Dnewc -I${MKLROOT}/include $(INTERP_LB_FLAGS) f90appflags = -O3 -xHost -fp-model fast=2 -fma -ipo \ - -align array64byte -fpp -I${MKLROOT}/include $(POLINT6_FLAG) + -align array64byte -fpp -I${MKLROOT}/include $(SRC_INC_FLAGS) $(POLINT6_FLAG) endif .SUFFIXES: .o .f90 .C .for .cu @@ -45,147 +45,199 @@ endif .cu.o: $(Cu) $(CUDA_APP_FLAGS) -c $< -o $@ $(CUDA_LIB_PATH) -# C rewrite of BSSN RHS kernel and helpers -bssn_rhs_c.o: bssn_rhs_c.C - ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ - -fderivs_c.o: fderivs_c.C - ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ - -fdderivs_c.o: fdderivs_c.C - ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ - -kodiss_c.o: kodiss_c.C - ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ - -lopsided_c.o: lopsided_c.C - ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ +## TwoPunctureABE uses fixed optimal flags with its own PGO profile, independent of CXXAPPFLAGS +TP_PROFDATA = /home/$(shell whoami)/AMSS-NCKU/pgo_profile/TwoPunctureABE.profdata +TP_OPTFLAGS = -O3 -xHost -fp-model fast=2 -fma -ipo \ + -fprofile-instr-use=$(TP_PROFDATA) \ + -Dfortran3 -Dnewc -I${MKLROOT}/include $(SRC_INC_FLAGS) -lopsided_kodis_c.o: lopsided_kodis_c.C - ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ +./Two_Puncture/TwoPunctures.o: ./Two_Puncture/TwoPunctures.C + ${CXX} $(TP_OPTFLAGS) -qopenmp -c $< -o $@ -#interp_lb_profile.o: interp_lb_profile.C interp_lb_profile.h -# ${CXX} $(CXXAPPFLAGS) -c $< $(filein) -o $@ +./Two_Puncture/TwoPunctureABE.o: ./Two_Puncture/TwoPunctureABE.C + ${CXX} $(TP_OPTFLAGS) -qopenmp -c $< -o $@ -## TwoPunctureABE uses fixed optimal flags with its own PGO profile, independent of CXXAPPFLAGS -TP_PROFDATA = /home/$(shell whoami)/AMSS-NCKU/pgo_profile/TwoPunctureABE.profdata -TP_OPTFLAGS = -O3 -xHost -fp-model fast=2 -fma -ipo \ - -fprofile-instr-use=$(TP_PROFDATA) \ - -Dfortran3 -Dnewc -I${MKLROOT}/include - -TwoPunctures.o: TwoPunctures.C - ${CXX} $(TP_OPTFLAGS) -qopenmp -c $< -o $@ - -TwoPunctureABE.o: TwoPunctureABE.C - ${CXX} $(TP_OPTFLAGS) -qopenmp -c $< -o $@ - -# Input files - -## Kernel implementation switch (set USE_CXX_KERNELS=0 to fall back to Fortran) +# Input files + +## Kernel implementation switch (set USE_CXX_KERNELS=0 to fall back to Fortran) ifeq ($(USE_CXX_KERNELS),0) -# Fortran mode: no C rewrite files; bssn_rhs.o is included via F90FILES below CFILES = else -# C++ mode (default): C rewrite of bssn_rhs and helper kernels -CFILES = bssn_rhs_c.o fderivs_c.o fdderivs_c.o kodiss_c.o lopsided_c.o lopsided_kodis_c.o +CFILES = ./BSSN/bssn_rhs_c.o \ + ./Derivative/fderivs_c.o \ + ./Derivative/fdderivs_c.o \ + ./KO_dissipation/kodiss_c.o \ + ./BSSN/lopsided_c.o \ + ./BSSN/lopsided_kodis_c.o endif ## RK4 kernel switch (independent from USE_CXX_KERNELS) ifeq ($(USE_CXX_RK4),1) -CFILES += rungekutta4_rout_c.o +CFILES += ./Runge_Kutta/rungekutta4_rout_c.o RK4_F90_OBJ = else -RK4_F90_OBJ = rungekutta4_rout.o +RK4_F90_OBJ = ./Runge_Kutta/rungekutta4_rout.o endif - -C++FILES = ABE.o Ansorg.o Block.o misc.o monitor.o Parallel.o MPatch.o var.o\ - cgh.o bssn_class.o surface_integral.o ShellPatch.o\ - bssnEScalar_class.o perf.o Z4c_class.o NullShellPatch.o\ - bssnEM_class.o cpbc_util.o z4c_rhs_point.o checkpoint.o\ - Parallel_bam.o scalar_class.o transpbh.o NullShellPatch2.o\ - NullShellPatch2_Evo.o writefile_f.o interp_lb_profile.o - -C++FILES_GPU = ABE.o Ansorg.o Block.o misc.o monitor.o Parallel.o MPatch.o var.o\ - cgh.o surface_integral.o ShellPatch.o\ - bssnEScalar_class.o perf.o Z4c_class.o NullShellPatch.o\ - bssnEM_class.o cpbc_util.o z4c_rhs_point.o checkpoint.o\ - Parallel_bam.o scalar_class.o transpbh.o NullShellPatch2.o\ - NullShellPatch2_Evo.o \ - bssn_gpu_class.o bssn_step_gpu.o bssn_macro.o writefile_f.o - -F90FILES_BASE = enforce_algebra.o fmisc.o initial_puncture.o prolongrestrict.o\ - prolongrestrict_cell.o prolongrestrict_vertex.o\ - $(RK4_F90_OBJ) diff_new.o kodiss.o kodiss_sh.o\ - lopsidediff.o sommerfeld_rout.o getnp4.o diff_new_sh.o\ - shellfunctions.o bssn_rhs_ss.o Set_Rho_ADM.o\ - getnp4EScalar.o bssnEScalar_rhs.o bssn_constraint.o ricci_gamma.o\ - fadmquantites_bssn.o Z4c_rhs.o Z4c_rhs_ss.o point_diff_new_sh.o\ - cpbc.o getnp4old.o NullEvol.o initial_null.o initial_maxwell.o\ - getnpem2.o empart.o NullNews.o fourdcurvature.o\ - bssn2adm.o adm_constraint.o adm_ricci_gamma.o\ - scalar_rhs.o initial_scalar.o NullEvol2.o initial_null2.o\ - NullNews2.o tool_f.o - -ifeq ($(USE_CXX_KERNELS),0) -# Fortran mode: include original bssn_rhs.o -F90FILES = $(F90FILES_BASE) bssn_rhs.o -else -# C++ mode (default): bssn_rhs.o replaced by C++ kernel -F90FILES = $(F90FILES_BASE) -endif - -F77FILES = zbesh.o - -AHFDOBJS = expansion.o expansion_Jacobian.o patch.o coords.o patch_info.o patch_interp.o patch_system.o \ -tgrid.o fd_grid.o ghost_zone.o array.o round.o norm.o fuzzy.o error_exit.o miscfp.o \ -linear_map.o cpm_map.o BH_diagnostics.o setup.o horizon_sequence.o find_horizons.o \ -initial_guess.o Newton.o Jacobian.o ilucg.o IntPnts0.o IntPnts.o - -TwoPunctureFILES = TwoPunctureABE.o TwoPunctures.o - -CUDAFILES = bssn_gpu.o bssn_gpu_rhs_ss.o - -# file dependences -$(C++FILES) $(C++FILES_GPU) $(F90FILES) $(CFILES) $(AHFDOBJS) $(CUDAFILES): macrodef.fh - -$(C++FILES): Block.h enforce_algebra.h fmisc.h initial_puncture.h macrodef.h\ - misc.h monitor.h MyList.h Parallel.h MPatch.h prolongrestrict.h\ - rungekutta4_rout.h var.h bssn_class.h bssn_rhs.h sommerfeld_rout.h\ - cgh.h surface_integral.h ShellPatch.h shellfunctions.h perf.h\ - fadmquantites_bssn.h cpbc.h getnp4.h initial_null.h NullEvol.h\ - NullShellPatch.h initial_maxwell.h bssnEM_class.h getnpem2.h\ - empart.h NullNews.h kodiss.h Parallel_bam.h ricci_gamma.h\ - initial_null2.h NullShellPatch2.h - -$(C++FILES_GPU): Block.h enforce_algebra.h fmisc.h initial_puncture.h macrodef.h\ - misc.h monitor.h MyList.h Parallel.h MPatch.h prolongrestrict.h\ - rungekutta4_rout.h var.h bssn_rhs.h sommerfeld_rout.h\ - cgh.h surface_integral.h ShellPatch.h shellfunctions.h perf.h\ - fadmquantites_bssn.h cpbc.h getnp4.h initial_null.h NullEvol.h\ - NullShellPatch.h initial_maxwell.h bssnEM_class.h getnpem2.h\ - empart.h NullNews.h kodiss.h Parallel_bam.h ricci_gamma.h\ - initial_null2.h NullShellPatch2.h \ - bssn_gpu_class.h bssn_macro.h - -$(AHFDOBJS): cctk.h cctk_Config.h cctk_Types.h cctk_Constants.h myglobal.h - -$(C++FILES) $(C++FILES_GPU) $(CFILES) $(AHFDOBJS) $(CUDAFILES): macrodef.h - -TwoPunctureFILES: TwoPunctures.h - -$(CUDAFILES): bssn_gpu.h gpu_mem.h gpu_rhsSS_mem.h - -misc.o : zbesh.o - -# projects -ABE: $(C++FILES) $(CFILES) $(F90FILES) $(F77FILES) $(AHFDOBJS) - $(CLINKER) $(CXXAPPFLAGS) -o $@ $(C++FILES) $(CFILES) $(F90FILES) $(F77FILES) $(AHFDOBJS) $(LDLIBS) + +C++FILES = ABE.o \ + ./Initial_Data_Solver/Ansorg.o \ + ./cgh/Block.o \ + ./misc/misc.o \ + ./Monitor/monitor.o \ + ./Parallel/Parallel.o \ + ./Patch/MPatch.o \ + ./Variable/var.o \ + ./cgh/cgh.o \ + ./BSSN/bssn_class.o \ + ./Surface_Integral/surface_integral.o \ + ./Shell_Patch/ShellPatch.o \ + ./Scalar/bssnEScalar_class.o \ + ./System_Performance/perf.o \ + ./Z4C/Z4c_class.o \ + ./Null_Evolve/NullShellPatch.o \ + ./BSSN/bssnEM_class.o \ + ./Z4C/cpbc_util.o \ + ./Z4C/z4c_rhs_point.o \ + ./Check_Point/checkpoint.o \ + ./Parallel/Parallel_bam.o \ + ./Scalar/scalar_class.o \ + ./BSSN/transpbh.o \ + ./Null_Evolve/NullShellPatch2.o \ + ./Null_Evolve/NullShellPatch2_Evo.o \ + ./Read_and_Write/writefile_f.o \ + interp_lb_profile.o + +C++FILES_GPU = ABE.o \ + ./Initial_Data_Solver/Ansorg.o \ + ./cgh/Block.o \ + ./misc/misc.o \ + ./Monitor/monitor.o \ + ./Parallel/Parallel.o \ + ./Patch/MPatch.o \ + ./Variable/var.o \ + ./cgh/cgh.o \ + ./Surface_Integral/surface_integral.o \ + ./Shell_Patch/ShellPatch.o \ + ./Scalar/bssnEScalar_class.o \ + ./System_Performance/perf.o \ + ./Z4C/Z4c_class.o \ + ./Null_Evolve/NullShellPatch.o \ + ./BSSN/bssnEM_class.o \ + ./Z4C/cpbc_util.o \ + ./Z4C/z4c_rhs_point.o \ + ./Check_Point/checkpoint.o \ + ./Parallel/Parallel_bam.o \ + ./Scalar/scalar_class.o \ + ./BSSN/transpbh.o \ + ./Null_Evolve/NullShellPatch2.o \ + ./Null_Evolve/NullShellPatch2_Evo.o \ + ./BSSN_GPU/bssn_gpu_class.o \ + ./BSSN_GPU/bssn_step_gpu.o \ + ./BSSN_GPU/bssn_macro.o \ + ./Read_and_Write/writefile_f.o + +F90FILES_BASE = ./BSSN/enforce_algebra.o \ + ./misc/fmisc.o \ + ./Initial_Data_Solver/initial_puncture.o \ + ./BSSN/prolongrestrict.o \ + ./BSSN/prolongrestrict_cell.o \ + ./BSSN/prolongrestrict_vertex.o \ + $(RK4_F90_OBJ) \ + ./Derivative/diff_new.o \ + ./KO_dissipation/kodiss.o \ + ./KO_dissipation/kodiss_sh.o \ + ./BSSN/lopsidediff.o \ + ./BSSN/sommerfeld_rout.o \ + ./Psi4/getnp4.o \ + ./Derivative/diff_new_sh.o \ + ./Shell_Patch/shellfunctions.o \ + ./BSSN/bssn_rhs_ss.o \ + ./Scalar/Set_Rho_ADM.o \ + ./Psi4/getnp4EScalar.o \ + ./Scalar/bssnEScalar_rhs.o \ + ./BSSN/bssn_constraint.o \ + ./Psi4/ricci_gamma.o \ + ./BSSN/fadmquantites_bssn.o \ + ./Z4C/Z4c_rhs.o \ + ./Z4C/Z4c_rhs_ss.o \ + ./Derivative/point_diff_new_sh.o \ + ./Z4C/cpbc.o \ + ./Psi4/getnp4old.o \ + ./Null_Evolve/NullEvol.o \ + ./Initial_Data_Solver/initial_null.o \ + ./Initial_Data_Solver/initial_maxwell.o \ + ./Psi4/getnpem2.o \ + ./BSSN/empart.o \ + ./Null_Evolve/NullNews.o \ + ./BSSN/fourdcurvature.o \ + ./BSSN/bssn2adm.o \ + ./BSSN/adm_constraint.o \ + ./Psi4/adm_ricci_gamma.o \ + ./Scalar/scalar_rhs.o \ + ./Initial_Data_Solver/initial_scalar.o \ + ./Null_Evolve/NullEvol2.o \ + ./Initial_Data_Solver/initial_null2.o \ + ./Null_Evolve/NullNews2.o \ + ./Read_and_Write/tool_f.o + +ifeq ($(USE_CXX_KERNELS),0) +F90FILES = $(F90FILES_BASE) ./BSSN/bssn_rhs.o +else +F90FILES = $(F90FILES_BASE) +endif + +F77FILES = ./Special_Function/zbesh.o + +AHFDOBJS = ./AHF_Direct/expansion.o \ + ./AHF_Direct/expansion_Jacobian.o \ + ./AHF_Direct/patch.o \ + ./AHF_Direct/coords.o \ + ./AHF_Direct/patch_info.o \ + ./AHF_Direct/patch_interp.o \ + ./AHF_Direct/patch_system.o \ + ./AHF_Direct/tgrid.o \ + ./AHF_Direct/fd_grid.o \ + ./AHF_Direct/ghost_zone.o \ + ./AHF_Direct/array.o \ + ./AHF_Direct/round.o \ + ./AHF_Direct/norm.o \ + ./AHF_Direct/fuzzy.o \ + ./AHF_Direct/error_exit.o \ + ./AHF_Direct/miscfp.o \ + ./AHF_Direct/linear_map.o \ + ./AHF_Direct/cpm_map.o \ + ./AHF_Direct/BH_diagnostics.o \ + ./AHF_Direct/setup.o \ + ./AHF_Direct/horizon_sequence.o \ + ./AHF_Direct/find_horizons.o \ + ./AHF_Direct/initial_guess.o \ + ./AHF_Direct/Newton.o \ + ./AHF_Direct/Jacobian.o \ + ./AHF_Direct/ilucg.o \ + ./AHF_Direct/IntPnts0.o \ + ./AHF_Direct/IntPnts.o + +TwoPunctureFILES = ./Two_Puncture/TwoPunctureABE.o ./Two_Puncture/TwoPunctures.o + +CUDAFILES = ./BSSN_GPU/bssn_gpu.o ./BSSN_GPU/bssn_gpu_rhs_ss.o + +$(C++FILES) $(C++FILES_GPU) $(F90FILES) $(CFILES) $(AHFDOBJS) $(CUDAFILES): macrodef.fh +$(C++FILES) $(C++FILES_GPU) $(CFILES) $(AHFDOBJS) $(CUDAFILES): macrodef.h +$(TwoPunctureFILES): ./Two_Puncture/TwoPunctures.h +$(CUDAFILES): ./BSSN_GPU/bssn_gpu.h ./BSSN_GPU/gpu_mem.h ./BSSN_GPU/gpu_rhsSS_mem.h + +./misc/misc.o: ./Special_Function/zbesh.o + +# projects +ABE: $(C++FILES) $(CFILES) $(F90FILES) $(F77FILES) $(AHFDOBJS) + $(CLINKER) $(CXXAPPFLAGS) -o $@ $(C++FILES) $(CFILES) $(F90FILES) $(F77FILES) $(AHFDOBJS) $(LDLIBS) ABEGPU: $(C++FILES_GPU) $(CFILES) $(F90FILES) $(F77FILES) $(AHFDOBJS) $(CUDAFILES) $(CLINKER) $(CXXAPPFLAGS) -o $@ $(C++FILES_GPU) $(CFILES) $(F90FILES) $(F77FILES) $(AHFDOBJS) $(CUDAFILES) $(LDLIBS) -TwoPunctureABE: $(TwoPunctureFILES) - $(CLINKER) $(TP_OPTFLAGS) -qopenmp -o $@ $(TwoPunctureFILES) $(LDLIBS) - -clean: - rm *.o ABE ABEGPU TwoPunctureABE make.log -f +TwoPunctureABE: $(TwoPunctureFILES) + $(CLINKER) $(TP_OPTFLAGS) -qopenmp -o $@ $(TwoPunctureFILES) $(LDLIBS) + +clean: + find . -name '*.o' -delete + rm -f ABE ABEGPU TwoPunctureABE make.log diff --git a/AMSS_NCKU_source/makefile.inc b/AMSS_NCKU_source/makefile.inc index 331cff1..ae0a0c0 100755 --- a/AMSS_NCKU_source/makefile.inc +++ b/AMSS_NCKU_source/makefile.inc @@ -3,8 +3,35 @@ ## filein = -I/usr/include/ -I/usr/include/openmpi-x86_64/ -I/usr/lib/x86_64-linux-gnu/openmpi/include/ -I/usr/lib/x86_64-linux-gnu/openmpi/lib/ -I/usr/lib/gcc/x86_64-linux-gnu/11/ -I/usr/include/c++/11/ ## LDLIBS = -L/usr/lib/x86_64-linux-gnu -L/usr/lib64 -L/usr/lib/gcc/x86_64-linux-gnu/11 -lgfortran -lmpi -lgfortran +SOURCE_DIRS = . \ + ./AHF_Direct \ + ./BSSN \ + ./BSSN_GPU \ + ./cgh \ + ./Check_Point \ + ./Derivative \ + ./Initial_Data_Solver \ + ./KO_dissipation \ + ./misc \ + ./Monitor \ + ./Null_Evolve \ + ./Parallel \ + ./Patch \ + ./Psi4 \ + ./Read_and_Write \ + ./Runge_Kutta \ + ./Scalar \ + ./Shell_Patch \ + ./Special_Function \ + ./Surface_Integral \ + ./System_Performance \ + ./Two_Puncture \ + ./Variable \ + ./Z4C +SRC_INC_FLAGS = $(foreach dir,$(SOURCE_DIRS),-I$(dir)) + ## Intel oneAPI version with oneMKL (Optimized for performance) -filein = -I/usr/include/ -I${MKLROOT}/include +filein = -I/usr/include/ -I${MKLROOT}/include $(SRC_INC_FLAGS) ## Using sequential MKL (OpenMP disabled for better single-threaded performance) ## Added -lifcore for Intel Fortran runtime and -limf for Intel math library @@ -60,6 +87,6 @@ CC = icx CLINKER = mpiicpx Cu = nvcc -CUDA_LIB_PATH = -L/usr/lib/cuda/lib64 -I/usr/include -I/usr/lib/cuda/include +CUDA_LIB_PATH = -L/usr/lib/cuda/lib64 -I/usr/include -I/usr/lib/cuda/include $(SRC_INC_FLAGS) #CUDA_APP_FLAGS = -c -g -O3 --ptxas-options=-v -arch compute_13 -code compute_13,sm_13 -Dfortran3 -Dnewc CUDA_APP_FLAGS = -c -g -O3 --ptxas-options=-v -Dfortran3 -Dnewc diff --git a/AMSS_NCKU_source/fmisc.f90 b/AMSS_NCKU_source/misc/fmisc.f90 similarity index 97% rename from AMSS_NCKU_source/fmisc.f90 rename to AMSS_NCKU_source/misc/fmisc.f90 index e55f3de..60645e1 100644 --- a/AMSS_NCKU_source/fmisc.f90 +++ b/AMSS_NCKU_source/misc/fmisc.f90 @@ -1,1116 +1,1116 @@ - - -#include "macrodef.fh" - -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif -!--------------------------------------------------------------------------------------------------- -! copy a point of data into data target for vertext center code -!--------------------------------------------------------------------------------------------------- - subroutine pointcopy(wei,llbout,uubout,ext_out,data_out,xx,yy,zz,dv) - implicit none - integer,intent(in) :: wei - integer,dimension(3),intent(in) ::ext_out - real*8,dimension(3) :: llbout,uubout - real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out - real*8,intent(in) :: xx,yy,zz,dv - - real*8,dimension(3) :: ho - integer :: i,j,k - -!sanity check - if(wei.ne.3)then - write(*,*)"fmisc.f90::pointcopy: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -!!! - if(any(ext_out == 1))then - write(*,*)"fmisc.f90::pointcopy: meets iolated points for out data" - write(*,*) llbout,uubout - stop - else - ho = (uubout-llbout)/(ext_out-1) - endif - i = idint((xx-llbout(1))/ho(1)+0.4)+1 - j = idint((yy-llbout(2))/ho(2)+0.4)+1 - k = idint((zz-llbout(3))/ho(3)+0.4)+1 - - if(i<1 .or. i>ext_out(1) .or. & - j<1 .or. j>ext_out(2) .or. & - k<1 .or. k>ext_out(3) )then - write(*,*)"i,j,k = ",i,j,k - write(*,*)"ext = ",ext_out - stop - endif - if(dabs(llbout(1)+(i-1)*ho(1)-xx)>ho(1)/2 .or. & - dabs(llbout(2)+(j-1)*ho(2)-yy)>ho(2)/2 .or. & - dabs(llbout(3)+(k-1)*ho(3)-zz)>ho(3)/2 )then - write(*,*)"fmisc.f90::pointcopy: llbout = ",llbout - write(*,*)"fmisc.f90::pointcopy: ho = ",ho - write(*,*)"fmisc.f90::pointcopy: x,y,z = ",llbout(1)+(i-1)*ho(1),llbout(2)+(j-1)*ho(2),llbout(3)+(k-1)*ho(3) - write(*,*)"fmisc.f90::pointcopy: point = ",xx,yy,zz - stop - endif - - data_out(i,j,k)=dv - - return - - end subroutine pointcopy -!--------------------------------------------------------------------------------------------------- -! copy a part of data from data source, for vertex center code -!--------------------------------------------------------------------------------------------------- - subroutine copy(wei,llbout,uubout,ext_out,data_out,llbin,uubin,ext_in,data_in,lcopy,ucopy) - implicit none - integer,intent(in) :: wei - integer,dimension(3),intent(in) ::ext_out,ext_in - real*8,dimension(3),intent(in) :: lcopy,ucopy - real*8,dimension(3) :: llbout,uubout,llbin,uubin - real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out - real*8,dimension(ext_in(1),ext_in(2),ext_in(3)),intent(in)::data_in - - real*8,dimension(3) :: ho,hi - integer,dimension(3) :: illo,iuuo,illi,iuui - -!sanity check - if(wei.ne.3)then - write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -!!! - if(any(ext_out == 1))then - if(any(ext_in == 1))then - write(*,*)"fmisc.f90::copy: meets iolated points for both in and out data" - write(*,*) llbin,uubin - write(*,*) llbout,uubout - stop - else - hi = (uubin-llbin)/(ext_in-1) - ho = hi - endif - else - ho = (uubout-llbout)/(ext_out-1) - if(any(ext_in == 1))then - hi = ho - else - hi = (uubin-llbin)/(ext_in-1) - if(any(abs(hi-ho) > min(hi,ho)/2))then - write(*,*)"fmisc.f90::copy: meets copy reqest for different numerical grid" - write(*,*)hi,ho - stop - endif - endif - endif - illo = idint((lcopy-llbout)/ho+0.4)+1 - iuuo = ext_out - idint((uubout-ucopy)/ho+0.4) - illi = idint((lcopy-llbin)/hi+0.4)+1 - iuui = ext_in - idint((uubin-ucopy)/hi+0.4) - - if(any(llbout-lcopy>ho/2) .or. any(ucopy-uubout>ho/2))then - write(*,*)"fmisc.f90::copy: llbout = ",llbout - write(*,*)"fmisc.f90::copy: uubout = ",uubout - write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy - write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy - write(*,*)"fmisc.f90::copy: ho = ",ho - write(*,*)llbout-lcopy,ucopy-uubout - stop - elseif(any(llbin -lcopy>hi/2) .or. any(ucopy-uubin >hi/2))then - write(*,*)"fmisc.f90::copy: llbin = ",llbin - write(*,*)"fmisc.f90::copy: uubin = ",uubin - write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy - write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy - stop - elseif(any(illo<1) .or. any(illi<1) .or. any(illo-iuuo>0) .or. any(illi-iuui>0) .or. & - any(iuui-ext_in>0) .or. any(iuuo-ext_out>0))then - write(*,*)"fmisc.f90::copy: illi = ",illi - write(*,*)"fmisc.f90::copy: iuui = ",iuui - write(*,*)"fmisc.f90::copy: illo = ",illo - write(*,*)"fmisc.f90::copy: iuuo = ",iuuo - write(*,*)"fmisc.f90::copy: llbout = ",llbout - write(*,*)"fmisc.f90::copy: uubout = ",uubout - write(*,*)"fmisc.f90::copy: llbin = ",llbin - write(*,*)"fmisc.f90::copy: uubin = ",uubin - write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy - write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy - stop - endif - - data_out(illo(1):iuuo(1),illo(2):iuuo(2),illo(3):iuuo(3))=data_in(illi(1):iuui(1),illi(2):iuui(2),illi(3):iuui(3)) - - return - - end subroutine copy -!----------------------------------------------------------------------------------------------------------------- -! three dimensional interpolation for vertex center grid structure - subroutine global_interp(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3), symmetry,ORDN - real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1,z1 - real*8, dimension(3), intent(in) :: SoA - -!~~~~~~> Other parameters: - - integer :: j,m,imin,jmin,kmin - integer,dimension(3) :: cxB,cxT,cxI,cmin,cmax - real*8,dimension(3) :: cx - real*8, dimension(1:ORDN) :: x1a - real*8, dimension(1:ORDN,1:ORDN,1:ORDN) :: ya - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8 :: dX,dY,dZ,ddy - real*8, parameter :: ONE=1.d0 - logical::decide3d - - imin = lbound(f,1) - jmin = lbound(f,2) - kmin = lbound(f,3) - - dX = X(imin+1)-X(imin) - dY = Y(jmin+1)-Y(jmin) - dZ = Z(kmin+1)-Z(kmin) - - forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE - - cxI(1) = idint((x1-X(1))/dX+0.4)+1 - cxI(2) = idint((y1-Y(1))/dY+0.4)+1 - cxI(3) = idint((z1-Z(1))/dZ+0.4)+1 - - cxB = cxI - ORDN/2+1 - cxT = cxB + ORDN - 1 - - cmin = 1 - cmax = ex - if(Symmetry == OCTANT .and.dabs(X(1)) cmax(m))then - cxT(m) = cmax(m) - cxB(m) = cxT(m) + 1 - ORDN - endif - enddo - if(cxB(1)>0)then - cx(1) = (x1 - X(cxB(1)))/dX - else - cx(1) = (x1 + X(2-cxB(1)))/dX - endif - if(cxB(2)>0)then - cx(2) = (y1 - Y(cxB(2)))/dY - else - cx(2) = (y1 + Y(2-cxB(2)))/dY - endif - if(cxB(3)>0)then - cx(3) = (z1 - Z(cxB(3)))/dZ - else - cx(3) = (z1 + Z(2-cxB(3)))/dZ - endif - - if(decide3d(ex,f,f,cxB,cxT,SoA,ya,ORDN,Symmetry))then - write(*,*)"global_interp position: ",x1,y1,z1 - write(*,*)"data range: ",X(1),X(ex(1)),Y(1),Y(ex(2)),Z(1),Z(ex(3)) - stop - endif - call polin3(x1a,x1a,x1a,ya,cx(1),cx(2),cx(3),f_int,ddy,ORDN) - - return - - end subroutine global_interp -!---------------------------------------------------------------- -! decide which 3d data to be used does not surport PI-Symmetry yet -!---------------------------------------------------------------- - function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont) - implicit none - - integer, intent(in) :: ORDN,Symmetry - integer,dimension(1:3) , intent(in) :: ex,cxB,cxT - real*8, dimension(1:3) , intent(in) :: SoA - real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi - real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya - logical::gont - - integer,dimension(1:3) :: fmin1,fmin2,fmax1,fmax2 - integer::i,j,k,m - - gont=.false. - do m=1,3 -! check cxB and cxT are NaN or not - if(.not.(iabs(cxB(m)).ge.0)) gont=.true. - if(.not.(iabs(cxT(m)).ge.0)) gont=.true. - fmin1(m) = max(1,cxB(m)) - fmax1(m) = cxT(m) - fmin2(m) = cxB(m) - fmax2(m) = min(0,cxT(m)) - if((fmin1(m).le.fmax1(m)).and.( fmin1(m)<1.or. fmax1(m)>ex(m)))gont=.true. - if((fmin2(m).le.fmax2(m)).and.(2-fmax2(m)<1.or.2-fmin2(m)>ex(m)))gont=.true. - enddo -!sanity check - if(gont)then - write(*,*)"error in decide3d" - write(*,*)((fmin1.le.fmax1).and.( fmin1<1.or. fmax1>ex)) - write(*,*)((fmin2.le.fmax2).and.(2-fmax2<1.or.2-fmin2>ex)) - write(*,*)"cxB, cxT and data shape:" - write(*,*)cxB,cxT,ex - write(*,*)"resulted fmin1, fmax1 and fmin2, fmax2:" - write(*,*)fmin1,fmax1,fmin2,fmax2 - else - - do k=fmin1(3),fmax1(3) - do j=fmin1(2),fmax1(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,j,k) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(2-i,j,k)*SoA(1) - enddo - enddo - do j=fmin2(2),fmax2(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,2-j,k)*SoA(2) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(2-i,2-j,k)*SoA(1)*SoA(2) - enddo - enddo - enddo - - do k=fmin2(3),fmax2(3) - do j=fmin1(2),fmax1(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,j,2-k)*SoA(3) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(2-i,j,2-k)*SoA(1)*SoA(3) - enddo - enddo - do j=fmin2(2),fmax2(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,2-j,2-k)*SoA(2)*SoA(3) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(2-i,2-j,2-k)*SoA(1)*SoA(2)*SoA(3) - enddo - enddo - enddo - - endif - - end function decide3d - -!--------------------------------------------------------------------------------------- -subroutine symmetry_bd(ord,extc,func,funcc,SoA) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1),-ord+1:extc(2),-ord+1:extc(3)),intent(out):: funcc - real*8, dimension(1:3), intent(in) :: SoA - - integer::i - - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) - enddo - do i=0,ord-1 - funcc(:,-i,1:extc(3)) = funcc(:,i+2,1:extc(3))*SoA(2) - enddo - do i=0,ord-1 - funcc(:,:,-i) = funcc(:,:,i+2)*SoA(3) - enddo - -end subroutine symmetry_bd - -subroutine symmetry_tbd(ord,extc,func,funcc,SoA) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,-ord+1:extc(3)+ord),intent(out):: funcc - real*8, dimension(1:3), intent(in) :: SoA - - integer::i - - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) - funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA(1) - enddo - do i=0,ord-1 - funcc(:,-i,1:extc(3)) = funcc(:,i+2,1:extc(3))*SoA(2) - funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-1-i,1:extc(3))*SoA(2) - enddo - do i=0,ord-1 - funcc(:,:,-i) = funcc(:,:,i+2)*SoA(3) - funcc(:,:,extc(3)+1+i) = funcc(:,:,extc(3)-1-i)*SoA(3) - enddo - -end subroutine symmetry_tbd - -subroutine symmetry_stbd(ord,extc,func,funcc,SoA) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc - real*8, dimension(2), intent(in) :: SoA - - integer::i - - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) - funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA(1) - enddo - do i=0,ord-1 - funcc(:,-i,1:extc(3)) = funcc(:,i+2,1:extc(3))*SoA(2) - funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-1-i,1:extc(3))*SoA(2) - enddo - -end subroutine symmetry_stbd - -subroutine symmetry_sntbd(ord,extc,func,funcc,SoA,actd) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord,actd - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc - real*8, intent(in) :: SoA - - integer::i - - funcc = 0.d0 - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - if(actd==0)then - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA - funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA - enddo - elseif(actd==1)then - do i=0,ord-1 - funcc(1:extc(1),-i,1:extc(3)) = funcc(1:extc(1),i+2,1:extc(3))*SoA - funcc(1:extc(1),extc(2)+1+i,1:extc(3)) = funcc(1:extc(1),extc(2)-1-i,1:extc(3))*SoA - enddo - else - write(*,*)"symmetry_sntbd: not recognized actd = ",actd - endif - -end subroutine symmetry_sntbd - - -subroutine d2dump(wei,llb,uub,ext,data_in,data_out,gord,SoA) - implicit none - integer, intent(in) :: wei,gord - integer,dimension(3),intent(in) :: ext - real*8, dimension(3),intent(in) :: SoA - real*8, dimension(3) :: llb,uub - real*8, dimension(ext(1),ext(2),ext(3)),intent(in) ::data_in - real*8, dimension(ext(1),ext(2)), intent(inout)::data_out - - real*8 :: dZ - integer :: i,j,k - -!sanity check - if(wei.ne.3)then - write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - dZ = (uub(3)-llb(3))/(ext(3)-1) - k = idint((0-llb(3))/dZ+0.4)+1 - - if(k < 1)then - write(*,*) "d2dump: something must be wrong" - return - endif - - data_out(i,j) = data_in(i,j,k) - -end subroutine d2dump - -#else -#ifdef Cell -!subroutine interp_2 support cell center only -!----------------------------------------------------------------------------- -! -! Interpolate function f using weights Delx, Dely and Delz -! -!----------------------------------------------------------------------------- - - subroutine interp_2(ex,f,f_int,il,iu,jl,ju,kl,ku,Dx,Dy,Dz,& - ordn,SoA,symmetry) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3), symmetry - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - integer, intent(in) :: il,iu,jl,ju,kl,ku,ordn - real*8, intent(in) :: Dx,Dy,Dz,SoA(3) - -!~~~~~~> Other parameters: - - integer :: j,imin,jmin,kmin - real*8, dimension(1:ordn) :: x1a - real*8, dimension(1:ordn,1:ordn,1:ordn) :: ya - real*8, parameter :: ONE=1.d0 - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8 :: ddy,symX,symY,symZ - - symX = SoA(1) - symY = SoA(2) - symZ = SoA(3) - - imin = lbound(f,1) - jmin = lbound(f,2) - kmin = lbound(f,3) - - forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE - - ya(2:ordn,2:ordn,2:ordn) = f(il+1:iu,jl+1:ju,kl+1:ku) - - if( il < imin .and. symmetry < OCTANT ) then - write(*,*) 'Error in interp_2!!!' - stop - endif - if( il < imin ) then - ya(1,2:ordn,2:ordn) = f(imin,jl+1:ju,kl+1:ku)* symX - else - ya(1,2:ordn,2:ordn) = f(il ,jl+1:ju,kl+1:ku) - endif - - if( jl < jmin .and. symmetry < OCTANT ) then - write(*,*) 'Error in interp_2!!!' - stop - endif - - if( jl < jmin ) then - ya(2:ordn,1,2:ordn) = f(il+1:iu,jmin,kl+1:ku)* symY - else - ya(2:ordn,1,2:ordn) = f(il+1:iu,jl,kl+1:ku) - endif - - if( kl < kmin .and. symmetry < EQUATORIAL ) then - write(*,*) 'Error in interp_2!!!' - stop - endif - - if( kl < kmin ) then - ya(2:ordn,2:ordn,1) = f(il+1:iu,jl+1:ju,kmin)* symZ - else - ya(2:ordn,2:ordn,1) = f(il+1:iu,jl+1:ju,kl ) - endif - - if( il < imin .and. jl < jmin ) then - ya(1,1,2:ordn) = f(imin,jmin,kl+1:ku)* symX * symY - else if( il >= imin .and. jl < jmin ) then - ya(1,1,2:ordn) = f(il,jmin,kl+1:ku)* symY - else if( il < imin .and. jl >= jmin ) then - ya(1,1,2:ordn) = f(imin,jl,kl+1:ku)* symX - else - ya(1,1,2:ordn) = f(il,jl,kl+1:ku) - endif - - if( il < imin .and. kl < kmin ) then - ya(1,2:ordn,1) = f(imin,jl+1:ju,kmin)* symX * symZ - else if( il >= imin .and. kl < kmin ) then - ya(1,2:ordn,1) = f(il,jl+1:ju,kmin)* symZ - else if( il < imin .and. kl >= kmin ) then - ya(1,2:ordn,1) = f(imin,jl+1:ju,kl)* symX - else - ya(1,2:ordn,1) = f(il,jl+1:ju,kl) - endif - - if( jl < jmin .and. kl < kmin ) then - ya(2:ordn,1,1) = f(il+1:iu,jmin,kmin)* symY * symZ - else if( jl >= jmin .and. kl < kmin ) then - ya(2:ordn,1,1) = f(il+1:iu,jl,kmin)* symZ - else if( jl < jmin .and. kl >= kmin ) then - ya(2:ordn,1,1) = f(il+1:iu,jmin,kl)* symY - else - ya(2:ordn,1,1) = f(il+1:iu,jl,kl) - endif - - if( il < imin ) then - if( jl < jmin .and. kl < kmin) then - ya(1,1,1) = f(imin,jmin,kmin)* symX * symY * symZ - else if( jl >= jmin .and. kl < kmin ) then - ya(1,1,1) = f(imin,jl,kmin)* symX * symZ - else if( jl < jmin .and. kl >= kmin ) then - ya(1,1,1) = f(imin,jmin,kl)* symX * symY - else - ya(1,1,1) = f(imin,jl,kl)* symX - endif - else - if( jl < jmin .and. kl < kmin) then - ya(1,1,1) = f(il,jmin,kmin)* symY * symZ - else if( jl >= jmin .and. kl < kmin ) then - ya(1,1,1) = f(il,jl,kmin)* symZ - else if( jl < jmin .and. kl >= kmin ) then - ya(1,1,1) = f(il,jmin,kl)* symY - else - ya(1,1,1) = f(il,jl,kl) - endif - endif - - call polin3(x1a,x1a,x1a,ya,Dx,Dy,Dz,f_int,ddy,ordn) - - if(.not.(dabs(f_int).ge.0))then - write(*,*)"find nan in interp_2:",f_int,"inputs are:" -! write(*,*)ya -! write(*,*)"-----------------------------------------" -! write(*,*)f(il:iu,jl:ju,kl:ku) - write(*,*)Dx,Dy,Dz,symx,symy,symz,ordn - write(*,*)il,iu,jl,ju,kl,ku,ex,symmetry - endif - - return - - end subroutine interp_2 -!--------------------------------------------------------------------------------------------------- -! copy a point of data into data target for vertext center code -!--------------------------------------------------------------------------------------------------- - subroutine pointcopy(wei,llbout,uubout,ext_out,data_out,xx,yy,zz,dv) - implicit none - integer,intent(in) :: wei - integer,dimension(3),intent(in) ::ext_out - real*8,dimension(3) :: llbout,uubout - real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out - real*8,intent(in) :: xx,yy,zz,dv - - real*8,dimension(3) :: ho - integer :: i,j,k - -!sanity check - if(wei.ne.3)then - write(*,*)"fmisc.f90::pointcopy: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -!!! - ho = (uubout-llbout)/ext_out - i = idint((xx-llbout(1))/ho(1)+0.4)+1 - j = idint((yy-llbout(2))/ho(2)+0.4)+1 - k = idint((zz-llbout(3))/ho(3)+0.4)+1 - - if(i<1 .or. i>ext_out(1) .or. & - j<1 .or. j>ext_out(2) .or. & - k<1 .or. k>ext_out(3) )then - write(*,*)"i,j,k = ",i,j,k - write(*,*)"ext = ",ext_out - stop - endif - if(dabs(llbout(1)+(i-0.5)*ho(1)-xx)>ho(1)/2 .or. & - dabs(llbout(2)+(j-0.5)*ho(2)-yy)>ho(2)/2 .or. & - dabs(llbout(3)+(k-0.5)*ho(3)-zz)>ho(3)/2 )then - write(*,*)"fmisc.f90::pointcopy: llbout = ",llbout - write(*,*)"fmisc.f90::pointcopy: ho = ",ho - write(*,*)"fmisc.f90::pointcopy: x,y,z = ",llbout(1)+(i-0.5)*ho(1),llbout(2)+(j-0.5)*ho(2),llbout(3)+(k-0.5)*ho(3) - write(*,*)"fmisc.f90::pointcopy: point = ",xx,yy,zz - stop - endif - - data_out(i,j,k)=dv - - return - - end subroutine pointcopy -!--------------------------------------------------------------------------------------------------- -! copy a part of data from data source, for cell center code -!--------------------------------------------------------------------------------------------------- - subroutine copy(wei,llbout,uubout,ext_out,data_out,llbin,uubin,ext_in,data_in,lcopy,ucopy) - implicit none - integer,intent(in) :: wei - integer,dimension(3),intent(in) ::ext_out,ext_in - real*8,dimension(3),intent(in) :: lcopy,ucopy - real*8,dimension(3) :: llbout,uubout,llbin,uubin - real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out - real*8,dimension(ext_in(1),ext_in(2),ext_in(3)),intent(in)::data_in - - real*8,dimension(3) :: ho,hi - integer,dimension(3) :: illo,iuuo,illi,iuui - -!sanity check - if(wei.ne.3)then - write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - -!!! - ho = (uubout-llbout)/ext_out - hi = (uubin-llbin)/ext_in - illo = idint((lcopy-llbout)/ho+0.4)+1 - iuuo = ext_out - idint((uubout-ucopy)/ho+0.4) - illi = idint((lcopy-llbin)/hi+0.4)+1 - iuui = ext_in - idint((uubin-ucopy)/hi+0.4) - - if(any(llbout-lcopy>ho/2) .or. any(ucopy-uubout>ho/2))then - write(*,*)"fmisc.f90::copy: llbout = ",llbout - write(*,*)"fmisc.f90::copy: uubout = ",uubout - write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy - write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy - write(*,*)"fmisc.f90::copy: ho = ",ho - write(*,*)llbout-lcopy,ucopy-uubout - stop - elseif(any(llbin -lcopy>hi/2) .or. any(ucopy-uubin >hi/2))then - write(*,*)"fmisc.f90::copy: llbin = ",llbin - write(*,*)"fmisc.f90::copy: uubin = ",uubin - write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy - write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy - stop - elseif(any(illo<1) .or. any(illi<1) .or. any(illo-iuuo>0) .or. any(illi-iuui>0) .or. & - any(iuui-ext_in>0) .or. any(iuuo-ext_out>0))then - write(*,*)"fmisc.f90::copy: illi = ",illi - write(*,*)"fmisc.f90::copy: iuui = ",iuui - write(*,*)"fmisc.f90::copy: illo = ",illo - write(*,*)"fmisc.f90::copy: iuuo = ",iuuo - write(*,*)"fmisc.f90::copy: llbout = ",llbout - write(*,*)"fmisc.f90::copy: uubout = ",uubout - write(*,*)"fmisc.f90::copy: llbin = ",llbin - write(*,*)"fmisc.f90::copy: uubin = ",uubin - write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy - write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy - stop - endif - - data_out(illo(1):iuuo(1),illo(2):iuuo(2),illo(3):iuuo(3))=data_in(illi(1):iuui(1),illi(2):iuui(2),illi(3):iuui(3)) - - return - - end subroutine copy -!-------------------------------------------------------------------------- -! three dimensional interpolation for cell center grid structure - subroutine global_interp(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3), symmetry,ORDN - real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1,z1 - real*8, dimension(3), intent(in) :: SoA - -!~~~~~~> Other parameters: - - integer :: j,m,imin,jmin,kmin - integer,dimension(3) :: cxB,cxT,cxI,cmin,cmax - real*8,dimension(3) :: cx - real*8, dimension(1:ORDN) :: x1a - real*8, dimension(1:ORDN,1:ORDN,1:ORDN) :: ya - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8 :: dX,dY,dZ,ddy - real*8, parameter :: ONE=1.d0 - logical::decide3d - - imin = lbound(f,1) - jmin = lbound(f,2) - kmin = lbound(f,3) - - dX = X(imin+1)-X(imin) - dY = Y(jmin+1)-Y(jmin) - dZ = Z(kmin+1)-Z(kmin) - - forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE - - cxI(1) = idint((x1-X(1))/dX+0.4)+1 - cxI(2) = idint((y1-Y(1))/dY+0.4)+1 - cxI(3) = idint((z1-Z(1))/dZ+0.4)+1 - - cxB = cxI - ORDN/2+1 - cxT = cxB + ORDN - 1 - - cmin = 1 - cmax = ex - if(Symmetry == OCTANT .and.dabs(X(1)) cmax(m))then - cxT(m) = cmax(m) - cxB(m) = cxT(m) + 1 - ORDN - endif - enddo - if(cxB(1)>0)then - cx(1) = (x1 - X(cxB(1)))/dX - else - cx(1) = (x1 + X(1-cxB(1)))/dX - endif - if(cxB(2)>0)then - cx(2) = (y1 - Y(cxB(2)))/dY - else - cx(2) = (y1 + Y(1-cxB(2)))/dY - endif - if(cxB(3)>0)then - cx(3) = (z1 - Z(cxB(3)))/dZ - else - cx(3) = (z1 + Z(1-cxB(3)))/dZ - endif - - if(decide3d(ex,f,f,cxB,cxT,SoA,ya,ORDN,Symmetry))then - write(*,*)"global_interp position: ",x1,y1,z1 - write(*,*)"data range: ",X(1),X(ex(1)),Y(1),Y(ex(2)),Z(1),Z(ex(3)) - stop - endif - call polin3(x1a,x1a,x1a,ya,cx(1),cx(2),cx(3),f_int,ddy,ORDN) - - return - - end subroutine global_interp -!---------------------------------------------------------------- -! decide which 3d data to be used does not surport PI-Symmetry yet -!---------------------------------------------------------------- - function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont) - implicit none - - integer, intent(in) :: ORDN,Symmetry - integer,dimension(1:3) , intent(in) :: ex,cxB,cxT - real*8, dimension(1:3) , intent(in) :: SoA - real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi - real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya - logical::gont - - integer,dimension(1:3) :: fmin1,fmin2,fmax1,fmax2 - integer::i,j,k,m - - gont=.false. - do m=1,3 -! check cxB and cxT are NaN or not - if(.not.(iabs(cxB(m)).ge.0)) gont=.true. - if(.not.(iabs(cxT(m)).ge.0)) gont=.true. - fmin1(m) = max(1,cxB(m)) - fmax1(m) = cxT(m) - fmin2(m) = cxB(m) - fmax2(m) = min(0,cxT(m)) - if((fmin1(m).le.fmax1(m)).and.( fmin1(m)<1.or. fmax1(m)>ex(m)))gont=.true. - if((fmin2(m).le.fmax2(m)).and.(1-fmax2(m)<1.or.1-fmin2(m)>ex(m)))gont=.true. - enddo -!sanity check - if(gont)then - write(*,*)"error in decide3d" - write(*,*)((fmin1.le.fmax1).and.( fmin1<1.or. fmax1>ex)) - write(*,*)((fmin2.le.fmax2).and.(1-fmax2<1.or.1-fmin2>ex)) - write(*,*)"cxB, cxT and data shape:" - write(*,*)cxB,cxT,ex - write(*,*)"resulted fmin1, fmax1 and fmin2, fmax2:" - write(*,*)fmin1,fmax1,fmin2,fmax2 - else - - do k=fmin1(3),fmax1(3) - do j=fmin1(2),fmax1(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,j,k) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(1-i,j,k)*SoA(1) - enddo - enddo - do j=fmin2(2),fmax2(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,1-j,k)*SoA(2) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(1-i,1-j,k)*SoA(1)*SoA(2) - enddo - enddo - enddo - - do k=fmin2(3),fmax2(3) - do j=fmin1(2),fmax1(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,j,1-k)*SoA(3) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(1-i,j,1-k)*SoA(1)*SoA(3) - enddo - enddo - do j=fmin2(2),fmax2(2) - do i=fmin1(1),fmax1(1) - ya(i,j,k) = f(i,1-j,1-k)*SoA(2)*SoA(3) - enddo - do i=fmin2(1),fmax2(1) - ya(i,j,k) = f(1-i,1-j,1-k)*SoA(1)*SoA(2)*SoA(3) - enddo - enddo - enddo - - endif - - end function decide3d - -!--------------------------------------------------------------------------------------- -subroutine symmetry_bd(ord,extc,func,funcc,SoA) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1),-ord+1:extc(2),-ord+1:extc(3)),intent(out):: funcc - real*8, dimension(1:3), intent(in) :: SoA - - integer::i - -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) - funcc(1:extc(1),1:extc(2),1:extc(3)) = func -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA(1) - enddo -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) - do i=0,ord-1 - funcc(:,-i,1:extc(3)) = funcc(:,i+1,1:extc(3))*SoA(2) - enddo -!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) - do i=0,ord-1 - funcc(:,:,-i) = funcc(:,:,i+1)*SoA(3) - enddo - -end subroutine symmetry_bd - -subroutine symmetry_tbd(ord,extc,func,funcc,SoA) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,-ord+1:extc(3)+ord),intent(out):: funcc - real*8, dimension(1:3), intent(in) :: SoA - - integer::i - - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA(1) - funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-i,1:extc(2),1:extc(3))*SoA(1) - enddo - do i=0,ord-1 - funcc(:,-i,1:extc(3)) = funcc(:,i+1,1:extc(3))*SoA(2) - funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-i,1:extc(3))*SoA(2) - enddo - do i=0,ord-1 - funcc(:,:,-i) = funcc(:,:,i+1)*SoA(3) - funcc(:,:,extc(3)+1+i) = funcc(:,:,extc(3)-i)*SoA(3) - enddo - -end subroutine symmetry_tbd - -subroutine symmetry_stbd(ord,extc,func,funcc,SoA) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc - real*8, dimension(2), intent(in) :: SoA - - integer::i - - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA(1) - funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-i,1:extc(2),1:extc(3))*SoA(1) - enddo - do i=0,ord-1 - funcc(:,-i,1:extc(3)) = funcc(:,i+1,1:extc(3))*SoA(2) - funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-i,1:extc(3))*SoA(2) - enddo - -end subroutine symmetry_stbd - -subroutine symmetry_sntbd(ord,extc,func,funcc,SoA,actd) - implicit none - -!~~~~~~> input arguments - integer,intent(in) :: ord,actd - integer,dimension(3), intent(in) :: extc - real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func - real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc - real*8, intent(in) :: SoA - - integer::i - - funcc = 0.d0 - funcc(1:extc(1),1:extc(2),1:extc(3)) = func - if(actd==0)then - do i=0,ord-1 - funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA - funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-i,1:extc(2),1:extc(3))*SoA - enddo - elseif(actd==1)then - do i=0,ord-1 - funcc(1:extc(1),-i,1:extc(3)) = funcc(1:extc(1),i+1,1:extc(3))*SoA - funcc(1:extc(1),extc(2)+1+i,1:extc(3)) = funcc(1:extc(1),extc(2)-i,1:extc(3))*SoA - enddo - else - write(*,*)"symmetry_sntbd: not recognized actd = ",actd - endif - -end subroutine symmetry_sntbd - -subroutine d2dump(wei,llb,uub,ext,data_in,data_out,gord,SoA) - implicit none - integer,intent(in) :: wei,gord - integer,dimension(3),intent(in) ::ext - real*8,dimension(3),intent(in) :: SoA - real*8,dimension(3) :: llb,uub - real*8,dimension(ext(1),ext(2),ext(3)),intent(in)::data_in - real*8,dimension(ext(1),ext(2)),intent(inout)::data_out - - real*8 :: dZ - integer :: i,j,k - -!sanity check - if(wei.ne.3)then - write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" - write(*,*)"dim = ",wei - stop - endif - - dZ = (uub(3)-llb(3))/ext(3) - k = idint((0-llb(3))/dZ+0.4)+1 - - select case (gord) - case (2) - if(k > 2)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.5625d0*(data_in(i,j,k)+data_in(i,j,k-1))-0.0625d0*(data_in(i,j,k+1)+data_in(i,j,k-2)) - enddo - enddo - else if(k == 1)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.5625d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k))-0.0625d0*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) - enddo - enddo - else - write(*,*) "d2dump: something must be wrong, k = ",k - return - endif - case (3) - if(k > 3)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.5859375d0*(data_in(i,j,k)+data_in(i,j,k-1)) & - -0.9765625d-1*(data_in(i,j,k+1)+data_in(i,j,k-2)) & - +0.1171875d-1*(data_in(i,j,k+2)+data_in(i,j,k-3)) - enddo - enddo - else if(k == 1)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.5859375d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k)) & - -0.9765625d-1*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) & - +0.1171875d-1*(data_in(i,j,k+2)+SoA(3)*data_in(i,j,k+2)) - enddo - enddo - else - write(*,*) "d2dump: something must be wrong, k = ",k - return - endif - case (4) - if(k > 4)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.5981445312d0*(data_in(i,j,k)+data_in(i,j,k-1)) & - -0.1196289063d0*(data_in(i,j,k+1)+data_in(i,j,k-2)) & - +0.2392578125d-1*(data_in(i,j,k+2)+data_in(i,j,k-3)) & - -0.2441406250d-2*(data_in(i,j,k+3)+data_in(i,j,k-4)) - enddo - enddo - else if(k == 1)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.5981445312d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k)) & - -0.1196289063d0*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) & - +0.2392578125d-1*(data_in(i,j,k+2)+SoA(3)*data_in(i,j,k+2)) & - -0.2441406250d-2*(data_in(i,j,k+3)+SoA(3)*data_in(i,j,k+3)) - enddo - enddo - else - write(*,*) "d2dump: something must be wrong, k = ",k - return - endif - case (5) - if(k > 5)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.6056213378d0*(data_in(i,j,k)+data_in(i,j,k-1)) & - -0.1345825196d0*(data_in(i,j,k+1)+data_in(i,j,k-2)) & - +0.3460693359d-1*(data_in(i,j,k+2)+data_in(i,j,k-3)) & - -0.6179809571d-2*(data_in(i,j,k+3)+data_in(i,j,k-4)) & - +0.5340576171d-3*(data_in(i,j,k+4)+data_in(i,j,k-5)) - enddo - enddo - else if(k == 1)then - do i=1,ext(1) - do j=1,ext(2) - data_out(i,j) = 0.6056213378d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k)) & - -0.1345825196d0*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) & - +0.3460693359d-1*(data_in(i,j,k+2)+SoA(3)*data_in(i,j,k+2)) & - -0.6179809571d-2*(data_in(i,j,k+3)+SoA(3)*data_in(i,j,k+3)) & - +0.5340576171d-3*(data_in(i,j,k+4)+SoA(3)*data_in(i,j,k+4)) - enddo - enddo - else - write(*,*) "d2dump: something must be wrong, k = ",k - return - endif - case default - write(*,*) "d2dump: not recognized ord = ",gord - return - end select - -end subroutine d2dump - -#else -#error Not define Vertex nor Cell -#endif -#endif -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + +#include "macrodef.fh" + +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif +!--------------------------------------------------------------------------------------------------- +! copy a point of data into data target for vertext center code +!--------------------------------------------------------------------------------------------------- + subroutine pointcopy(wei,llbout,uubout,ext_out,data_out,xx,yy,zz,dv) + implicit none + integer,intent(in) :: wei + integer,dimension(3),intent(in) ::ext_out + real*8,dimension(3) :: llbout,uubout + real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out + real*8,intent(in) :: xx,yy,zz,dv + + real*8,dimension(3) :: ho + integer :: i,j,k + +!sanity check + if(wei.ne.3)then + write(*,*)"fmisc.f90::pointcopy: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +!!! + if(any(ext_out == 1))then + write(*,*)"fmisc.f90::pointcopy: meets iolated points for out data" + write(*,*) llbout,uubout + stop + else + ho = (uubout-llbout)/(ext_out-1) + endif + i = idint((xx-llbout(1))/ho(1)+0.4)+1 + j = idint((yy-llbout(2))/ho(2)+0.4)+1 + k = idint((zz-llbout(3))/ho(3)+0.4)+1 + + if(i<1 .or. i>ext_out(1) .or. & + j<1 .or. j>ext_out(2) .or. & + k<1 .or. k>ext_out(3) )then + write(*,*)"i,j,k = ",i,j,k + write(*,*)"ext = ",ext_out + stop + endif + if(dabs(llbout(1)+(i-1)*ho(1)-xx)>ho(1)/2 .or. & + dabs(llbout(2)+(j-1)*ho(2)-yy)>ho(2)/2 .or. & + dabs(llbout(3)+(k-1)*ho(3)-zz)>ho(3)/2 )then + write(*,*)"fmisc.f90::pointcopy: llbout = ",llbout + write(*,*)"fmisc.f90::pointcopy: ho = ",ho + write(*,*)"fmisc.f90::pointcopy: x,y,z = ",llbout(1)+(i-1)*ho(1),llbout(2)+(j-1)*ho(2),llbout(3)+(k-1)*ho(3) + write(*,*)"fmisc.f90::pointcopy: point = ",xx,yy,zz + stop + endif + + data_out(i,j,k)=dv + + return + + end subroutine pointcopy +!--------------------------------------------------------------------------------------------------- +! copy a part of data from data source, for vertex center code +!--------------------------------------------------------------------------------------------------- + subroutine copy(wei,llbout,uubout,ext_out,data_out,llbin,uubin,ext_in,data_in,lcopy,ucopy) + implicit none + integer,intent(in) :: wei + integer,dimension(3),intent(in) ::ext_out,ext_in + real*8,dimension(3),intent(in) :: lcopy,ucopy + real*8,dimension(3) :: llbout,uubout,llbin,uubin + real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out + real*8,dimension(ext_in(1),ext_in(2),ext_in(3)),intent(in)::data_in + + real*8,dimension(3) :: ho,hi + integer,dimension(3) :: illo,iuuo,illi,iuui + +!sanity check + if(wei.ne.3)then + write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +!!! + if(any(ext_out == 1))then + if(any(ext_in == 1))then + write(*,*)"fmisc.f90::copy: meets iolated points for both in and out data" + write(*,*) llbin,uubin + write(*,*) llbout,uubout + stop + else + hi = (uubin-llbin)/(ext_in-1) + ho = hi + endif + else + ho = (uubout-llbout)/(ext_out-1) + if(any(ext_in == 1))then + hi = ho + else + hi = (uubin-llbin)/(ext_in-1) + if(any(abs(hi-ho) > min(hi,ho)/2))then + write(*,*)"fmisc.f90::copy: meets copy reqest for different numerical grid" + write(*,*)hi,ho + stop + endif + endif + endif + illo = idint((lcopy-llbout)/ho+0.4)+1 + iuuo = ext_out - idint((uubout-ucopy)/ho+0.4) + illi = idint((lcopy-llbin)/hi+0.4)+1 + iuui = ext_in - idint((uubin-ucopy)/hi+0.4) + + if(any(llbout-lcopy>ho/2) .or. any(ucopy-uubout>ho/2))then + write(*,*)"fmisc.f90::copy: llbout = ",llbout + write(*,*)"fmisc.f90::copy: uubout = ",uubout + write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy + write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy + write(*,*)"fmisc.f90::copy: ho = ",ho + write(*,*)llbout-lcopy,ucopy-uubout + stop + elseif(any(llbin -lcopy>hi/2) .or. any(ucopy-uubin >hi/2))then + write(*,*)"fmisc.f90::copy: llbin = ",llbin + write(*,*)"fmisc.f90::copy: uubin = ",uubin + write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy + write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy + stop + elseif(any(illo<1) .or. any(illi<1) .or. any(illo-iuuo>0) .or. any(illi-iuui>0) .or. & + any(iuui-ext_in>0) .or. any(iuuo-ext_out>0))then + write(*,*)"fmisc.f90::copy: illi = ",illi + write(*,*)"fmisc.f90::copy: iuui = ",iuui + write(*,*)"fmisc.f90::copy: illo = ",illo + write(*,*)"fmisc.f90::copy: iuuo = ",iuuo + write(*,*)"fmisc.f90::copy: llbout = ",llbout + write(*,*)"fmisc.f90::copy: uubout = ",uubout + write(*,*)"fmisc.f90::copy: llbin = ",llbin + write(*,*)"fmisc.f90::copy: uubin = ",uubin + write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy + write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy + stop + endif + + data_out(illo(1):iuuo(1),illo(2):iuuo(2),illo(3):iuuo(3))=data_in(illi(1):iuui(1),illi(2):iuui(2),illi(3):iuui(3)) + + return + + end subroutine copy +!----------------------------------------------------------------------------------------------------------------- +! three dimensional interpolation for vertex center grid structure + subroutine global_interp(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3), symmetry,ORDN + real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1,z1 + real*8, dimension(3), intent(in) :: SoA + +!~~~~~~> Other parameters: + + integer :: j,m,imin,jmin,kmin + integer,dimension(3) :: cxB,cxT,cxI,cmin,cmax + real*8,dimension(3) :: cx + real*8, dimension(1:ORDN) :: x1a + real*8, dimension(1:ORDN,1:ORDN,1:ORDN) :: ya + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8 :: dX,dY,dZ,ddy + real*8, parameter :: ONE=1.d0 + logical::decide3d + + imin = lbound(f,1) + jmin = lbound(f,2) + kmin = lbound(f,3) + + dX = X(imin+1)-X(imin) + dY = Y(jmin+1)-Y(jmin) + dZ = Z(kmin+1)-Z(kmin) + + forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE + + cxI(1) = idint((x1-X(1))/dX+0.4)+1 + cxI(2) = idint((y1-Y(1))/dY+0.4)+1 + cxI(3) = idint((z1-Z(1))/dZ+0.4)+1 + + cxB = cxI - ORDN/2+1 + cxT = cxB + ORDN - 1 + + cmin = 1 + cmax = ex + if(Symmetry == OCTANT .and.dabs(X(1)) cmax(m))then + cxT(m) = cmax(m) + cxB(m) = cxT(m) + 1 - ORDN + endif + enddo + if(cxB(1)>0)then + cx(1) = (x1 - X(cxB(1)))/dX + else + cx(1) = (x1 + X(2-cxB(1)))/dX + endif + if(cxB(2)>0)then + cx(2) = (y1 - Y(cxB(2)))/dY + else + cx(2) = (y1 + Y(2-cxB(2)))/dY + endif + if(cxB(3)>0)then + cx(3) = (z1 - Z(cxB(3)))/dZ + else + cx(3) = (z1 + Z(2-cxB(3)))/dZ + endif + + if(decide3d(ex,f,f,cxB,cxT,SoA,ya,ORDN,Symmetry))then + write(*,*)"global_interp position: ",x1,y1,z1 + write(*,*)"data range: ",X(1),X(ex(1)),Y(1),Y(ex(2)),Z(1),Z(ex(3)) + stop + endif + call polin3(x1a,x1a,x1a,ya,cx(1),cx(2),cx(3),f_int,ddy,ORDN) + + return + + end subroutine global_interp +!---------------------------------------------------------------- +! decide which 3d data to be used does not surport PI-Symmetry yet +!---------------------------------------------------------------- + function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont) + implicit none + + integer, intent(in) :: ORDN,Symmetry + integer,dimension(1:3) , intent(in) :: ex,cxB,cxT + real*8, dimension(1:3) , intent(in) :: SoA + real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi + real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya + logical::gont + + integer,dimension(1:3) :: fmin1,fmin2,fmax1,fmax2 + integer::i,j,k,m + + gont=.false. + do m=1,3 +! check cxB and cxT are NaN or not + if(.not.(iabs(cxB(m)).ge.0)) gont=.true. + if(.not.(iabs(cxT(m)).ge.0)) gont=.true. + fmin1(m) = max(1,cxB(m)) + fmax1(m) = cxT(m) + fmin2(m) = cxB(m) + fmax2(m) = min(0,cxT(m)) + if((fmin1(m).le.fmax1(m)).and.( fmin1(m)<1.or. fmax1(m)>ex(m)))gont=.true. + if((fmin2(m).le.fmax2(m)).and.(2-fmax2(m)<1.or.2-fmin2(m)>ex(m)))gont=.true. + enddo +!sanity check + if(gont)then + write(*,*)"error in decide3d" + write(*,*)((fmin1.le.fmax1).and.( fmin1<1.or. fmax1>ex)) + write(*,*)((fmin2.le.fmax2).and.(2-fmax2<1.or.2-fmin2>ex)) + write(*,*)"cxB, cxT and data shape:" + write(*,*)cxB,cxT,ex + write(*,*)"resulted fmin1, fmax1 and fmin2, fmax2:" + write(*,*)fmin1,fmax1,fmin2,fmax2 + else + + do k=fmin1(3),fmax1(3) + do j=fmin1(2),fmax1(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,j,k) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(2-i,j,k)*SoA(1) + enddo + enddo + do j=fmin2(2),fmax2(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,2-j,k)*SoA(2) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(2-i,2-j,k)*SoA(1)*SoA(2) + enddo + enddo + enddo + + do k=fmin2(3),fmax2(3) + do j=fmin1(2),fmax1(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,j,2-k)*SoA(3) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(2-i,j,2-k)*SoA(1)*SoA(3) + enddo + enddo + do j=fmin2(2),fmax2(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,2-j,2-k)*SoA(2)*SoA(3) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(2-i,2-j,2-k)*SoA(1)*SoA(2)*SoA(3) + enddo + enddo + enddo + + endif + + end function decide3d + +!--------------------------------------------------------------------------------------- +subroutine symmetry_bd(ord,extc,func,funcc,SoA) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1),-ord+1:extc(2),-ord+1:extc(3)),intent(out):: funcc + real*8, dimension(1:3), intent(in) :: SoA + + integer::i + + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) + enddo + do i=0,ord-1 + funcc(:,-i,1:extc(3)) = funcc(:,i+2,1:extc(3))*SoA(2) + enddo + do i=0,ord-1 + funcc(:,:,-i) = funcc(:,:,i+2)*SoA(3) + enddo + +end subroutine symmetry_bd + +subroutine symmetry_tbd(ord,extc,func,funcc,SoA) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,-ord+1:extc(3)+ord),intent(out):: funcc + real*8, dimension(1:3), intent(in) :: SoA + + integer::i + + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) + funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA(1) + enddo + do i=0,ord-1 + funcc(:,-i,1:extc(3)) = funcc(:,i+2,1:extc(3))*SoA(2) + funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-1-i,1:extc(3))*SoA(2) + enddo + do i=0,ord-1 + funcc(:,:,-i) = funcc(:,:,i+2)*SoA(3) + funcc(:,:,extc(3)+1+i) = funcc(:,:,extc(3)-1-i)*SoA(3) + enddo + +end subroutine symmetry_tbd + +subroutine symmetry_stbd(ord,extc,func,funcc,SoA) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc + real*8, dimension(2), intent(in) :: SoA + + integer::i + + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA(1) + funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA(1) + enddo + do i=0,ord-1 + funcc(:,-i,1:extc(3)) = funcc(:,i+2,1:extc(3))*SoA(2) + funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-1-i,1:extc(3))*SoA(2) + enddo + +end subroutine symmetry_stbd + +subroutine symmetry_sntbd(ord,extc,func,funcc,SoA,actd) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord,actd + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc + real*8, intent(in) :: SoA + + integer::i + + funcc = 0.d0 + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + if(actd==0)then + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+2,1:extc(2),1:extc(3))*SoA + funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-1-i,1:extc(2),1:extc(3))*SoA + enddo + elseif(actd==1)then + do i=0,ord-1 + funcc(1:extc(1),-i,1:extc(3)) = funcc(1:extc(1),i+2,1:extc(3))*SoA + funcc(1:extc(1),extc(2)+1+i,1:extc(3)) = funcc(1:extc(1),extc(2)-1-i,1:extc(3))*SoA + enddo + else + write(*,*)"symmetry_sntbd: not recognized actd = ",actd + endif + +end subroutine symmetry_sntbd + + +subroutine d2dump(wei,llb,uub,ext,data_in,data_out,gord,SoA) + implicit none + integer, intent(in) :: wei,gord + integer,dimension(3),intent(in) :: ext + real*8, dimension(3),intent(in) :: SoA + real*8, dimension(3) :: llb,uub + real*8, dimension(ext(1),ext(2),ext(3)),intent(in) ::data_in + real*8, dimension(ext(1),ext(2)), intent(inout)::data_out + + real*8 :: dZ + integer :: i,j,k + +!sanity check + if(wei.ne.3)then + write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + dZ = (uub(3)-llb(3))/(ext(3)-1) + k = idint((0-llb(3))/dZ+0.4)+1 + + if(k < 1)then + write(*,*) "d2dump: something must be wrong" + return + endif + + data_out(i,j) = data_in(i,j,k) + +end subroutine d2dump + +#else +#ifdef Cell +!subroutine interp_2 support cell center only +!----------------------------------------------------------------------------- +! +! Interpolate function f using weights Delx, Dely and Delz +! +!----------------------------------------------------------------------------- + + subroutine interp_2(ex,f,f_int,il,iu,jl,ju,kl,ku,Dx,Dy,Dz,& + ordn,SoA,symmetry) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3), symmetry + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + integer, intent(in) :: il,iu,jl,ju,kl,ku,ordn + real*8, intent(in) :: Dx,Dy,Dz,SoA(3) + +!~~~~~~> Other parameters: + + integer :: j,imin,jmin,kmin + real*8, dimension(1:ordn) :: x1a + real*8, dimension(1:ordn,1:ordn,1:ordn) :: ya + real*8, parameter :: ONE=1.d0 + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8 :: ddy,symX,symY,symZ + + symX = SoA(1) + symY = SoA(2) + symZ = SoA(3) + + imin = lbound(f,1) + jmin = lbound(f,2) + kmin = lbound(f,3) + + forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE + + ya(2:ordn,2:ordn,2:ordn) = f(il+1:iu,jl+1:ju,kl+1:ku) + + if( il < imin .and. symmetry < OCTANT ) then + write(*,*) 'Error in interp_2!!!' + stop + endif + if( il < imin ) then + ya(1,2:ordn,2:ordn) = f(imin,jl+1:ju,kl+1:ku)* symX + else + ya(1,2:ordn,2:ordn) = f(il ,jl+1:ju,kl+1:ku) + endif + + if( jl < jmin .and. symmetry < OCTANT ) then + write(*,*) 'Error in interp_2!!!' + stop + endif + + if( jl < jmin ) then + ya(2:ordn,1,2:ordn) = f(il+1:iu,jmin,kl+1:ku)* symY + else + ya(2:ordn,1,2:ordn) = f(il+1:iu,jl,kl+1:ku) + endif + + if( kl < kmin .and. symmetry < EQUATORIAL ) then + write(*,*) 'Error in interp_2!!!' + stop + endif + + if( kl < kmin ) then + ya(2:ordn,2:ordn,1) = f(il+1:iu,jl+1:ju,kmin)* symZ + else + ya(2:ordn,2:ordn,1) = f(il+1:iu,jl+1:ju,kl ) + endif + + if( il < imin .and. jl < jmin ) then + ya(1,1,2:ordn) = f(imin,jmin,kl+1:ku)* symX * symY + else if( il >= imin .and. jl < jmin ) then + ya(1,1,2:ordn) = f(il,jmin,kl+1:ku)* symY + else if( il < imin .and. jl >= jmin ) then + ya(1,1,2:ordn) = f(imin,jl,kl+1:ku)* symX + else + ya(1,1,2:ordn) = f(il,jl,kl+1:ku) + endif + + if( il < imin .and. kl < kmin ) then + ya(1,2:ordn,1) = f(imin,jl+1:ju,kmin)* symX * symZ + else if( il >= imin .and. kl < kmin ) then + ya(1,2:ordn,1) = f(il,jl+1:ju,kmin)* symZ + else if( il < imin .and. kl >= kmin ) then + ya(1,2:ordn,1) = f(imin,jl+1:ju,kl)* symX + else + ya(1,2:ordn,1) = f(il,jl+1:ju,kl) + endif + + if( jl < jmin .and. kl < kmin ) then + ya(2:ordn,1,1) = f(il+1:iu,jmin,kmin)* symY * symZ + else if( jl >= jmin .and. kl < kmin ) then + ya(2:ordn,1,1) = f(il+1:iu,jl,kmin)* symZ + else if( jl < jmin .and. kl >= kmin ) then + ya(2:ordn,1,1) = f(il+1:iu,jmin,kl)* symY + else + ya(2:ordn,1,1) = f(il+1:iu,jl,kl) + endif + + if( il < imin ) then + if( jl < jmin .and. kl < kmin) then + ya(1,1,1) = f(imin,jmin,kmin)* symX * symY * symZ + else if( jl >= jmin .and. kl < kmin ) then + ya(1,1,1) = f(imin,jl,kmin)* symX * symZ + else if( jl < jmin .and. kl >= kmin ) then + ya(1,1,1) = f(imin,jmin,kl)* symX * symY + else + ya(1,1,1) = f(imin,jl,kl)* symX + endif + else + if( jl < jmin .and. kl < kmin) then + ya(1,1,1) = f(il,jmin,kmin)* symY * symZ + else if( jl >= jmin .and. kl < kmin ) then + ya(1,1,1) = f(il,jl,kmin)* symZ + else if( jl < jmin .and. kl >= kmin ) then + ya(1,1,1) = f(il,jmin,kl)* symY + else + ya(1,1,1) = f(il,jl,kl) + endif + endif + + call polin3(x1a,x1a,x1a,ya,Dx,Dy,Dz,f_int,ddy,ordn) + + if(.not.(dabs(f_int).ge.0))then + write(*,*)"find nan in interp_2:",f_int,"inputs are:" +! write(*,*)ya +! write(*,*)"-----------------------------------------" +! write(*,*)f(il:iu,jl:ju,kl:ku) + write(*,*)Dx,Dy,Dz,symx,symy,symz,ordn + write(*,*)il,iu,jl,ju,kl,ku,ex,symmetry + endif + + return + + end subroutine interp_2 +!--------------------------------------------------------------------------------------------------- +! copy a point of data into data target for vertext center code +!--------------------------------------------------------------------------------------------------- + subroutine pointcopy(wei,llbout,uubout,ext_out,data_out,xx,yy,zz,dv) + implicit none + integer,intent(in) :: wei + integer,dimension(3),intent(in) ::ext_out + real*8,dimension(3) :: llbout,uubout + real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out + real*8,intent(in) :: xx,yy,zz,dv + + real*8,dimension(3) :: ho + integer :: i,j,k + +!sanity check + if(wei.ne.3)then + write(*,*)"fmisc.f90::pointcopy: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +!!! + ho = (uubout-llbout)/ext_out + i = idint((xx-llbout(1))/ho(1)+0.4)+1 + j = idint((yy-llbout(2))/ho(2)+0.4)+1 + k = idint((zz-llbout(3))/ho(3)+0.4)+1 + + if(i<1 .or. i>ext_out(1) .or. & + j<1 .or. j>ext_out(2) .or. & + k<1 .or. k>ext_out(3) )then + write(*,*)"i,j,k = ",i,j,k + write(*,*)"ext = ",ext_out + stop + endif + if(dabs(llbout(1)+(i-0.5)*ho(1)-xx)>ho(1)/2 .or. & + dabs(llbout(2)+(j-0.5)*ho(2)-yy)>ho(2)/2 .or. & + dabs(llbout(3)+(k-0.5)*ho(3)-zz)>ho(3)/2 )then + write(*,*)"fmisc.f90::pointcopy: llbout = ",llbout + write(*,*)"fmisc.f90::pointcopy: ho = ",ho + write(*,*)"fmisc.f90::pointcopy: x,y,z = ",llbout(1)+(i-0.5)*ho(1),llbout(2)+(j-0.5)*ho(2),llbout(3)+(k-0.5)*ho(3) + write(*,*)"fmisc.f90::pointcopy: point = ",xx,yy,zz + stop + endif + + data_out(i,j,k)=dv + + return + + end subroutine pointcopy +!--------------------------------------------------------------------------------------------------- +! copy a part of data from data source, for cell center code +!--------------------------------------------------------------------------------------------------- + subroutine copy(wei,llbout,uubout,ext_out,data_out,llbin,uubin,ext_in,data_in,lcopy,ucopy) + implicit none + integer,intent(in) :: wei + integer,dimension(3),intent(in) ::ext_out,ext_in + real*8,dimension(3),intent(in) :: lcopy,ucopy + real*8,dimension(3) :: llbout,uubout,llbin,uubin + real*8,dimension(ext_out(1),ext_out(2),ext_out(3)),intent(inout)::data_out + real*8,dimension(ext_in(1),ext_in(2),ext_in(3)),intent(in)::data_in + + real*8,dimension(3) :: ho,hi + integer,dimension(3) :: illo,iuuo,illi,iuui + +!sanity check + if(wei.ne.3)then + write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + +!!! + ho = (uubout-llbout)/ext_out + hi = (uubin-llbin)/ext_in + illo = idint((lcopy-llbout)/ho+0.4)+1 + iuuo = ext_out - idint((uubout-ucopy)/ho+0.4) + illi = idint((lcopy-llbin)/hi+0.4)+1 + iuui = ext_in - idint((uubin-ucopy)/hi+0.4) + + if(any(llbout-lcopy>ho/2) .or. any(ucopy-uubout>ho/2))then + write(*,*)"fmisc.f90::copy: llbout = ",llbout + write(*,*)"fmisc.f90::copy: uubout = ",uubout + write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy + write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy + write(*,*)"fmisc.f90::copy: ho = ",ho + write(*,*)llbout-lcopy,ucopy-uubout + stop + elseif(any(llbin -lcopy>hi/2) .or. any(ucopy-uubin >hi/2))then + write(*,*)"fmisc.f90::copy: llbin = ",llbin + write(*,*)"fmisc.f90::copy: uubin = ",uubin + write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy + write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy + stop + elseif(any(illo<1) .or. any(illi<1) .or. any(illo-iuuo>0) .or. any(illi-iuui>0) .or. & + any(iuui-ext_in>0) .or. any(iuuo-ext_out>0))then + write(*,*)"fmisc.f90::copy: illi = ",illi + write(*,*)"fmisc.f90::copy: iuui = ",iuui + write(*,*)"fmisc.f90::copy: illo = ",illo + write(*,*)"fmisc.f90::copy: iuuo = ",iuuo + write(*,*)"fmisc.f90::copy: llbout = ",llbout + write(*,*)"fmisc.f90::copy: uubout = ",uubout + write(*,*)"fmisc.f90::copy: llbin = ",llbin + write(*,*)"fmisc.f90::copy: uubin = ",uubin + write(*,*)"fmisc.f90::copy: llbcopy = ",lcopy + write(*,*)"fmisc.f90::copy: uubcopy = ",ucopy + stop + endif + + data_out(illo(1):iuuo(1),illo(2):iuuo(2),illo(3):iuuo(3))=data_in(illi(1):iuui(1),illi(2):iuui(2),illi(3):iuui(3)) + + return + + end subroutine copy +!-------------------------------------------------------------------------- +! three dimensional interpolation for cell center grid structure + subroutine global_interp(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3), symmetry,ORDN + real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1,z1 + real*8, dimension(3), intent(in) :: SoA + +!~~~~~~> Other parameters: + + integer :: j,m,imin,jmin,kmin + integer,dimension(3) :: cxB,cxT,cxI,cmin,cmax + real*8,dimension(3) :: cx + real*8, dimension(1:ORDN) :: x1a + real*8, dimension(1:ORDN,1:ORDN,1:ORDN) :: ya + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8 :: dX,dY,dZ,ddy + real*8, parameter :: ONE=1.d0 + logical::decide3d + + imin = lbound(f,1) + jmin = lbound(f,2) + kmin = lbound(f,3) + + dX = X(imin+1)-X(imin) + dY = Y(jmin+1)-Y(jmin) + dZ = Z(kmin+1)-Z(kmin) + + forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE + + cxI(1) = idint((x1-X(1))/dX+0.4)+1 + cxI(2) = idint((y1-Y(1))/dY+0.4)+1 + cxI(3) = idint((z1-Z(1))/dZ+0.4)+1 + + cxB = cxI - ORDN/2+1 + cxT = cxB + ORDN - 1 + + cmin = 1 + cmax = ex + if(Symmetry == OCTANT .and.dabs(X(1)) cmax(m))then + cxT(m) = cmax(m) + cxB(m) = cxT(m) + 1 - ORDN + endif + enddo + if(cxB(1)>0)then + cx(1) = (x1 - X(cxB(1)))/dX + else + cx(1) = (x1 + X(1-cxB(1)))/dX + endif + if(cxB(2)>0)then + cx(2) = (y1 - Y(cxB(2)))/dY + else + cx(2) = (y1 + Y(1-cxB(2)))/dY + endif + if(cxB(3)>0)then + cx(3) = (z1 - Z(cxB(3)))/dZ + else + cx(3) = (z1 + Z(1-cxB(3)))/dZ + endif + + if(decide3d(ex,f,f,cxB,cxT,SoA,ya,ORDN,Symmetry))then + write(*,*)"global_interp position: ",x1,y1,z1 + write(*,*)"data range: ",X(1),X(ex(1)),Y(1),Y(ex(2)),Z(1),Z(ex(3)) + stop + endif + call polin3(x1a,x1a,x1a,ya,cx(1),cx(2),cx(3),f_int,ddy,ORDN) + + return + + end subroutine global_interp +!---------------------------------------------------------------- +! decide which 3d data to be used does not surport PI-Symmetry yet +!---------------------------------------------------------------- + function decide3d(ex,f,fpi,cxB,cxT,SoA,ya,ORDN,Symmetry) result(gont) + implicit none + + integer, intent(in) :: ORDN,Symmetry + integer,dimension(1:3) , intent(in) :: ex,cxB,cxT + real*8, dimension(1:3) , intent(in) :: SoA + real*8, dimension(ex(1),ex(2),ex(3)) , intent(in) :: f,fpi + real*8, dimension(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)), intent(out):: ya + logical::gont + + integer,dimension(1:3) :: fmin1,fmin2,fmax1,fmax2 + integer::i,j,k,m + + gont=.false. + do m=1,3 +! check cxB and cxT are NaN or not + if(.not.(iabs(cxB(m)).ge.0)) gont=.true. + if(.not.(iabs(cxT(m)).ge.0)) gont=.true. + fmin1(m) = max(1,cxB(m)) + fmax1(m) = cxT(m) + fmin2(m) = cxB(m) + fmax2(m) = min(0,cxT(m)) + if((fmin1(m).le.fmax1(m)).and.( fmin1(m)<1.or. fmax1(m)>ex(m)))gont=.true. + if((fmin2(m).le.fmax2(m)).and.(1-fmax2(m)<1.or.1-fmin2(m)>ex(m)))gont=.true. + enddo +!sanity check + if(gont)then + write(*,*)"error in decide3d" + write(*,*)((fmin1.le.fmax1).and.( fmin1<1.or. fmax1>ex)) + write(*,*)((fmin2.le.fmax2).and.(1-fmax2<1.or.1-fmin2>ex)) + write(*,*)"cxB, cxT and data shape:" + write(*,*)cxB,cxT,ex + write(*,*)"resulted fmin1, fmax1 and fmin2, fmax2:" + write(*,*)fmin1,fmax1,fmin2,fmax2 + else + + do k=fmin1(3),fmax1(3) + do j=fmin1(2),fmax1(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,j,k) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(1-i,j,k)*SoA(1) + enddo + enddo + do j=fmin2(2),fmax2(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,1-j,k)*SoA(2) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(1-i,1-j,k)*SoA(1)*SoA(2) + enddo + enddo + enddo + + do k=fmin2(3),fmax2(3) + do j=fmin1(2),fmax1(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,j,1-k)*SoA(3) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(1-i,j,1-k)*SoA(1)*SoA(3) + enddo + enddo + do j=fmin2(2),fmax2(2) + do i=fmin1(1),fmax1(1) + ya(i,j,k) = f(i,1-j,1-k)*SoA(2)*SoA(3) + enddo + do i=fmin2(1),fmax2(1) + ya(i,j,k) = f(1-i,1-j,1-k)*SoA(1)*SoA(2)*SoA(3) + enddo + enddo + enddo + + endif + + end function decide3d + +!--------------------------------------------------------------------------------------- +subroutine symmetry_bd(ord,extc,func,funcc,SoA) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1),-ord+1:extc(2),-ord+1:extc(3)),intent(out):: funcc + real*8, dimension(1:3), intent(in) :: SoA + + integer::i + +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) + funcc(1:extc(1),1:extc(2),1:extc(3)) = func +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA(1) + enddo +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) + do i=0,ord-1 + funcc(:,-i,1:extc(3)) = funcc(:,i+1,1:extc(3))*SoA(2) + enddo +!DIR$ SIMD VECTORLENGTHFOR(KNOWN_INTEGER=8) + do i=0,ord-1 + funcc(:,:,-i) = funcc(:,:,i+1)*SoA(3) + enddo + +end subroutine symmetry_bd + +subroutine symmetry_tbd(ord,extc,func,funcc,SoA) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,-ord+1:extc(3)+ord),intent(out):: funcc + real*8, dimension(1:3), intent(in) :: SoA + + integer::i + + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA(1) + funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-i,1:extc(2),1:extc(3))*SoA(1) + enddo + do i=0,ord-1 + funcc(:,-i,1:extc(3)) = funcc(:,i+1,1:extc(3))*SoA(2) + funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-i,1:extc(3))*SoA(2) + enddo + do i=0,ord-1 + funcc(:,:,-i) = funcc(:,:,i+1)*SoA(3) + funcc(:,:,extc(3)+1+i) = funcc(:,:,extc(3)-i)*SoA(3) + enddo + +end subroutine symmetry_tbd + +subroutine symmetry_stbd(ord,extc,func,funcc,SoA) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc + real*8, dimension(2), intent(in) :: SoA + + integer::i + + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA(1) + funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-i,1:extc(2),1:extc(3))*SoA(1) + enddo + do i=0,ord-1 + funcc(:,-i,1:extc(3)) = funcc(:,i+1,1:extc(3))*SoA(2) + funcc(:,extc(2)+1+i,1:extc(3)) = funcc(:,extc(2)-i,1:extc(3))*SoA(2) + enddo + +end subroutine symmetry_stbd + +subroutine symmetry_sntbd(ord,extc,func,funcc,SoA,actd) + implicit none + +!~~~~~~> input arguments + integer,intent(in) :: ord,actd + integer,dimension(3), intent(in) :: extc + real*8, dimension(extc(1),extc(2),extc(3)),intent(in ):: func + real*8, dimension(-ord+1:extc(1)+ord,-ord+1:extc(2)+ord,extc(3)),intent(out):: funcc + real*8, intent(in) :: SoA + + integer::i + + funcc = 0.d0 + funcc(1:extc(1),1:extc(2),1:extc(3)) = func + if(actd==0)then + do i=0,ord-1 + funcc(-i,1:extc(2),1:extc(3)) = funcc(i+1,1:extc(2),1:extc(3))*SoA + funcc(extc(1)+1+i,1:extc(2),1:extc(3)) = funcc(extc(1)-i,1:extc(2),1:extc(3))*SoA + enddo + elseif(actd==1)then + do i=0,ord-1 + funcc(1:extc(1),-i,1:extc(3)) = funcc(1:extc(1),i+1,1:extc(3))*SoA + funcc(1:extc(1),extc(2)+1+i,1:extc(3)) = funcc(1:extc(1),extc(2)-i,1:extc(3))*SoA + enddo + else + write(*,*)"symmetry_sntbd: not recognized actd = ",actd + endif + +end subroutine symmetry_sntbd + +subroutine d2dump(wei,llb,uub,ext,data_in,data_out,gord,SoA) + implicit none + integer,intent(in) :: wei,gord + integer,dimension(3),intent(in) ::ext + real*8,dimension(3),intent(in) :: SoA + real*8,dimension(3) :: llb,uub + real*8,dimension(ext(1),ext(2),ext(3)),intent(in)::data_in + real*8,dimension(ext(1),ext(2)),intent(inout)::data_out + + real*8 :: dZ + integer :: i,j,k + +!sanity check + if(wei.ne.3)then + write(*,*)"fmisc.f90::copy: this routine only surport 3 dimension" + write(*,*)"dim = ",wei + stop + endif + + dZ = (uub(3)-llb(3))/ext(3) + k = idint((0-llb(3))/dZ+0.4)+1 + + select case (gord) + case (2) + if(k > 2)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.5625d0*(data_in(i,j,k)+data_in(i,j,k-1))-0.0625d0*(data_in(i,j,k+1)+data_in(i,j,k-2)) + enddo + enddo + else if(k == 1)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.5625d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k))-0.0625d0*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) + enddo + enddo + else + write(*,*) "d2dump: something must be wrong, k = ",k + return + endif + case (3) + if(k > 3)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.5859375d0*(data_in(i,j,k)+data_in(i,j,k-1)) & + -0.9765625d-1*(data_in(i,j,k+1)+data_in(i,j,k-2)) & + +0.1171875d-1*(data_in(i,j,k+2)+data_in(i,j,k-3)) + enddo + enddo + else if(k == 1)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.5859375d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k)) & + -0.9765625d-1*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) & + +0.1171875d-1*(data_in(i,j,k+2)+SoA(3)*data_in(i,j,k+2)) + enddo + enddo + else + write(*,*) "d2dump: something must be wrong, k = ",k + return + endif + case (4) + if(k > 4)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.5981445312d0*(data_in(i,j,k)+data_in(i,j,k-1)) & + -0.1196289063d0*(data_in(i,j,k+1)+data_in(i,j,k-2)) & + +0.2392578125d-1*(data_in(i,j,k+2)+data_in(i,j,k-3)) & + -0.2441406250d-2*(data_in(i,j,k+3)+data_in(i,j,k-4)) + enddo + enddo + else if(k == 1)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.5981445312d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k)) & + -0.1196289063d0*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) & + +0.2392578125d-1*(data_in(i,j,k+2)+SoA(3)*data_in(i,j,k+2)) & + -0.2441406250d-2*(data_in(i,j,k+3)+SoA(3)*data_in(i,j,k+3)) + enddo + enddo + else + write(*,*) "d2dump: something must be wrong, k = ",k + return + endif + case (5) + if(k > 5)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.6056213378d0*(data_in(i,j,k)+data_in(i,j,k-1)) & + -0.1345825196d0*(data_in(i,j,k+1)+data_in(i,j,k-2)) & + +0.3460693359d-1*(data_in(i,j,k+2)+data_in(i,j,k-3)) & + -0.6179809571d-2*(data_in(i,j,k+3)+data_in(i,j,k-4)) & + +0.5340576171d-3*(data_in(i,j,k+4)+data_in(i,j,k-5)) + enddo + enddo + else if(k == 1)then + do i=1,ext(1) + do j=1,ext(2) + data_out(i,j) = 0.6056213378d0*(data_in(i,j,k)+SoA(3)*data_in(i,j,k)) & + -0.1345825196d0*(data_in(i,j,k+1)+SoA(3)*data_in(i,j,k+1)) & + +0.3460693359d-1*(data_in(i,j,k+2)+SoA(3)*data_in(i,j,k+2)) & + -0.6179809571d-2*(data_in(i,j,k+3)+SoA(3)*data_in(i,j,k+3)) & + +0.5340576171d-3*(data_in(i,j,k+4)+SoA(3)*data_in(i,j,k+4)) + enddo + enddo + else + write(*,*) "d2dump: something must be wrong, k = ",k + return + endif + case default + write(*,*) "d2dump: not recognized ord = ",gord + return + end select + +end subroutine d2dump + +#else +#error Not define Vertex nor Cell +#endif +#endif +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! common code for cell and vertex !------------------------------------------------------------------------------ ! Lagrangian polynomial interpolation @@ -1262,10 +1262,10 @@ end subroutine d2dump implicit none integer, intent(in) :: ordn - real*8, dimension(ordn), intent(in) :: xa, ya - real*8, intent(in) :: x - real*8, intent(out) :: y, dy - + real*8, dimension(ordn), intent(in) :: xa, ya + real*8, intent(in) :: x + real*8, intent(out) :: y, dy + integer :: i, m, ns, n_m real*8, dimension(ordn) :: c, d, ho real*8 :: dif, dift, hp, h, den_val @@ -1282,49 +1282,49 @@ end subroutine d2dump c = ya d = ya ho = xa - x - - ns = 1 - dif = abs(x - xa(1)) - - do i = 2, ordn - dift = abs(x - xa(i)) - if (dift < dif) then - ns = i - dif = dift - end if - end do - - y = ya(ns) - ns = ns - 1 - - do m = 1, ordn - 1 - n_m = ordn - m - do i = 1, n_m - hp = ho(i) - h = ho(i+m) - den_val = hp - h - - if (den_val == 0.0d0) then - write(*,*) 'failure in polint for point',x - write(*,*) 'with input points: ',xa - stop - end if - - den_val = (c(i+1) - d(i)) / den_val - - d(i) = h * den_val - c(i) = hp * den_val - end do - - if (2 * ns < n_m) then - dy = c(ns + 1) - else - dy = d(ns) - ns = ns - 1 - end if - y = y + dy - end do - + + ns = 1 + dif = abs(x - xa(1)) + + do i = 2, ordn + dift = abs(x - xa(i)) + if (dift < dif) then + ns = i + dif = dift + end if + end do + + y = ya(ns) + ns = ns - 1 + + do m = 1, ordn - 1 + n_m = ordn - m + do i = 1, n_m + hp = ho(i) + h = ho(i+m) + den_val = hp - h + + if (den_val == 0.0d0) then + write(*,*) 'failure in polint for point',x + write(*,*) 'with input points: ',xa + stop + end if + + den_val = (c(i+1) - d(i)) / den_val + + d(i) = h * den_val + c(i) = hp * den_val + end do + + if (2 * ns < n_m) then + dy = c(ns + 1) + else + dy = d(ns) + ns = ns - 1 + end if + y = y + dy + end do + return end subroutine polint !------------------------------------------------------------------------------ @@ -1367,67 +1367,67 @@ end subroutine d2dump ! interpolation in 2 dimensions, follow yx order ! !------------------------------------------------------------------------------ - subroutine polin2(x1a,x2a,ya,x1,x2,y,dy,ordn) - implicit none - - integer,intent(in) :: ordn - real*8, dimension(1:ordn), intent(in) :: x1a,x2a - real*8, dimension(1:ordn,1:ordn), intent(in) :: ya - real*8, intent(in) :: x1,x2 - real*8, intent(out) :: y,dy - -#ifdef POLINT_LEGACY_ORDER - integer :: i,m - real*8, dimension(ordn) :: ymtmp - real*8, dimension(ordn) :: yntmp - - m=size(x1a) - do i=1,m - yntmp=ya(i,:) - call polint(x2a,yntmp,x2,ymtmp(i),dy,ordn) - end do - call polint(x1a,ymtmp,x1,y,dy,ordn) -#else - integer :: j - real*8, dimension(ordn) :: ymtmp - real*8 :: dy_temp - - do j=1,ordn - call polint(x1a, ya(:,j), x1, ymtmp(j), dy_temp, ordn) - end do - call polint(x2a, ymtmp, x2, y, dy, ordn) -#endif - - return - end subroutine polin2 -!------------------------------------------------------------------------------ -! -! interpolation in 3 dimensions, follow zyx order -! -!------------------------------------------------------------------------------ - subroutine polin3(x1a,x2a,x3a,ya,x1,x2,x3,y,dy,ordn) - implicit none - - integer,intent(in) :: ordn - real*8, dimension(1:ordn), intent(in) :: x1a,x2a,x3a - real*8, dimension(1:ordn,1:ordn,1:ordn), intent(in) :: ya - real*8, intent(in) :: x1,x2,x3 - real*8, intent(out) :: y,dy - + subroutine polin2(x1a,x2a,ya,x1,x2,y,dy,ordn) + implicit none + + integer,intent(in) :: ordn + real*8, dimension(1:ordn), intent(in) :: x1a,x2a + real*8, dimension(1:ordn,1:ordn), intent(in) :: ya + real*8, intent(in) :: x1,x2 + real*8, intent(out) :: y,dy + +#ifdef POLINT_LEGACY_ORDER + integer :: i,m + real*8, dimension(ordn) :: ymtmp + real*8, dimension(ordn) :: yntmp + + m=size(x1a) + do i=1,m + yntmp=ya(i,:) + call polint(x2a,yntmp,x2,ymtmp(i),dy,ordn) + end do + call polint(x1a,ymtmp,x1,y,dy,ordn) +#else + integer :: j + real*8, dimension(ordn) :: ymtmp + real*8 :: dy_temp + + do j=1,ordn + call polint(x1a, ya(:,j), x1, ymtmp(j), dy_temp, ordn) + end do + call polint(x2a, ymtmp, x2, y, dy, ordn) +#endif + + return + end subroutine polin2 +!------------------------------------------------------------------------------ +! +! interpolation in 3 dimensions, follow zyx order +! +!------------------------------------------------------------------------------ + subroutine polin3(x1a,x2a,x3a,ya,x1,x2,x3,y,dy,ordn) + implicit none + + integer,intent(in) :: ordn + real*8, dimension(1:ordn), intent(in) :: x1a,x2a,x3a + real*8, dimension(1:ordn,1:ordn,1:ordn), intent(in) :: ya + real*8, intent(in) :: x1,x2,x3 + real*8, intent(out) :: y,dy + #ifdef POLINT_LEGACY_ORDER integer :: i,j,m,n real*8, dimension(ordn,ordn) :: yatmp real*8, dimension(ordn) :: ymtmp real*8, dimension(ordn) :: yntmp - real*8, dimension(ordn) :: yqtmp - - m=size(x1a) - n=size(x2a) - do i=1,m - do j=1,n - yqtmp=ya(i,j,:) - call polint(x3a,yqtmp,x3,yatmp(i,j),dy,ordn) - end do + real*8, dimension(ordn) :: yqtmp + + m=size(x1a) + n=size(x2a) + do i=1,m + do j=1,n + yqtmp=ya(i,j,:) + call polint(x3a,yqtmp,x3,yatmp(i,j),dy,ordn) + end do yntmp=yatmp(i,:) call polint(x2a,yntmp,x2,ymtmp(i),dy,ordn) end do @@ -1458,59 +1458,59 @@ end subroutine d2dump return end subroutine polin3 -!-------------------------------------------------------------------------------------- -! calculate L2norm - subroutine l2normhelper(ex, X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,& - f,f_out,gw) - - implicit none -!~~~~~~> Input parameters: - integer,intent(in ):: ex(1:3) - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),xmin,ymin,zmin,xmax,ymax,zmax - integer,intent(in)::gw - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out) :: f_out -!~~~~~~> Other variables: - - real*8, parameter :: ZEO = 0.D0 - real*8 :: dX, dY, dZ - integer::imin,jmin,kmin - integer::imax,jmax,kmax - integer::i,j,k,n_elements - real*8, dimension(:), allocatable :: f_flat - real*8, external :: DDOT - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - -! for ghost zone - imin = gw+1 - jmin = gw+1 - kmin = gw+1 - - imax = ex(1) - gw - jmax = ex(2) - gw - kmax = ex(3) - gw - -!for patch boundary (i.e., not ghost boundary) - -if(dabs(X(ex(1))-xmax) < dX) imax = ex(1) -if(dabs(Y(ex(2))-ymax) < dY) jmax = ex(2) -if(dabs(Z(ex(3))-zmax) < dZ) kmax = ex(3) -if(dabs(X(1)-xmin) < dX) imin = 1 -if(dabs(Y(1)-ymin) < dY) jmin = 1 -if(dabs(Z(1)-zmin) < dZ) kmin = 1 - -! Optimized with oneMKL BLAS DDOT for dot product -n_elements = (imax-imin+1)*(jmax-jmin+1)*(kmax-kmin+1) -allocate(f_flat(n_elements)) -f_flat = reshape(f(imin:imax,jmin:jmax,kmin:kmax), [n_elements]) -f_out = DDOT(n_elements, f_flat, 1, f_flat, 1) -deallocate(f_flat) - -f_out = f_out*dX*dY*dZ - +!-------------------------------------------------------------------------------------- +! calculate L2norm + subroutine l2normhelper(ex, X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,& + f,f_out,gw) + + implicit none +!~~~~~~> Input parameters: + integer,intent(in ):: ex(1:3) + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),xmin,ymin,zmin,xmax,ymax,zmax + integer,intent(in)::gw + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out) :: f_out +!~~~~~~> Other variables: + + real*8, parameter :: ZEO = 0.D0 + real*8 :: dX, dY, dZ + integer::imin,jmin,kmin + integer::imax,jmax,kmax + integer::i,j,k,n_elements + real*8, dimension(:), allocatable :: f_flat + real*8, external :: DDOT + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + +! for ghost zone + imin = gw+1 + jmin = gw+1 + kmin = gw+1 + + imax = ex(1) - gw + jmax = ex(2) - gw + kmax = ex(3) - gw + +!for patch boundary (i.e., not ghost boundary) + +if(dabs(X(ex(1))-xmax) < dX) imax = ex(1) +if(dabs(Y(ex(2))-ymax) < dY) jmax = ex(2) +if(dabs(Z(ex(3))-zmax) < dZ) kmax = ex(3) +if(dabs(X(1)-xmin) < dX) imin = 1 +if(dabs(Y(1)-ymin) < dY) jmin = 1 +if(dabs(Z(1)-zmin) < dZ) kmin = 1 + +! Optimized with oneMKL BLAS DDOT for dot product +n_elements = (imax-imin+1)*(jmax-jmin+1)*(kmax-kmin+1) +allocate(f_flat(n_elements)) +f_flat = reshape(f(imin:imax,jmin:jmax,kmin:kmax), [n_elements]) +f_out = DDOT(n_elements, f_flat, 1, f_flat, 1) +deallocate(f_flat) + +f_out = f_out*dX*dY*dZ + return end subroutine l2normhelper @@ -1593,288 +1593,288 @@ if(dabs(Z(1)-zmin) < dZ) kmin = 1 ! calculate L2norm especially for shell Blocks subroutine l2normhelper_sh(ex, X, Y, Z,xmin,ymin,zmin,xmax,ymax,zmax,& f,f_out,gw,ogw,Symmetry) - - implicit none -!~~~~~~> Input parameters: - integer,intent(in ):: ex(1:3),Symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),xmin,ymin,zmin,xmax,ymax,zmax - integer,intent(in)::gw,ogw - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out) :: f_out -!~~~~~~> Other variables: - - real*8, parameter :: ZEO = 0.D0 - real*8 :: dX, dY, dZ - integer::imin,jmin,kmin - integer::imax,jmax,kmax - integer::i,j,k,n_elements - real*8, dimension(:), allocatable :: f_flat - real*8, external :: DDOT - - real*8 :: PIo4 - - PIo4 = dacos(-1.d0)/4.d0 - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - -! for ghost zone - imin = gw+1 - jmin = gw+1 - kmin = gw+1 - - imax = ex(1) - gw - jmax = ex(2) - gw - kmax = ex(3) - gw - -!for patch boundary (i.e., not ghost boundary) - -if(dabs(X(ex(1))-xmax) < dX)then - if(X(ex(1))-PIo4 > dX)then - imax = ex(1)-ogw ! for overlap zone - else - imax = ex(1) - endif -endif -if(dabs(Y(ex(2))-ymax) < dY)then - if(Y(ex(2))-PIo4 > dY)then - jmax = ex(2)-ogw ! for overlap zone - else - jmax = ex(2) - endif -endif -if(dabs(Z(ex(3))-zmax) < dZ) kmax = ex(3) - -if(dabs(X(1)-xmin) < dX)then - if(X(1)+PIo4 < dX)then - imin = 1+ogw ! for overlap zone - else - imin = 1 - endif -endif -if(dabs(Y(1)-ymin) < dY)then - if(Y(1)+PIo4 < dY)then - jmin = 1+ogw ! for overlap zone - else - jmin = 1 - endif -endif -if(dabs(Z(1)-zmin) < dZ) kmin = 1 - -!for Symmetry ghost points -if(Symmetry==1)then - if(dabs(ymin+gw*dY)0.d0) jmax = ex(2)-gw -endif -if(Symmetry==2)then - if(dabs(xmin+gw*dX) Input parameters: - integer,intent(in ):: ex(1:3),Symmetry - real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),xmin,ymin,zmin,xmax,ymax,zmax - integer,intent(in)::gw,ogw - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out) :: f_out - integer,intent(out) :: Nout -!~~~~~~> Other variables: - - real*8, parameter :: ZEO = 0.D0 - real*8 :: dX, dY, dZ - integer::imin,jmin,kmin - integer::imax,jmax,kmax - integer::i,j,k - real*8, dimension(:), allocatable :: f_flat - real*8, external :: DDOT - - real*8 :: PIo4 - - PIo4 = dacos(-1.d0)/4.d0 - - dX = X(2) - X(1) - dY = Y(2) - Y(1) - dZ = Z(2) - Z(1) - -! for ghost zone - imin = gw+1 - jmin = gw+1 - kmin = gw+1 - - imax = ex(1) - gw - jmax = ex(2) - gw - kmax = ex(3) - gw - -!for patch boundary (i.e., not ghost boundary) - -if(dabs(X(ex(1))-xmax) < dX)then - if(X(ex(1))-PIo4 > dX)then - imax = ex(1)-ogw ! for overlap zone - else - imax = ex(1) - endif -endif -if(dabs(Y(ex(2))-ymax) < dY)then - if(Y(ex(2))-PIo4 > dY)then - jmax = ex(2)-ogw ! for overlap zone - else - jmax = ex(2) - endif -endif -if(dabs(Z(ex(3))-zmax) < dZ) kmax = ex(3) - -if(dabs(X(1)-xmin) < dX)then - if(X(1)+PIo4 < dX)then - imin = 1+ogw ! for overlap zone - else - imin = 1 - endif -endif -if(dabs(Y(1)-ymin) < dY)then - if(Y(1)+PIo4 < dY)then - jmin = 1+ogw ! for overlap zone - else - jmin = 1 - endif -endif -if(dabs(Z(1)-zmin) < dZ) kmin = 1 - -!for Symmetry ghost points -if(Symmetry==1)then - if(dabs(ymin+gw*dY)0.d0) jmax = ex(2)-gw -endif -if(Symmetry==2)then - if(dabs(xmin+gw*dX) t -! ^ -! f=3/4*f_1 + 1/4*f_2 - - real*8,parameter::C1=0.75d0,C2=0.25d0 - - fout = C1*f1+C2*f2 - - return - - end subroutine average3 -!----------------------------------------------------------------------------- - subroutine average2(ext,f1,f2,f3,fout) - implicit none - integer,dimension(3), intent(in) :: ext - real*8, dimension(ext(1),ext(2),ext(3)),intent(in):: f1,f2,f3 - real*8, dimension(ext(1),ext(2),ext(3)),intent(out):: fout -! f1 ---------- ^ -! fout ------ | -! f2 ---------- | t -! | -! f3 ---------- | -! 3 points, 2nd order interpolation -! 1 2 3 -! f3 f2 f1 -! *---*---*--> t -! ^ -! f=3/8*f_1 + 3/4*f_2 - 1/8*f_3 - + + implicit none +!~~~~~~> Input parameters: + integer,intent(in ):: ex(1:3),Symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),xmin,ymin,zmin,xmax,ymax,zmax + integer,intent(in)::gw,ogw + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out) :: f_out +!~~~~~~> Other variables: + + real*8, parameter :: ZEO = 0.D0 + real*8 :: dX, dY, dZ + integer::imin,jmin,kmin + integer::imax,jmax,kmax + integer::i,j,k,n_elements + real*8, dimension(:), allocatable :: f_flat + real*8, external :: DDOT + + real*8 :: PIo4 + + PIo4 = dacos(-1.d0)/4.d0 + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + +! for ghost zone + imin = gw+1 + jmin = gw+1 + kmin = gw+1 + + imax = ex(1) - gw + jmax = ex(2) - gw + kmax = ex(3) - gw + +!for patch boundary (i.e., not ghost boundary) + +if(dabs(X(ex(1))-xmax) < dX)then + if(X(ex(1))-PIo4 > dX)then + imax = ex(1)-ogw ! for overlap zone + else + imax = ex(1) + endif +endif +if(dabs(Y(ex(2))-ymax) < dY)then + if(Y(ex(2))-PIo4 > dY)then + jmax = ex(2)-ogw ! for overlap zone + else + jmax = ex(2) + endif +endif +if(dabs(Z(ex(3))-zmax) < dZ) kmax = ex(3) + +if(dabs(X(1)-xmin) < dX)then + if(X(1)+PIo4 < dX)then + imin = 1+ogw ! for overlap zone + else + imin = 1 + endif +endif +if(dabs(Y(1)-ymin) < dY)then + if(Y(1)+PIo4 < dY)then + jmin = 1+ogw ! for overlap zone + else + jmin = 1 + endif +endif +if(dabs(Z(1)-zmin) < dZ) kmin = 1 + +!for Symmetry ghost points +if(Symmetry==1)then + if(dabs(ymin+gw*dY)0.d0) jmax = ex(2)-gw +endif +if(Symmetry==2)then + if(dabs(xmin+gw*dX) Input parameters: + integer,intent(in ):: ex(1:3),Symmetry + real*8, intent(in ):: X(1:ex(1)),Y(1:ex(2)),Z(1:ex(3)),xmin,ymin,zmin,xmax,ymax,zmax + integer,intent(in)::gw,ogw + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out) :: f_out + integer,intent(out) :: Nout +!~~~~~~> Other variables: + + real*8, parameter :: ZEO = 0.D0 + real*8 :: dX, dY, dZ + integer::imin,jmin,kmin + integer::imax,jmax,kmax + integer::i,j,k + real*8, dimension(:), allocatable :: f_flat + real*8, external :: DDOT + + real*8 :: PIo4 + + PIo4 = dacos(-1.d0)/4.d0 + + dX = X(2) - X(1) + dY = Y(2) - Y(1) + dZ = Z(2) - Z(1) + +! for ghost zone + imin = gw+1 + jmin = gw+1 + kmin = gw+1 + + imax = ex(1) - gw + jmax = ex(2) - gw + kmax = ex(3) - gw + +!for patch boundary (i.e., not ghost boundary) + +if(dabs(X(ex(1))-xmax) < dX)then + if(X(ex(1))-PIo4 > dX)then + imax = ex(1)-ogw ! for overlap zone + else + imax = ex(1) + endif +endif +if(dabs(Y(ex(2))-ymax) < dY)then + if(Y(ex(2))-PIo4 > dY)then + jmax = ex(2)-ogw ! for overlap zone + else + jmax = ex(2) + endif +endif +if(dabs(Z(ex(3))-zmax) < dZ) kmax = ex(3) + +if(dabs(X(1)-xmin) < dX)then + if(X(1)+PIo4 < dX)then + imin = 1+ogw ! for overlap zone + else + imin = 1 + endif +endif +if(dabs(Y(1)-ymin) < dY)then + if(Y(1)+PIo4 < dY)then + jmin = 1+ogw ! for overlap zone + else + jmin = 1 + endif +endif +if(dabs(Z(1)-zmin) < dZ) kmin = 1 + +!for Symmetry ghost points +if(Symmetry==1)then + if(dabs(ymin+gw*dY)0.d0) jmax = ex(2)-gw +endif +if(Symmetry==2)then + if(dabs(xmin+gw*dX) t +! ^ +! f=3/4*f_1 + 1/4*f_2 + + real*8,parameter::C1=0.75d0,C2=0.25d0 + + fout = C1*f1+C2*f2 + + return + + end subroutine average3 +!----------------------------------------------------------------------------- + subroutine average2(ext,f1,f2,f3,fout) + implicit none + integer,dimension(3), intent(in) :: ext + real*8, dimension(ext(1),ext(2),ext(3)),intent(in):: f1,f2,f3 + real*8, dimension(ext(1),ext(2),ext(3)),intent(out):: fout +! f1 ---------- ^ +! fout ------ | +! f2 ---------- | t +! | +! f3 ---------- | +! 3 points, 2nd order interpolation +! 1 2 3 +! f3 f2 f1 +! *---*---*--> t +! ^ +! f=3/8*f_1 + 3/4*f_2 - 1/8*f_3 + real*8,parameter::C1=3.d0/8.d0,C2=3.d0/4.d0,C3=-1.d0/8.d0 integer :: i,j,k @@ -1883,702 +1883,702 @@ deallocate(f_flat) end do return - - end subroutine average2 -!----------------------------------------------------------------------------- - subroutine average2p(ext,f1,f2,f3,fout) - implicit none - integer,dimension(3), intent(in) :: ext - real*8, dimension(ext(1),ext(2),ext(3)),intent(in):: f1,f2,f3 - real*8, dimension(ext(1),ext(2),ext(3)),intent(out):: fout -! f1 ---------- ^ -! fout ------p | -! f2 ---------- | t -! | -! f3 ---------- | -! 3 points, 2nd order interpolation -! 1 2 3 -! f3 f2 f1 -! *---*---*--> t -! ^ -! f=21/32*f_1 + 7/16*f_2 - 3/32*f_3 - - real*8,parameter::C1=5.d0/3.2d1,C2=1.5d1/1.6d1,C3=-3.d0/3.2d1 - - fout = C1*f1+C2*f2+C3*f3 - - return - - end subroutine average2p -!----------------------------------------------------------------------------- - subroutine average2m(ext,f1,f2,f3,fout) - implicit none - integer,dimension(3), intent(in) :: ext - real*8, dimension(ext(1),ext(2),ext(3)),intent(in):: f1,f2,f3 - real*8, dimension(ext(1),ext(2),ext(3)),intent(out):: fout -! f1 ---------- ^ -! fout ------m | -! f2 ---------- | t -! | -! f3 ---------- | -! 3 points, 2nd order interpolation -! 1 2 3 -! f3 f2 f1 -! *---*---*--> t -! ^ -! f=5/32*f_1 + 15/16*f_2 - 3/32*f_3 - - real*8,parameter::C1=5.d0/3.2d1,C2=1.5d1/1.6d1,C3=-3.d0/3.2d1 - - fout = C1*f1+C2*f2+C3*f3 - - return - - end subroutine average2m -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - subroutine lowerboundset(ex,chi0,TINNY) - implicit none - -!~~~~~~% Input parameters: - - integer ,intent(in):: ex(1:3) - real*8 ,intent(in):: TINNY - real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::chi0 - - where(chi0 < TINNY) chi0 = TINNY - - return - - end subroutine lowerboundset -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!global interpolation with given index and coeffients - subroutine global_interpind(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,inds,coef,sst) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3), symmetry,ORDN,sst - real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1,z1 - real*8, dimension(3), intent(in) :: SoA - integer,dimension(3), intent(in) :: inds - real*8, dimension(3*ORDN), intent(in) :: coef - -!~~~~~~> Other parameters: - - real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,-ORDN+1:ex(3)+ORDN) :: fh - integer :: m - integer,dimension(3) :: cxB,cxT - real*8, dimension(ORDN,ORDN,ORDN) :: ya - real*8, dimension(ORDN,ORDN) :: tmp2 - real*8, dimension(ORDN) :: tmp1 - real*8, dimension(3) :: SoAh - real*8, external :: DDOT - -! +1 because c++ gives 0 for first point - cxB = inds+1 - cxT = cxB + ORDN - 1 - - if(all(cxB>0).and.all(cxTex+ORDN))then - write(*,*)"error in global_interpind, cxB = ",cxB - write(*,*)" cxT = ",cxT - write(*,*)" ext = ",ex - stop - else - if(sst==-1)then - SoAh = SoA - if(any(cxT>ex)) write(*,*)"error global_interpind sst =",sst - elseif(sst==0.or.sst==1)then - SoAh = SoA - SoAh(3) = 0 - if(cxB(3)<1.or.cxT(3)>ex(3)) write(*,*)"error global_interpind sst =",sst - elseif(sst==2.or.sst==3)then - SoAh(1) = SoA(2) - SoAh(2) = SoA(3) - SoAh(3) = 0 - if(cxB(3)<1.or.cxT(3)>ex(3)) write(*,*)"error global_interpind sst =",sst - elseif(sst==4.or.sst==5)then - SoAh(1) = SoA(1) - SoAh(2) = SoA(3) - SoAh(3) = 0 - if(cxB(3)<1.or.cxT(3)>ex(3)) write(*,*)"error global_interpind sst =",sst,cxB(3),cxT(3) - endif - call symmetry_tbd(ORDN,ex,f,fh,SoAh) - ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)) - endif - - ! Optimized with BLAS operations for better performance - ! First dimension: z-direction weighted sum - tmp2=0 - do m=1,ORDN - tmp2 = tmp2 + coef(2*ORDN+m)*ya(:,:,m) - enddo - - ! Second dimension: y-direction weighted sum - tmp1=0 - do m=1,ORDN - tmp1 = tmp1 + coef(ORDN+m)*tmp2(:,m) - enddo - - ! Third dimension: x-direction weighted sum using BLAS DDOT - f_int = DDOT(ORDN, coef(1:ORDN), 1, tmp1, 1) - - return - - end subroutine global_interpind -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!global interpolation with given index and coeffients -! special for shell to shell - subroutine global_interpind2d(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,inds,coef,sst) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3), symmetry,ORDN,sst - real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1,z1 - real*8, dimension(3), intent(in) :: SoA - integer,dimension(3), intent(in) :: inds - real*8, dimension(2*ORDN), intent(in) :: coef - -!~~~~~~> Other parameters: - - real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,ex(3)) :: fh - integer :: m - integer,dimension(2) :: cxB,cxT - real*8, dimension(ORDN,ORDN) :: ya - real*8, dimension(ORDN) :: tmp1 - real*8, dimension(2) :: SoAh - real*8, external :: DDOT - -! +1 because c++ gives 0 for first point - cxB = inds(1:2)+1 - cxT = cxB + ORDN - 1 - - if(all(cxB>0).and.all(cxTex(1:2)+ORDN))then - write(*,*)"error in global_interpind2d, cxB = ",cxB - write(*,*)" cxT = ",cxT - write(*,*)" ext = ",ex(1:2) - stop - else - if(sst==-1)then - write(*,*)"error in global_interpind2d, sst = ",sst - stop - elseif(sst==0.or.sst==1)then - SoAh = SoA(1:2) - elseif(sst==2.or.sst==3)then - SoAh(1) = SoA(2) - SoAh(2) = SoA(3) - elseif(sst==4.or.sst==5)then - SoAh(1) = SoA(1) - SoAh(2) = SoA(3) - endif - call symmetry_stbd(ORDN,ex,f,fh,SoAh) - ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),inds(3)) - endif - - ! Optimized with BLAS operations - tmp1=0 - do m=1,ORDN - tmp1 = tmp1 + coef(ORDN+m)*ya(:,m) - enddo - - ! Use BLAS DDOT for final weighted sum - f_int = DDOT(ORDN, coef(1:ORDN), 1, tmp1, 1) - - return - - end subroutine global_interpind2d -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!global interpolation with given index and coeffients -! special for shell to shell -! dumyd refer to source - subroutine global_interpind1d(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,indsi,coef,sst,dumyd) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),symmetry,ORDN,sst,dumyd - real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1,z1 - real*8, dimension(3), intent(in) :: SoA - integer,dimension(3), intent(in) :: indsi - real*8, dimension(ORDN), intent(in) :: coef - -!~~~~~~> Other parameters: - - real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,ex(3)) :: fh - integer :: m - integer :: cxB,cxT - real*8, dimension(ORDN) :: ya - real*8 :: SoAh - integer,dimension(3) :: inds - real*8, external :: DDOT - -! +1 because c++ gives 0 for first point - inds = indsi + 1 - cxB = inds(1) - cxT = cxB + ORDN - 1 - -! active is rho - if(dumyd==1)then - - if(cxB>0.and.cxTex(1)+ORDN)then - write(*,*)"error in global_interpind1d, cxB = ",cxB - write(*,*)" cxT = ",cxT - write(*,*)" ext = ",ex(1) - stop - else - if(sst==-1)then - write(*,*)"error in global_interpind1d, sst = ",sst - stop - elseif(sst==0.or.sst==1)then - SoAh = SoA(1) - elseif(sst==2.or.sst==3)then - SoAh = SoA(2) - elseif(sst==4.or.sst==5)then - SoAh = SoA(1) - endif - call symmetry_sntbd(ORDN,ex,f,fh,SoAh,1-dumyd) - ya=fh(cxB:cxT,inds(2),inds(3)) - endif - -! active is sigma - elseif(dumyd==0)then - - if(cxB>0.and.cxTex(2)+ORDN)then - write(*,*)"error in global_interpind1d, cxB = ",cxB - write(*,*)" cxT = ",cxT - write(*,*)" ext = ",ex(2) - stop - else - if(sst==-1)then - write(*,*)"error in global_interpind1d, sst = ",sst - stop - elseif(sst==0.or.sst==1)then - SoAh = SoA(2) - elseif(sst==2.or.sst==3)then - SoAh = SoA(3) - elseif(sst==4.or.sst==5)then - SoAh = SoA(3) - endif - call symmetry_sntbd(ORDN,ex,f,fh,SoAh,1-dumyd) - ya=fh(inds(2),cxB:cxT,inds(3)) - endif - - else - write(*,*)"error in global_interpind1d, not recognized dumyd = ",dumyd - endif - - ! Optimized with BLAS DDOT for weighted sum - f_int = DDOT(ORDN, coef, 1, ya, 1) - - return - - end subroutine global_interpind1d -!----------------------------------------------------------------------------------------------------------------- -! three dimensional interpolation for both vertex and cell center grid structure -! for distinguishing shell and Cartesian - subroutine global_interp_ss(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,sst) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3), symmetry,ORDN,sst - real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1,z1 - real*8, dimension(3), intent(in) :: SoA - -!~~~~~~> Other parameters: - - real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,-ORDN+1:ex(3)+ORDN) :: fh - real*8, dimension(3) :: SoAh - integer :: j,m,imin,jmin,kmin - integer,dimension(3) :: cxB,cxT,cxI,cmin,cmax - real*8,dimension(3) :: cx - real*8, dimension(1:ORDN) :: x1a - real*8, dimension(1:ORDN,1:ORDN,1:ORDN) :: ya - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8 :: dX,dY,dZ,ddy - real*8, parameter :: ONE=1.d0 - - imin = lbound(f,1) - jmin = lbound(f,2) - kmin = lbound(f,3) - - dX = X(imin+1)-X(imin) - dY = Y(jmin+1)-Y(jmin) - dZ = Z(kmin+1)-Z(kmin) - - forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE - - cxI(1) = idint((x1-X(1))/dX+0.4)+1 - cxI(2) = idint((y1-Y(1))/dY+0.4)+1 - cxI(3) = idint((z1-Z(1))/dZ+0.4)+1 - - cxB = cxI - ORDN/2+1 - cxT = cxB + ORDN - 1 - - cmin = 1 - cmax = ex - - if(sst==-1)then - SoAh = SoA - cmin = -ORDN+1 - elseif(sst==0.or.sst==1)then - SoAh = SoA - SoAh(3) = 0 - cmin(1:2) = -ORDN+1 - cmax(1:2) = ex(1:2)+ORDN - elseif(sst==2.or.sst==3)then - SoAh(1) = SoA(2) - SoAh(2) = SoA(3) - SoAh(3) = 0 - cmin(1:2) = -ORDN+1 - cmax(1:2) = ex(1:2)+ORDN - elseif(sst==4.or.sst==5)then - SoAh(1) = SoA(1) - SoAh(2) = SoA(3) - SoAh(3) = 0 - cmin(1:2) = -ORDN+1 - cmax(1:2) = ex(1:2)+ORDN - endif - do m =1,3 - if(cxB(m) < cmin(m))then - cxB(m) = cmin(m) - cxT(m) = cxB(m) + ORDN - 1 - endif - if(cxT(m) > cmax(m))then - cxT(m) = cmax(m) - cxB(m) = cxT(m) + 1 - ORDN - endif - enddo - cx(1) = (x1 - X(1))/dX-cxB(1)+1 - cx(2) = (y1 - Y(1))/dY-cxB(2)+1 - cx(3) = (z1 - Z(1))/dZ-cxB(3)+1 - - call symmetry_tbd(ORDN,ex,f,fh,SoAh) - ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)) - - call polin3(x1a,x1a,x1a,ya,cx(1),cx(2),cx(3),f_int,ddy,ORDN) - - return - - end subroutine global_interp_ss -!----------------------------------------------------------------------------------------------------------------- -! two dimensional interpolation for both vertex and cell center grid structure -! for distinguishing shell and Cartesian - subroutine global_interp_ss_2d(ex,X,Y,indZ,f,f_int,x1,y1,ORDN,SoA,symmetry,sst) - implicit none - -!~~~~~~> Input parameters: - - integer, intent(in) :: ex(1:3),indZ,symmetry,ORDN,sst - real*8,intent(in) :: X(ex(1)),Y(ex(2)) - real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f - real*8, intent(out):: f_int - real*8, intent(in) :: x1,y1 - real*8, dimension(3), intent(in) :: SoA - -!~~~~~~> Other parameters: - - real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,-ORDN+1:ex(3)+ORDN) :: fh - real*8, dimension(3) :: SoAh - integer :: j,m,imin,jmin,kmin - integer,dimension(2) :: cxB,cxT,cxI,cmin,cmax - real*8,dimension(2) :: cx - real*8, dimension(1:ORDN) :: x1a - real*8, dimension(1:ORDN,1:ORDN) :: ya - integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 - real*8 :: dX,dY,ddy - real*8, parameter :: ONE=1.d0 - -! sanity check - if(indZ < 1 .or. indZ > ex(3))then - write(*,*)"error in global_interp_ss_2d, ext = ",ex(3),"ind = ",indZ - return - endif - - imin = lbound(f,1) - jmin = lbound(f,2) - kmin = lbound(f,3) - - dX = X(imin+1)-X(imin) - dY = Y(jmin+1)-Y(jmin) - - forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE - - cxI(1) = idint((x1-X(1))/dX+0.4)+1 - cxI(2) = idint((y1-Y(1))/dY+0.4)+1 - - cxB = cxI - ORDN/2+1 - cxT = cxB + ORDN - 1 - - cmin = 1 - cmax = ex(1:2) - - if(sst==-1)then - SoAh = SoA - cmin = -ORDN+1 - elseif(sst==0.or.sst==1)then - SoAh = SoA - SoAh(3) = 0 - cmin(1:2) = -ORDN+1 - cmax(1:2) = ex(1:2)+ORDN - elseif(sst==2.or.sst==3)then - SoAh(1) = SoA(2) - SoAh(2) = SoA(3) - SoAh(3) = 0 - cmin(1:2) = -ORDN+1 - cmax(1:2) = ex(1:2)+ORDN - elseif(sst==4.or.sst==5)then - SoAh(1) = SoA(1) - SoAh(2) = SoA(3) - SoAh(3) = 0 - cmin(1:2) = -ORDN+1 - cmax(1:2) = ex(1:2)+ORDN - endif - do m =1,2 - if(cxB(m) < cmin(m))then - cxB(m) = cmin(m) - cxT(m) = cxB(m) + ORDN - 1 - endif - if(cxT(m) > cmax(m))then - cxT(m) = cmax(m) - cxB(m) = cxT(m) + 1 - ORDN - endif - enddo - cx(1) = (x1 - X(1))/dX-cxB(1)+1 - cx(2) = (y1 - Y(1))/dY-cxB(2)+1 - - call symmetry_tbd(ORDN,ex,f,fh,SoAh) - ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),indZ) - - call polin2(x1a,x1a,ya,cx(1),cx(2),f_int,ddy,ORDN) - - return - - end subroutine global_interp_ss_2d -!------------------------------------------ -!fortran version of Wigner d function -!Eq.(42) of PRD 77, 024027 (2008) -!we consider only theta in [0,pi] -!------------------------------------------ - function fWigner_d_function(l,m,s,costheta) result(gont) - implicit none - integer,intent(in) :: l,m,s - real*8,intent(in) :: costheta - - real*8 :: gont - - integer :: t,C1,C2 - real*8 :: ffact,vv,sinht,cosht - - C1=max(0,m-s) - C2=min(l+m,l-s) - vv=0 - sinht=dsqrt((1.d0-costheta)/2.d0) - cosht=dsqrt((1.d0+costheta)/2.d0); - if(C1/2*2==C1)then - do t=C1,C2,2 - vv=vv+cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) - enddo - do t=C1+1,C2,2 - vv=vv-cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) - enddo - else - do t=C1,C2,2 - vv=vv-cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) - enddo - do t=C1+1,C2,2 - vv=vv+cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) - enddo - endif - - gont = vv*dsqrt(ffact(l+m)*ffact(l-m)*ffact(l+s)*ffact(l-s)) - - return - - end function fWigner_d_function -!---------------------------------- -! Optimized factorial function using lookup table for small N -! and log-gamma for large N to avoid overflow - function ffact(N) result(gont) - implicit none - integer,intent(in) :: N - - real*8 :: gont - integer :: i - - ! Lookup table for factorials 0! to 20! (precomputed) - real*8, parameter, dimension(0:20) :: fact_table = [ & - 1.d0, 1.d0, 2.d0, 6.d0, 24.d0, 120.d0, 720.d0, 5040.d0, 40320.d0, & - 362880.d0, 3628800.d0, 39916800.d0, 479001600.d0, 6227020800.d0, & - 87178291200.d0, 1307674368000.d0, 20922789888000.d0, & - 355687428096000.d0, 6402373705728000.d0, 121645100408832000.d0, & - 2432902008176640000.d0 ] - -! sanity check - if(N < 0)then - write(*,*) "ffact: error input for factorial" - gont = 1.d0 - return - endif - - ! Use lookup table for small N (fast path) - if(N <= 20)then - gont = fact_table(N) - else - ! Use log-gamma function for large N: N! = exp(log_gamma(N+1)) - ! This avoids overflow and is computed efficiently - gont = exp(log_gamma(dble(N+1))) - endif - - return - - end function ffact -!--------------------------- -!Eq.(41) of PRD 77, 024027 (2008) -!---------------------------------- - function Yslm(s,l,m,the,phi) result(gont) - implicit none - integer,intent(in) :: s,l,m - real*8,intent(in) :: the,phi - - double complex :: gont - - real*8 :: fWigner_d_function,PI,rp - - PI = dacos(-1.d0) - - rp = fWigner_d_function(l,m,s,dcos(the)) - rp = rp*dsqrt((2*l+1.d0)/4.d0/PI) - if(s/2*2.ne.s) rp = -rp - - gont = dcmplx(dcos(m*phi),dsin(m*phi)) - - gont = rp*gont - - return - - end function Yslm -!------------------------------------------------------------------------------------ -subroutine set_value(ext,data_out,rr) - - IMPLICIT NONE - - integer, intent(in) :: ext(3) - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(out) :: data_out - REAL*8, intent(in) :: rr - - data_out = rr - - return -end subroutine set_value -subroutine add_value(ext,data_out,rr) - - IMPLICIT NONE - - integer, intent(in) :: ext(3) - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(inout) :: data_out - REAL*8, intent(in) :: rr - - data_out = data_out + rr - - return -end subroutine add_value -! copy array2 to array1 -subroutine array_copy(ext,data1,data2) - - IMPLICIT NONE - - integer, intent(in) :: ext(3) - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(out) :: data1 - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: data2 - - data1 = data2 - - return - end subroutine array_copy -! add array2 to array1 -subroutine array_add(ext,data1,data2) - - IMPLICIT NONE - - integer, intent(in) :: ext(3) - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(inout) :: data1 - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: data2 - - data1 = data1 + data2 - - return - end subroutine array_add -! subtract array2 from array1 -subroutine array_subtract(ext,data1,data2) - - IMPLICIT NONE - - integer, intent(in) :: ext(3) - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(inout) :: data1 - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: data2 - - data1 = data1 - data2 - - return - end subroutine array_subtract -! find out the maximum -subroutine find_maximum(ext,X,Y,Z,fun,val,pos,llb,uub) - - implicit none - - integer,intent(in) :: ext(3),llb(3),uub(3) - real*8 :: X(ext(1)),Y(ext(2)),Z(ext(3)) - REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: fun - real*8,intent(out) :: val,pos(3) - - integer :: i,j,k,ii,jj,kk - real*8 :: tmp - - tmp = 0.d0 - - ii=1 - jj=1 - kk=1 - - do k=llb(3)+1,ext(3)-uub(3) - do j=llb(2)+1,ext(2)-uub(2) - do i=llb(1)+1,ext(1)-uub(1) - if(dabs(fun(i,j,k)) > tmp)then - tmp = dabs(fun(i,j,k)) - ii = i - jj = j - kk = k - endif - enddo - enddo - enddo - - pos(1) = X(ii) - pos(2) = Y(jj) - pos(3) = Z(kk) - val = tmp - - return - -end subroutine + + end subroutine average2 +!----------------------------------------------------------------------------- + subroutine average2p(ext,f1,f2,f3,fout) + implicit none + integer,dimension(3), intent(in) :: ext + real*8, dimension(ext(1),ext(2),ext(3)),intent(in):: f1,f2,f3 + real*8, dimension(ext(1),ext(2),ext(3)),intent(out):: fout +! f1 ---------- ^ +! fout ------p | +! f2 ---------- | t +! | +! f3 ---------- | +! 3 points, 2nd order interpolation +! 1 2 3 +! f3 f2 f1 +! *---*---*--> t +! ^ +! f=21/32*f_1 + 7/16*f_2 - 3/32*f_3 + + real*8,parameter::C1=5.d0/3.2d1,C2=1.5d1/1.6d1,C3=-3.d0/3.2d1 + + fout = C1*f1+C2*f2+C3*f3 + + return + + end subroutine average2p +!----------------------------------------------------------------------------- + subroutine average2m(ext,f1,f2,f3,fout) + implicit none + integer,dimension(3), intent(in) :: ext + real*8, dimension(ext(1),ext(2),ext(3)),intent(in):: f1,f2,f3 + real*8, dimension(ext(1),ext(2),ext(3)),intent(out):: fout +! f1 ---------- ^ +! fout ------m | +! f2 ---------- | t +! | +! f3 ---------- | +! 3 points, 2nd order interpolation +! 1 2 3 +! f3 f2 f1 +! *---*---*--> t +! ^ +! f=5/32*f_1 + 15/16*f_2 - 3/32*f_3 + + real*8,parameter::C1=5.d0/3.2d1,C2=1.5d1/1.6d1,C3=-3.d0/3.2d1 + + fout = C1*f1+C2*f2+C3*f3 + + return + + end subroutine average2m +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + subroutine lowerboundset(ex,chi0,TINNY) + implicit none + +!~~~~~~% Input parameters: + + integer ,intent(in):: ex(1:3) + real*8 ,intent(in):: TINNY + real*8, dimension(ex(1),ex(2),ex(3)),intent(inout) ::chi0 + + where(chi0 < TINNY) chi0 = TINNY + + return + + end subroutine lowerboundset +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!global interpolation with given index and coeffients + subroutine global_interpind(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,inds,coef,sst) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3), symmetry,ORDN,sst + real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1,z1 + real*8, dimension(3), intent(in) :: SoA + integer,dimension(3), intent(in) :: inds + real*8, dimension(3*ORDN), intent(in) :: coef + +!~~~~~~> Other parameters: + + real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,-ORDN+1:ex(3)+ORDN) :: fh + integer :: m + integer,dimension(3) :: cxB,cxT + real*8, dimension(ORDN,ORDN,ORDN) :: ya + real*8, dimension(ORDN,ORDN) :: tmp2 + real*8, dimension(ORDN) :: tmp1 + real*8, dimension(3) :: SoAh + real*8, external :: DDOT + +! +1 because c++ gives 0 for first point + cxB = inds+1 + cxT = cxB + ORDN - 1 + + if(all(cxB>0).and.all(cxTex+ORDN))then + write(*,*)"error in global_interpind, cxB = ",cxB + write(*,*)" cxT = ",cxT + write(*,*)" ext = ",ex + stop + else + if(sst==-1)then + SoAh = SoA + if(any(cxT>ex)) write(*,*)"error global_interpind sst =",sst + elseif(sst==0.or.sst==1)then + SoAh = SoA + SoAh(3) = 0 + if(cxB(3)<1.or.cxT(3)>ex(3)) write(*,*)"error global_interpind sst =",sst + elseif(sst==2.or.sst==3)then + SoAh(1) = SoA(2) + SoAh(2) = SoA(3) + SoAh(3) = 0 + if(cxB(3)<1.or.cxT(3)>ex(3)) write(*,*)"error global_interpind sst =",sst + elseif(sst==4.or.sst==5)then + SoAh(1) = SoA(1) + SoAh(2) = SoA(3) + SoAh(3) = 0 + if(cxB(3)<1.or.cxT(3)>ex(3)) write(*,*)"error global_interpind sst =",sst,cxB(3),cxT(3) + endif + call symmetry_tbd(ORDN,ex,f,fh,SoAh) + ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)) + endif + + ! Optimized with BLAS operations for better performance + ! First dimension: z-direction weighted sum + tmp2=0 + do m=1,ORDN + tmp2 = tmp2 + coef(2*ORDN+m)*ya(:,:,m) + enddo + + ! Second dimension: y-direction weighted sum + tmp1=0 + do m=1,ORDN + tmp1 = tmp1 + coef(ORDN+m)*tmp2(:,m) + enddo + + ! Third dimension: x-direction weighted sum using BLAS DDOT + f_int = DDOT(ORDN, coef(1:ORDN), 1, tmp1, 1) + + return + + end subroutine global_interpind +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!global interpolation with given index and coeffients +! special for shell to shell + subroutine global_interpind2d(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,inds,coef,sst) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3), symmetry,ORDN,sst + real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1,z1 + real*8, dimension(3), intent(in) :: SoA + integer,dimension(3), intent(in) :: inds + real*8, dimension(2*ORDN), intent(in) :: coef + +!~~~~~~> Other parameters: + + real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,ex(3)) :: fh + integer :: m + integer,dimension(2) :: cxB,cxT + real*8, dimension(ORDN,ORDN) :: ya + real*8, dimension(ORDN) :: tmp1 + real*8, dimension(2) :: SoAh + real*8, external :: DDOT + +! +1 because c++ gives 0 for first point + cxB = inds(1:2)+1 + cxT = cxB + ORDN - 1 + + if(all(cxB>0).and.all(cxTex(1:2)+ORDN))then + write(*,*)"error in global_interpind2d, cxB = ",cxB + write(*,*)" cxT = ",cxT + write(*,*)" ext = ",ex(1:2) + stop + else + if(sst==-1)then + write(*,*)"error in global_interpind2d, sst = ",sst + stop + elseif(sst==0.or.sst==1)then + SoAh = SoA(1:2) + elseif(sst==2.or.sst==3)then + SoAh(1) = SoA(2) + SoAh(2) = SoA(3) + elseif(sst==4.or.sst==5)then + SoAh(1) = SoA(1) + SoAh(2) = SoA(3) + endif + call symmetry_stbd(ORDN,ex,f,fh,SoAh) + ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),inds(3)) + endif + + ! Optimized with BLAS operations + tmp1=0 + do m=1,ORDN + tmp1 = tmp1 + coef(ORDN+m)*ya(:,m) + enddo + + ! Use BLAS DDOT for final weighted sum + f_int = DDOT(ORDN, coef(1:ORDN), 1, tmp1, 1) + + return + + end subroutine global_interpind2d +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +!global interpolation with given index and coeffients +! special for shell to shell +! dumyd refer to source + subroutine global_interpind1d(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,indsi,coef,sst,dumyd) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),symmetry,ORDN,sst,dumyd + real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1,z1 + real*8, dimension(3), intent(in) :: SoA + integer,dimension(3), intent(in) :: indsi + real*8, dimension(ORDN), intent(in) :: coef + +!~~~~~~> Other parameters: + + real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,ex(3)) :: fh + integer :: m + integer :: cxB,cxT + real*8, dimension(ORDN) :: ya + real*8 :: SoAh + integer,dimension(3) :: inds + real*8, external :: DDOT + +! +1 because c++ gives 0 for first point + inds = indsi + 1 + cxB = inds(1) + cxT = cxB + ORDN - 1 + +! active is rho + if(dumyd==1)then + + if(cxB>0.and.cxTex(1)+ORDN)then + write(*,*)"error in global_interpind1d, cxB = ",cxB + write(*,*)" cxT = ",cxT + write(*,*)" ext = ",ex(1) + stop + else + if(sst==-1)then + write(*,*)"error in global_interpind1d, sst = ",sst + stop + elseif(sst==0.or.sst==1)then + SoAh = SoA(1) + elseif(sst==2.or.sst==3)then + SoAh = SoA(2) + elseif(sst==4.or.sst==5)then + SoAh = SoA(1) + endif + call symmetry_sntbd(ORDN,ex,f,fh,SoAh,1-dumyd) + ya=fh(cxB:cxT,inds(2),inds(3)) + endif + +! active is sigma + elseif(dumyd==0)then + + if(cxB>0.and.cxTex(2)+ORDN)then + write(*,*)"error in global_interpind1d, cxB = ",cxB + write(*,*)" cxT = ",cxT + write(*,*)" ext = ",ex(2) + stop + else + if(sst==-1)then + write(*,*)"error in global_interpind1d, sst = ",sst + stop + elseif(sst==0.or.sst==1)then + SoAh = SoA(2) + elseif(sst==2.or.sst==3)then + SoAh = SoA(3) + elseif(sst==4.or.sst==5)then + SoAh = SoA(3) + endif + call symmetry_sntbd(ORDN,ex,f,fh,SoAh,1-dumyd) + ya=fh(inds(2),cxB:cxT,inds(3)) + endif + + else + write(*,*)"error in global_interpind1d, not recognized dumyd = ",dumyd + endif + + ! Optimized with BLAS DDOT for weighted sum + f_int = DDOT(ORDN, coef, 1, ya, 1) + + return + + end subroutine global_interpind1d +!----------------------------------------------------------------------------------------------------------------- +! three dimensional interpolation for both vertex and cell center grid structure +! for distinguishing shell and Cartesian + subroutine global_interp_ss(ex,X,Y,Z,f,f_int,x1,y1,z1,ORDN,SoA,symmetry,sst) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3), symmetry,ORDN,sst + real*8,intent(in) :: X(ex(1)),Y(ex(2)),Z(ex(3)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1,z1 + real*8, dimension(3), intent(in) :: SoA + +!~~~~~~> Other parameters: + + real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,-ORDN+1:ex(3)+ORDN) :: fh + real*8, dimension(3) :: SoAh + integer :: j,m,imin,jmin,kmin + integer,dimension(3) :: cxB,cxT,cxI,cmin,cmax + real*8,dimension(3) :: cx + real*8, dimension(1:ORDN) :: x1a + real*8, dimension(1:ORDN,1:ORDN,1:ORDN) :: ya + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8 :: dX,dY,dZ,ddy + real*8, parameter :: ONE=1.d0 + + imin = lbound(f,1) + jmin = lbound(f,2) + kmin = lbound(f,3) + + dX = X(imin+1)-X(imin) + dY = Y(jmin+1)-Y(jmin) + dZ = Z(kmin+1)-Z(kmin) + + forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE + + cxI(1) = idint((x1-X(1))/dX+0.4)+1 + cxI(2) = idint((y1-Y(1))/dY+0.4)+1 + cxI(3) = idint((z1-Z(1))/dZ+0.4)+1 + + cxB = cxI - ORDN/2+1 + cxT = cxB + ORDN - 1 + + cmin = 1 + cmax = ex + + if(sst==-1)then + SoAh = SoA + cmin = -ORDN+1 + elseif(sst==0.or.sst==1)then + SoAh = SoA + SoAh(3) = 0 + cmin(1:2) = -ORDN+1 + cmax(1:2) = ex(1:2)+ORDN + elseif(sst==2.or.sst==3)then + SoAh(1) = SoA(2) + SoAh(2) = SoA(3) + SoAh(3) = 0 + cmin(1:2) = -ORDN+1 + cmax(1:2) = ex(1:2)+ORDN + elseif(sst==4.or.sst==5)then + SoAh(1) = SoA(1) + SoAh(2) = SoA(3) + SoAh(3) = 0 + cmin(1:2) = -ORDN+1 + cmax(1:2) = ex(1:2)+ORDN + endif + do m =1,3 + if(cxB(m) < cmin(m))then + cxB(m) = cmin(m) + cxT(m) = cxB(m) + ORDN - 1 + endif + if(cxT(m) > cmax(m))then + cxT(m) = cmax(m) + cxB(m) = cxT(m) + 1 - ORDN + endif + enddo + cx(1) = (x1 - X(1))/dX-cxB(1)+1 + cx(2) = (y1 - Y(1))/dY-cxB(2)+1 + cx(3) = (z1 - Z(1))/dZ-cxB(3)+1 + + call symmetry_tbd(ORDN,ex,f,fh,SoAh) + ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),cxB(3):cxT(3)) + + call polin3(x1a,x1a,x1a,ya,cx(1),cx(2),cx(3),f_int,ddy,ORDN) + + return + + end subroutine global_interp_ss +!----------------------------------------------------------------------------------------------------------------- +! two dimensional interpolation for both vertex and cell center grid structure +! for distinguishing shell and Cartesian + subroutine global_interp_ss_2d(ex,X,Y,indZ,f,f_int,x1,y1,ORDN,SoA,symmetry,sst) + implicit none + +!~~~~~~> Input parameters: + + integer, intent(in) :: ex(1:3),indZ,symmetry,ORDN,sst + real*8,intent(in) :: X(ex(1)),Y(ex(2)) + real*8, dimension(ex(1),ex(2),ex(3)),intent(in) :: f + real*8, intent(out):: f_int + real*8, intent(in) :: x1,y1 + real*8, dimension(3), intent(in) :: SoA + +!~~~~~~> Other parameters: + + real*8, dimension(-ORDN+1:ex(1)+ORDN,-ORDN+1:ex(2)+ORDN,-ORDN+1:ex(3)+ORDN) :: fh + real*8, dimension(3) :: SoAh + integer :: j,m,imin,jmin,kmin + integer,dimension(2) :: cxB,cxT,cxI,cmin,cmax + real*8,dimension(2) :: cx + real*8, dimension(1:ORDN) :: x1a + real*8, dimension(1:ORDN,1:ORDN) :: ya + integer, parameter :: NO_SYMM = 0, EQUATORIAL = 1, OCTANT = 2 + real*8 :: dX,dY,ddy + real*8, parameter :: ONE=1.d0 + +! sanity check + if(indZ < 1 .or. indZ > ex(3))then + write(*,*)"error in global_interp_ss_2d, ext = ",ex(3),"ind = ",indZ + return + endif + + imin = lbound(f,1) + jmin = lbound(f,2) + kmin = lbound(f,3) + + dX = X(imin+1)-X(imin) + dY = Y(jmin+1)-Y(jmin) + + forall( j = 1:ordn ) x1a(j) = ( j - 1 )* ONE + + cxI(1) = idint((x1-X(1))/dX+0.4)+1 + cxI(2) = idint((y1-Y(1))/dY+0.4)+1 + + cxB = cxI - ORDN/2+1 + cxT = cxB + ORDN - 1 + + cmin = 1 + cmax = ex(1:2) + + if(sst==-1)then + SoAh = SoA + cmin = -ORDN+1 + elseif(sst==0.or.sst==1)then + SoAh = SoA + SoAh(3) = 0 + cmin(1:2) = -ORDN+1 + cmax(1:2) = ex(1:2)+ORDN + elseif(sst==2.or.sst==3)then + SoAh(1) = SoA(2) + SoAh(2) = SoA(3) + SoAh(3) = 0 + cmin(1:2) = -ORDN+1 + cmax(1:2) = ex(1:2)+ORDN + elseif(sst==4.or.sst==5)then + SoAh(1) = SoA(1) + SoAh(2) = SoA(3) + SoAh(3) = 0 + cmin(1:2) = -ORDN+1 + cmax(1:2) = ex(1:2)+ORDN + endif + do m =1,2 + if(cxB(m) < cmin(m))then + cxB(m) = cmin(m) + cxT(m) = cxB(m) + ORDN - 1 + endif + if(cxT(m) > cmax(m))then + cxT(m) = cmax(m) + cxB(m) = cxT(m) + 1 - ORDN + endif + enddo + cx(1) = (x1 - X(1))/dX-cxB(1)+1 + cx(2) = (y1 - Y(1))/dY-cxB(2)+1 + + call symmetry_tbd(ORDN,ex,f,fh,SoAh) + ya=fh(cxB(1):cxT(1),cxB(2):cxT(2),indZ) + + call polin2(x1a,x1a,ya,cx(1),cx(2),f_int,ddy,ORDN) + + return + + end subroutine global_interp_ss_2d +!------------------------------------------ +!fortran version of Wigner d function +!Eq.(42) of PRD 77, 024027 (2008) +!we consider only theta in [0,pi] +!------------------------------------------ + function fWigner_d_function(l,m,s,costheta) result(gont) + implicit none + integer,intent(in) :: l,m,s + real*8,intent(in) :: costheta + + real*8 :: gont + + integer :: t,C1,C2 + real*8 :: ffact,vv,sinht,cosht + + C1=max(0,m-s) + C2=min(l+m,l-s) + vv=0 + sinht=dsqrt((1.d0-costheta)/2.d0) + cosht=dsqrt((1.d0+costheta)/2.d0); + if(C1/2*2==C1)then + do t=C1,C2,2 + vv=vv+cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) + enddo + do t=C1+1,C2,2 + vv=vv-cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) + enddo + else + do t=C1,C2,2 + vv=vv-cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) + enddo + do t=C1+1,C2,2 + vv=vv+cosht**(2*l+m-s-2*t)*sinht**(2*t+s-m)/(ffact(l+m-t)*ffact(l-s-t)*ffact(t)*ffact(t+s-m)) + enddo + endif + + gont = vv*dsqrt(ffact(l+m)*ffact(l-m)*ffact(l+s)*ffact(l-s)) + + return + + end function fWigner_d_function +!---------------------------------- +! Optimized factorial function using lookup table for small N +! and log-gamma for large N to avoid overflow + function ffact(N) result(gont) + implicit none + integer,intent(in) :: N + + real*8 :: gont + integer :: i + + ! Lookup table for factorials 0! to 20! (precomputed) + real*8, parameter, dimension(0:20) :: fact_table = [ & + 1.d0, 1.d0, 2.d0, 6.d0, 24.d0, 120.d0, 720.d0, 5040.d0, 40320.d0, & + 362880.d0, 3628800.d0, 39916800.d0, 479001600.d0, 6227020800.d0, & + 87178291200.d0, 1307674368000.d0, 20922789888000.d0, & + 355687428096000.d0, 6402373705728000.d0, 121645100408832000.d0, & + 2432902008176640000.d0 ] + +! sanity check + if(N < 0)then + write(*,*) "ffact: error input for factorial" + gont = 1.d0 + return + endif + + ! Use lookup table for small N (fast path) + if(N <= 20)then + gont = fact_table(N) + else + ! Use log-gamma function for large N: N! = exp(log_gamma(N+1)) + ! This avoids overflow and is computed efficiently + gont = exp(log_gamma(dble(N+1))) + endif + + return + + end function ffact +!--------------------------- +!Eq.(41) of PRD 77, 024027 (2008) +!---------------------------------- + function Yslm(s,l,m,the,phi) result(gont) + implicit none + integer,intent(in) :: s,l,m + real*8,intent(in) :: the,phi + + double complex :: gont + + real*8 :: fWigner_d_function,PI,rp + + PI = dacos(-1.d0) + + rp = fWigner_d_function(l,m,s,dcos(the)) + rp = rp*dsqrt((2*l+1.d0)/4.d0/PI) + if(s/2*2.ne.s) rp = -rp + + gont = dcmplx(dcos(m*phi),dsin(m*phi)) + + gont = rp*gont + + return + + end function Yslm +!------------------------------------------------------------------------------------ +subroutine set_value(ext,data_out,rr) + + IMPLICIT NONE + + integer, intent(in) :: ext(3) + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(out) :: data_out + REAL*8, intent(in) :: rr + + data_out = rr + + return +end subroutine set_value +subroutine add_value(ext,data_out,rr) + + IMPLICIT NONE + + integer, intent(in) :: ext(3) + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(inout) :: data_out + REAL*8, intent(in) :: rr + + data_out = data_out + rr + + return +end subroutine add_value +! copy array2 to array1 +subroutine array_copy(ext,data1,data2) + + IMPLICIT NONE + + integer, intent(in) :: ext(3) + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(out) :: data1 + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: data2 + + data1 = data2 + + return + end subroutine array_copy +! add array2 to array1 +subroutine array_add(ext,data1,data2) + + IMPLICIT NONE + + integer, intent(in) :: ext(3) + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(inout) :: data1 + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: data2 + + data1 = data1 + data2 + + return + end subroutine array_add +! subtract array2 from array1 +subroutine array_subtract(ext,data1,data2) + + IMPLICIT NONE + + integer, intent(in) :: ext(3) + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(inout) :: data1 + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: data2 + + data1 = data1 - data2 + + return + end subroutine array_subtract +! find out the maximum +subroutine find_maximum(ext,X,Y,Z,fun,val,pos,llb,uub) + + implicit none + + integer,intent(in) :: ext(3),llb(3),uub(3) + real*8 :: X(ext(1)),Y(ext(2)),Z(ext(3)) + REAL*8, DIMENSION(ext(1),ext(2),ext(3)), intent(in) :: fun + real*8,intent(out) :: val,pos(3) + + integer :: i,j,k,ii,jj,kk + real*8 :: tmp + + tmp = 0.d0 + + ii=1 + jj=1 + kk=1 + + do k=llb(3)+1,ext(3)-uub(3) + do j=llb(2)+1,ext(2)-uub(2) + do i=llb(1)+1,ext(1)-uub(1) + if(dabs(fun(i,j,k)) > tmp)then + tmp = dabs(fun(i,j,k)) + ii = i + jj = j + kk = k + endif + enddo + enddo + enddo + + pos(1) = X(ii) + pos(2) = Y(jj) + pos(3) = Z(kk) + val = tmp + + return + +end subroutine diff --git a/AMSS_NCKU_source/fmisc.h b/AMSS_NCKU_source/misc/fmisc.h similarity index 96% rename from AMSS_NCKU_source/fmisc.h rename to AMSS_NCKU_source/misc/fmisc.h index 5af428e..1c3cf5c 100644 --- a/AMSS_NCKU_source/fmisc.h +++ b/AMSS_NCKU_source/misc/fmisc.h @@ -1,164 +1,164 @@ - -#ifndef FMISC_H -#define FMISC_H - -#ifdef fortran1 -#define f_interp_2 interp_2 -#define f_pointcopy pointcopy -#define f_copy copy -#define f_global_interp global_interp -#define f_global_interp_ss global_interp_ss -#define f_global_interp_ss_2d global_interp_ss_2d -#define f_global_interpind global_interpind -#define f_global_interpind2d global_interpind2d -#define f_global_interpind1d global_interpind1d + +#ifndef FMISC_H +#define FMISC_H + +#ifdef fortran1 +#define f_interp_2 interp_2 +#define f_pointcopy pointcopy +#define f_copy copy +#define f_global_interp global_interp +#define f_global_interp_ss global_interp_ss +#define f_global_interp_ss_2d global_interp_ss_2d +#define f_global_interpind global_interpind +#define f_global_interpind2d global_interpind2d +#define f_global_interpind1d global_interpind1d #define f_l2normhelper l2normhelper #define f_l2normhelper7 l2normhelper7 #define f_l2normhelper_sh l2normhelper_sh #define f_l2normhelper_sh_rms l2normhelper_sh_rms -#define f_average average -#define f_average3 average3 -#define f_average2 average2 -#define f_average2p average2p -#define f_average2m average2m -#define f_lowerboundset lowerboundset -#define f_set_value set_value -#define f_add_value add_value -#define f_array_add array_add -#define f_array_copy array_copy -#define f_array_subtract array_subtract -#define f_fft four1 -#define f_find_maximum find_maximum -#define f_polint polint -#define f_d2dump d2dump -#endif -#ifdef fortran2 -#define f_interp_2 INTERP_2 -#define f_pointcopy POINTCOPY -#define f_copy COPY -#define f_global_interp GLOBAL_INTERP -#define f_global_interp_ss GLOBAL_INTERP_SS -#define f_global_interp_ss_2d GLOBAL_INTERP_SS_2D -#define f_global_interpind GLOBAL_INTERPIND -#define f_global_interpind2d GLOBAL_INTERPIND2D -#define f_global_interpind1d GLOBAL_INTERPIND1D +#define f_average average +#define f_average3 average3 +#define f_average2 average2 +#define f_average2p average2p +#define f_average2m average2m +#define f_lowerboundset lowerboundset +#define f_set_value set_value +#define f_add_value add_value +#define f_array_add array_add +#define f_array_copy array_copy +#define f_array_subtract array_subtract +#define f_fft four1 +#define f_find_maximum find_maximum +#define f_polint polint +#define f_d2dump d2dump +#endif +#ifdef fortran2 +#define f_interp_2 INTERP_2 +#define f_pointcopy POINTCOPY +#define f_copy COPY +#define f_global_interp GLOBAL_INTERP +#define f_global_interp_ss GLOBAL_INTERP_SS +#define f_global_interp_ss_2d GLOBAL_INTERP_SS_2D +#define f_global_interpind GLOBAL_INTERPIND +#define f_global_interpind2d GLOBAL_INTERPIND2D +#define f_global_interpind1d GLOBAL_INTERPIND1D #define f_l2normhelper L2NORMHELPER #define f_l2normhelper7 L2NORMHELPER7 #define f_l2normhelper_sh L2NORMHELPER_SH #define f_l2normhelper_sh_rms L2NORMHELPER_SH_RMS -#define f_average AVERAGE -#define f_average3 AVERAGE3 -#define f_average2 AVERAGE2 -#define f_average2p AVERAGE2P -#define f_average2m AVERAGE2M -#define f_lowerboundset LOWERBOUNDSET -#define f_set_value SET_VALU -#define f_add_value ADD_VALUE -#define f_array_add ARRAY_ADD -#define f_array_copy ARRAY_COPY -#define f_array_subtract ARRAY_SUBTRACT -#define f_fft FOUR1 -#define f_find_maximum FIND_MAXIMUM -#define f_polint POLINT -#define f_d2dump D2DUMP -#endif -#ifdef fortran3 -#define f_interp_2 interp_2_ -#define f_pointcopy pointcopy_ -#define f_copy copy_ -#define f_global_interp global_interp_ -#define f_global_interp_ss global_interp_ss_ -#define f_global_interp_ss_2d global_interp_ss_2d_ -#define f_global_interpind global_interpind_ -#define f_global_interpind2d global_interpind2d_ -#define f_global_interpind1d global_interpind1d_ +#define f_average AVERAGE +#define f_average3 AVERAGE3 +#define f_average2 AVERAGE2 +#define f_average2p AVERAGE2P +#define f_average2m AVERAGE2M +#define f_lowerboundset LOWERBOUNDSET +#define f_set_value SET_VALU +#define f_add_value ADD_VALUE +#define f_array_add ARRAY_ADD +#define f_array_copy ARRAY_COPY +#define f_array_subtract ARRAY_SUBTRACT +#define f_fft FOUR1 +#define f_find_maximum FIND_MAXIMUM +#define f_polint POLINT +#define f_d2dump D2DUMP +#endif +#ifdef fortran3 +#define f_interp_2 interp_2_ +#define f_pointcopy pointcopy_ +#define f_copy copy_ +#define f_global_interp global_interp_ +#define f_global_interp_ss global_interp_ss_ +#define f_global_interp_ss_2d global_interp_ss_2d_ +#define f_global_interpind global_interpind_ +#define f_global_interpind2d global_interpind2d_ +#define f_global_interpind1d global_interpind1d_ #define f_l2normhelper l2normhelper_ #define f_l2normhelper7 l2normhelper7_ #define f_l2normhelper_sh l2normhelper_sh_ #define f_l2normhelper_sh_rms l2normhelper_sh_rms_ -#define f_average average_ -#define f_average3 average3_ -#define f_average2 average2_ -#define f_average2p average2p_ -#define f_average2m average2m_ -#define f_lowerboundset lowerboundset_ -#define f_set_value set_value_ -#define f_add_value add_value_ -#define f_array_add array_add_ -#define f_array_copy array_copy_ -#define f_array_subtract array_subtract_ -#define f_fft four1_ -#define f_find_maximum find_maximum_ -#define f_polint polint_ -#define f_d2dump d2dump_ -#endif - -extern "C" -{ - void f_pointcopy(int &, - double *, double *, int *, double *, - double &, double &, double &, double &); -} - -extern "C" -{ - void f_copy(int &, - double *, double *, int *, double *, - double *, double *, int *, double *, - double *, double *); -} - -extern "C" -{ - void f_global_interp(int *, double *, double *, double *, - double *, double &, - double &, double &, double &, - int &, double *, int &); -} - -extern "C" -{ - void f_global_interp_ss(int *, double *, double *, double *, - double *, double &, - double &, double &, double &, - int &, double *, int &, int &); -} - -extern "C" -{ - void f_global_interp_ss_2d(int *, double *, double *, int &, - double *, double &, - double &, double &, - int &, double *, int &, int &); -} - -extern "C" -{ - void f_global_interpind(int *, double *, double *, double *, - double *, double &, - double &, double &, double &, - int &, double *, int &, - int *, double *, int &); -} - -extern "C" -{ - void f_global_interpind2d(int *, double *, double *, double *, - double *, double &, - double &, double &, double &, - int &, double *, int &, - int *, double *, int &); -} - -extern "C" -{ - void f_global_interpind1d(int *, double *, double *, double *, - double *, double &, - double &, double &, double &, - int &, double *, int &, - int *, double *, int &, int &); -} - +#define f_average average_ +#define f_average3 average3_ +#define f_average2 average2_ +#define f_average2p average2p_ +#define f_average2m average2m_ +#define f_lowerboundset lowerboundset_ +#define f_set_value set_value_ +#define f_add_value add_value_ +#define f_array_add array_add_ +#define f_array_copy array_copy_ +#define f_array_subtract array_subtract_ +#define f_fft four1_ +#define f_find_maximum find_maximum_ +#define f_polint polint_ +#define f_d2dump d2dump_ +#endif + +extern "C" +{ + void f_pointcopy(int &, + double *, double *, int *, double *, + double &, double &, double &, double &); +} + +extern "C" +{ + void f_copy(int &, + double *, double *, int *, double *, + double *, double *, int *, double *, + double *, double *); +} + +extern "C" +{ + void f_global_interp(int *, double *, double *, double *, + double *, double &, + double &, double &, double &, + int &, double *, int &); +} + +extern "C" +{ + void f_global_interp_ss(int *, double *, double *, double *, + double *, double &, + double &, double &, double &, + int &, double *, int &, int &); +} + +extern "C" +{ + void f_global_interp_ss_2d(int *, double *, double *, int &, + double *, double &, + double &, double &, + int &, double *, int &, int &); +} + +extern "C" +{ + void f_global_interpind(int *, double *, double *, double *, + double *, double &, + double &, double &, double &, + int &, double *, int &, + int *, double *, int &); +} + +extern "C" +{ + void f_global_interpind2d(int *, double *, double *, double *, + double *, double &, + double &, double &, double &, + int &, double *, int &, + int *, double *, int &); +} + +extern "C" +{ + void f_global_interpind1d(int *, double *, double *, double *, + double *, double &, + double &, double &, double &, + int &, double *, int &, + int *, double *, int &, int &); +} + extern "C" { void f_l2normhelper(int *, double *, double *, double *, @@ -182,95 +182,95 @@ extern "C" double &, double &, double &, double &, double &, double &, double *, double &, int &, int &, int &); -} - -extern "C" -{ - void f_l2normhelper_sh_rms(int *, double *, double *, double *, - double &, double &, double &, - double &, double &, double &, - double *, double &, int &, int &, int &, int &); -} - -extern "C" -{ - void f_average(int *, double *, double *, double *); -} - -extern "C" -{ - void f_average3(int *, double *, double *, double *); -} - -extern "C" -{ - void f_average2(int *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_average2p(int *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_average2m(int *, double *, double *, double *, double *); -} - -extern "C" -{ - void f_lowerboundset(int *, double *, double &); -} - -#if 0 -extern "C" { void f_interp_2( int *, double *, - double &, int &,int &,int &,int &,int &,int &, - double &,double &,double &, - int &, double *, - int & - );} -#endif - -extern "C" -{ - void f_set_value(int *, double *, double &); -} -extern "C" -{ - void f_add_value(int *, double *, double &); -} -extern "C" -{ - void f_array_add(int *, double *, double *); -} -extern "C" -{ - void f_array_copy(int *, double *, double *); -} -extern "C" -{ - void f_array_subtract(int *, double *, double *); -} - -extern "C" -{ - void f_fft(double *, int &, int &); -} - -extern "C" -{ - void f_find_maximum(int *, - double *, double *, double *, double *, - double &, double *, int *, int *); -} - -extern "C" -{ - void f_polint(double *, double *, double &, double &, double &, int &); -} - -extern "C" -{ - void f_d2dump(int &, double *, double *, int *, double *, double *, int &, double *); -} -#endif /* FMISC_H */ +} + +extern "C" +{ + void f_l2normhelper_sh_rms(int *, double *, double *, double *, + double &, double &, double &, + double &, double &, double &, + double *, double &, int &, int &, int &, int &); +} + +extern "C" +{ + void f_average(int *, double *, double *, double *); +} + +extern "C" +{ + void f_average3(int *, double *, double *, double *); +} + +extern "C" +{ + void f_average2(int *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_average2p(int *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_average2m(int *, double *, double *, double *, double *); +} + +extern "C" +{ + void f_lowerboundset(int *, double *, double &); +} + +#if 0 +extern "C" { void f_interp_2( int *, double *, + double &, int &,int &,int &,int &,int &,int &, + double &,double &,double &, + int &, double *, + int & + );} +#endif + +extern "C" +{ + void f_set_value(int *, double *, double &); +} +extern "C" +{ + void f_add_value(int *, double *, double &); +} +extern "C" +{ + void f_array_add(int *, double *, double *); +} +extern "C" +{ + void f_array_copy(int *, double *, double *); +} +extern "C" +{ + void f_array_subtract(int *, double *, double *); +} + +extern "C" +{ + void f_fft(double *, int &, int &); +} + +extern "C" +{ + void f_find_maximum(int *, + double *, double *, double *, double *, + double &, double *, int *, int *); +} + +extern "C" +{ + void f_polint(double *, double *, double &, double &, double &, int &); +} + +extern "C" +{ + void f_d2dump(int &, double *, double *, int *, double *, double *, int &, double *); +} +#endif /* FMISC_H */ diff --git a/AMSS_NCKU_source/misc.C b/AMSS_NCKU_source/misc/misc.C similarity index 96% rename from AMSS_NCKU_source/misc.C rename to AMSS_NCKU_source/misc/misc.C index b692485..3bf701d 100644 --- a/AMSS_NCKU_source/misc.C +++ b/AMSS_NCKU_source/misc/misc.C @@ -1,1358 +1,1358 @@ - -#ifdef newc -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#endif -#include - -#include "misc.h" -#include "macrodef.h" -#include "zbesh.h" - -#define PI M_PI - -void misc::tillherecheck(int myrank) -{ - int atp = 1, tatp; - MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - if (myrank == 0) - cout << " here now: " << tatp << " processors." << endl; -} -void misc::tillherecheck(const char str[]) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - int atp = 1, tatp; - MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); - if (myrank == 0) - { - cout << " here now: " << tatp << " processors." << endl; - cout << str << endl; - } -} -void misc::tillherecheck(MPI_Comm Comm_here, int out_rank, const char str[]) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - int atp = 1, tatp; - - MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, Comm_here); - if (myrank == out_rank) - { - cout << " here now: " << tatp << " processors." << endl; - cout << str << endl; - } -} -void misc::tillherecheck(MPI_Comm Comm_here, int out_rank, const string str) -{ - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD, &myrank); - int atp = 1, tatp; - - MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, Comm_here); - if (myrank == out_rank) - { - cout << " here now: " << tatp << " processors." << endl; - cout << str << endl; - } -} -// pick out value from input string -int misc::parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind) -{ - int pos1, pos2; - string s0; - - ind = 0; - - // remove comments - str = str.substr(0, str.find("#")); - if (rTrim(str).empty()) - return 0; // continue; - - // parse {group, key, val} - pos1 = str.find("::"); - pos2 = str.find("="); - if (pos1 == string::npos || pos2 == string::npos) - return -1; - - s0 = str.substr(0, pos1); - sgrp = lTrim(s0); - s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); - skey = rTrim(s0); - s0 = str.substr(pos2 + 1); - sval = Trim(s0); - - pos1 = sval.find("\""); - pos2 = sval.rfind("\""); - if (pos1 != string::npos) - { - sval = sval.substr(1, pos2 - 1); - } - - pos1 = skey.find("["); - pos2 = skey.find("]"); - if (pos1 != string::npos) - { - s0 = skey.substr(0, pos1); - ind = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - skey = s0; - } - - return 1; -} -int misc::parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2) -{ - int pos1, pos2; - string s0, s1; - - ind1 = ind2 = 0; - - // remove comments - str = str.substr(0, str.find("#")); - if (rTrim(str).empty()) - return 0; // continue; - - // parse {group, key, val} - pos1 = str.find("::"); - pos2 = str.find("="); - if (pos1 == string::npos || pos2 == string::npos) - return -1; - - s0 = str.substr(0, pos1); - sgrp = lTrim(s0); - s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); - skey = rTrim(s0); - s0 = str.substr(pos2 + 1); - sval = Trim(s0); - - pos1 = sval.find("\""); - pos2 = sval.rfind("\""); - if (pos1 != string::npos) - { - sval = sval.substr(1, pos2 - 1); - } - - pos1 = skey.find("["); - pos2 = skey.find("]"); - if (pos1 != string::npos) - { - s0 = skey.substr(0, pos1); - s1 = skey.substr(pos2 + 1); - ind1 = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - skey = s0; - } - - pos1 = s1.find("["); - pos2 = s1.find("]"); - if (pos1 != string::npos) - { - s0 = s1.substr(pos2 + 1); - ind2 = atoi(s1.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - } - - return 1; -} -int misc::parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2, int &ind3) -{ - int pos1, pos2; - string s0, s1; - - ind1 = ind2 = ind3 = 0; - - // remove comments - str = str.substr(0, str.find("#")); - if (rTrim(str).empty()) - return 0; // continue; - - // parse {group, key, val} - pos1 = str.find("::"); - pos2 = str.find("="); - if (pos1 == string::npos || pos2 == string::npos) - return -1; - - s0 = str.substr(0, pos1); - sgrp = lTrim(s0); - s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); - skey = rTrim(s0); - s0 = str.substr(pos2 + 1); - sval = Trim(s0); - - pos1 = sval.find("\""); - pos2 = sval.rfind("\""); - if (pos1 != string::npos) - { - sval = sval.substr(1, pos2 - 1); - } - - pos1 = skey.find("["); - pos2 = skey.find("]"); - if (pos1 != string::npos) - { - s0 = skey.substr(0, pos1); - s1 = skey.substr(pos2 + 1); - ind1 = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - skey = s0; - } - - pos1 = s1.find("["); - pos2 = s1.find("]"); - if (pos1 != string::npos) - { - s0 = s1.substr(pos2 + 1); - ind2 = atoi(s1.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - } - - pos1 = s0.find("["); - pos2 = s0.find("]"); - if (pos1 != string::npos) - { - ind3 = atoi(s0.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); - } - - return 1; -} -// sent me from Roman Gold on 2010-10-8 -void misc::gaulegf(double x1, double x2, double *x, double *w, int n) -{ - int i, j, m; - double eps = 1.2E-16; - double p1, p2, p3, pp, xl, xm, z, z1; - - m = (n + 1) / 2; - xm = 0.5 * (x2 + x1); - xl = 0.5 * (x2 - x1); - for (i = 0; i < m; i++) - { - z = cos(PI * ((double)i + 0.75) / ((double)n + 0.5)); - do - { - p1 = 1.0; - p2 = 0.0; - for (j = 0; j < n; j++) - { - p3 = p2; - p2 = p1; - p1 = ((2 * (double)j + 1) * z * p2 - (double)j * p3) / ((double)j + 1); - } - pp = n * (z * p1 - p2) / (z * z - 1.0); - z1 = z; - z = z1 - p1 / pp; - } while (fabs(z - z1) > eps); - x[i] = xm - xl * z; - x[n - 1 - i] = xm + xl * z; - w[i] = 2.0 * xl / ((1.0 - z * z) * pp * pp); - w[n - 1 - i] = w[i]; - } -} /* end gaulegf */ -void misc::inversearray(double *aa, int NN) -{ - int i, m; - m = (NN + 1) / 2; - double rr; - for (i = 0; i < m; i++) - { - rr = aa[i]; - aa[i] = aa[NN - 1 - i]; - aa[NN - 1 - i] = rr; - } -} -// Eq.(42) of PRD 77, 024027 (2008) -double misc::Wigner_d_function(int l, int m, int s, double costheta) -{ - // we consider only theta in [0,pi] - int C1 = max(0, m - s), C2 = min(l + m, l - s); - - double vv = 0; - double sinht = sqrt((1 - costheta) / 2.0), cosht = sqrt((1 + costheta) / 2.0); - if (C1 % 2 == 0) - { - for (int t = C1; t < C2 + 1; t += 2) - vv = vv + pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / - (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); - for (int t = C1 + 1; t < C2 + 1; t += 2) - vv = vv - pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / - (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); - } - else - { - for (int t = C1; t < C2 + 1; t += 2) - vv = vv - pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / - (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); - for (int t = C1 + 1; t < C2 + 1; t += 2) - vv = vv + pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / - (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); - } - return vv * sqrt(fact(l + m) * fact(l - m) * fact(l + s) * fact(l - s)); -} -double misc::fact(int N) -{ - if (N < 0) - cout << "error input for factorial." << endl; - double f; - if (N == 0) - f = 1; - else - f = N * fact(N - 1); - return f; -} -int misc::num_of_str(char *c) -{ - int NN = 0, N1 = 0; - std::istringstream iss; - iss.str(c); - - char c1[1000]; - while (!iss.eof()) - { - iss >> c1; - if (int(c1[0]) == 45 || int(c1[0]) == 46 || (int(c1[0]) > 47 && int(c1[0]) < 58)) - NN++; - N1++; - } - - char *c2 = c; - while (*(c2 + 1)) - c2++; - if (int(*c2) == 32) - { - NN--; - N1--; - } - - // cout<<"found "< &f0, - std::vector &f1, std::vector &f_rhs, const int RK4) -{ - const int N = f0.size(); - const double F1o6 = 1.0 / 6, HLF = 0.5, TWO = 2; - switch (RK4) - { - case 0: - for (int i = 0; i < N; i++) - f1[i] = f0[i] + HLF * dT * f_rhs[i]; - break; - case 1: - for (int i = 0; i < N; i++) - { - f_rhs[i] = f_rhs[i] + TWO * f1[i]; - f1[i] = f0[i] + HLF * dT * f1[i]; - } - break; - case 2: - for (int i = 0; i < N; i++) - { - f_rhs[i] = f_rhs[i] + TWO * f1[i]; - f1[i] = f0[i] + dT * f1[i]; - } - break; - case 3: - for (int i = 0; i < N; i++) - f1[i] = f0[i] + F1o6 * dT * (f1[i] + f_rhs[i]); - break; - default: - cout << "misc::rungekutta4: something is wrong in RK4 counting!!" << endl; - } -} -void misc::dividBlock(const int DIM, int *shape_here, double *bbox_here, const int pices, double *picef, int *shape_res, double *bbox_res, - const int min_width) -{ - if (pices < 1) - { - cerr << "error in dividBlock: pices = " << pices << endl; - return; - } - if (pices == 1) - { - for (int i = 0; i < DIM; i++) - { - shape_res[i] = shape_here[i]; - bbox_res[i] = bbox_here[i]; - bbox_res[DIM + i] = bbox_here[DIM + i]; - } - return; - } - - double dd = picef[0]; - for (int i = 1; i < pices; i++) - dd += picef[i]; - - if (feq(dd, 1, 1e-8)) - { - int leg = shape_here[0]; - int legi = 0; - for (int i = 1; i < DIM; i++) - { - if (leg < shape_here[i]) - { - leg = shape_here[i]; - legi = i; - } - } - - int pic = 0; - - for (int ip = 0; ip < pices; ip++) - { - for (int i = 0; i < DIM; i++) - { - if (i == legi) - { - if (ip == pices - 1) - shape_res[ip * DIM + i] = shape_here[i] - pic; - else - { - shape_res[ip * DIM + i] = shape_here[i] * picef[ip]; - pic += shape_res[ip * DIM + i]; - } - } - else - shape_res[ip * DIM + i] = shape_here[i]; - } - } - - for (int ip = 0; ip < pices; ip++) - { - for (int i = 0; i < DIM; i++) - { -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - dd = (bbox_here[DIM + i] - bbox_here[i]) / (shape_here[i] - 1); -#else -#ifdef Cell - dd = (bbox_here[DIM + i] - bbox_here[i]) / shape_here[i]; -#else -#error Not define Vertex nor Cell -#endif -#endif - - if (i == legi) - { - if (shape_res[ip * DIM + i] < min_width) - { - cerr << "dividBlock: resulted too small shape, shapeo = " << shape_here[i] << ", shape = " << shape_res[ip * DIM + i] << ", min_width = " << min_width << endl; - MPI_Abort(MPI_COMM_WORLD, 1); - } - - if (ip == 0) - bbox_res[ip * 2 * DIM + i] = bbox_here[i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - bbox_res[ip * 2 * DIM + i] = bbox_res[(ip - 1) * 2 * DIM + DIM + i] - ghost_width * dd + dd; // because for ip-1 we have already considered ghost points -#else -#ifdef Cell - else - bbox_res[ip * 2 * DIM + i] = bbox_res[(ip - 1) * 2 * DIM + DIM + i] - ghost_width * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - - if (ip == pices - 1) - bbox_res[ip * 2 * DIM + DIM + i] = bbox_here[DIM + i]; -#ifdef Vertex -#ifdef Cell -#error Both Cell and Vertex are defined -#endif - else - bbox_res[ip * 2 * DIM + DIM + i] = bbox_res[ip * 2 * DIM + i] + (shape_res[ip * DIM + i] - 1) * dd; -#else -#ifdef Cell - else - bbox_res[ip * 2 * DIM + DIM + i] = bbox_res[ip * 2 * DIM + i] + shape_res[ip * DIM + i] * dd; -#else -#error Not define Vertex nor Cell -#endif -#endif - - if (ip > 0) - { - shape_res[ip * DIM + i] += ghost_width; - bbox_res[ip * 2 * DIM + i] -= ghost_width * dd; - } - if (ip < pices - 1) - { - shape_res[ip * DIM + i] += ghost_width; - bbox_res[ip * 2 * DIM + DIM + i] += ghost_width * dd; - } - } - else - { - bbox_res[ip * 2 * DIM + i] = bbox_here[i]; - bbox_res[ip * 2 * DIM + DIM + i] = bbox_here[DIM + i]; - } - } - } - } - else - { - cerr << "error in dividBlock: "; - for (int i = 0; i < pices; i++) - cerr << picef[i] << " "; - cerr << endl; - } -#if 0 -// for check - int myrank; - MPI_Comm_rank(MPI_COMM_WORLD,&myrank); - if(myrank == 0) - { - cerr<<"original one"< &f0, std::vector &f1) -{ - const int N = f0.size(); - double tt; - for (int i = 0; i < N; i++) - { - tt = f0[i]; - f0[i] = f1[i]; - f1[i] = tt; - } -} -complex misc::complex_gamma(complex z) -{ - const double p[9] = {0.99999999999980993, 676.5203681218851, -1259.1392167224028, - 771.32342877765313, -176.61502916214059, 12.507343278686905, - -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7}; - - if (real(z) < 0.5) - { - return PI / (sin(PI * z) * complex_gamma(1.0 - z)); - } - z -= 1.0; - complex x = p[0]; - for (int i = 1; i < 9; i++) - { - x += p[i] / (z + complex(i, 0)); - } - complex t = z + (7 + 0.5); - t = sqrt(2 * PI) * pow(t, z + 0.5) * exp(-t) * x; - - return t; -} -// also called Kummer function, -// Confluent hypergeometric function 1F1 -#if 1 -complex misc::KummerComplex(const complex a, const complex b, complex x) -{ - // Default tolerance is tol = 1e-10. Feel free to change this as needed. - const double tol = 1e-10; - - // Estimates the value by summing powers of the generalized hypergeometric - // series: - // - // sum(n=0-->Inf)[(a)_n*x^n/{(b)_n*n!}] - // - // until the specified tolerance is acheived. - - complex term = x * a / b; - complex f = 1.0 + term; - int n = 1; - complex an = a; - complex bn = b; - int nmin = 100000; - - while (n < nmin && (abs(term)) > tol) - { - n = n + 1; - an = an + 1.0; - bn = bn + 1.0; - term = x * term * an / bn / double(n); - f = f + term; - } - - if ((abs(term)) > tol && n == nmin) - cout << "misc::KummerComplex has n > " << nmin << " with error " << abs(term) << endl - << "a = " << a << " b = " << b << " x = " << x << endl; - - return f; -} -// new code -#else -complex misc::KummerComplex(const complex a, const complex b, complex z) -{ - // Default tolerance is tol = 1e-10. Feel free to change this as needed. - int precision = 15; - int m, j, k; - complex cr, chg; - double cMax; - complex g1, g2, g3; - complex ba; - complex cs1, cs2, cr1, cr2; - double c1Max, c2Max; - - // Special cases - - if (b.imag() == 0 && b.real() <= 0 && b.real() == int(b.real())) // b==-n;n=1,2,3,.. - { - if (a.imag() == 0 && a.real() <= 0 && a.real() == int(a.real()) && abs(a) < abs(b)) // a==-m;m=1,2,.. - { - m = int(-a.real()); - cr = 1; - chg = 1; - - cMax = abs(cr); - - for (k = 1; k <= m; k++) - { - cr = cr * (k - 1.0 + a) / double(k) / (k - 1.0 + b) * z; - chg = chg + cr; - - cMax = max(cMax, max(abs(cr), abs(chg))); - } - - precision = 15 - int(log10(cMax / abs(chg))); - } - else if (a.imag() == 0 && a.real() <= 0 && a.real() == int(a.real()) && abs(a) == abs(b)) // a==b; - { - cout << "!!!Confluent hypergeometric function is indeterminate for input a = " - << a << " b = " << b << " z = " << z << endl; - chg = 0; - } - else - { - cout << "!!!Confluent hypergeometric function error for input a = " - << a << " b = " << b << " z = " << z << endl; - chg = 0; - } - } - else if (a == 0.0 || z == 0.0) - { - chg = 1; - } - else if (a == -1.0) - { - chg = 1.0 - z / b; - } - else if (a == b) - { - chg = exp(z); - } - else if ((a - b) == 1.0) - { - chg = (1.0 + z / b) * exp(z); - } - else if (a == 1.0 && b == 2.0) - { - chg = (exp(z) - 1.0) / z; - } - // finite number of elements in a row - else if (a.imag() == 0 && a.real() < 0 && a.real() == int(a.real())) - { - m = int(-a.real()); - cr = 1; - chg = 1; - - cMax = abs(cr); - - for (k = 1; k <= m; k++) - { - cr = cr * (k - 1.0 + a) / double(k) / (k - 1.0 + b) * z; - chg = chg + cr; - - cMax = max(cMax, max(abs(cr), abs(chg))); - } - - precision = 15 - int(log10(cMax / abs(chg))); - } - else if (abs(z) > 10 * abs(a) && abs(z) > 10 * abs(b)) // Abramowitz Stegun 13.5.1 - { - g1 = complex_gamma(a); - g2 = complex_gamma(b); - ba = b - a; - g3 = complex_gamma(ba); - - cs1 = 1; - cs2 = 1; - cr1 = 1; - cr2 = 1; - - c1Max = abs(cr1); - c2Max = abs(cr2); - - for (j = 1; j <= 500; j++) - { - cr1 = -cr1 * (j - 1.0 + a) * (a - b + double(j)) / (z * double(j)); - cr2 = cr2 * (j - 1.0 + b - a) * (double(j) - a) / (z * double(j)); - cs1 = cs1 + cr1; - cs2 = cs2 + cr2; - - c1Max = max(c1Max, max(abs(cr1), abs(cs1))); - c2Max = max(c2Max, max(abs(cr2), abs(cs2))); - - if (abs(cr1) / abs(cs1) < 1e-15 && abs(cr2) / abs(cs2) < 1e-15) - break; // break j - - if (j == 500) - { - cout << "Got to the " << j << " limit in the series of confluent hypergeometric function!" << endl; - chg = 0; - return chg; - } - } - - precision = 15 - int(log10(max(c1Max / abs(cs1), c2Max / abs(cs2)))); - - double x = z.real(); - double y = z.imag(); - double phi; - complex cfac, chg1, chg2; - int ns; - - if (x == 0.0 && y >= 0.0) - phi = 0.5 * PI; - else if (x == 0.0 && y <= 0.0) - phi = -0.5 * PI; - else - phi = atan(y / x); - - if (phi > -0.5 * PI && phi < 1.5 * PI) - ns = 1; - - if (phi > -1.5 * PI && phi <= -0.5 * PI) - ns = -1; - - cfac = exp(PI * ns * (complex(0, 1)) * a); - - if (y == 0) - cfac = cos(PI * a); - - chg1 = g2 / g3 * pow(z, -a) * cfac * cs1; - chg2 = g2 / g1 * exp(z) * pow(z, a - b) * cs2; - chg = chg1 + chg2; - } - else // General case - { - chg = 1; - complex crg = 1; - double cgMax = abs(crg); - - for (j = 1; j <= 500; j++) - { - crg = crg * (j - 1.0 + a) / (double(j) * (j - 1.0 + b)) * z; // Abramowitz Stegun 13.1.2 - chg = chg + crg; - - cgMax = max(cgMax, max(abs(crg), abs(chg))); - - if (abs(crg) / abs(chg) < 1e-15) - break; // break j - - if (j == 500) - { - cout << "Got to the " << j << " limit in the series of confluent hypergeometric function!" << endl; - chg = 0; - return chg; - } - } - - precision = 15 - int(log10(cgMax / abs(chg))); - } - - if (precision <= 0) - { - precision = 0; - chg = 0; - } - - if (precision < 10) - cout << "!!! Warning!!! Only about " << precision << " first digits are correct!!!" << endl; - - return chg; -} -#endif -// Bessel function of the first kind: J_a -#if 0 -// -// sum(m=0-->Inf)(-1)^m/m!/Gamma(m+a+1) (x/2)^{2 m+a} -// -complex misc::First_Bessel(const complex a,complex x) -{ -// Default tolerance is tol = 1e-10. Feel free to change this as needed. - const double tol = 1e-10; - - x = x/2.0; - complex term,term1=pow(x,a),term2=1.0/complex_gamma(a+1.0); - complex f = term1*term2; - int m = 0; - const int mmax = 50; - - term = f; - while(m < mmax && (abs(term)) > tol) - { - m++; - term1 = x*x*term1; - term2 = -term2/double(m*m); - term = term1*term2; - f = f + term; - } - -if((abs(term)) > tol && m == mmax) cout<<"misc::First_Bessel has m > "< " << jmax << ", error = " << abs(sum2 - sum) << endl; - - return sum2; -} -complex misc::Simpson_Int(const double xmin, const double xmax, complex fun(double x)) -{ - // Default tolerance is tol = 1e-10. Feel free to change this as needed. - const double tol = 1e-8; - - int N = 1000; - double dx = (xmax - xmin) / (N - 1); - complex sum = 0, sum2 = 0; - sum2 = 17.0 * fun(xmin) + 59.0 * fun(xmin + dx) + 43.0 * fun(xmin + 2 * dx) + 49.0 * fun(xmin + 3 * dx); - for (int i = 4; i < N - 3; i++) - { - sum2 += 48.0 * fun(xmin + i * dx); - } - sum2 = sum2 + 17.0 * fun(xmax) + 59.0 * fun(xmax - dx) + 43.0 * fun(xmax - 2 * dx) + 49.0 * fun(xmax - 3 * dx); - sum2 = sum2 * dx / 48.0; - - int j = 1; - const int jmax = 50; - while (j < jmax && abs(sum2 - sum) > tol) - { - j++; - N = N * 2; - dx = (xmax - xmin) / (N - 1); - sum = sum2; - sum2 = 17.0 * fun(xmin) + 59.0 * fun(xmin + dx) + 43.0 * fun(xmin + 2 * dx) + 49.0 * fun(xmin + 3 * dx); - for (int i = 4; i < N - 3; i++) - { - sum2 += 48.0 * fun(xmin + i * dx); - } - sum2 = sum2 + 17.0 * fun(xmax) + 59.0 * fun(xmax - dx) + 43.0 * fun(xmax - 2 * dx) + 49.0 * fun(xmax - 3 * dx); - sum2 = sum2 * dx / 48.0; - - // cout<<"j = "< " << jmax << ", error = " << abs(sum2 - sum) << endl; - - return sum2; -} -complex misc::Simpson3o8_Int(const double xmin, const double xmax, complex fun(double x)) -{ - // Default tolerance is tol = 1e-10. Feel free to change this as needed. - const double tol = 1e-8; - - int m = 300, N; - N = 3 * m + 2; - double dx = (xmax - xmin) / (N - 1); - complex sum = 0, sum2; - sum2 = fun(xmin) + fun(xmax); - for (int i = 0; i < m; i++) - { - sum2 += 3.0 * (fun(xmin + (3 * i + 1) * dx) + fun(xmin + (3 * i + 2) * dx)) + 2.0 * fun(xmin + (3 * i + 3) * dx); - // cout< tol) - { - j++; - m = m * 2; - N = 3 * m + 2; - dx = (xmax - xmin) / (N - 1); - sum = sum2; - sum2 = fun(xmin) + fun(xmax); - for (int i = 0; i < m; i++) - { - sum2 += 3.0 * (fun(xmin + (3 * i + 1) * dx) + fun(xmin + (3 * i + 2) * dx)) + 2.0 * fun(xmin + (3 * i + 3) * dx); - } - sum2 = sum2 * dx * 3.0 / 8.0; - - // cout<<"j = "< " << jmax << ", error = " << abs(sum2 - sum) << endl; - - return sum2; -} -#if 0 -complex misc::Gauss_Int(const double xmin,const double xmax,complex fun(double x)) -{ -// Default tolerance is tol = 1e-10. Feel free to change this as needed. - const double tol = 1e-8; - - int N=int(xmax-xmin)*10; - if(N<1000) N = 1000; - double *arcostheta,*wtcostheta; -// weight function cover all of [xmin,xmax] - arcostheta = new double[N]; - wtcostheta = new double[N]; - - gaulegf(xmin,xmax,arcostheta,wtcostheta,N); - complex sum=0,sum2=0; - for(int i =0;i tol) - { - j++; - N = N*2; - arcostheta = new double[N]; - wtcostheta = new double[N]; - - gaulegf(xmin,xmax,arcostheta,wtcostheta,N); - sum=sum2; - sum2=0; - for(int i =0;i "< " << jmax << ", error = " << abs(sum2 - sum) << endl; - - return sum2; -} -#endif -complex misc::gaulegf(double x1, double x2, int n, complex fun(double x)) -{ - int i, j, m; - double eps = 1.2E-16; - double p1, p2, p3, pp, xl, xm, z, z1; - double w; - - m = (n + 1) / 2; - xm = 0.5 * (x2 + x1); - xl = 0.5 * (x2 - x1); - complex sum = 0; - for (i = 0; i < m; i++) - { - z = cos(PI * ((double)i + 0.75) / ((double)n + 0.5)); - do - { - p1 = 1.0; - p2 = 0.0; - for (j = 0; j < n; j++) - { - p3 = p2; - p2 = p1; - p1 = ((2 * (double)j + 1) * z * p2 - (double)j * p3) / ((double)j + 1); - } - pp = n * (z * p1 - p2) / (z * z - 1.0); - z1 = z; - z = z1 - p1 / pp; - // cout<<"here"< eps); - - // cout<<"there"<> 1; - j = 0; - for (i = 0; i < n - 1; i++) - { - if (i < j) - { - tx = x[i]; - ty = y[i]; - x[i] = x[j]; - y[i] = y[j]; - x[j] = tx; - y[j] = ty; - } - k = i2; - while (k <= j) - { - j -= k; - k >>= 1; - } - j += k; - } - - /* Compute the FFT */ - c1 = -1.0; - c2 = 0.0; - l2 = 1; - for (l = 0; l < m; l++) - { - l1 = l2; - l2 <<= 1; - u1 = 1.0; - u2 = 0.0; - for (j = 0; j < l1; j++) - { - for (i = j; i < n; i += l2) - { - i1 = i + l1; - t1 = u1 * x[i1] - u2 * y[i1]; - t2 = u1 * y[i1] + u2 * x[i1]; - x[i1] = x[i] - t1; - y[i1] = y[i] - t2; - x[i] += t1; - y[i] += t2; - } - z = u1 * c1 - u2 * c2; - u2 = u1 * c2 + u2 * c1; - u1 = z; - } - c2 = sqrt((1.0 - c1) / 2.0); - if (dir == 1) - c2 = -c2; - c1 = sqrt((1.0 + c1) / 2.0); - } - - /* Scaling for forward transform */ - if (dir == 1) - { - for (i = 0; i < n; i++) - { - x[i] /= n; - y[i] /= n; - } - } -} -// assume a[0] a[1]......a[NN/2-1] a[NN/2] ...... a[NN-1] -// 0 df (NN/2-1)*df combine of \pm NN/2*df -df -// 0 1 2 3 4 5 -// ^ ^ ^ o ^ ^ -// 0 1 2 3 -// ^ ^ o ^ -void misc::Low_Pass_Filt(const int NN, double *a) -{ - // we use 2/3 law, NN/2 * 2/3 = NN/3 - for (int i = 0; i < NN / 3; i++) - { - a[NN / 2 + i] = 0; - a[NN / 2 - i] = 0; - } -} -void misc::polyinterp(double t, double &rr, double *ti, double *ri, const int ORD) -{ - // (x -x_1)...(x -x_i-1)(x -x_i+1)...(x -x_N) - // ------------------------------------------------f_i - // (x_i-x_1)...(x_i-x_i-1)(x_i-x_i+1)...(x_i-x_N) - - rr = 0; - for (int i = 0; i < ORD; i++) - { - double ss = 1, xx = 1; - for (int j = 0; j < ORD; j++) - { - if (j != i) - { - ss *= t - ti[j]; - xx *= ti[i] - ti[j]; - } - } - rr += ss / xx * ri[i]; - } -#if 0 - if(!isfinite(rr)) - { - cout.setf(ios::scientific); - cout<<"misc::polyinterp: error at t = "< Nin -} -int misc::MYpow2(int i) -{ - if (i == 0) - return 1; - else if (i > 0) - return 2 * MYpow2(i - 1); - else - return MYpow2(i + 1) / 2; -} + +#ifdef newc +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#endif +#include + +#include "misc.h" +#include "macrodef.h" +#include "zbesh.h" + +#define PI M_PI + +void misc::tillherecheck(int myrank) +{ + int atp = 1, tatp; + MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + if (myrank == 0) + cout << " here now: " << tatp << " processors." << endl; +} +void misc::tillherecheck(const char str[]) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + int atp = 1, tatp; + MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, MPI_COMM_WORLD); + if (myrank == 0) + { + cout << " here now: " << tatp << " processors." << endl; + cout << str << endl; + } +} +void misc::tillherecheck(MPI_Comm Comm_here, int out_rank, const char str[]) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + int atp = 1, tatp; + + MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, Comm_here); + if (myrank == out_rank) + { + cout << " here now: " << tatp << " processors." << endl; + cout << str << endl; + } +} +void misc::tillherecheck(MPI_Comm Comm_here, int out_rank, const string str) +{ + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD, &myrank); + int atp = 1, tatp; + + MPI_Allreduce(&atp, &tatp, 1, MPI_INT, MPI_SUM, Comm_here); + if (myrank == out_rank) + { + cout << " here now: " << tatp << " processors." << endl; + cout << str << endl; + } +} +// pick out value from input string +int misc::parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind) +{ + int pos1, pos2; + string s0; + + ind = 0; + + // remove comments + str = str.substr(0, str.find("#")); + if (rTrim(str).empty()) + return 0; // continue; + + // parse {group, key, val} + pos1 = str.find("::"); + pos2 = str.find("="); + if (pos1 == string::npos || pos2 == string::npos) + return -1; + + s0 = str.substr(0, pos1); + sgrp = lTrim(s0); + s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); + skey = rTrim(s0); + s0 = str.substr(pos2 + 1); + sval = Trim(s0); + + pos1 = sval.find("\""); + pos2 = sval.rfind("\""); + if (pos1 != string::npos) + { + sval = sval.substr(1, pos2 - 1); + } + + pos1 = skey.find("["); + pos2 = skey.find("]"); + if (pos1 != string::npos) + { + s0 = skey.substr(0, pos1); + ind = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + skey = s0; + } + + return 1; +} +int misc::parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2) +{ + int pos1, pos2; + string s0, s1; + + ind1 = ind2 = 0; + + // remove comments + str = str.substr(0, str.find("#")); + if (rTrim(str).empty()) + return 0; // continue; + + // parse {group, key, val} + pos1 = str.find("::"); + pos2 = str.find("="); + if (pos1 == string::npos || pos2 == string::npos) + return -1; + + s0 = str.substr(0, pos1); + sgrp = lTrim(s0); + s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); + skey = rTrim(s0); + s0 = str.substr(pos2 + 1); + sval = Trim(s0); + + pos1 = sval.find("\""); + pos2 = sval.rfind("\""); + if (pos1 != string::npos) + { + sval = sval.substr(1, pos2 - 1); + } + + pos1 = skey.find("["); + pos2 = skey.find("]"); + if (pos1 != string::npos) + { + s0 = skey.substr(0, pos1); + s1 = skey.substr(pos2 + 1); + ind1 = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + skey = s0; + } + + pos1 = s1.find("["); + pos2 = s1.find("]"); + if (pos1 != string::npos) + { + s0 = s1.substr(pos2 + 1); + ind2 = atoi(s1.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + } + + return 1; +} +int misc::parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2, int &ind3) +{ + int pos1, pos2; + string s0, s1; + + ind1 = ind2 = ind3 = 0; + + // remove comments + str = str.substr(0, str.find("#")); + if (rTrim(str).empty()) + return 0; // continue; + + // parse {group, key, val} + pos1 = str.find("::"); + pos2 = str.find("="); + if (pos1 == string::npos || pos2 == string::npos) + return -1; + + s0 = str.substr(0, pos1); + sgrp = lTrim(s0); + s0 = str.substr(pos1 + 2, pos2 - pos1 - 2); + skey = rTrim(s0); + s0 = str.substr(pos2 + 1); + sval = Trim(s0); + + pos1 = sval.find("\""); + pos2 = sval.rfind("\""); + if (pos1 != string::npos) + { + sval = sval.substr(1, pos2 - 1); + } + + pos1 = skey.find("["); + pos2 = skey.find("]"); + if (pos1 != string::npos) + { + s0 = skey.substr(0, pos1); + s1 = skey.substr(pos2 + 1); + ind1 = atoi(skey.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + skey = s0; + } + + pos1 = s1.find("["); + pos2 = s1.find("]"); + if (pos1 != string::npos) + { + s0 = s1.substr(pos2 + 1); + ind2 = atoi(s1.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + } + + pos1 = s0.find("["); + pos2 = s0.find("]"); + if (pos1 != string::npos) + { + ind3 = atoi(s0.substr(pos1 + 1, pos2 - pos1 - 1).c_str()); + } + + return 1; +} +// sent me from Roman Gold on 2010-10-8 +void misc::gaulegf(double x1, double x2, double *x, double *w, int n) +{ + int i, j, m; + double eps = 1.2E-16; + double p1, p2, p3, pp, xl, xm, z, z1; + + m = (n + 1) / 2; + xm = 0.5 * (x2 + x1); + xl = 0.5 * (x2 - x1); + for (i = 0; i < m; i++) + { + z = cos(PI * ((double)i + 0.75) / ((double)n + 0.5)); + do + { + p1 = 1.0; + p2 = 0.0; + for (j = 0; j < n; j++) + { + p3 = p2; + p2 = p1; + p1 = ((2 * (double)j + 1) * z * p2 - (double)j * p3) / ((double)j + 1); + } + pp = n * (z * p1 - p2) / (z * z - 1.0); + z1 = z; + z = z1 - p1 / pp; + } while (fabs(z - z1) > eps); + x[i] = xm - xl * z; + x[n - 1 - i] = xm + xl * z; + w[i] = 2.0 * xl / ((1.0 - z * z) * pp * pp); + w[n - 1 - i] = w[i]; + } +} /* end gaulegf */ +void misc::inversearray(double *aa, int NN) +{ + int i, m; + m = (NN + 1) / 2; + double rr; + for (i = 0; i < m; i++) + { + rr = aa[i]; + aa[i] = aa[NN - 1 - i]; + aa[NN - 1 - i] = rr; + } +} +// Eq.(42) of PRD 77, 024027 (2008) +double misc::Wigner_d_function(int l, int m, int s, double costheta) +{ + // we consider only theta in [0,pi] + int C1 = max(0, m - s), C2 = min(l + m, l - s); + + double vv = 0; + double sinht = sqrt((1 - costheta) / 2.0), cosht = sqrt((1 + costheta) / 2.0); + if (C1 % 2 == 0) + { + for (int t = C1; t < C2 + 1; t += 2) + vv = vv + pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / + (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); + for (int t = C1 + 1; t < C2 + 1; t += 2) + vv = vv - pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / + (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); + } + else + { + for (int t = C1; t < C2 + 1; t += 2) + vv = vv - pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / + (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); + for (int t = C1 + 1; t < C2 + 1; t += 2) + vv = vv + pow(cosht, 2 * l + m - s - 2 * t) * pow(sinht, 2 * t + s - m) / + (fact(l + m - t) * fact(l - s - t) * fact(t) * fact(t + s - m)); + } + return vv * sqrt(fact(l + m) * fact(l - m) * fact(l + s) * fact(l - s)); +} +double misc::fact(int N) +{ + if (N < 0) + cout << "error input for factorial." << endl; + double f; + if (N == 0) + f = 1; + else + f = N * fact(N - 1); + return f; +} +int misc::num_of_str(char *c) +{ + int NN = 0, N1 = 0; + std::istringstream iss; + iss.str(c); + + char c1[1000]; + while (!iss.eof()) + { + iss >> c1; + if (int(c1[0]) == 45 || int(c1[0]) == 46 || (int(c1[0]) > 47 && int(c1[0]) < 58)) + NN++; + N1++; + } + + char *c2 = c; + while (*(c2 + 1)) + c2++; + if (int(*c2) == 32) + { + NN--; + N1--; + } + + // cout<<"found "< &f0, + std::vector &f1, std::vector &f_rhs, const int RK4) +{ + const int N = f0.size(); + const double F1o6 = 1.0 / 6, HLF = 0.5, TWO = 2; + switch (RK4) + { + case 0: + for (int i = 0; i < N; i++) + f1[i] = f0[i] + HLF * dT * f_rhs[i]; + break; + case 1: + for (int i = 0; i < N; i++) + { + f_rhs[i] = f_rhs[i] + TWO * f1[i]; + f1[i] = f0[i] + HLF * dT * f1[i]; + } + break; + case 2: + for (int i = 0; i < N; i++) + { + f_rhs[i] = f_rhs[i] + TWO * f1[i]; + f1[i] = f0[i] + dT * f1[i]; + } + break; + case 3: + for (int i = 0; i < N; i++) + f1[i] = f0[i] + F1o6 * dT * (f1[i] + f_rhs[i]); + break; + default: + cout << "misc::rungekutta4: something is wrong in RK4 counting!!" << endl; + } +} +void misc::dividBlock(const int DIM, int *shape_here, double *bbox_here, const int pices, double *picef, int *shape_res, double *bbox_res, + const int min_width) +{ + if (pices < 1) + { + cerr << "error in dividBlock: pices = " << pices << endl; + return; + } + if (pices == 1) + { + for (int i = 0; i < DIM; i++) + { + shape_res[i] = shape_here[i]; + bbox_res[i] = bbox_here[i]; + bbox_res[DIM + i] = bbox_here[DIM + i]; + } + return; + } + + double dd = picef[0]; + for (int i = 1; i < pices; i++) + dd += picef[i]; + + if (feq(dd, 1, 1e-8)) + { + int leg = shape_here[0]; + int legi = 0; + for (int i = 1; i < DIM; i++) + { + if (leg < shape_here[i]) + { + leg = shape_here[i]; + legi = i; + } + } + + int pic = 0; + + for (int ip = 0; ip < pices; ip++) + { + for (int i = 0; i < DIM; i++) + { + if (i == legi) + { + if (ip == pices - 1) + shape_res[ip * DIM + i] = shape_here[i] - pic; + else + { + shape_res[ip * DIM + i] = shape_here[i] * picef[ip]; + pic += shape_res[ip * DIM + i]; + } + } + else + shape_res[ip * DIM + i] = shape_here[i]; + } + } + + for (int ip = 0; ip < pices; ip++) + { + for (int i = 0; i < DIM; i++) + { +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + dd = (bbox_here[DIM + i] - bbox_here[i]) / (shape_here[i] - 1); +#else +#ifdef Cell + dd = (bbox_here[DIM + i] - bbox_here[i]) / shape_here[i]; +#else +#error Not define Vertex nor Cell +#endif +#endif + + if (i == legi) + { + if (shape_res[ip * DIM + i] < min_width) + { + cerr << "dividBlock: resulted too small shape, shapeo = " << shape_here[i] << ", shape = " << shape_res[ip * DIM + i] << ", min_width = " << min_width << endl; + MPI_Abort(MPI_COMM_WORLD, 1); + } + + if (ip == 0) + bbox_res[ip * 2 * DIM + i] = bbox_here[i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + bbox_res[ip * 2 * DIM + i] = bbox_res[(ip - 1) * 2 * DIM + DIM + i] - ghost_width * dd + dd; // because for ip-1 we have already considered ghost points +#else +#ifdef Cell + else + bbox_res[ip * 2 * DIM + i] = bbox_res[(ip - 1) * 2 * DIM + DIM + i] - ghost_width * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + + if (ip == pices - 1) + bbox_res[ip * 2 * DIM + DIM + i] = bbox_here[DIM + i]; +#ifdef Vertex +#ifdef Cell +#error Both Cell and Vertex are defined +#endif + else + bbox_res[ip * 2 * DIM + DIM + i] = bbox_res[ip * 2 * DIM + i] + (shape_res[ip * DIM + i] - 1) * dd; +#else +#ifdef Cell + else + bbox_res[ip * 2 * DIM + DIM + i] = bbox_res[ip * 2 * DIM + i] + shape_res[ip * DIM + i] * dd; +#else +#error Not define Vertex nor Cell +#endif +#endif + + if (ip > 0) + { + shape_res[ip * DIM + i] += ghost_width; + bbox_res[ip * 2 * DIM + i] -= ghost_width * dd; + } + if (ip < pices - 1) + { + shape_res[ip * DIM + i] += ghost_width; + bbox_res[ip * 2 * DIM + DIM + i] += ghost_width * dd; + } + } + else + { + bbox_res[ip * 2 * DIM + i] = bbox_here[i]; + bbox_res[ip * 2 * DIM + DIM + i] = bbox_here[DIM + i]; + } + } + } + } + else + { + cerr << "error in dividBlock: "; + for (int i = 0; i < pices; i++) + cerr << picef[i] << " "; + cerr << endl; + } +#if 0 +// for check + int myrank; + MPI_Comm_rank(MPI_COMM_WORLD,&myrank); + if(myrank == 0) + { + cerr<<"original one"< &f0, std::vector &f1) +{ + const int N = f0.size(); + double tt; + for (int i = 0; i < N; i++) + { + tt = f0[i]; + f0[i] = f1[i]; + f1[i] = tt; + } +} +complex misc::complex_gamma(complex z) +{ + const double p[9] = {0.99999999999980993, 676.5203681218851, -1259.1392167224028, + 771.32342877765313, -176.61502916214059, 12.507343278686905, + -0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7}; + + if (real(z) < 0.5) + { + return PI / (sin(PI * z) * complex_gamma(1.0 - z)); + } + z -= 1.0; + complex x = p[0]; + for (int i = 1; i < 9; i++) + { + x += p[i] / (z + complex(i, 0)); + } + complex t = z + (7 + 0.5); + t = sqrt(2 * PI) * pow(t, z + 0.5) * exp(-t) * x; + + return t; +} +// also called Kummer function, +// Confluent hypergeometric function 1F1 +#if 1 +complex misc::KummerComplex(const complex a, const complex b, complex x) +{ + // Default tolerance is tol = 1e-10. Feel free to change this as needed. + const double tol = 1e-10; + + // Estimates the value by summing powers of the generalized hypergeometric + // series: + // + // sum(n=0-->Inf)[(a)_n*x^n/{(b)_n*n!}] + // + // until the specified tolerance is acheived. + + complex term = x * a / b; + complex f = 1.0 + term; + int n = 1; + complex an = a; + complex bn = b; + int nmin = 100000; + + while (n < nmin && (abs(term)) > tol) + { + n = n + 1; + an = an + 1.0; + bn = bn + 1.0; + term = x * term * an / bn / double(n); + f = f + term; + } + + if ((abs(term)) > tol && n == nmin) + cout << "misc::KummerComplex has n > " << nmin << " with error " << abs(term) << endl + << "a = " << a << " b = " << b << " x = " << x << endl; + + return f; +} +// new code +#else +complex misc::KummerComplex(const complex a, const complex b, complex z) +{ + // Default tolerance is tol = 1e-10. Feel free to change this as needed. + int precision = 15; + int m, j, k; + complex cr, chg; + double cMax; + complex g1, g2, g3; + complex ba; + complex cs1, cs2, cr1, cr2; + double c1Max, c2Max; + + // Special cases + + if (b.imag() == 0 && b.real() <= 0 && b.real() == int(b.real())) // b==-n;n=1,2,3,.. + { + if (a.imag() == 0 && a.real() <= 0 && a.real() == int(a.real()) && abs(a) < abs(b)) // a==-m;m=1,2,.. + { + m = int(-a.real()); + cr = 1; + chg = 1; + + cMax = abs(cr); + + for (k = 1; k <= m; k++) + { + cr = cr * (k - 1.0 + a) / double(k) / (k - 1.0 + b) * z; + chg = chg + cr; + + cMax = max(cMax, max(abs(cr), abs(chg))); + } + + precision = 15 - int(log10(cMax / abs(chg))); + } + else if (a.imag() == 0 && a.real() <= 0 && a.real() == int(a.real()) && abs(a) == abs(b)) // a==b; + { + cout << "!!!Confluent hypergeometric function is indeterminate for input a = " + << a << " b = " << b << " z = " << z << endl; + chg = 0; + } + else + { + cout << "!!!Confluent hypergeometric function error for input a = " + << a << " b = " << b << " z = " << z << endl; + chg = 0; + } + } + else if (a == 0.0 || z == 0.0) + { + chg = 1; + } + else if (a == -1.0) + { + chg = 1.0 - z / b; + } + else if (a == b) + { + chg = exp(z); + } + else if ((a - b) == 1.0) + { + chg = (1.0 + z / b) * exp(z); + } + else if (a == 1.0 && b == 2.0) + { + chg = (exp(z) - 1.0) / z; + } + // finite number of elements in a row + else if (a.imag() == 0 && a.real() < 0 && a.real() == int(a.real())) + { + m = int(-a.real()); + cr = 1; + chg = 1; + + cMax = abs(cr); + + for (k = 1; k <= m; k++) + { + cr = cr * (k - 1.0 + a) / double(k) / (k - 1.0 + b) * z; + chg = chg + cr; + + cMax = max(cMax, max(abs(cr), abs(chg))); + } + + precision = 15 - int(log10(cMax / abs(chg))); + } + else if (abs(z) > 10 * abs(a) && abs(z) > 10 * abs(b)) // Abramowitz Stegun 13.5.1 + { + g1 = complex_gamma(a); + g2 = complex_gamma(b); + ba = b - a; + g3 = complex_gamma(ba); + + cs1 = 1; + cs2 = 1; + cr1 = 1; + cr2 = 1; + + c1Max = abs(cr1); + c2Max = abs(cr2); + + for (j = 1; j <= 500; j++) + { + cr1 = -cr1 * (j - 1.0 + a) * (a - b + double(j)) / (z * double(j)); + cr2 = cr2 * (j - 1.0 + b - a) * (double(j) - a) / (z * double(j)); + cs1 = cs1 + cr1; + cs2 = cs2 + cr2; + + c1Max = max(c1Max, max(abs(cr1), abs(cs1))); + c2Max = max(c2Max, max(abs(cr2), abs(cs2))); + + if (abs(cr1) / abs(cs1) < 1e-15 && abs(cr2) / abs(cs2) < 1e-15) + break; // break j + + if (j == 500) + { + cout << "Got to the " << j << " limit in the series of confluent hypergeometric function!" << endl; + chg = 0; + return chg; + } + } + + precision = 15 - int(log10(max(c1Max / abs(cs1), c2Max / abs(cs2)))); + + double x = z.real(); + double y = z.imag(); + double phi; + complex cfac, chg1, chg2; + int ns; + + if (x == 0.0 && y >= 0.0) + phi = 0.5 * PI; + else if (x == 0.0 && y <= 0.0) + phi = -0.5 * PI; + else + phi = atan(y / x); + + if (phi > -0.5 * PI && phi < 1.5 * PI) + ns = 1; + + if (phi > -1.5 * PI && phi <= -0.5 * PI) + ns = -1; + + cfac = exp(PI * ns * (complex(0, 1)) * a); + + if (y == 0) + cfac = cos(PI * a); + + chg1 = g2 / g3 * pow(z, -a) * cfac * cs1; + chg2 = g2 / g1 * exp(z) * pow(z, a - b) * cs2; + chg = chg1 + chg2; + } + else // General case + { + chg = 1; + complex crg = 1; + double cgMax = abs(crg); + + for (j = 1; j <= 500; j++) + { + crg = crg * (j - 1.0 + a) / (double(j) * (j - 1.0 + b)) * z; // Abramowitz Stegun 13.1.2 + chg = chg + crg; + + cgMax = max(cgMax, max(abs(crg), abs(chg))); + + if (abs(crg) / abs(chg) < 1e-15) + break; // break j + + if (j == 500) + { + cout << "Got to the " << j << " limit in the series of confluent hypergeometric function!" << endl; + chg = 0; + return chg; + } + } + + precision = 15 - int(log10(cgMax / abs(chg))); + } + + if (precision <= 0) + { + precision = 0; + chg = 0; + } + + if (precision < 10) + cout << "!!! Warning!!! Only about " << precision << " first digits are correct!!!" << endl; + + return chg; +} +#endif +// Bessel function of the first kind: J_a +#if 0 +// +// sum(m=0-->Inf)(-1)^m/m!/Gamma(m+a+1) (x/2)^{2 m+a} +// +complex misc::First_Bessel(const complex a,complex x) +{ +// Default tolerance is tol = 1e-10. Feel free to change this as needed. + const double tol = 1e-10; + + x = x/2.0; + complex term,term1=pow(x,a),term2=1.0/complex_gamma(a+1.0); + complex f = term1*term2; + int m = 0; + const int mmax = 50; + + term = f; + while(m < mmax && (abs(term)) > tol) + { + m++; + term1 = x*x*term1; + term2 = -term2/double(m*m); + term = term1*term2; + f = f + term; + } + +if((abs(term)) > tol && m == mmax) cout<<"misc::First_Bessel has m > "< " << jmax << ", error = " << abs(sum2 - sum) << endl; + + return sum2; +} +complex misc::Simpson_Int(const double xmin, const double xmax, complex fun(double x)) +{ + // Default tolerance is tol = 1e-10. Feel free to change this as needed. + const double tol = 1e-8; + + int N = 1000; + double dx = (xmax - xmin) / (N - 1); + complex sum = 0, sum2 = 0; + sum2 = 17.0 * fun(xmin) + 59.0 * fun(xmin + dx) + 43.0 * fun(xmin + 2 * dx) + 49.0 * fun(xmin + 3 * dx); + for (int i = 4; i < N - 3; i++) + { + sum2 += 48.0 * fun(xmin + i * dx); + } + sum2 = sum2 + 17.0 * fun(xmax) + 59.0 * fun(xmax - dx) + 43.0 * fun(xmax - 2 * dx) + 49.0 * fun(xmax - 3 * dx); + sum2 = sum2 * dx / 48.0; + + int j = 1; + const int jmax = 50; + while (j < jmax && abs(sum2 - sum) > tol) + { + j++; + N = N * 2; + dx = (xmax - xmin) / (N - 1); + sum = sum2; + sum2 = 17.0 * fun(xmin) + 59.0 * fun(xmin + dx) + 43.0 * fun(xmin + 2 * dx) + 49.0 * fun(xmin + 3 * dx); + for (int i = 4; i < N - 3; i++) + { + sum2 += 48.0 * fun(xmin + i * dx); + } + sum2 = sum2 + 17.0 * fun(xmax) + 59.0 * fun(xmax - dx) + 43.0 * fun(xmax - 2 * dx) + 49.0 * fun(xmax - 3 * dx); + sum2 = sum2 * dx / 48.0; + + // cout<<"j = "< " << jmax << ", error = " << abs(sum2 - sum) << endl; + + return sum2; +} +complex misc::Simpson3o8_Int(const double xmin, const double xmax, complex fun(double x)) +{ + // Default tolerance is tol = 1e-10. Feel free to change this as needed. + const double tol = 1e-8; + + int m = 300, N; + N = 3 * m + 2; + double dx = (xmax - xmin) / (N - 1); + complex sum = 0, sum2; + sum2 = fun(xmin) + fun(xmax); + for (int i = 0; i < m; i++) + { + sum2 += 3.0 * (fun(xmin + (3 * i + 1) * dx) + fun(xmin + (3 * i + 2) * dx)) + 2.0 * fun(xmin + (3 * i + 3) * dx); + // cout< tol) + { + j++; + m = m * 2; + N = 3 * m + 2; + dx = (xmax - xmin) / (N - 1); + sum = sum2; + sum2 = fun(xmin) + fun(xmax); + for (int i = 0; i < m; i++) + { + sum2 += 3.0 * (fun(xmin + (3 * i + 1) * dx) + fun(xmin + (3 * i + 2) * dx)) + 2.0 * fun(xmin + (3 * i + 3) * dx); + } + sum2 = sum2 * dx * 3.0 / 8.0; + + // cout<<"j = "< " << jmax << ", error = " << abs(sum2 - sum) << endl; + + return sum2; +} +#if 0 +complex misc::Gauss_Int(const double xmin,const double xmax,complex fun(double x)) +{ +// Default tolerance is tol = 1e-10. Feel free to change this as needed. + const double tol = 1e-8; + + int N=int(xmax-xmin)*10; + if(N<1000) N = 1000; + double *arcostheta,*wtcostheta; +// weight function cover all of [xmin,xmax] + arcostheta = new double[N]; + wtcostheta = new double[N]; + + gaulegf(xmin,xmax,arcostheta,wtcostheta,N); + complex sum=0,sum2=0; + for(int i =0;i tol) + { + j++; + N = N*2; + arcostheta = new double[N]; + wtcostheta = new double[N]; + + gaulegf(xmin,xmax,arcostheta,wtcostheta,N); + sum=sum2; + sum2=0; + for(int i =0;i "< " << jmax << ", error = " << abs(sum2 - sum) << endl; + + return sum2; +} +#endif +complex misc::gaulegf(double x1, double x2, int n, complex fun(double x)) +{ + int i, j, m; + double eps = 1.2E-16; + double p1, p2, p3, pp, xl, xm, z, z1; + double w; + + m = (n + 1) / 2; + xm = 0.5 * (x2 + x1); + xl = 0.5 * (x2 - x1); + complex sum = 0; + for (i = 0; i < m; i++) + { + z = cos(PI * ((double)i + 0.75) / ((double)n + 0.5)); + do + { + p1 = 1.0; + p2 = 0.0; + for (j = 0; j < n; j++) + { + p3 = p2; + p2 = p1; + p1 = ((2 * (double)j + 1) * z * p2 - (double)j * p3) / ((double)j + 1); + } + pp = n * (z * p1 - p2) / (z * z - 1.0); + z1 = z; + z = z1 - p1 / pp; + // cout<<"here"< eps); + + // cout<<"there"<> 1; + j = 0; + for (i = 0; i < n - 1; i++) + { + if (i < j) + { + tx = x[i]; + ty = y[i]; + x[i] = x[j]; + y[i] = y[j]; + x[j] = tx; + y[j] = ty; + } + k = i2; + while (k <= j) + { + j -= k; + k >>= 1; + } + j += k; + } + + /* Compute the FFT */ + c1 = -1.0; + c2 = 0.0; + l2 = 1; + for (l = 0; l < m; l++) + { + l1 = l2; + l2 <<= 1; + u1 = 1.0; + u2 = 0.0; + for (j = 0; j < l1; j++) + { + for (i = j; i < n; i += l2) + { + i1 = i + l1; + t1 = u1 * x[i1] - u2 * y[i1]; + t2 = u1 * y[i1] + u2 * x[i1]; + x[i1] = x[i] - t1; + y[i1] = y[i] - t2; + x[i] += t1; + y[i] += t2; + } + z = u1 * c1 - u2 * c2; + u2 = u1 * c2 + u2 * c1; + u1 = z; + } + c2 = sqrt((1.0 - c1) / 2.0); + if (dir == 1) + c2 = -c2; + c1 = sqrt((1.0 + c1) / 2.0); + } + + /* Scaling for forward transform */ + if (dir == 1) + { + for (i = 0; i < n; i++) + { + x[i] /= n; + y[i] /= n; + } + } +} +// assume a[0] a[1]......a[NN/2-1] a[NN/2] ...... a[NN-1] +// 0 df (NN/2-1)*df combine of \pm NN/2*df -df +// 0 1 2 3 4 5 +// ^ ^ ^ o ^ ^ +// 0 1 2 3 +// ^ ^ o ^ +void misc::Low_Pass_Filt(const int NN, double *a) +{ + // we use 2/3 law, NN/2 * 2/3 = NN/3 + for (int i = 0; i < NN / 3; i++) + { + a[NN / 2 + i] = 0; + a[NN / 2 - i] = 0; + } +} +void misc::polyinterp(double t, double &rr, double *ti, double *ri, const int ORD) +{ + // (x -x_1)...(x -x_i-1)(x -x_i+1)...(x -x_N) + // ------------------------------------------------f_i + // (x_i-x_1)...(x_i-x_i-1)(x_i-x_i+1)...(x_i-x_N) + + rr = 0; + for (int i = 0; i < ORD; i++) + { + double ss = 1, xx = 1; + for (int j = 0; j < ORD; j++) + { + if (j != i) + { + ss *= t - ti[j]; + xx *= ti[i] - ti[j]; + } + } + rr += ss / xx * ri[i]; + } +#if 0 + if(!isfinite(rr)) + { + cout.setf(ios::scientific); + cout<<"misc::polyinterp: error at t = "< Nin +} +int misc::MYpow2(int i) +{ + if (i == 0) + return 1; + else if (i > 0) + return 2 * MYpow2(i - 1); + else + return MYpow2(i + 1) / 2; +} diff --git a/AMSS_NCKU_source/misc.h b/AMSS_NCKU_source/misc/misc.h similarity index 97% rename from AMSS_NCKU_source/misc.h rename to AMSS_NCKU_source/misc/misc.h index 3b9ddcc..aa4e7cb 100644 --- a/AMSS_NCKU_source/misc.h +++ b/AMSS_NCKU_source/misc/misc.h @@ -1,94 +1,94 @@ - -#ifndef MISC_H -#define MISC_H - -#ifdef newc -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -using namespace std; -#else -#include -#include -#include -#include -#include -#include -#include -#endif - -#include - -namespace misc -{ - inline string &lTrim(string &ss) - { - string::iterator p = find_if(ss.begin(), ss.end(), not1(ptr_fun(isspace))); - ss.erase(ss.begin(), p); - return ss; - } - inline string &rTrim(string &ss) - { - string::reverse_iterator p = find_if(ss.rbegin(), ss.rend(), not1(ptr_fun(isspace))); - ss.erase(p.base(), ss.end()); - return ss; - } - inline string &Trim(string &st) - { - lTrim(rTrim(st)); - return st; - } - - template - void swap(T &a, T &b) - { - T c = a; - a = b; - b = c; - } - void tillherecheck(int myrank); - void tillherecheck(const char str[]); - void tillherecheck(MPI_Comm Comm_here, int out_rank, const char str[]); - void tillherecheck(MPI_Comm Comm_here, int out_rank, const string str); - int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind); - int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2); - int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2, int &ind3); - void gaulegf(double x1, double x2, double *x, double *w, int n); - complex gaulegf(double x1, double x2, int n, complex fun(double x)); - void inversearray(double *aa, int NN); - double fact(int N); - double Wigner_d_function(int l, int m, int s, double costheta); - int num_of_str(char *c); - void TVDrungekutta3(const int N, const double dT, double *f0, double *f1, double *f_rhs, const int RK4); - void rungekutta4(const int N, const double dT, double *f0, double *f1, double *f_rhs, const int RK4); - void rungekutta4(const double dT, const std::vector &f0, - std::vector &f1, std::vector &f_rhs, const int RK4); - void dividBlock(const int DIM, int *shape_here, double *bbox_here, const int pices, double *picef, int *shape_res, double *bbox_res, const int min_width); - void swapvector(std::vector &f0, std::vector &f1); - complex complex_gamma(complex z); - complex KummerComplex(const complex a, const complex b, complex x); -#if 0 -complex First_Bessel(const complex a,complex x); -#else - complex First_Bessel(double a, complex x); -#endif - complex Rec_Int(const double xmin, const double xmax, complex fun(double x)); - complex Simpson_Int(const double xmin, const double xmax, complex fun(double x)); - complex Simpson3o8_Int(const double xmin, const double xmax, complex fun(double x)); - complex Gauss_Int(const double xmin, const double xmax, complex fun(double x)); - - void FFT(short int dir, long m, double *x, double *y); - void Low_Pass_Filt(const int NN, double *a); - void polyinterp(double t, double &rr, double *ti, double *ri, const int ORD); - void polyinterp_d1(double t, double &rr, double *ti, double *ri, const int ORD); - void next2power(long int Nin, long int &Nout, int &M); - int MYpow2(int i); -} -#endif /* MISC_H */ + +#ifndef MISC_H +#define MISC_H + +#ifdef newc +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +using namespace std; +#else +#include +#include +#include +#include +#include +#include +#include +#endif + +#include + +namespace misc +{ + inline string &lTrim(string &ss) + { + string::iterator p = find_if(ss.begin(), ss.end(), not1(ptr_fun(isspace))); + ss.erase(ss.begin(), p); + return ss; + } + inline string &rTrim(string &ss) + { + string::reverse_iterator p = find_if(ss.rbegin(), ss.rend(), not1(ptr_fun(isspace))); + ss.erase(p.base(), ss.end()); + return ss; + } + inline string &Trim(string &st) + { + lTrim(rTrim(st)); + return st; + } + + template + void swap(T &a, T &b) + { + T c = a; + a = b; + b = c; + } + void tillherecheck(int myrank); + void tillherecheck(const char str[]); + void tillherecheck(MPI_Comm Comm_here, int out_rank, const char str[]); + void tillherecheck(MPI_Comm Comm_here, int out_rank, const string str); + int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind); + int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2); + int parse_parts(string str, string &sgrp, string &skey, string &sval, int &ind1, int &ind2, int &ind3); + void gaulegf(double x1, double x2, double *x, double *w, int n); + complex gaulegf(double x1, double x2, int n, complex fun(double x)); + void inversearray(double *aa, int NN); + double fact(int N); + double Wigner_d_function(int l, int m, int s, double costheta); + int num_of_str(char *c); + void TVDrungekutta3(const int N, const double dT, double *f0, double *f1, double *f_rhs, const int RK4); + void rungekutta4(const int N, const double dT, double *f0, double *f1, double *f_rhs, const int RK4); + void rungekutta4(const double dT, const std::vector &f0, + std::vector &f1, std::vector &f_rhs, const int RK4); + void dividBlock(const int DIM, int *shape_here, double *bbox_here, const int pices, double *picef, int *shape_res, double *bbox_res, const int min_width); + void swapvector(std::vector &f0, std::vector &f1); + complex complex_gamma(complex z); + complex KummerComplex(const complex a, const complex b, complex x); +#if 0 +complex First_Bessel(const complex a,complex x); +#else + complex First_Bessel(double a, complex x); +#endif + complex Rec_Int(const double xmin, const double xmax, complex fun(double x)); + complex Simpson_Int(const double xmin, const double xmax, complex fun(double x)); + complex Simpson3o8_Int(const double xmin, const double xmax, complex fun(double x)); + complex Gauss_Int(const double xmin, const double xmax, complex fun(double x)); + + void FFT(short int dir, long m, double *x, double *y); + void Low_Pass_Filt(const int NN, double *a); + void polyinterp(double t, double &rr, double *ti, double *ri, const int ORD); + void polyinterp_d1(double t, double &rr, double *ti, double *ri, const int ORD); + void next2power(long int Nin, long int &Nout, int &M); + int MYpow2(int i); +} +#endif /* MISC_H */ diff --git a/BBH_orbit_parameter.py b/BBH_orbit_parameter.py index 4adf781..4b5a12b 100755 --- a/BBH_orbit_parameter.py +++ b/BBH_orbit_parameter.py @@ -16,7 +16,7 @@ import math import os import sympy import numpy -import derivative ## numerical differentiation +import derivative_xiaoqu as derivative ## numerical differentiation ############################################################################################## diff --git a/generate_TwoPuncture_input.py b/generate_TwoPuncture_input.py index 6fd4da2..2090814 100755 --- a/generate_TwoPuncture_input.py +++ b/generate_TwoPuncture_input.py @@ -155,30 +155,43 @@ elif (input_data.puncture_data_set == "Manually" ): ## Write the above binary data into the AMSS-NCKU TwoPuncture input file -def generate_AMSSNCKU_TwoPuncture_input(): +def generate_AMSSNCKU_TwoPuncture_input(puncture_data=None): file1 = open( os.path.join(input_data.File_directory, "AMSS-NCKU-TwoPuncture.input"), "w") + if puncture_data is None: + distance_value = distance + momentum_value = momentum_BH + angular_momentum_value = angular_momentum_BH + BBH_M1_value = BBH_M1 + BBH_M2_value = BBH_M2 + else: + distance_value = puncture_data.distance_d0 + momentum_value = puncture_data.momentum_BH + angular_momentum_value = puncture_data.angular_momentum_BH + BBH_M1_value = puncture_data.BBH_M1 + BBH_M2_value = puncture_data.BBH_M2 + print( "# -----0-----> y", file=file1 ) print( "# - + use Brugmann's convention", file=file1 ) print( "ABE::mp = -1.0", file=file1 ) ## use negative values so the code solves for bare masses automatically print( "ABE::mm = -1.0", file=file1 ) print( "# b = D/2", file=file1 ) - print( "ABE::b = ", ( distance / 2.0 ), file=file1 ) - print( "ABE::P_plusx = ", momentum_BH[0,0], file=file1 ) - print( "ABE::P_plusy = ", momentum_BH[0,1], file=file1 ) - print( "ABE::P_plusz = ", momentum_BH[0,2], file=file1 ) - print( "ABE::P_minusx = ", momentum_BH[1,0], file=file1 ) - print( "ABE::P_minusy = ", momentum_BH[1,1], file=file1 ) - print( "ABE::P_minusz = ", momentum_BH[1,2], file=file1 ) - print( "ABE::S_plusx = ", angular_momentum_BH[0,0], file=file1 ) - print( "ABE::S_plusy = ", angular_momentum_BH[0,1], file=file1 ) - print( "ABE::S_plusz = ", angular_momentum_BH[0,2], file=file1 ) - print( "ABE::S_minusx = ", angular_momentum_BH[1,0], file=file1 ) - print( "ABE::S_minusy = ", angular_momentum_BH[1,1], file=file1 ) - print( "ABE::S_minusz = ", angular_momentum_BH[1,2], file=file1 ) - print( "ABE::Mp = ", BBH_M1, file=file1 ) - print( "ABE::Mm = ", BBH_M2, file=file1 ) + print( "ABE::b = ", ( distance_value / 2.0 ), file=file1 ) + print( "ABE::P_plusx = ", momentum_value[0,0], file=file1 ) + print( "ABE::P_plusy = ", momentum_value[0,1], file=file1 ) + print( "ABE::P_plusz = ", momentum_value[0,2], file=file1 ) + print( "ABE::P_minusx = ", momentum_value[1,0], file=file1 ) + print( "ABE::P_minusy = ", momentum_value[1,1], file=file1 ) + print( "ABE::P_minusz = ", momentum_value[1,2], file=file1 ) + print( "ABE::S_plusx = ", angular_momentum_value[0,0], file=file1 ) + print( "ABE::S_plusy = ", angular_momentum_value[0,1], file=file1 ) + print( "ABE::S_plusz = ", angular_momentum_value[0,2], file=file1 ) + print( "ABE::S_minusx = ", angular_momentum_value[1,0], file=file1 ) + print( "ABE::S_minusy = ", angular_momentum_value[1,1], file=file1 ) + print( "ABE::S_minusz = ", angular_momentum_value[1,2], file=file1 ) + print( "ABE::Mp = ", BBH_M1_value, file=file1 ) + print( "ABE::Mm = ", BBH_M2_value, file=file1 ) print( "ABE::admtol = 1.e-8", file=file1 ) print( "ABE::Newtontol = 5.e-12", file=file1 ) print( "ABE::nA = 50", file=file1 ) diff --git a/numerical_grid.py b/numerical_grid.py index d4e583e..03882b5 100755 --- a/numerical_grid.py +++ b/numerical_grid.py @@ -13,45 +13,14 @@ import matplotlib.pyplot as plt import os import AMSS_NCKU_Input as input_data -## import print_information +import puncture_initialize ################################################# # set the information of black hole puncture -puncture = numpy.zeros( (input_data.puncture_number,3) ) - -print( ) -print( " Setting Puncture's position and momentum " ) -print( ) - -################################################# - -## setting puncture position - -## read resetted puncture position if puncture_data_set is Automatically-BBH - -if (input_data.puncture_data_set == "Automatically-BBH" ): - - import generate_TwoPuncture_input - - for i in range(input_data.puncture_number): - if (i<=1): - puncture[i] = generate_TwoPuncture_input.position_BH[i] - else: - puncture[i] = input_data.position_BH[i] - -## read in puncture position directly if puncture_data_set is Manually - -elif (input_data.puncture_data_set == "Manually" ): - - puncture = input_data.position_BH - -else: - - print( ) - print( " Found Error in setting Puncture's position and momentum !!! " ) - print( ) +puncture_data = puncture_initialize.generate_puncture_input_data() +puncture = puncture_data.position_BH ################################################# diff --git a/puncture_initialize.py b/puncture_initialize.py new file mode 100644 index 0000000..7e65428 --- /dev/null +++ b/puncture_initialize.py @@ -0,0 +1,157 @@ +################################################################## +## +## Initialize puncture data used by AMSS-NCKU Python helpers +## Author: Xiaoqu +## Adapted for the current branch +## +################################################################## + +import math + +import numpy + +import AMSS_NCKU_Input as input_data + + +class PunctureData: + def __init__( + self, + BBH_M1, + BBH_M2, + distance_d0, + ellipticity_e0, + dimensionless_mass_BH, + charge_Q_BH, + position_BH, + momentum_BH, + angular_momentum_BH, + ): + self.BBH_M1 = BBH_M1 + self.BBH_M2 = BBH_M2 + self.distance_d0 = distance_d0 + self.ellipticity_e0 = ellipticity_e0 + self.dimensionless_mass_BH = dimensionless_mass_BH + self.charge_Q_BH = charge_Q_BH + self.position_BH = position_BH + self.momentum_BH = momentum_BH + self.angular_momentum_BH = angular_momentum_BH + + +def _angular_momentum_from_input(masses): + angular_momentum_BH = numpy.zeros((input_data.puncture_number, 3)) + for i in range(input_data.puncture_number): + if input_data.Symmetry in ("octant-symmetry", "equatorial-symmetry"): + angular_momentum_BH[i] = [0.0, 0.0, (masses[i] ** 2) * input_data.parameter_BH[i, 2]] + elif input_data.Symmetry == "no-symmetry": + angular_momentum_BH[i] = (masses[i] ** 2) * input_data.dimensionless_spin_BH[i] + else: + raise ValueError("Unsupported symmetry setting") + return angular_momentum_BH + + +def print_puncture_information(puncture_data): + print("------------------------------------------------------------------------------------------") + print() + print(" Printing the puncture information ") + print() + + for i in range(input_data.puncture_number): + mass = puncture_data.dimensionless_mass_BH[i] + charge = puncture_data.charge_Q_BH[i] + position = puncture_data.position_BH[i] + momentum = puncture_data.momentum_BH[i] + angular_momentum = puncture_data.angular_momentum_BH[i] + + if input_data.Symmetry in ("octant-symmetry", "equatorial-symmetry"): + a_star = angular_momentum[2] / (mass ** 2) + else: + a_star = numpy.linalg.norm(angular_momentum) / (mass ** 2) + + print(f" The information for puncture {i+1} ") + print(f" Mass({i+1}) = {mass:>10.6f}, Q({i+1}) = {charge:>10.6f}, a*({i+1}) = {a_star:>10.6f}") + print(f" X({i+1}) = {position[0]:>10.6f}, Y({i+1}) = {position[1]:>10.6f}, Z({i+1}) = {position[2]:>10.6f}") + print(f" Px({i+1}) = {momentum[0]:>10.6f}, Py({i+1}) = {momentum[1]:>10.6f}, Pz({i+1}) = {momentum[2]:>10.6f}") + print( + f" Jx({i+1}) = {angular_momentum[0]:>10.6f}, Jy({i+1}) = {angular_momentum[1]:>10.6f}, Jz({i+1}) = {angular_momentum[2]:>10.6f}" + ) + print() + + print("------------------------------------------------------------------------------------------") + + +def generate_puncture_input_data(): + print() + print(" Setting puncture position, momentum and angular momentum ") + print() + + if input_data.puncture_data_set == "Automatically-BBH": + mass_ratio_Q = input_data.parameter_BH[0, 0] / input_data.parameter_BH[1, 0] + if mass_ratio_Q < 1.0: + raise ValueError("The first black hole must be the larger-mass puncture") + + BBH_M1 = mass_ratio_Q / (1.0 + mass_ratio_Q) + BBH_M2 = 1.0 / (1.0 + mass_ratio_Q) + distance_d0 = input_data.Distance + ellipticity_e0 = input_data.e0 + + position_BH = numpy.zeros((input_data.puncture_number, 3)) + position_BH[0] = [0.0, distance_d0 / (1.0 + mass_ratio_Q), 0.0] + position_BH[1] = [0.0, -distance_d0 * mass_ratio_Q / (1.0 + mass_ratio_Q), 0.0] + for i in range(2, input_data.puncture_number): + position_BH[i] = input_data.position_BH[i] + + dimensionless_mass_BH = numpy.zeros(input_data.puncture_number) + dimensionless_mass_BH[0] = BBH_M1 + dimensionless_mass_BH[1] = BBH_M2 + for i in range(2, input_data.puncture_number): + dimensionless_mass_BH[i] = input_data.parameter_BH[i, 0] + + charge_Q_BH = dimensionless_mass_BH * input_data.parameter_BH[:, 1] + angular_momentum_BH = _angular_momentum_from_input(dimensionless_mass_BH) + + import BBH_orbit_parameter + + BBH_S1 = angular_momentum_BH[0] / (BBH_M1 ** 2) + BBH_S2 = angular_momentum_BH[1] / (BBH_M2 ** 2) + momentum_BH = numpy.zeros((input_data.puncture_number, 3)) + momentum_BH[0], momentum_BH[1] = BBH_orbit_parameter.generate_BBH_orbit_parameters( + BBH_M1, BBH_M2, BBH_S1, BBH_S2, distance_d0, ellipticity_e0 + ) + for i in range(2, input_data.puncture_number): + momentum_BH[i] = input_data.momentum_BH[i] + + elif input_data.puncture_data_set == "Manually": + position_BH = numpy.array(input_data.position_BH, copy=True) + momentum_BH = numpy.array(input_data.momentum_BH, copy=True) + dimensionless_mass_BH = numpy.array(input_data.parameter_BH[:, 0], copy=True) + charge_Q_BH = dimensionless_mass_BH * input_data.parameter_BH[:, 1] + angular_momentum_BH = _angular_momentum_from_input(dimensionless_mass_BH) + + if input_data.puncture_number >= 2: + distance_d0 = math.sqrt( + (position_BH[0, 0] - position_BH[1, 0]) ** 2 + + (position_BH[0, 1] - position_BH[1, 1]) ** 2 + + (position_BH[0, 2] - position_BH[1, 2]) ** 2 + ) + else: + distance_d0 = 0.0 + ellipticity_e0 = input_data.e0 + BBH_M1 = dimensionless_mass_BH[0] if input_data.puncture_number >= 1 else 0.0 + BBH_M2 = dimensionless_mass_BH[1] if input_data.puncture_number >= 2 else 0.0 + + else: + raise ValueError("Unsupported puncture_data_set setting") + + puncture_data = PunctureData( + BBH_M1, + BBH_M2, + distance_d0, + ellipticity_e0, + dimensionless_mass_BH, + charge_Q_BH, + position_BH, + momentum_BH, + angular_momentum_BH, + ) + print_puncture_information(puncture_data) + return puncture_data diff --git a/renew_puncture_parameter.py b/renew_puncture_parameter.py index 7a76ccd..e621ec8 100755 --- a/renew_puncture_parameter.py +++ b/renew_puncture_parameter.py @@ -60,7 +60,7 @@ def read_TwoPuncture_Output(Output_File_directory): ## Append the computed puncture information into the AMSS-NCKU input file -def append_AMSSNCKU_BSSN_input(File_directory, TwoPuncture_File_directory): +def append_AMSSNCKU_BSSN_input(File_directory, TwoPuncture_File_directory, puncture_data=None): charge_Q_BH = numpy.zeros( input_data.puncture_number ) ## initialize charge for each black hole @@ -74,27 +74,32 @@ def append_AMSSNCKU_BSSN_input(File_directory, TwoPuncture_File_directory): ## If using another method for initial data, read parameters directly from input else: - position_BH = input_data.position_BH - momentum_BH = input_data.momentum_BH - ## angular_momentum_BH = input_data.angular_momentum_BH - angular_momentum_BH = numpy.zeros( (input_data.puncture_number, 3) ) ## initialize spin angular momentum array - mass_BH = numpy.zeros( input_data.puncture_number ) ## initialize mass array + if puncture_data is None: + position_BH = input_data.position_BH + momentum_BH = input_data.momentum_BH + angular_momentum_BH = numpy.zeros( (input_data.puncture_number, 3) ) ## initialize spin angular momentum array + mass_BH = numpy.zeros( input_data.puncture_number ) ## initialize mass array - ## Set charge and spin angular momentum for each puncture - for i in range(input_data.puncture_number): - - if ( input_data.Symmetry == "octant-symmetry" ): - mass_BH[i] = input_data.parameter_BH[i,0] - charge_Q_BH[i] = mass_BH[i]* input_data.parameter_BH[i,1] - angular_momentum_BH[i] = [ 0.0, 0.0, (mass_BH[i]**2) * input_data.parameter_BH[i,2] ] - elif ( input_data.Symmetry == "equatorial-symmetry" ): - mass_BH[i] = input_data.parameter_BH[i,0] - charge_Q_BH[i] = mass_BH[i]* input_data.parameter_BH[i,1] - angular_momentum_BH[i] = [ 0.0, 0.0, (mass_BH[i]**2) * input_data.parameter_BH[i,2] ] - elif ( input_data.Symmetry == "no-symmetry" ): - mass_BH[i] = input_data.parameter_BH[i,0] - angular_momentum_BH[i] = (mass_BH[i]**2) * input_data.dimensionless_spin_BH[i] - charge_Q_BH[i] = mass_BH[i] * input_data.parameter_BH[i,1] + ## Set charge and spin angular momentum for each puncture + for i in range(input_data.puncture_number): + if ( input_data.Symmetry == "octant-symmetry" ): + mass_BH[i] = input_data.parameter_BH[i,0] + charge_Q_BH[i] = mass_BH[i]* input_data.parameter_BH[i,1] + angular_momentum_BH[i] = [ 0.0, 0.0, (mass_BH[i]**2) * input_data.parameter_BH[i,2] ] + elif ( input_data.Symmetry == "equatorial-symmetry" ): + mass_BH[i] = input_data.parameter_BH[i,0] + charge_Q_BH[i] = mass_BH[i]* input_data.parameter_BH[i,1] + angular_momentum_BH[i] = [ 0.0, 0.0, (mass_BH[i]**2) * input_data.parameter_BH[i,2] ] + elif ( input_data.Symmetry == "no-symmetry" ): + mass_BH[i] = input_data.parameter_BH[i,0] + angular_momentum_BH[i] = (mass_BH[i]**2) * input_data.dimensionless_spin_BH[i] + charge_Q_BH[i] = mass_BH[i] * input_data.parameter_BH[i,1] + else: + position_BH = puncture_data.position_BH + momentum_BH = puncture_data.momentum_BH + angular_momentum_BH = puncture_data.angular_momentum_BH + mass_BH = puncture_data.dimensionless_mass_BH + charge_Q_BH = puncture_data.charge_Q_BH file1 = open( os.path.join(input_data.File_directory, "AMSS-NCKU.input"), "a") ## open file in append mode